(FILECREATED "31-Dec-83 15:08:48" {PHYLUM}<LISPCORE>SOURCES>SPP.;29 102256
changes to: (VARS SPPCOMS)
previous date: "17-NOV-83 14:50:35" {PHYLUM}<LISPCORE>SOURCES>SPP.;28)
(* Copyright (c) 1983 by Xerox Corporation)
(PRETTYCOMPRINT SPPCOMS)
(RPAQQ SPPCOMS [(COMS (DECLARE: DONTCOPY EVAL@COMPILE (FILES (LOADCOMP)
LLNS)))
(COMS (* Sequenced Packet Protocol.)
(SYSRECORDS SPPCON)
(DECLARE: DONTCOPY (RECORDS SPPCON SPPHEAD)
(CONSTANTS (\SPPHEAD.LENGTH 12)
\SPPHEAD.CC.SYSTEM \SPPHEAD.CC.ACKNOWLEDGE \SPPHEAD.CC.ATTENTION
\SPPHEAD.CC.EOM)
(CONSTANTS (\SPP.INITIAL.ALLOCATION 5)
(\SPP.INITIAL.ROUNDTRIP 1000))
(CONSTANTS (\SPPDSTYPE.COURIER 0)
(\SPPDSTYPE.BULKDATA 1)
(\SPPDSTYPE.END 254)
(\SPPDSTYPE.ENDREPLY 255))
(MACROS GETPACKETSEQNO GETPACKETACKNO GETPACKETDSTYPE GETPACKETCC BITTEST
ORINCCBITS EPKT.LEVEL3.CONTENTS)
(GLOBALVARS SPP.USER.TIMEOUT SPP.MIN.TIMEOUT))
(INITRECORDS SPPCON)
(INITVARS (SPP.USER.TIMEOUT 15000)
(SPP.MIN.TIMEOUT 50))
(FNS \SPPCONNECTION \SPP.SENDPKT \SPP.FIXPKT \SPPWEDGED \SPPATTN \FILLINSPP \SPP.PROBE
\SPP.SYSPKT \GETSPP \UNGETSPP \SENDSPP \TERMINATESPP \SPPWATCHER \SPPEXIT
\SPPINPUTWORK \PUT.IN.LINE \SPPAREYOUTHERE? \SPP.RELEASE.ACKED.PACKETS
\SPP.START.RETRANSMIT \SPP.RETRANSMIT.NEXT \SPP.WAIT.FOR.RETRANSMIT.FINISH
\SPPGETERROR \SPPSENDERROR))
(COMS (* Stream interface to Sequenced Packet Protocol.)
(DECLARE: DONTCOPY (RECORDS SPPSTREAM)
(CONSTANTS (\MAX.LEVEL3.DATALENGTH (DIFFERENCE \MAX.XIPDATALENGTH
\SPPHEAD.LENGTH)))
(MACROS GETSPPCON GETWORD PUTWORD GETLONG PUTLONG)
(GLOBALVARS \SPPDEVICE \SPP.BULKDATA.DEVICE))
(INITRECORDS SPPSTREAM)
(FNS \INITSPP SPP.OPEN \ACTIVE.SPP.STREAMP \STREAM.FROM.PACKET SPP.FLUSH SPP.SENDEOM
SPP.SENDATTENTION SPP.CLOSE \SPP.CLOSE.IF.ERROR \SPP.RESETCLOSE SPP.GETBYTE
SPP.PEEKBIN SPP.BACKFILEPTR SPP.PUTBYTE \GETSPP.FOR.STREAM \FILLINSPP.FOR.STREAM
SPP.DSTYPE SPP.READP SPP.EOFP SPP.ATTENTIONP)
(P (\INITSPP)))
(COMS (* Courier Remote Procedure Call Protocol.)
(DECLARE: DONTCOPY (CONSTANTS (COURIER.VERSION# 3))
(CONSTANTS (\COURIERMSG.CALL 0)
(\COURIERMSG.REJECT 1)
(\COURIERMSG.RETURN 2)
(\COURIERMSG.ABORT 3))
(MACROS GET.BULK.DATA.CONTINUATION)
(RECORDS BULKDATASTREAM \BULK.DATA.CONTINUATION))
(INITRECORDS BULKDATASTREAM)
(* Facilities for manipulating Courier definitions.)
(INITVARS (\COURIERPROGRAM (HARRAY 20)))
(FNS COURIERPROGRAM DUMP.COURIERPROGRAMS \GET.COURIER.PROG#VERS#.PAIR
\GET.COURIER.DEFINITION COURIER.QUALIFIED.NAMEP \GET.COURIER.TYPE
\GET.COURIER.PROCEDURE.ARGS \GET.COURIER.PROCEDURE.RESULTS
\GET.COURIER.PROCEDURE.ERRORS \GET.COURIER.PROCEDURE.NUMBER
\GET.COURIER.ERROR.ARGS \GET.COURIER.ERROR.NUMBER)
(FILEPKGCOMS COURIERPROGRAMS)
(GLOBALVARS \COURIERPROGRAM)
(* Functions for calling Courier procedures.)
(INITVARS (NSWIZARDFLG))
(FNS COURIER.OPEN COURIER.CALL COURIER.ARGS COURIER.RESULTS HANDLE.COURIER.ERROR
\BULK.DATA.STREAM \BULK.DATA.CLOSE \FAKE.BULK.DATA.EOF \BULK.DATA.CLOSE.INTERNAL
\ABORT.BULK.DATA COURIER.WRITE COURIER.READ COURIER.WRITE.REP COURIER.READ.REP
\COURIER.READ.REP.INTERNAL COURIER.READ.BULKDATA))
(COMS (* Debugging)
(ALISTS (XIPPRINTMACROS 5))
(INITVARS (COURIERTRACEFILE)
(COURIERTRACEFLG))
(FNS PPSPP \SPP.CHECK.INPUT.QUEUE PRINTSPP SPP.DRIBBLE COURIERTRACE \COURIER.TRACE))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA
DUMP.COURIERPROGRAMS
COURIERPROGRAM)
(NLAML)
(LAMA COURIER.CALL])
(DECLARE: DONTCOPY EVAL@COMPILE
(FILESLOAD (LOADCOMP)
LLNS)
)
(* Sequenced Packet Protocol.)
[ADDTOVAR SYSTEMRECLST
(DATATYPE SPPCON ((NIL POINTER)
(SPPESTABLISHEDP FLAG)
(SPP.ESTABLISHED.EVENT POINTER)
(SPPINWAIT POINTER)
(SPPTERMINATEDP FLAG)
(SPPRETRANSMITQ POINTER)
(SPPDSTYPE BYTE)
(SPPDESTNSADDRESS POINTER)
(SPPRETRANSMITTING POINTER)
(SPPLOCK POINTER)
(SPPMYNSOCKET POINTER)
(SPPMYID WORD)
(SPPHISID WORD)
(SPPSEQNO WORD)
(SPPACKEDSEQNO WORD)
(SPPACKNO WORD)
(SPPALLOCNO WORD)
(SPPACCEPTNO WORD)
(SPPTIMETOPOKE POINTER)
(SPPACKREQUESTED POINTER)
(SPPREQUEST.TIME POINTER)
(SPPREQUEST.TIMEOUT POINTER)
(SPPROUNDTRIPTIME POINTER)
(SPPAREYOUTHERE POINTER)
(SPPACKPENDING POINTER)
(SPPACKPENDINGTIMEOUT POINTER)
(SPPINPKT POINTER)
(SPPOUTPKT POINTER)
(SPPSYSPKT POINTER)
(SPP.PENDING.CLOSE FLAG)
(SPPSTREAM POINTER)
(SPPSUBSTREAM POINTER)
(SPP.PROCESS POINTER)
(SPP.NEWALLOCATION POINTER)
(SPP.PACKETARRIVED POINTER)
(NIL POINTER)
(NIL POINTER)))
]
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(DATATYPE SPPCON ((NIL POINTER) (* Used for SYSQUEUEing.)
(SPPESTABLISHEDP FLAG) (* True when connection is established.)
(SPP.ESTABLISHED.EVENT POINTER) (* Notified when connection becomes established.)
(SPPINWAIT POINTER) (* Packets that have arrived wait in this queue.
The packets are in order but some may be missing.)
(SPPTERMINATEDP FLAG) (* Will be set to T when \TERMINATESPP wants this one to
go away.)
(SPPRETRANSMITQ POINTER) (* Packets which have been to SENDXIP but have not yet
been acknowledged.)
(SPPDSTYPE BYTE) (* Current datastream type from our outgoing side.)
(SPPDESTNSADDRESS POINTER) (* NS address of the other end of the connection.)
(SPPRETRANSMITTING POINTER) (* Queue of packets that we get back from the driver
after transmission. These have to be merged into the
retransmit queue.)
(SPPLOCK POINTER) (* Monitor lock for connection.)
(SPPMYNSOCKET POINTER) (* NS socket for sending and receiving XIPs.)
(SPPMYID WORD) (* Connection identification number for this side.)
(SPPHISID WORD) (* Connection identification number for the other side.)
(SPPSEQNO WORD) (* Current sequence number -- next packet to go out will
take this and increment it.)
(SPPACKEDSEQNO WORD) (* The most recent Acknowledge number we have received;
i.e. the SEQNO he expects to receive next.)
(SPPACKNO WORD) (* We've seen all seqno's up to but not including this
one.)
(SPPALLOCNO WORD) (* The most recent Allocation number we've received.)
(SPPACCEPTNO WORD) (* The Allocation number we've sent -- I'll accept his
sequence numbers up to and including this.)
(SPPTIMETOPOKE POINTER) (* Time at which the next Acknowledgement request or
retransmission should occur.)
(SPPACKREQUESTED POINTER) (* Will be set to T when an ACK request has been sent
but not acknowledged.)
(SPPREQUEST.TIME POINTER) (* Whenever an ACK request is sent, this is set to the
current time. When a response arrives, the round trip
time is updated.)
(SPPREQUEST.TIMEOUT POINTER) (* Time at which an ACK request should be considered
hopeless.)
(SPPROUNDTRIPTIME POINTER) (* Estimate of (twice) the round trip delay on this
connection.)
(SPPAREYOUTHERE POINTER) (* If non-NIL, the time for the next probe to see if the
other end is still there.)
(SPPACKPENDING POINTER) (* True if we have been requested to send an Ack)
(SPPACKPENDINGTIMEOUT POINTER) (* Timer for when we should send an ack by)
(SPPINPKT POINTER) (* Packet currently being read from, for BIN.)
(SPPOUTPKT POINTER) (* Packet currently being written to, for BOUT.)
(SPPSYSPKT POINTER) (* Cached System packet for probing and answering
Acknowledgement requests.)
(SPP.PENDING.CLOSE FLAG) (* Set to T when user wishes to close connection, but
substream is still open.)
(SPPSTREAM POINTER) (* Stream interface for this connection.)
(SPPSUBSTREAM POINTER) (* Bulk data substream for connection.)
(SPP.PROCESS POINTER) (* Process managing this connection.)
(SPP.NEWALLOCATION POINTER) (* Event which occurs when the allocation increases.)
(SPP.PACKETARRIVED POINTER) (* Event which occurs when the next data packet
arrives.)
(NIL POINTER)
(NIL POINTER))
SPPINWAIT ←(create SYSQUEUE)
SPPRETRANSMITQ ←(create SYSQUEUE)
SPPLOCK ←(CREATE.MONITORLOCK)
SPP.NEWALLOCATION ←(CREATE.EVENT)
SPP.PACKETARRIVED ←(CREATE.EVENT)
SPP.ESTABLISHED.EVENT ←(CREATE.EVENT)
SPPACCEPTNO ← \SPP.INITIAL.ALLOCATION SPPROUNDTRIPTIME ← \SPP.INITIAL.ROUNDTRIP
SPPTIMETOPOKE ←(SETUPTIMER 0))
(BLOCKRECORD SPPHEAD ((CC BYTE)
(DSTYPE BYTE)
(SOURCECONID WORD)
(DESTCONID WORD)
(SEQNO WORD)
(ACKNO WORD)
(ALLOCNO WORD)))
]
(/DECLAREDATATYPE (QUOTE SPPCON)
(QUOTE (POINTER FLAG POINTER POINTER FLAG POINTER BYTE POINTER POINTER POINTER
POINTER WORD WORD WORD WORD WORD WORD WORD POINTER POINTER POINTER
POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
FLAG POINTER POINTER POINTER POINTER POINTER POINTER POINTER)))
(DECLARE: EVAL@COMPILE
(RPAQQ \SPPHEAD.LENGTH 12)
(RPAQQ \SPPHEAD.CC.SYSTEM 128)
(RPAQQ \SPPHEAD.CC.ACKNOWLEDGE 64)
(RPAQQ \SPPHEAD.CC.ATTENTION 32)
(RPAQQ \SPPHEAD.CC.EOM 16)
(CONSTANTS (\SPPHEAD.LENGTH 12)
\SPPHEAD.CC.SYSTEM \SPPHEAD.CC.ACKNOWLEDGE \SPPHEAD.CC.ATTENTION \SPPHEAD.CC.EOM)
)
(DECLARE: EVAL@COMPILE
(RPAQQ \SPP.INITIAL.ALLOCATION 5)
(RPAQQ \SPP.INITIAL.ROUNDTRIP 1000)
(CONSTANTS (\SPP.INITIAL.ALLOCATION 5)
(\SPP.INITIAL.ROUNDTRIP 1000))
)
(DECLARE: EVAL@COMPILE
(RPAQQ \SPPDSTYPE.COURIER 0)
(RPAQQ \SPPDSTYPE.BULKDATA 1)
(RPAQQ \SPPDSTYPE.END 254)
(RPAQQ \SPPDSTYPE.ENDREPLY 255)
(CONSTANTS (\SPPDSTYPE.COURIER 0)
(\SPPDSTYPE.BULKDATA 1)
(\SPPDSTYPE.END 254)
(\SPPDSTYPE.ENDREPLY 255))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS GETPACKETSEQNO MACRO ((X)
(FETCH (SPPHEAD SEQNO) OF (FETCH XIPCONTENTS OF X))))
(PUTPROPS GETPACKETACKNO MACRO ((X)
(FETCH (SPPHEAD ACKNO) OF (FETCH XIPCONTENTS OF X))))
(PUTPROPS GETPACKETDSTYPE MACRO ((X)
(FETCH (SPPHEAD DSTYPE) OF (FETCH XIPCONTENTS OF X))))
(PUTPROPS GETPACKETCC MACRO ((X)
(fetch (SPPHEAD CC) OF (fetch XIPCONTENTS of X))))
(PUTPROPS BITTEST MACRO ((N MASK)
(NEQ 0 (LOGAND N MASK))))
(PUTPROPS ORINCCBITS MACRO [OPENLAMBDA (EPKT CCBITS)
(PROG (X)
(SETQ X (fetch XIPCONTENTS of EPKT))
(replace (SPPHEAD CC) of X
with (LOGOR (fetch (SPPHEAD CC) of X)
CCBITS])
(PUTPROPS EPKT.LEVEL3.CONTENTS MACRO ((EPKT)
(\ADDBASE (fetch XIPCONTENTS of EPKT)
(FOLDHI \SPPHEAD.LENGTH BYTESPERWORD))))
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS SPP.USER.TIMEOUT SPP.MIN.TIMEOUT)
)
)
(/DECLAREDATATYPE (QUOTE SPPCON)
(QUOTE (POINTER FLAG POINTER POINTER FLAG POINTER BYTE POINTER POINTER POINTER
POINTER WORD WORD WORD WORD WORD WORD WORD POINTER POINTER POINTER
POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
FLAG POINTER POINTER POINTER POINTER POINTER POINTER POINTER)))
(RPAQ? SPP.USER.TIMEOUT 15000)
(RPAQ? SPP.MIN.TIMEOUT 50)
(DEFINEQ
(\SPPCONNECTION
[LAMBDA (HOST SOCKET NAME) (* bvm: "16-OCT-83 17:27")
(* Create an active connection if HOST is specified, or
a passive connection if HOST is NIL.)
(PROG ((CON (create SPPCON))
(HOSTNSADDRESS (create NSADDRESS))
NSOC)
[COND
((NULL HOST) (* If host is NIL, we want to listen on the specified
socket.)
(SETQ NSOC (OPENNSOCKET SOCKET T)))
(T (* User wants to initiate connection to host.)
(\MOVENSADDRESSES (\NS.FINDNSADDRESS HOST)
HOSTNSADDRESS)
(COND
((AND (ZEROP (fetch NSSOCKET of HOSTNSADDRESS))
(NOT (NULL SOCKET)))
(replace NSSOCKET of HOSTNSADDRESS with SOCKET)))
(SETQ NSOC (OPENNSOCKET]
(replace SPPMYNSOCKET of CON with NSOC)
(replace SPPMYID of CON with (LOGOR 32768 (LOGAND (DAYTIME)
32767)))
(replace SPPDESTNSADDRESS of CON with HOSTNSADDRESS)
[replace SPP.PROCESS of CON with (ADD.PROCESS (BQUOTE (\SPPWATCHER (QUOTE , CON)))
(QUOTE NAME)
(OR NAME (QUOTE SPP]
(RETURN CON])
(\SPP.SENDPKT
[LAMBDA (CON EPKT RETRANSMITP) (* bvm: "16-OCT-83 21:32")
(* This function makes sure the variable connection information in the packet is current, and actually sends the
packet. If the packet is to be retransmitted, the connection must be locked when this function is called.
Note that the sequence number is NOT updated; it was allocated once and for all by \SENDSPP)
(PROG ((BASE (fetch XIPCONTENTS of EPKT))
CC SEQNO)
(SETQ CC (fetch (SPPHEAD CC) of BASE))
[CHECK (NOT (AND (BITTEST CC \SPPHEAD.CC.SYSTEM)
RETRANSMITP
(SHOULDNT "System packet to be retransmitted?"]
(replace (SPPHEAD ACKNO) of BASE with (fetch SPPACKNO of CON))
(replace (SPPHEAD ALLOCNO) of BASE with (fetch SPPACCEPTNO of CON))
[COND
((BITTEST CC \SPPHEAD.CC.ACKNOWLEDGE)
(* We start a timer when we send an Ack request, and turn it off when the next packet arrives
(in \SPPINPUTWORK.) If the timer expires, we assume that the connection is wedged. Otherwise, the elapsed time
will be used to update our estimate of the round trip delay. The timer will go off after the user-level timeout,
or twice the round trip delay, whichever is longer.)
(SETQ SEQNO (fetch (SPPHEAD SEQNO) of BASE))
(COND
((OR (NOT (fetch SPPACKREQUESTED of CON))
(IGREATERP SEQNO (fetch SPPACKREQUESTED of CON)))
(replace SPPACKREQUESTED of CON with SEQNO)
(replace SPPREQUEST.TIMEOUT of CON
with (SETUPTIMER (MAX SPP.USER.TIMEOUT (UNFOLD (fetch SPPROUNDTRIPTIME
of CON)
4))
(fetch SPPREQUEST.TIMEOUT of CON)))
(replace SPPREQUEST.TIME of CON with (SETUPTIMER 0 (fetch SPPREQUEST.TIME
of CON]
(replace SPPACKPENDING of CON with NIL) (* If partner asked for an ack, this will satisfy it)
(replace EPREQUEUE of EPKT with (AND RETRANSMITP (fetch SPPRETRANSMITQ of CON)))
(SENDXIP (fetch SPPMYNSOCKET of CON)
EPKT)
(replace SPPTIMETOPOKE of CON with (SETUPTIMER (COND
((fetch SPPRETRANSMITTING of CON)
SPP.MIN.TIMEOUT)
(T (UNFOLD (fetch SPPROUNDTRIPTIME
of CON)
2)))
(fetch SPPTIMETOPOKE of CON])
(\SPP.FIXPKT
[LAMBDA (CON EPKT) (* ecc " 2-MAY-83 16:50")
(* This function should be called to fill in "constant"
connection information.)
(PROG ((BASE (fetch XIPCONTENTS of EPKT)))
(replace XIPDESTNSADDRESS of EPKT with (fetch SPPDESTNSADDRESS of CON))
(replace (SPPHEAD SOURCECONID) of BASE with (fetch SPPMYID of CON))
(replace (SPPHEAD DESTCONID) of BASE with (fetch SPPHISID of CON))
(RETURN EPKT])
(\SPPWEDGED
[LAMBDA (CON) (* bvm: "16-OCT-83 21:40")
(* There hasn't been any response to our probes for a
while.)
(COND
((OR (NOT (fetch SPPESTABLISHEDP of CON))
(IGREATERP (fetch SPPROUNDTRIPTIME of CON)
(ITIMES SPP.USER.TIMEOUT 10))) (* If the connection hasn't been established yet, or if
the roundtrip time is intolerably long, we drop the
connection.)
(replace SPPTERMINATEDP of CON with T))
(T (* Warn the user that the other end may have crashed,
but hang in there.)
(replace SPPROUNDTRIPTIME of CON with (IMIN SPP.USER.TIMEOUT (ITIMES (fetch SPPROUNDTRIPTIME
of CON)
2)))
(* Increase our estimate of the time it takes the other
end to respond.)
(replace SPPACKREQUESTED of CON with NIL)
(printout PROMPTWINDOW .TAB0 0 (PROCESSPROP (THIS.PROCESS)
(QUOTE NAME))
" not responding. "])
(\SPPATTN
[LAMBDA (CON EPKT BYTE) (* ecc " 3-OCT-83 17:11")
(if (NOT (AND (fetch SPPSUBSTREAM of CON)
(EQ (GETPACKETDSTYPE EPKT)
\SPPDSTYPE.BULKDATA)
(EQ BYTE 1)))
then (AND NSWIZARDFLG (printout PROMPTWINDOW .TAB0 0 "[Attention packet (" BYTE ")]"))
elseif (OR NSWIZARDFLG (WRITEABLE (fetch SPPSUBSTREAM of CON)))
then (printout PROMPTWINDOW .TAB0 0 "[Bulk data stream truncated]"])
(\FILLINSPP
[LAMBDA (CON CCONTROL DSTYPE) (* ecc "26-MAY-83 19:04")
(PROG ([EPKT (\FILLINXIP \XIPT.SPP (fetch SPPMYNSOCKET of CON)
(fetch SPPDESTNSADDRESS of CON)
NIL NIL (CONSTANT (IPLUS \XIPOVLEN \SPPHEAD.LENGTH]
BASE)
(SETQ BASE (fetch XIPCONTENTS of EPKT))
(replace (SPPHEAD CC) of BASE with (OR (SMALLP CCONTROL)
(SETQ CCONTROL 0)))
[replace (SPPHEAD DSTYPE) of BASE with (OR (SMALLP DSTYPE)
(SETQ DSTYPE (fetch SPPDSTYPE of CON]
(RETURN EPKT])
(\SPP.PROBE
[LAMBDA (CON) (* ecc "31-MAY-83 13:52")
(* Send out a system packet requesting acknowledgement
from other side.)
(\SPP.SENDPKT CON (\SPP.SYSPKT CON \SPPHEAD.CC.ACKNOWLEDGE)
NIL])
(\SPP.SYSPKT
[LAMBDA (CON CCBITS) (* bvm: "13-OCT-83 12:08")
(* Return a System packet for the connection with the
specified control bits set. Uses the cached packet if
there is one.)
(PROG ((XIP (fetch SPPSYSPKT of CON))
BASE)
[COND
((NULL XIP)
[SETQ XIP (\FILLINXIP \XIPT.SPP (fetch SPPMYNSOCKET of CON)
(fetch SPPDESTNSADDRESS of CON)
NIL NIL (CONSTANT (IPLUS \XIPOVLEN \SPPHEAD.LENGTH]
(\SPP.FIXPKT CON XIP)
(replace SPPSYSPKT of CON with XIP))
(T (while (fetch EPTRANSMITTING of XIP) do (BLOCK]
(SETQ BASE (fetch XIPCONTENTS of XIP))
(replace (SPPHEAD CC) of BASE with (LOGOR \SPPHEAD.CC.SYSTEM (OR CCBITS 0)))
(replace (SPPHEAD SEQNO) of BASE with (fetch SPPSEQNO of CON))
(RETURN XIP])
(\GETSPP
[LAMBDA (CON TIMEOUT) (* ecc " 3-OCT-83 17:58")
(WITH.MONITOR (fetch SPPLOCK of CON)
(bind (EPKT ← NIL)
(EXPIRED ←(AND TIMEOUT (ZEROP TIMEOUT))) until (fetch SPPTERMINATEDP
of CON)
do (if (AND (SETQ EPKT (\QUEUEHEAD (fetch SPPINWAIT of CON)))
(ILESSP (GETPACKETSEQNO EPKT)
(fetch SPPACKNO of CON)))
then (* This is the packet we've been waiting for.
The ACKNO field has already been incremented in
\PUT.IN.LINE)
(\DEQUEUE (fetch SPPINWAIT of CON))
(add (fetch SPPACCEPTNO of CON)
1)
(if (NOT (BITTEST (GETPACKETCC EPKT)
\SPPHEAD.CC.ATTENTION))
then (RETURN EPKT)
else (* Special case: throw away Attention packets since
their presence in the data stream confuses the Courier
code.)
(RELEASE.XIP EPKT))
elseif (AND TIMEOUT EXPIRED)
then (RETURN NIL)
else (MONITOR.AWAIT.EVENT (fetch SPPLOCK of CON)
(fetch SPP.PACKETARRIVED of CON)
TIMEOUT)
(SETQ EXPIRED T])
(\UNGETSPP
[LAMBDA (CON EPKT) (* ecc "16-AUG-83 14:45")
(* Push back a packet that we don't want to handle yet.
The next call to \GETSPP will get it again.)
(WITH.MONITOR (fetch SPPLOCK of CON)
(replace QLINK of EPKT with (\QUEUEHEAD (fetch SPPINWAIT of CON)))
(replace SYSQUEUEHEAD of (fetch SPPINWAIT of CON) with EPKT)
(add (fetch SPPACCEPTNO of CON)
-1) (* \GETSPP automatically increments our Allocation
number. Since we haven't really consumed the packet yet,
we have to decrement it.)
NIL])
(\SENDSPP
[LAMBDA (CON EPKT) (* bvm: "16-OCT-83 17:05")
(* Send the next SPP packet over the connection. Blocks if necessary until the allocation window opens up.
Returns T if successful, NIL if connection dropped.)
(CHECK (type? ETHERPACKET EPKT)
(NOT (BITTEST (GETPACKETCC EPKT)
\SPPHEAD.CC.SYSTEM)))
(WITH.MONITOR (fetch SPPLOCK of CON)
(bind SEQNO while (NOT (fetch SPPTERMINATEDP of CON))
do (COND
((AND (OR (ILEQ (fetch SPPSEQNO of CON)
(fetch SPPALLOCNO of CON))
(BITTEST (GETPACKETCC EPKT)
\SPPHEAD.CC.ATTENTION))
(NOT (fetch SPPRETRANSMITTING of CON)))
(* We can send the packet now if it's within the
allocation window, or if it's an Attention packet.)
(\SPP.FIXPKT CON EPKT) (* Fill in "constant" connection data.)
(replace (SPPHEAD SEQNO) of (fetch XIPCONTENTS of EPKT)
with (SETQ SEQNO (fetch SPPSEQNO of CON)))
(* Fill in and advance the packet sequence number.)
(replace SPPSEQNO of CON with (ADD1 SEQNO))
(COND
((EQ SEQNO (fetch SPPALLOCNO of CON))
(ORINCCBITS EPKT \SPPHEAD.CC.ACKNOWLEDGE)))
(\SPP.SENDPKT CON EPKT T)
(RETURN T))
(T (* Otherwise, we have to wait until the other end opens
up the allocation window.)
(MONITOR.AWAIT.EVENT (fetch SPPLOCK of CON)
(fetch SPP.NEWALLOCATION of CON])
(\TERMINATESPP
[LAMBDA (CON ACTIVEP) (* bvm: "12-OCT-83 12:23")
(* Reliable connection termination, as in section 7.5 of
the spec.)
(PROG (EPKT DSTYPE)
(COND
((NOT (fetch SPPESTABLISHEDP of CON))
(replace SPPTERMINATEDP of CON with T)
(RETURN NIL)))
(COND
((fetch SPPTERMINATEDP of CON)
(RETURN NIL)))
[COND
(ACTIVEP (* We initiate the termination by sending an END
packet.)
(\SENDSPP CON (\FILLINSPP CON (LOGOR \SPPHEAD.CC.ACKNOWLEDGE \SPPHEAD.CC.EOM)
\SPPDSTYPE.END))
(while (SETQ EPKT (\GETSPP CON SPP.USER.TIMEOUT))
do (* Throw away any incoming data packets.)
(SELECTC (SETQ DSTYPE (GETPACKETDSTYPE EPKT))
((LIST \SPPDSTYPE.END \SPPDSTYPE.ENDREPLY)
(RETURN))
NIL)
finally (* Timed out)
(GO DONE]
[COND
[(OR (NOT ACTIVEP)
(EQ DSTYPE \SPPDSTYPE.END)) (* The other end initiated the termination with an END
packet.)
(\SENDSPP CON (\FILLINSPP CON (LOGOR \SPPHEAD.CC.ACKNOWLEDGE \SPPHEAD.CC.EOM)
\SPPDSTYPE.ENDREPLY))
(until (OR (NULL (SETQ EPKT (\GETSPP CON SPP.USER.TIMEOUT)))
(EQ (SETQ DSTYPE (GETPACKETDSTYPE EPKT))
\SPPDSTYPE.ENDREPLY]
(T (* Respond to end-reply with our own end-reply, and stop
dallying)
(\SENDSPP CON (\FILLINSPP CON \SPPHEAD.CC.EOM \SPPDSTYPE.ENDREPLY]
DONE(replace SPPTERMINATEDP of CON with T)
(RETURN (EQ DSTYPE \SPPDSTYPE.ENDREPLY])
(\SPPWATCHER
[LAMBDA (SPPCON) (* bvm: "16-OCT-83 21:50")
(DECLARE (SPECVARS SPPCON))
(RESETSAVE NIL (LIST (FUNCTION \SPPEXIT)
SPPCON))
[PROCESSPROP (THIS.PROCESS)
(QUOTE INFOHOOK)
(FUNCTION (LAMBDA NIL
(DECLARE (USEDFREE SPPCON))
(INSPECT SPPCON]
(WITH.MONITOR (fetch SPPLOCK of SPPCON)
(bind (SOCEVENT ←(NSOCKETEVENT (fetch SPPMYNSOCKET of SPPCON)))
ACTIVITY until (fetch SPPTERMINATEDP of SPPCON)
do [COND
((AND (fetch SPPACKREQUESTED of SPPCON)
(TIMEREXPIRED? (fetch SPPREQUEST.TIMEOUT of SPPCON)))
(\SPPWEDGED SPPCON))
(T (SETQ ACTIVITY (\SPPINPUTWORK SPPCON))
(COND
((fetch SPPRETRANSMITTING of SPPCON)
(\SPP.RETRANSMIT.NEXT SPPCON))
((fetch SPPACKPENDING of SPPCON)
(\SPP.SENDPKT SPPCON (\SPP.SYSPKT SPPCON))
(replace SPPACKPENDING of SPPCON with NIL))
((AND (NULL ACTIVITY)
(OR (fetch SPPESTABLISHEDP of SPPCON)
(fetch SPPDESTNSADDRESS of SPPCON)))
(COND
((AND (OR (fetch SPPACKREQUESTED of SPPCON)
(ILESSP (fetch SPPACKEDSEQNO of SPPCON)
(fetch SPPSEQNO of SPPCON))
(ILESSP (fetch SPPALLOCNO of SPPCON)
(fetch SPPSEQNO of SPPCON)))
(TIMEREXPIRED? (fetch SPPTIMETOPOKE of SPPCON)))
(* We asked for an ack and/or are out of allocation, so
poke again)
(\SPP.PROBE SPPCON))
(T (\SPPAREYOUTHERE? SPPCON]
(MONITOR.AWAIT.EVENT (fetch SPPLOCK of SPPCON)
SOCEVENT
(fetch SPPTIMETOPOKE of SPPCON)
T])
(\SPPEXIT
[LAMBDA (CON) (* bvm: "16-OCT-83 16:36")
(* Called when \SPPWATCHER exits.)
(WITH.MONITOR (fetch SPPLOCK of CON)
(PROG ((PROC (fetch SPP.PROCESS of CON)))
(replace SPPTERMINATEDP of CON with T)
(NOTIFY.EVENT (fetch SPP.PACKETARRIVED of CON))
(NOTIFY.EVENT (fetch SPP.NEWALLOCATION of CON))
(* We just notified anyone who might be blocked waiting
for something to happen on this connection.)
[MAPC (LIST (fetch SPPSTREAM of CON)
(fetch SPPSUBSTREAM of CON))
(FUNCTION (LAMBDA (STREAM)
(COND
(STREAM (replace ACCESSBITS of STREAM with NoBits)
(replace CPPTR of STREAM with NIL)
(replace CBUFSIZE of STREAM with 0]
(replace SPPSTREAM of CON with (replace SPPSUBSTREAM of CON with NIL))
[MAPC (LIST (fetch SPPINWAIT of CON)
(fetch SPPRETRANSMITQ of CON))
(FUNCTION (LAMBDA (Q)
(replace SYSQUEUEHEAD of Q with (replace SYSQUEUETAIL of Q
with NIL]
[replace SPPRETRANSMITTING of CON
with (replace SPPINPKT of CON
with (replace SPPOUTPKT of CON
with (replace SPPSYSPKT of CON with NIL]
(CLOSENSOCKET (PROG1 (fetch SPPMYNSOCKET of CON)
(replace SPPMYNSOCKET of CON with NIL))
T)
(replace SPP.PROCESS of CON with NIL)
(DEL.PROCESS PROC])
(\SPPINPUTWORK
[LAMBDA (CON) (* bvm: "16-OCT-83 21:38")
(* Handle all queued input packets.
Returns T if there was activity on the connection.)
(PROG (XIP SPPBASE PKTSEQNO CC ACTIVE? ATTN ACKED ACKRECEIVED ALLOCINCREASED)
LOOP(SETQ XIP (GETXIP (fetch SPPMYNSOCKET of CON)))
(COND
((NULL XIP)
(COND
((AND ACKRECEIVED (NOT ALLOCINCREASED)
(ILESSP (fetch SPPACKEDSEQNO of CON)
(fetch SPPSEQNO of CON))
(NULL (fetch SPPRETRANSMITTING of CON)))
(* We received an apparently genuine ack, but there are still unacked packets, so assume that they have not been
seen--start retransmitting them. The test for ALLOCINCREASED is in the hopes that this ack was so old that future
acks will say the data arrived okay)
(\SPP.START.RETRANSMIT CON)))
(RETURN ACTIVE?)))
(COND
((NEQ (fetch XIPTYPE of XIP)
\XIPT.SPP)
(COND
((EQ (fetch XIPTYPE of XIP)
\XIPT.ERROR)
(\SPPGETERROR CON XIP))
(T (\SPPSENDERROR CON XIP "Random packet to Sequenced Packet Protocol socket.")))
(GO DROPIT)))
(SETQ SPPBASE (fetch XIPCONTENTS of XIP))
(COND
([OR (AND (fetch SPPESTABLISHEDP of CON)
(NEQ (fetch (SPPHEAD SOURCECONID) of SPPBASE)
(fetch SPPHISID of CON)))
(AND (NEQ (fetch (SPPHEAD DESTCONID) of SPPBASE)
0)
(NEQ (fetch (SPPHEAD DESTCONID) of SPPBASE)
(fetch SPPMYID of CON]
(* If the connection has already been established, then both connection IDs must match. Otherwise, the destination
ID in the packet must be ours if it is nonzero.)
(\SPPSENDERROR CON XIP "Wrong connection ID.")
(GO DROPIT)))
(SETQ PKTSEQNO (fetch (SPPHEAD SEQNO) of SPPBASE))
(COND
((OR (ILESSP (IPLUS PKTSEQNO 3000)
(fetch SPPACKNO of CON))
(IGREATERP PKTSEQNO (IPLUS (fetch SPPACCEPTNO of CON)
2)))
(* Sequence numbers more than 1 or 2 past the allocation or delayed by more than a few thousand are grounds for
generating an error response. See section 7.2 of the spec.)
(\SPPSENDERROR CON XIP "Packet out of allocation sequence.")
(GO DROPIT))) (* We have a legal packet for this connection.)
(SETQ ACTIVE? T)
[COND
((NOT (fetch SPPESTABLISHEDP of CON)) (* We're just now establishing the connection.)
(replace SPPDESTNSADDRESS of CON with (fetch XIPSOURCENSADDRESS of XIP))
(* The other end may have switched from a well-known
socket to a private one.)
(replace SPPHISID of CON with (fetch (SPPHEAD SOURCECONID) of SPPBASE))
[COND
((fetch SPPSYSPKT of CON) (* Make sure the info in the cached System packet is
correct.)
(\SPP.FIXPKT CON (fetch SPPSYSPKT of CON]
[PROGN (* Does this ever happen? That we send data on a
non-established connection?)
(\SPP.WAIT.FOR.RETRANSMIT.FINISH CON)
(bind (PKT ←(\QUEUEHEAD (fetch SPPRETRANSMITQ of CON)))
while (NOT (NULL PKT))
do (* Go through the packets to be retransmitted and fix
them up.)
(\SPP.FIXPKT CON PKT)
(SETQ PKT (fetch QLINK of PKT]
(replace SPPESTABLISHEDP of CON with T)
(NOTIFY.EVENT (fetch SPP.ESTABLISHED.EVENT of CON]
(SETQ CC (fetch (SPPHEAD CC) of SPPBASE))
(COND
((BITTEST CC \SPPHEAD.CC.ATTENTION)
(COND
((BITTEST CC \SPPHEAD.CC.SYSTEM)
(\SPPSENDERROR CON XIP "Both System and Attention control bits?")
(GO DROPIT)))
(COND
((IGREATERP (IDIFFERENCE (fetch XIPLENGTH of XIP)
(IPLUS \XIPOVLEN \SPPHEAD.LENGTH))
1)
(\SPPSENDERROR CON XIP "More than 1 byte of data in Attention packet?")
(GO DROPIT)))
(SETQ ATTN T)))
(COND
((IGREATERP (SETQ ACKED (fetch (SPPHEAD ACKNO) of SPPBASE))
(fetch SPPACKEDSEQNO of CON))
(\SPP.RELEASE.ACKED.PACKETS CON ACKED)))
[COND
((IGREATERP (fetch (SPPHEAD ALLOCNO) of SPPBASE)
(fetch SPPALLOCNO of CON))
(replace SPPALLOCNO of CON with (fetch (SPPHEAD ALLOCNO) of SPPBASE))
(SETQ ALLOCINCREASED T)
(NOTIFY.EVENT (fetch SPP.NEWALLOCATION of CON]
(COND
((BITTEST CC \SPPHEAD.CC.SYSTEM) (* Don't keep system packets)
(RELEASE.XIP XIP))
(T (\PUT.IN.LINE CON XIP) (* Note that this call may increment the connection's
ACKNO field.)
))
(COND
((BITTEST CC \SPPHEAD.CC.ACKNOWLEDGE) (* The other end wants an acknowledgment.
Wait until we have processed all input)
(replace SPPACKPENDING of CON with T)))
(COND
([AND (fetch SPPACKREQUESTED of CON)
(OR (NEQ ACKED (fetch SPPACKREQUESTED of CON))
(EQ ACKED (fetch SPPSEQNO of CON]
(* This is the first packet that has arrived since we turned on the Ack request timer in \SPP.SENDPKT.
Turn off the timer and update our estimate of round trip delay. This packet might be delayed, and not really in
response to our Ack request. The NEQ test filters out packets that cannot possibly be in response to our ACK: if
partner received our request at seqno N, and has seen up thru N-1, ACKED should be N+1, unless the ack request was
on a system packet.)
(replace SPPROUNDTRIPTIME of CON
with (LRSH (IPLUS (ITIMES 3 (fetch SPPROUNDTRIPTIME of CON))
(IMAX SPP.MIN.TIMEOUT (IMIN (CLOCKDIFFERENCE (fetch
SPPREQUEST.TIME
of CON))
SPP.USER.TIMEOUT)))
2))
(replace SPPACKREQUESTED of CON with NIL)
(SETQ ACKRECEIVED T)))
[COND
(ATTN (\SPPATTN CON XIP (\GETBASEBYTE (EPKT.LEVEL3.CONTENTS XIP)
0]
(GO LOOP)
DROPIT
(RELEASE.XIP XIP)
(GO LOOP])
(\PUT.IN.LINE
[LAMBDA (CON XIP) (* bvm: "18-OCT-83 11:38")
(* This function is called when a non-System packet has arrived for a connection. It inserts the packet in the
proper place in the queue, ordered by sequence number. If the packet is a duplicate, it is dropped.)
(PROG ((ACKNO (fetch SPPACKNO of CON))
(INQ (fetch SPPINWAIT of CON))
(XIPNO (GETPACKETSEQNO XIP))
CURRENT NEXT PKTNO)
(CHECK (\SPP.CHECK.INPUT.QUEUE CON))
[COND
((ILESSP XIPNO ACKNO) (* This packet is a duplicate, so drop it.)
(RELEASE.XIP XIP)
(RETURN))
([OR (NULL (SETQ CURRENT (\QUEUEHEAD INQ)))
(IGREATERP XIPNO (GETPACKETSEQNO (fetch SYSQUEUETAIL of INQ]
(* Goes at tail end of queue.)
(\ENQUEUE INQ XIP))
((ILESSP XIPNO (SETQ PKTNO (GETPACKETSEQNO CURRENT)))
(* Goes right at head of queue.)
(replace QLINK of XIP with CURRENT)
(replace SYSQUEUEHEAD of INQ with XIP))
(T (do (* Loop until the correct place is found for this
packet.)
(if (EQ XIPNO PKTNO)
then (* This packet is a duplicate, so drop it.)
(RELEASE.XIP XIP)
(RETURN))
(SETQ NEXT (fetch QLINK of CURRENT))
(SETQ PKTNO (GETPACKETSEQNO NEXT))
(if (ILESSP XIPNO PKTNO)
then (* Here's where it goes.)
(replace QLINK of XIP with NEXT)
(replace QLINK of CURRENT with XIP)
(RETURN))
(SETQ CURRENT NEXT]
(if (EQ XIPNO ACKNO)
then
(* Looks like this packet opens the way for some acknowledgements. Find the end of the run of consecutive packets
starting with the one we've just inserted.)
(while (AND (SETQ XIP (fetch QLINK of XIP))
(EQ (SETQ PKTNO (GETPACKETSEQNO XIP))
(ADD1 XIPNO)))
do (SETQ XIPNO PKTNO))
(replace SPPACKNO of CON with (ADD1 XIPNO))
(NOTIFY.EVENT (fetch SPP.PACKETARRIVED of CON])
(\SPPAREYOUTHERE?
[LAMBDA (CON) (* ecc "28-JUN-83 11:08")
(* This function gets called when there is no activity
on a connection, and occasionally probes the other end.)
(PROG ((TIMER (fetch SPPAREYOUTHERE of CON)))
(if (OR (NULL TIMER)
(TIMEREXPIRED? TIMER))
then (if TIMER
then (\SPP.PROBE CON))
(replace SPPAREYOUTHERE of CON with (SETUPTIMER (MAX SPP.USER.TIMEOUT
(ITIMES (fetch
SPPROUNDTRIPTIME
of CON)
2))
TIMER])
(\SPP.RELEASE.ACKED.PACKETS
[LAMBDA (CON ACKNO) (* bvm: "16-OCT-83 16:42")
(* Releases packets that are acked by incoming ACKNO, i.e., any packets with sequence number less than ACKNO.
Packets are usually in the retransmit queue, but they can also be in the ether driver's queue awaiting
transmission, or in the SPPRETRANSMITTING queue awaiting retransmission)
(PROG ((QUEUE (fetch SPPRETRANSMITQ of CON))
(OLDACKNO (fetch SPPACKEDSEQNO of CON))
XIP PKTNO)
LP (while (AND (SETQ XIP (fetch SYSQUEUEHEAD of QUEUE))
(ILESSP (SETQ PKTNO (GETPACKETSEQNO XIP))
ACKNO))
do (UNINTERRUPTABLY
(RELEASE.XIP (\DEQUEUE QUEUE))
(replace SPPACKEDSEQNO of CON with (SETQ OLDACKNO (ADD1 PKTNO))))
(COND
((EQ OLDACKNO ACKNO) (* That's the last acked packet)
(RETURN)))
finally (* Didn't get to the last acked packet, so it's either
in transit, or scheduled for retransmission)
(COND
(XIP (HELP "SPP Retransmit Queue out of order" CON)))
(COND
((OR (NULL (SETQ XIP (fetch SPPRETRANSMITTING of CON)))
(NEQ (GETPACKETSEQNO XIP)
OLDACKNO)) (* Something still in transmission)
(do (BLOCK) repeatuntil (fetch SYSQUEUEHEAD of QUEUE))
(GO LP)))
(while (AND XIP (ILESSP (SETQ PKTNO (GETPACKETSEQNO XIP))
ACKNO))
do (UNINTERRUPTABLY
(replace SPPACKEDSEQNO of CON with (ADD1 PKTNO))
[RELEASE.XIP (PROG1 XIP (replace SPPRETRANSMITTING of CON
with (SETQ XIP (fetch EPLINK of XIP])])
(\SPP.START.RETRANSMIT
[LAMBDA (CON) (* bvm: "14-OCT-83 18:31")
(UNINTERRUPTABLY (* Remove the retransmit queue.)
(PROG ((QUEUE (fetch SPPRETRANSMITQ of CON)))
(replace SPPRETRANSMITTING of CON with (fetch SYSQUEUEHEAD of QUEUE))
(replace SYSQUEUEHEAD of QUEUE with NIL)
(replace SYSQUEUETAIL of QUEUE with NIL)))])
(\SPP.RETRANSMIT.NEXT
[LAMBDA (CON) (* bvm: "16-OCT-83 21:20")
(PROG ((XIP (fetch SPPRETRANSMITTING of CON))
BASE)
(SETQ BASE (fetch XIPCONTENTS of XIP))
[change (fetch (SPPHEAD CC) of BASE)
(COND
((EQ (fetch (SPPHEAD SEQNO) of BASE)
(fetch SPPALLOCNO of CON))
(LOGOR DATUM \SPPHEAD.CC.ACKNOWLEDGE))
(T (LOGAND DATUM (LOGXOR 65535 \SPPHEAD.CC.ACKNOWLEDGE]
(* Turn off any acknowledge bit)
(UNINTERRUPTABLY
(replace SPPRETRANSMITTING of CON with (fetch EPLINK of XIP))
(\SPP.SENDPKT CON XIP T))])
(\SPP.WAIT.FOR.RETRANSMIT.FINISH
[LAMBDA (CON) (* bvm: "16-OCT-83 17:40")
(* Wait until everything that we may have been
transmitting ends up on (fetch SPPRETRANSMITQ of CON))
(PROG [(QUEUE (fetch SPPRETRANSMITQ of CON))
(SEQNO (COND
[(fetch SPPRETRANSMITTING of CON)
(fetch (SPPHEAD SEQNO) of (fetch XIPCONTENTS of (fetch SPPRETRANSMITTING
of CON]
(T (fetch SPPSEQNO of CON]
(while (NEQ (COND
[(fetch SYSQUEUETAIL of QUEUE)
(ADD1 (fetch (SPPHEAD SEQNO) of (fetch XIPCONTENTS
of (fetch SYSQUEUETAIL of QUEUE]
(T (fetch SPPACKEDSEQNO of CON)))
SEQNO)
do (BLOCK)) (* Wait for packets to come back from driver)
(bind (XIP ←(fetch SPPRETRANSMITTING of CON)) while XIP
do [\ENQUEUE QUEUE (PROG1 XIP (SETQ XIP (fetch EPLINK of XIP]
finally (replace SPPRETRANSMITTING of CON with NIL])
(\SPPGETERROR
[LAMBDA (CON TRIALPKT MOREMSG) (* ecc " 3-OCT-83 17:09")
(if XIPTRACEFLG
then (printout XIPTRACEFILE "Error packet received on Sequenced Packet Protocol connection."
T)
(PRINTPACKET TRIALPKT NIL XIPTRACEFILE)
(if MOREMSG
then (printout XIPTRACEFILE .TAB0 0 MOREMSG))
(TERPRI XIPTRACEFILE])
(\SPPSENDERROR
[LAMBDA (CON EPKT MSG) (* ecc " 3-OCT-83 17:19")
(* Stub for now)
(PROG ((FILE (OR (AND XIPTRACEFLG XIPTRACEFILE)
T)))
(PRINT MSG FILE)
(TERPRI FILE)
(PRINTPACKET EPKT NIL FILE)
(TERPRI FILE])
)
(* Stream interface to Sequenced Packet Protocol.)
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(ACCESSFNS SPPSTREAM ((SPP.CONNECTION (fetch F1 of DATUM)
(replace F1 of DATUM with NEWVALUE)))
(CREATE (create STREAM
COFFSET ← 0
CBUFSIZE ← 0
BINABLE ← T
BOUTABLE ← T
DEVICE ← \SPPDEVICE
ACCESS ←(QUOTE BOTH))))
]
(DECLARE: EVAL@COMPILE
(RPAQ \MAX.LEVEL3.DATALENGTH (DIFFERENCE \MAX.XIPDATALENGTH \SPPHEAD.LENGTH))
(CONSTANTS (\MAX.LEVEL3.DATALENGTH (DIFFERENCE \MAX.XIPDATALENGTH \SPPHEAD.LENGTH)))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS GETSPPCON MACRO ((X)
(fetch SPP.CONNECTION of X)))
(PUTPROPS GETWORD MACRO (= . \WIN))
(PUTPROPS PUTWORD MACRO (= . \WOUT))
(PUTPROPS GETLONG MACRO (OPENLAMBDA (STREAM)
(\MAKENUMBER (\WIN STREAM)
(\WIN STREAM))))
(PUTPROPS PUTLONG MACRO [OPENLAMBDA (STREAM FIXP)
(PROGN (\WOUT STREAM (\HINUM FIXP))
(\WOUT STREAM (LOGAND FIXP 65535])
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \SPPDEVICE \SPP.BULKDATA.DEVICE)
)
)
(DEFINEQ
(\INITSPP
[LAMBDA NIL (* ecc "12-AUG-83 17:16")
(* Set up devices so that SPP streams can be used generically. The Bulk Data device enables a naive stream user to
read or write a Bulk Data object.)
(SETQ \SPPDEVICE (create FDEV
DEVICENAME ←(QUOTE SPP)
EVENTFN ←(FUNCTION NILL)
TRUNCATEFILE ←(FUNCTION NILL)
CLOSEFILE ←(FUNCTION SPP.CLOSE)
BIN ←(FUNCTION SPP.GETBYTE)
BOUT ←(FUNCTION SPP.PUTBYTE)
EOFP ←(FUNCTION SPP.EOFP)
PEEKBIN ←(FUNCTION SPP.PEEKBIN)
BACKFILEPTR ←(FUNCTION SPP.BACKFILEPTR)))
(SETQ \SPP.BULKDATA.DEVICE (create FDEV using \SPPDEVICE DEVICENAME ←(QUOTE COURIER.BULK.DATA)
CLOSEFILE ←(FUNCTION \BULK.DATA.CLOSE)))
(\DEFINEDEVICE NIL \SPPDEVICE)
(\DEFINEDEVICE NIL \SPP.BULKDATA.DEVICE])
(SPP.OPEN
[LAMBDA (HOST SOCKET PROBEP NAME) (* ecc "18-AUG-83 12:41")
(PROG ((CON (\SPPCONNECTION HOST SOCKET NAME))
(STREAM (create SPPSTREAM)))
[WITH.MONITOR (fetch SPPLOCK of CON)
(replace SPPSTREAM of CON with STREAM)
(replace SPP.CONNECTION of STREAM with CON)
(if (AND (NOT (fetch SPPESTABLISHEDP of CON))
PROBEP)
then (\SPP.PROBE CON)
(MONITOR.AWAIT.EVENT (fetch SPPLOCK of CON)
(fetch SPP.ESTABLISHED.EVENT of CON)
SPP.USER.TIMEOUT)
(if (NOT (fetch SPPESTABLISHEDP of CON))
then (SETQ STREAM NIL]
(RETURN STREAM])
(\ACTIVE.SPP.STREAMP
[LAMBDA (STREAM) (* ecc "17-AUG-83 12:26")
(PROG (CON)
(RETURN (AND STREAM (SETQ CON (GETSPPCON STREAM))
(OR (EQ STREAM (fetch SPPSTREAM of CON))
(EQ STREAM (fetch SPPSUBSTREAM of CON)))
(fetch SPP.PROCESS of CON])
(\STREAM.FROM.PACKET
[LAMBDA (EPKT) (* ecc "11-JUL-83 14:12")
(* Return a stream which will read out of the contents
of a single Packet Exchange packet.)
(CHECK (EQP (fetch XIPTYPE of EPKT)
\XIPT.EXCHANGE))
(* (\STRINGOFD (create STRINGP READONLY ← T BASE ← (LOCF (fetch PACKETEXCHANGEBODY of (fetch XIPCONTENTS of EPKT))
) OFFST ← 0 LENGTH ← (IDIFFERENCE (fetch XIPLENGTH of EPKT) (CONSTANT (IPLUS \XIPOVLEN 6))))))
(\MAKEBASEBYTESTREAM (LOCF (fetch PACKETEXCHANGEBODY of (fetch XIPCONTENTS of EPKT)))
0
(IDIFFERENCE (fetch XIPLENGTH of EPKT)
(CONSTANT (IPLUS \XIPOVLEN 6)))
(QUOTE INPUT])
(SPP.FLUSH
[LAMBDA (STREAM) (* ecc "24-AUG-83 16:30")
(PROG (CON EPKT)
(if (NOT (WRITEABLE STREAM))
then (RETURN))
(SETQ CON (GETSPPCON STREAM))
(if (SETQ EPKT (fetch SPPOUTPKT of CON))
then (add (fetch XIPLENGTH of EPKT)
(fetch COFFSET of STREAM))
(replace SPPOUTPKT of CON with NIL)
(replace CBUFSIZE of STREAM with 0)
(replace COFFSET of STREAM with 0)
(replace CPPTR of STREAM with NIL)
(if (NOT (\SENDSPP CON EPKT))
then (LISPERROR "FILE NOT OPEN" (OR (fetch FULLFILENAME of STREAM)
STREAM])
(SPP.SENDEOM
[LAMBDA (STREAM) (* ecc "24-AUG-83 16:30")
(* Send the End of Message indication.)
(PROG ((CON (GETSPPCON STREAM))
EPKT)
(if (NOT (WRITEABLE STREAM))
then (LISPERROR "FILE NOT OPEN" (OR (fetch FULLFILENAME of STREAM)
STREAM)))
(if (NULL (SETQ EPKT (fetch SPPOUTPKT of CON)))
then (SETQ EPKT (\FILLINSPP.FOR.STREAM STREAM \SPPHEAD.CC.EOM))
else (ORINCCBITS EPKT \SPPHEAD.CC.EOM))
(SPP.FLUSH STREAM])
(SPP.SENDATTENTION
[LAMBDA (STREAM ATTENTIONBYTE CC) (* ecc " 3-OCT-83 16:32")
(* Send an Attention packet with the specified data byte
and control bits. Can't use normal stream mechanism
because stream may be read only.)
(PROG ((CON (GETSPPCON STREAM))
EPKT)
[SETQ EPKT (\FILLINSPP CON (LOGOR \SPPHEAD.CC.ATTENTION (OR CC 0]
(\PUTBASEBYTE (EPKT.LEVEL3.CONTENTS EPKT)
0 ATTENTIONBYTE)
(add (fetch XIPLENGTH of EPKT)
1)
(RETURN (\SENDSPP CON EPKT])
(SPP.CLOSE
[LAMBDA (STREAM ABORT?) (* ecc "17-AUG-83 14:18")
(* Close an SPP stream. Don't close it if there's still
an open Bulk Data stream, unless the user is aborting
the connection.)
(if (\ACTIVE.SPP.STREAMP STREAM)
then (PROG ((CON (GETSPPCON STREAM))
STATUS)
(if (OR (NULL (fetch SPPSUBSTREAM of CON))
ABORT?)
then (if (NOT ABORT?)
then (SPP.FLUSH STREAM))
[SETQ STATUS (\TERMINATESPP CON (NOT (SPP.READP STREAM]
(* Initiate the close if there's nothing more to read or if we've seen the EOF. Otherwise just do the last 2
shakes of the 3-way handshake. We can't call SPP.EOFP because that might block; we just want to know if we've
already encountered it.)
else (replace SPP.PENDING.CLOSE of CON with T)
(* This lets \BULK.DATA.CLOSE know that it's OK to go
ahead and close this stream as well.))
(RETURN STATUS])
(\SPP.CLOSE.IF.ERROR
[LAMBDA (STREAM) (* bvm: "16-NOV-83 14:57")
(COND
(RESETSTATE (SPP.CLOSE STREAM T])
(\SPP.RESETCLOSE
[LAMBDA (STREAM) (* bvm: "16-NOV-83 14:59")
(* * For use in RESETSAVE -- sets the abort arg to SPP.CLOSE according to RESETSTATE)
(SPP.CLOSE STREAM RESETSTATE])
(SPP.GETBYTE
[LAMBDA (STREAM) (* ecc " 3-OCT-83 13:55")
(do (if (ILESSP (fetch COFFSET of STREAM)
(fetch CBUFSIZE of STREAM))
then [RETURN (\GETBASEBYTE (fetch CPPTR of STREAM)
(PROG1 (fetch COFFSET of STREAM)
(add (fetch COFFSET of STREAM)
1]
elseif (NULL (\GETSPP.FOR.STREAM STREAM))
then (RETURN (STREAMOP (QUOTE ENDOFSTREAMOP)
STREAM STREAM])
(SPP.PEEKBIN
[LAMBDA (STREAM NOERRORFLG) (* ecc " 3-OCT-83 13:55")
(do (if (ILESSP (fetch COFFSET of STREAM)
(fetch CBUFSIZE of STREAM))
then (RETURN (\GETBASEBYTE (fetch CPPTR of STREAM)
(fetch COFFSET of STREAM)))
elseif (NULL (\GETSPP.FOR.STREAM STREAM))
then (RETURN (if NOERRORFLG
then NIL
else (STREAMOP (QUOTE ENDOFSTREAMOP)
STREAM STREAM])
(SPP.BACKFILEPTR
[LAMBDA (STREAM) (* ecc "28-JUN-83 15:46")
(if (NOT (ZEROP (fetch COFFSET of STREAM)))
then (add (fetch COFFSET of STREAM)
-1])
(SPP.PUTBYTE
[LAMBDA (STREAM CHAR) (* ecc "11-JUL-83 16:47")
(do (if (ILESSP (fetch COFFSET of STREAM)
(fetch CBUFSIZE of STREAM))
then (\PUTBASEBYTE (fetch CPPTR of STREAM)
(fetch COFFSET of STREAM)
CHAR)
(add (fetch COFFSET of STREAM)
1)
(RETURN)
else (SPP.FLUSH STREAM)
(\FILLINSPP.FOR.STREAM STREAM])
(\GETSPP.FOR.STREAM
[LAMBDA (STREAM TIMEOUT) (* ecc " 3-OCT-83 14:48")
(* Gets the next input packet for the stream interface, or if timeout expires. returns NIL if the packet's
datastream type is END, or if the user is trying to read past the end of a Bulk Data transfer.
Otherwise it returns T)
(PROG ((CON (GETSPPCON STREAM))
EPKT DSTYPE BULK.DATA.STREAM?)
(if (NOT (\ACTIVE.SPP.STREAMP STREAM))
then (* We shouldn't expect any more packets on this stream.)
(RETURN))
(if (SETQ EPKT (fetch SPPINPKT of CON))
then (* Look at previous packet to make sure we're not trying
to read past the end of the stream.)
(SETQ DSTYPE (GETPACKETDSTYPE EPKT))
(SETQ BULK.DATA.STREAM? (EQ STREAM (fetch SPPSUBSTREAM of CON)))
(if (OR [AND BULK.DATA.STREAM? (EQ DSTYPE \SPPDSTYPE.BULKDATA)
(BITTEST (GETPACKETCC EPKT)
(CONSTANT (LOGOR \SPPHEAD.CC.EOM \SPPHEAD.CC.ATTENTION]
(EQ DSTYPE \SPPDSTYPE.END)
(EQ DSTYPE \SPPDSTYPE.ENDREPLY))
then (* Attempt to read past the end of the stream.)
(replace COFFSET of STREAM with (fetch CBUFSIZE of STREAM))
(RETURN)
else (* Throw away the previous packet in preparation for the
next one.)
(replace SPPINPKT of CON with NIL)
(replace CPPTR of STREAM with NIL)
(RELEASE.XIP EPKT)))
(replace CBUFSIZE of STREAM with 0)
AGAIN
(SETQ EPKT (\GETSPP CON TIMEOUT))
[if (NULL EPKT)
then (if TIMEOUT
then (RETURN NIL)
else (ERROR "Connection dropped" (OR (fetch FULLFILENAME of STREAM)
STREAM]
(SETQ DSTYPE (GETPACKETDSTYPE EPKT))
(if (EQ DSTYPE \SPPDSTYPE.END)
then (RETURN))
(if (AND (NOT BULK.DATA.STREAM?)
(EQ DSTYPE \SPPDSTYPE.BULKDATA))
then (* We got a Bulk Data packet on our Courier stream.
It's probably a straggler after we aborted a transfer,
so ignore it.)
(GO AGAIN))
(if (AND BULK.DATA.STREAM? (NOT (EQ DSTYPE \SPPDSTYPE.BULKDATA)))
then
(* This packet was probably meant for the Courier stream, not us. This can happen if we thought we made a Courier
call that returns Bulk Data, but in fact the remote system element is returning an error. We push the packet back
and treat it as an End of Stream.)
(\UNGETSPP CON EPKT)
(\FAKE.BULK.DATA.EOF STREAM)
(RETURN))
(replace SPPINPKT of CON with EPKT)
(replace CPPTR of STREAM with (EPKT.LEVEL3.CONTENTS EPKT))
(replace COFFSET of STREAM with 0)
[replace CBUFSIZE of STREAM with (IDIFFERENCE (fetch XIPLENGTH of EPKT)
(CONSTANT (IPLUS \XIPOVLEN \SPPHEAD.LENGTH]
(if (BITTEST (GETPACKETCC EPKT)
\SPPHEAD.CC.ATTENTION)
then (* Try to clean up after receiving an Attention packet.)
(if BULK.DATA.STREAM?
then (* We're probably underneath a Bulk Data transfer which
the other end has truncated or aborted.)
(replace COFFSET of STREAM with (fetch CBUFSIZE of STREAM))
(* Make it look like we've read past the Attention byte. Then close the stream, getting the Courier results of the
transfer -- probably an error message.)
(RETURN)
else (ERROR "Attention packet received")))
(RETURN T])
(\FILLINSPP.FOR.STREAM
[LAMBDA (STREAM CC) (* ecc "11-JUL-83 16:47")
(* Fill in a new packet for the output side of the
stream interface.)
(PROG ((CON (GETSPPCON STREAM))
EPKT)
(SETQ EPKT (\FILLINSPP CON CC))
(replace SPPOUTPKT of CON with EPKT)
(replace CPPTR of STREAM with (EPKT.LEVEL3.CONTENTS EPKT))
(replace COFFSET of STREAM with 0)
(replace CBUFSIZE of STREAM with \MAX.LEVEL3.DATALENGTH)
(RETURN EPKT])
(SPP.DSTYPE
[LAMBDA (STREAM DSTYPE) (* lmm "29-SEP-83 22:24")
(* Get or set datastream type of current packet.)
(PROG ((CON (GETSPPCON STREAM)))
(RETURN (if DSTYPE
then (if (fetch SPPOUTPKT of CON)
then (replace (SPPHEAD DSTYPE) of (fetch XIPCONTENTS
of (fetch SPPOUTPKT of CON))
with DSTYPE))
(replace SPPDSTYPE of CON with DSTYPE)
else (if (NOT (READABLE STREAM))
then (fetch SPPDSTYPE of CON)
else [if (ZEROP (fetch CBUFSIZE of STREAM))
then (OR (\GETSPP.FOR.STREAM STREAM)
(PROGN (* ACTUALLY, AN ODD ERROR)
(STREAMOP (QUOTE ENDOFSTREAMOP)
STREAM STREAM]
(GETPACKETDSTYPE (fetch SPPINPKT of CON])
(SPP.READP
[LAMBDA (STREAM) (* ecc " 3-OCT-83 14:06")
(if (NOT (READABLE STREAM))
then (LISPERROR "FILE NOT OPEN" (FULLNAME STREAM))
elseif (ILESSP (fetch COFFSET of STREAM)
(fetch CBUFSIZE of STREAM))
then T
else (\GETSPP.FOR.STREAM STREAM 0])
(SPP.EOFP
[LAMBDA (STREAM) (* lmm "29-SEP-83 23:15")
(if (NOT (READABLE STREAM))
then T
elseif (ILESSP (fetch COFFSET of STREAM)
(fetch CBUFSIZE of STREAM))
then NIL
else (NULL (\GETSPP.FOR.STREAM STREAM])
(SPP.ATTENTIONP
[LAMBDA (STREAM) (* lmm "29-SEP-83 23:17")
(PROG NIL
(if (ZEROP (fetch CBUFSIZE of STREAM))
then (OR (\GETSPP.FOR.STREAM STREAM)
(RETURN)))
(RETURN (BITTEST (GETPACKETCC (fetch SPPINPKT of (GETSPPCON STREAM)))
\SPPHEAD.CC.ATTENTION])
)
(\INITSPP)
(* Courier Remote Procedure Call Protocol.)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
(RPAQQ COURIER.VERSION# 3)
(CONSTANTS (COURIER.VERSION# 3))
)
(DECLARE: EVAL@COMPILE
(RPAQQ \COURIERMSG.CALL 0)
(RPAQQ \COURIERMSG.REJECT 1)
(RPAQQ \COURIERMSG.RETURN 2)
(RPAQQ \COURIERMSG.ABORT 3)
(CONSTANTS (\COURIERMSG.CALL 0)
(\COURIERMSG.REJECT 1)
(\COURIERMSG.RETURN 2)
(\COURIERMSG.ABORT 3))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS GET.BULK.DATA.CONTINUATION MACRO ((X)
(fetch BULK.DATA.CONTINUATION of X)))
)
[DECLARE: EVAL@COMPILE
(ACCESSFNS BULKDATASTREAM ((BULK.DATA.CONTINUATION (fetch F2 of DATUM)
(replace F2 of DATUM with NEWVALUE)))
(CREATE (create SPPSTREAM)))
(RECORD \BULK.DATA.CONTINUATION (PROGRAM PROCEDURE RESULT.FUNCTION))
]
)
(* Facilities for manipulating Courier definitions.)
(RPAQ? \COURIERPROGRAM (HARRAY 20))
(DEFINEQ
(COURIERPROGRAM
[NLAMBDA X (* bvm: "16-NOV-83 14:39")
(* Define a Courier program and its associated types, constants, procedures, and errors. Syntax is
(COURIERPROGRAM programName (programNumber versionNumber) TYPES (typeDeclarations ...) PROCEDURES
(procedureDeclarations ...) ERRORS (errorDeclarations ...)) The TYPES, PROCEDURES, and ERRORS may appear in any
order after the program number/version number pair.)
(PROG ((PROGRAMNAME (CAR X))
(NEWINFO (CDR X))
OLDINFO)
(SETQ OLDINFO (GETHASH (SETQ PROGRAMNAME (\DTEST PROGRAMNAME (QUOTE LITATOM)))
\COURIERPROGRAM))
(COND
((AND OLDINFO (NEQ DFNFLG T)
(NOT (EQUAL OLDINFO NEWINFO)))
(LISPXPRINT (LIST (QUOTE COURIER)
(QUOTE program)
PROGRAMNAME
(QUOTE redefined))
T T)))
(PUTHASH PROGRAMNAME NEWINFO \COURIERPROGRAM)
(RETURN PROGRAMNAME])
(DUMP.COURIERPROGRAMS
[NLAMBDA NAMES (* bvm: "17-NOV-83 14:42")
(* Used by the COURIERPROGRAMS filepkgcom)
(for PROGRAM in NAMES bind PGMDEF do (COND
((SETQ PGMDEF (GETHASH PROGRAM \COURIERPROGRAM))
(TERPRI) (* because if you have a really bold font, it lines up
the bottoms, but you can get crowded into the line
above.)
(PRIN1 "(COURIERPROGRAM ")
(COND
((AND FONTCHANGEFLG PRETTYCOMFONT)
(CHANGEFONT PRETTYCOMFONT)))
(PRIN2 PROGRAM)
(COND
((AND FONTCHANGEFLG PRETTYCOMFONT)
(CHANGEFONT DEFAULTFONT)))
(SPACES 1)
(PRIN2 (CAR PGMDEF))
(* Version pair)
(for TAIL on (CDR PGMDEF) by (CDDR TAIL)
do (TAB 4)
(COND
((AND FONTCHANGEFLG CLISPFONT)
(CHANGEFONT PRETTYCOMFONT)))
(PRIN2 (CAR TAIL))
(COND
((AND FONTCHANGEFLG CLISPFONT)
(CHANGEFONT DEFAULTFONT)))
(* Property name)
(TAB 6)
(PRINTDEF (CADR TAIL)
6))
(PRIN1 (QUOTE %)))
(TERPRI))
(T (LISPXPRINT (APPEND (QUOTE (no COURIER definition for))
(LIST PROGRAM))
T T])
(\GET.COURIER.PROG#VERS#.PAIR
[LAMBDA (PROGRAMNAME) (* rmk: "11-OCT-83 17:58")
(OR (CAR (GETHASH PROGRAMNAME \COURIERPROGRAM))
(ERROR "Undefined Courier program" PROGRAMNAME])
(\GET.COURIER.DEFINITION
[LAMBDA (PROGRAM NAME TYPE) (* bvm: "16-NOV-83 14:40")
(COND
((COURIER.QUALIFIED.NAMEP NAME)
(\GET.COURIER.DEFINITION (CAR NAME)
(CDR NAME)
TYPE))
(T (OR (CDR (ASSOC NAME (LISTGET (CDR (GETHASH PROGRAM \COURIERPROGRAM))
TYPE)))
(ERROR (CONCAT "No " TYPE " definition for")
(LIST PROGRAM NAME])
(COURIER.QUALIFIED.NAMEP
[LAMBDA (X) (* bvm: "16-NOV-83 14:40")
(AND (LISTP X)
(LITATOM (CDR X))
(LITATOM (CAR X])
(\GET.COURIER.TYPE
[LAMBDA (PROGRAMNAME TYPENAME) (* ecc " 7-JUL-83 14:34")
(CAR (\GET.COURIER.DEFINITION PROGRAMNAME TYPENAME (QUOTE TYPES])
(\GET.COURIER.PROCEDURE.ARGS
[LAMBDA (PROGRAMNAME PROCEDURENAME) (* ecc " 7-JUL-83 12:43")
(LISTGET (\GET.COURIER.DEFINITION PROGRAMNAME PROCEDURENAME (QUOTE PROCEDURES))
(QUOTE ARGS])
(\GET.COURIER.PROCEDURE.RESULTS
[LAMBDA (PROGRAMNAME PROCEDURENAME) (* ecc " 7-JUL-83 12:44")
(LISTGET (\GET.COURIER.DEFINITION PROGRAMNAME PROCEDURENAME (QUOTE PROCEDURES))
(QUOTE RESULTS])
(\GET.COURIER.PROCEDURE.ERRORS
[LAMBDA (PROGRAMNAME PROCEDURENAME) (* ecc " 7-JUL-83 12:44")
(LISTGET (\GET.COURIER.DEFINITION PROGRAMNAME PROCEDURENAME (QUOTE PROCEDURES))
(QUOTE ERRORS])
(\GET.COURIER.PROCEDURE.NUMBER
[LAMBDA (PROGRAMNAME PROCEDURENAME) (* bvm: "16-NOV-83 14:51")
(PROG [(N (CAR (LAST (\GET.COURIER.DEFINITION PROGRAMNAME PROCEDURENAME (QUOTE PROCEDURES]
(RETURN (COND
((COURIER.QUALIFIED.NAMEP N)
(\GET.COURIER.PROCEDURE.NUMBER (CAR N)
(CDR N)))
(T N])
(\GET.COURIER.ERROR.ARGS
[LAMBDA (PROGRAMNAME ERRORNAME) (* ecc "11-JUL-83 16:22")
(LISTGET (\GET.COURIER.DEFINITION PROGRAMNAME ERRORNAME (QUOTE ERRORS))
(QUOTE ARGS])
(\GET.COURIER.ERROR.NUMBER
[LAMBDA (PROGRAMNAME ERRORNAME) (* bvm: "16-NOV-83 14:52")
(PROG [(N (CAR (LAST (\GET.COURIER.DEFINITION PROGRAMNAME ERRORNAME (QUOTE ERRORS]
(RETURN (COND
((COURIER.QUALIFIED.NAMEP N)
(\GET.COURIER.ERROR.NUMBER (CAR N)
(CDR N)))
(T N])
)
(PUTDEF (QUOTE COURIERPROGRAMS) (QUOTE FILEPKGCOMS) (QUOTE ((COM MACRO (X (E (DUMP.COURIERPROGRAMS .
X)))
CONTENTS NILL))))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \COURIERPROGRAM)
)
(* Functions for calling Courier procedures.)
(RPAQ? NSWIZARDFLG )
(DEFINEQ
(COURIER.OPEN
[LAMBDA (HOSTNAME SERVERTYPE NOERRORFLG NAME) (* bvm: "16-NOV-83 14:58")
(* Open a Courier connection to the specified host.)
(RESETLST (PROG (ADDRESS STREAM LOW.VERSION HIGH.VERSION)
[COND
[(NULL HOSTNAME)
(COND
(NOERRORFLG (RETURN NIL))
(T (ERROR "No host specified" NIL T]
((type? NSADDRESS HOSTNAME)
(SETQ ADDRESS HOSTNAME))
(T (SETQ ADDRESS (LOOKUP.NS.SERVER HOSTNAME SERVERTYPE]
[COND
((NULL ADDRESS)
(COND
(NOERRORFLG (RETURN NIL))
(T (ERROR "Unknown host" HOSTNAME T]
[COND
((NULL (SETQ STREAM (SPP.OPEN ADDRESS \NS.WKS.Courier T NAME)))
(COND
(NOERRORFLG (RETURN NIL))
(T (ERROR "Host not responding" HOSTNAME T]
(RESETSAVE NIL (LIST (FUNCTION \SPP.CLOSE.IF.ERROR)
STREAM))
(SPP.DSTYPE STREAM \SPPDSTYPE.COURIER)
(PUTWORD STREAM COURIER.VERSION#)
(PUTWORD STREAM COURIER.VERSION#)
(SPP.SENDEOM STREAM)
(SETQ LOW.VERSION (GETWORD STREAM))
(SETQ HIGH.VERSION (GETWORD STREAM))
[COND
((NOT (AND (ILEQ LOW.VERSION COURIER.VERSION#)
(ILEQ COURIER.VERSION# HIGH.VERSION)))
(SPP.CLOSE STREAM)
(COND
(NOERRORFLG (RETURN NIL))
(T (ERROR "Server supports wrong version of Courier" (LIST HOSTNAME
LOW.VERSION
HIGH.VERSION)
T]
(RETURN STREAM])
(COURIER.CALL
[LAMBDA ARGS (* ecc " 7-JUL-83 14:27")
(* Call a Courier procedure. (COURIER.CALL stream program-name procedure-name arg1 ... argN no-error-flag) Returns
the result of the remote procedure, or a list of such results if it returns more than one.
If no-error-flag is T, return NIL if the Courier program aborts with an error. If the Courier procedure takes a
Bulk Data parameter, then the result of COURIER.CALL is a stream for the transfer. When the stream is closed, the
results will be read and the functional argument that was supplied in the call, if any, will be applied to the
results.)
(PROG ((STREAM (ARG ARGS 1))
(PROGRAM (ARG ARGS 2))
(PROCEDURE (ARG ARGS 3))
#ARGS ARGLIST NOERRORFLG)
(SETQ #ARGS (LENGTH (\GET.COURIER.PROCEDURE.ARGS PROGRAM PROCEDURE)))
(if (ILESSP ARGS (IPLUS #ARGS 3))
then (ERROR "Too few arguments to Courier procedure" (LIST PROGRAM PROCEDURE)))
(SETQ ARGLIST (for I from 4 to (IPLUS #ARGS 3) collect (ARG ARGS I)))
[if (ILESSP (IPLUS #ARGS 3)
ARGS)
then (SETQ NOERRORFLG (ARG ARGS (IPLUS #ARGS 4]
(if (ILESSP (IPLUS #ARGS 4)
ARGS)
then (ERROR "Too many arguments to Courier procedure" PROCEDURE))
(RETURN (if (COURIER.ARGS STREAM PROGRAM PROCEDURE ARGLIST)
else (COURIER.RESULTS STREAM PROGRAM PROCEDURE NOERRORFLG])
(COURIER.ARGS
[LAMBDA (STREAM PROGRAM PROCEDURE ARGLIST) (* ecc " 4-AUG-83 15:07")
(* Send the arguments for a Courier call to the remote program. Returns NIL if none of the formal parameters are
of type BULK.DATA.SOURCE or BULK.DATA.SINK, otherwise returns a stream for the Bulk Data transfer.)
(if COURIERTRACEFLG
then (\COURIER.TRACE (QUOTE CALL)
PROGRAM PROCEDURE ARGLIST))
(PROG ((PROG#VERS# (\GET.COURIER.PROG#VERS#.PAIR PROGRAM))
SOURCEFLG SOURCEFN SINKFLG SINKFN)
(SPP.DSTYPE STREAM \SPPDSTYPE.COURIER)
(PUTWORD STREAM \COURIERMSG.CALL)
(PUTWORD STREAM 0) (* Transaction ID, ignored for now.)
(PUTLONG STREAM (CAR PROG#VERS#))
(PUTWORD STREAM (CADR PROG#VERS#))
(PUTWORD STREAM (\GET.COURIER.PROCEDURE.NUMBER PROGRAM PROCEDURE))
(for VALUE in ARGLIST as TYPE in (\GET.COURIER.PROCEDURE.ARGS PROGRAM PROCEDURE)
do (SELECTQ TYPE
(BULK.DATA.SOURCE (SETQ SOURCEFLG T)
(SETQ SOURCEFN VALUE)
(PUTWORD STREAM 1))
(BULK.DATA.SINK (SETQ SINKFLG T)
(SETQ SINKFN VALUE)
(PUTWORD STREAM 1))
(COURIER.WRITE STREAM VALUE PROGRAM TYPE)))
(SPP.SENDEOM STREAM)
(CHECK (NOT (AND SOURCEFLG SINKFLG)))
(RETURN (if (OR SOURCEFLG SINKFLG)
then (\BULK.DATA.STREAM STREAM (if SINKFLG
then (QUOTE INPUT)
else (QUOTE OUTPUT))
PROGRAM PROCEDURE (OR SOURCEFN SINKFN))
else NIL])
(COURIER.RESULTS
[LAMBDA (STREAM PROGRAM PROCEDURE NOERRORFLG) (* bvm: "16-NOV-83 15:29")
(PROG (MSGTYPE RESULT)
(SETQ RESULT
(SELECTC (SETQ MSGTYPE (GETWORD STREAM))
[\COURIERMSG.RETURN (PROG ((RESULTTYPES (\GET.COURIER.PROCEDURE.RESULTS PROGRAM
PROCEDURE)))
(GETWORD STREAM)
(* Skip the Transaction ID.)
(RETURN (COND
((EQ (LENGTH RESULTTYPES)
1)
(COURIER.READ STREAM PROGRAM (CAR
RESULTTYPES)))
(T (for TYPE in RESULTTYPES
collect (COURIER.READ STREAM PROGRAM
TYPE]
[\COURIERMSG.ABORT (PROG (NUMBER NAME ARGTYPES ARGVALUES)
(GETWORD STREAM)
(* Skip the Transaction ID.)
(SETQ NUMBER (GETWORD STREAM))
[for ERR in (\GET.COURIER.PROCEDURE.ERRORS PROGRAM
PROCEDURE)
do (COND
((IEQP (\GET.COURIER.ERROR.NUMBER PROGRAM ERR)
NUMBER)
(SETQ NAME ERR)
(SETQ ARGTYPES (\GET.COURIER.ERROR.ARGS
PROGRAM ERR))
(RETURN]
[COND
(NAME (SETQ ARGVALUES (for TYPE in ARGTYPES
collect (COURIER.READ STREAM
PROGRAM
TYPE]
(RETURN (SELECTQ NOERRORFLG
(RETURNERRORS
(CONS (QUOTE ERROR)
(CONS (COND
(NAME)
(NUMBER))
ARGVALUES)))
(NIL (ERROR (CONCAT
"Error in Courier program "
PROGRAM
", procedure "
PROCEDURE ": "
(COND
(NAME)
(NUMBER)))
ARGVALUES))
(PROGN (HANDLE.COURIER.ERROR
PROGRAM PROCEDURE (COND
(NAME)
(NUMBER))
ARGVALUES)
NIL]
[\COURIERMSG.REJECT (GETWORD STREAM) (* Skip the Transaction ID.)
(ERROR (CONCAT "Courier program " PROGRAM
" rejected call to procedure "
PROCEDURE)
(COURIER.READ
STREAM PROGRAM
(QUOTE (CHOICE (noSuchProgramNumber 0)
(noSuchVersionNumber
1
(RECORD (lowest CARDINAL)
(highest CARDINAL)))
(noSuchProcedureValue 2)
(invalidArguments 3)
(unspecifiedError -1]
(ERROR "Unknown Courier message type" MSGTYPE)))
(COND
(COURIERTRACEFLG (\COURIER.TRACE (QUOTE RETURN)
PROGRAM PROCEDURE RESULT)))
(RETURN RESULT])
(HANDLE.COURIER.ERROR
[LAMBDA (PROGRAM PROCEDURE ERRORNAME ERRORARGS) (* edited: " 2-AUG-83 16:39")
(if NSWIZARDFLG
then (printout PROMPTWINDOW .TAB0 0 "Error in Courier program " PROGRAM ", procedure "
PROCEDURE ": " ERRORNAME ": " ERRORARGS])
(\BULK.DATA.STREAM
[LAMBDA (STREAM MODE PROGRAM PROCEDURE RESULT.FUNCTION) (* ecc " 3-OCT-83 16:50")
(* Return a specialized version of an SPP stream suitable for sending or receiving a Bulk Data object.
Uses the Bulk Data device, which redefines the EOFP and CLOSE functions. Save the program, procedure, and result
function in the stream record for use by \BULK.DATA.CLOSE.)
(PROG ((CON (GETSPPCON STREAM))
SUBSTREAM)
(SETQ SUBSTREAM (create BULKDATASTREAM
BULK.DATA.CONTINUATION ←(create \BULK.DATA.CONTINUATION
PROGRAM ← PROGRAM
PROCEDURE ← PROCEDURE
RESULT.FUNCTION ← RESULT.FUNCTION)))
(replace DEVICE of SUBSTREAM with \SPP.BULKDATA.DEVICE)
(replace SPP.CONNECTION of SUBSTREAM with CON)
(replace ACCESSBITS of SUBSTREAM with (SELECTQ MODE
(INPUT ReadBit)
(OUTPUT OutputBits)
(LISPERROR "ILLEGAL ARG" MODE)))
(replace SPPSUBSTREAM of CON with SUBSTREAM)
(if COURIERTRACEFLG
then (\COURIER.TRACE (QUOTE BEGIN.BULK.DATA)
PROGRAM PROCEDURE))
(SPP.DSTYPE SUBSTREAM \SPPDSTYPE.BULKDATA)
(RETURN SUBSTREAM])
(\BULK.DATA.CLOSE
[LAMBDA (STREAM) (* ecc " 3-OCT-83 17:30")
(* Close a Bulk Data stream after the transfer has taken place. If a result function was specified in
COURIER.CALL, call it on the stream and the result or list of results.)
(PROG ((CON (GETSPPCON STREAM))
(CONTINUATION (GET.BULK.DATA.CONTINUATION STREAM))
ABORTFLG COURIERSTREAM RESULTS RESULT.FUNCTION)
(if (NULL (fetch SPPSUBSTREAM of CON))
then
(* This stream has already been closed. We don't want to try to read the Courier results twice, so
\BULK.DATA.CLOSE.INTERNAL sets the substream field of the connection record to NIL.)
(RETURN))
(if COURIERTRACEFLG
then (\COURIER.TRACE (QUOTE END.BULK.DATA)
(fetch PROGRAM of CONTINUATION)
(fetch PROCEDURE of CONTINUATION)))
(if (WRITEABLE STREAM)
then (SPP.SENDEOM STREAM)
elseif (NOT (EOFP STREAM))
then (* Closing before all the data has been read -- abort
the transfer.)
(SETQ ABORTFLG T)
(\ABORT.BULK.DATA STREAM))
(replace SPPINPKT of CON with NIL) (* This stream is closing; make sure there aren't any
dangling pointers into the middle of ether packets.)
(replace CPPTR of STREAM with NIL)
(replace CBUFSIZE of STREAM with 0)
(SETQ COURIERSTREAM (fetch SPPSTREAM of CON))
(RESETLST (RESETSAVE NIL (LIST (FUNCTION \BULK.DATA.CLOSE.INTERNAL)
STREAM))
(* The result of the Courier call may be an error which the user should see; however, we still need to clean up
the substream, so we wrap it in this RESETLST.)
[if ABORTFLG
then (* Don't want any "transfer aborted" errors.
This is overkill.)
[NLSETQ (SETQ RESULTS (COURIER.RESULTS COURIERSTREAM
(fetch PROGRAM of CONTINUATION)
(fetch PROCEDURE of CONTINUATION]
else (SETQ RESULTS (COURIER.RESULTS COURIERSTREAM (fetch PROGRAM of
CONTINUATION)
(fetch PROCEDURE of CONTINUATION]
(if (SETQ RESULT.FUNCTION (fetch RESULT.FUNCTION of CONTINUATION))
then (NLSETQ (APPLY* RESULT.FUNCTION STREAM RESULTS])
(\FAKE.BULK.DATA.EOF
[LAMBDA (STREAM) (* ecc "16-AUG-83 15:28")
(* Make a Bulk Data stream look like EOF has occurred,
by allocating a fake packet with the EOM bit on.)
(PROG ((CON (GETSPPCON STREAM))
EPKT)
(SETQ EPKT (\FILLINSPP CON \SPPHEAD.CC.EOM \SPPDSTYPE.BULKDATA))
(replace SPPINPKT of CON with EPKT)
(replace CPPTR of STREAM with NIL)
(replace COFFSET of STREAM with 0)
(replace CBUFSIZE of STREAM with 0])
(\BULK.DATA.CLOSE.INTERNAL
[LAMBDA (SUBSTREAM) (* ecc "11-AUG-83 14:12")
(PROG ((CON (GETSPPCON SUBSTREAM)))
(replace SPPSUBSTREAM of CON with NIL)
(if (fetch SPP.PENDING.CLOSE of CON)
then (* User has already tried to close the stream, so go
ahead and do it.)
(SPP.CLOSE (fetch SPPSTREAM of CON])
(\ABORT.BULK.DATA
[LAMBDA (STREAM) (* ecc " 3-OCT-83 16:32")
(PROG (EPKT)
(while (\GETSPP.FOR.STREAM STREAM 0) do (* Empty queue of waiting packets without blocking.)
)
(if [AND (SETQ EPKT (fetch SPPINPKT of (GETSPPCON STREAM)))
(BITTEST (GETPACKETCC EPKT)
(CONSTANT (LOGOR \SPPHEAD.CC.EOM \SPPHEAD.CC.ATTENTION]
then (* We've already received the last packet of the Bulk
Data transfer.)
else
(* Abort the bulk data stream by sending an Attention packet with a 1 in it. WARNING: if the EOM bit is set in
this packet, the NS fileserver will crash.)
(SPP.SENDATTENTION STREAM 1)
(* (while (\GETSPP.FOR.STREAM STREAM SPP.USER.TIMEOUT) do (* Ignore any remaining bulk data packets -- there
shouldn't be many if the other end is obeying the protocol.)))
])
(COURIER.WRITE
[LAMBDA (STREAM ITEM PROGRAM TYPE) (* bvm: "18-OCT-83 11:05")
(if (COURIER.QUALIFIED.NAMEP TYPE)
then (COURIER.WRITE STREAM ITEM (CAR TYPE)
(CDR TYPE))
else (SELECTQ (TYPENAME TYPE)
[LITATOM (SELECTQ TYPE
(BOOLEAN (PUTWORD STREAM (if ITEM
then 1
else 0)))
((CARDINAL INTEGER UNSPECIFIED)
(PUTWORD STREAM ITEM))
((LONGCARDINAL LONGINTEGER)
(PUTLONG STREAM ITEM))
[STRING (PROG [(LENGTH (NCHARS (SETQ ITEM (MKSTRING ITEM]
(PUTWORD STREAM LENGTH)
(\BOUTS STREAM (fetch (STRINGP BASE)
of ITEM)
(fetch (STRINGP OFFST) of ITEM)
LENGTH)
(if (ODDP LENGTH)
then (BOUT STREAM 0]
(TIME (COURIER.WRITE STREAM (LISP.TO.ALTO.DATE ITEM)
PROGRAM
(QUOTE LONGCARDINAL)))
(if (\GET.COURIER.TYPE PROGRAM TYPE)
then (COURIER.WRITE STREAM ITEM PROGRAM (\GET.COURIER.TYPE
PROGRAM TYPE))
else (ERROR "Unknown Courier type" TYPE]
(LISTP (SELECTQ (CAR TYPE)
[ENUMERATION (PUTWORD STREAM (COND
[(CADR (ASSOC ITEM (CDR TYPE]
(T (ERROR
"Illegal Courier value for enumeration type"
ITEM]
[ARRAY (PROG ((SIZE (CADR TYPE))
(BASETYPE (CADDR TYPE)))
(if (NOT (IEQP SIZE (LENGTH ITEM)))
then (ERROR
"Wrong number of elements for Courier array"
ITEM))
(for X in ITEM do (COURIER.WRITE STREAM X PROGRAM
BASETYPE]
[SEQUENCE (* We ignore the maximum length of the sequence.)
(PROG [(BASETYPE (if (CADDR TYPE)
elseif (CADR TYPE]
(PUTWORD STREAM (LENGTH ITEM))
(for X in ITEM do (COURIER.WRITE STREAM X PROGRAM
BASETYPE]
[RECORD (for NAMEANDTYPE in (CDR TYPE) as NAMEANDVALUE
in ITEM
do (if (NEQ (CAR NAMEANDTYPE)
(CAR NAMEANDVALUE))
then (ERROR
"Illegal Courier value for record type"
ITEM))
(COURIER.WRITE STREAM (CADR NAMEANDVALUE)
PROGRAM
(CADR NAMEANDTYPE]
[CHOICE (PROG [(WHICH (ASSOC (CAR ITEM)
(CDR TYPE]
(if (NULL WHICH)
then (ERROR
"Illegal Courier value for choice type"
ITEM))
(PUTWORD STREAM (CADR WHICH))
(if (CADDR WHICH)
then (COURIER.WRITE STREAM (CADR ITEM)
PROGRAM
(CADDR WHICH]
(ERROR "Unknown Courier type" TYPE)))
(ERROR "Unknown Courier type" TYPE])
(COURIER.READ
[LAMBDA (STREAM PROGRAM TYPE) (* bvm: "18-OCT-83 11:07")
(if (COURIER.QUALIFIED.NAMEP TYPE)
then (COURIER.READ STREAM (CAR TYPE)
(CDR TYPE))
else (SELECTQ (TYPENAME TYPE)
[LITATOM (SELECTQ TYPE
[BOOLEAN (NOT (ZEROP (GETWORD STREAM]
((CARDINAL INTEGER UNSPECIFIED)
(GETWORD STREAM))
((LONGCARDINAL LONGINTEGER)
(GETLONG STREAM))
(STRING (PROG ((LENGTH (GETWORD STREAM))
STRING)
(SETQ STRING (ALLOCSTRING LENGTH))
(\BINS STREAM (fetch (STRINGP BASE) of STRING)
(fetch (STRINGP OFFST) of STRING)
LENGTH)
(if (ODDP LENGTH)
then (BIN STREAM))
(RETURN STRING)))
[TIME (ALTO.TO.LISP.DATE (COURIER.READ STREAM PROGRAM
(QUOTE LONGCARDINAL]
(if (\GET.COURIER.TYPE PROGRAM TYPE)
then (COURIER.READ STREAM PROGRAM (\GET.COURIER.TYPE
PROGRAM
TYPE))
else (ERROR "Unknown Courier type" TYPE]
(LISTP (SELECTQ (CAR TYPE)
(ENUMERATION (bind (ITEM ←(GETWORD STREAM)) for DEF
in (CDR TYPE) do (if (IEQP ITEM (CADR DEF))
then (RETURN (CAR DEF)))
finally (RETURN ITEM)))
(ARRAY (bind (BASETYPE ←(CADDR TYPE)) to (CADR TYPE)
collect (COURIER.READ STREAM PROGRAM BASETYPE)))
(SEQUENCE (* We ignore the maximum length of the sequence.)
(bind (BASETYPE ←(if (CADDR TYPE)
elseif (CADR TYPE)))
to (GETWORD STREAM) collect (COURIER.READ STREAM
PROGRAM
BASETYPE)))
[RECORD (for NAMEANDTYPE in (CDR TYPE)
collect (LIST (CAR NAMEANDTYPE)
(COURIER.READ STREAM PROGRAM
(CADR NAMEANDTYPE]
[CHOICE (bind (WHICH ←(GETWORD STREAM)) for DEF
in (CDR TYPE)
do [if (IEQP WHICH (CADR DEF))
then (RETURN (if (CADDR DEF)
then
(LIST (CAR DEF)
(COURIER.READ
STREAM PROGRAM
(CADDR DEF)))
else (LIST (CAR DEF]
finally (RETURN (LIST WHICH (QUOTE ???]
(ERROR "Unknown Courier type" TYPE)))
(ERROR "Unknown Courier type" TYPE])
(COURIER.WRITE.REP
[LAMBDA (ITEM PROGRAM TYPE) (* bvm: "18-OCT-83 11:18")
(* Like COURIER.WRITE but returns a list of integers
corresponding to the sequence of 20Q bit words in the
Courier representation of ITEM.)
(if (COURIER.QUALIFIED.NAMEP TYPE)
then (COURIER.WRITE.REP ITEM (CAR TYPE)
(CDR TYPE))
else
(SELECTQ
(TYPENAME TYPE)
[LITATOM (SELECTQ
TYPE
(BOOLEAN (LIST (if ITEM
then 1
else 0)))
((CARDINAL INTEGER UNSPECIFIED)
(LIST ITEM))
[(LONGCARDINAL LONGINTEGER)
(LIST (LRSH ITEM (CONSTANT (ITIMES BitsPerByte BYTESPERWORD)))
(LOGAND ITEM (CONSTANT (SUB1 (LLSH 1 (CONSTANT (ITIMES BitsPerByte
BYTESPERWORD]
[STRING (PROG (LENGTH CHARLIST)
[SETQ LENGTH (LENGTH (SETQ CHARLIST (UNPACK (MKSTRING ITEM]
(RETURN (CONS LENGTH
(for CHARPAIR on CHARLIST by (CDDR CHARLIST)
collect (LOGOR (LLSH (CHCON1 (CAR CHARPAIR))
BitsPerByte)
(if (NOT (NULL (CADR CHARPAIR)))
then (CHCON1 (CADR CHARPAIR))
else 0]
(TIME (COURIER.WRITE.REP (LISP.TO.ALTO.DATE ITEM)
PROGRAM
(QUOTE LONGCARDINAL)))
(if (\GET.COURIER.TYPE PROGRAM TYPE)
then (COURIER.WRITE.REP ITEM PROGRAM (\GET.COURIER.TYPE PROGRAM TYPE))
else (ERROR "Unknown Courier type" TYPE]
(LISTP (SELECTQ (CAR TYPE)
[ENUMERATION (LIST (COND
[(CADR (ASSOC ITEM (CDR TYPE]
(T (ERROR "Illegal Courier value for enumeration type"
ITEM]
[ARRAY (PROG ((SIZE (CADR TYPE))
(BASETYPE (CADDR TYPE)))
(if (NOT (IEQP SIZE (LENGTH ITEM)))
then (ERROR "Wrong number of elements for Courier array"
ITEM))
(RETURN (for X in ITEM join (COURIER.WRITE.REP X PROGRAM
BASETYPE]
[SEQUENCE (* We ignore the maximum length of the sequence.)
(PROG [(BASETYPE (if (CADDR TYPE)
elseif (CADR TYPE]
(RETURN (CONS (LENGTH ITEM)
(for X in ITEM join (COURIER.WRITE.REP X
PROGRAM
BASETYPE]
[RECORD (for NAMEANDTYPE in (CDR TYPE) as NAMEANDVALUE in ITEM
join (if (NEQ (CAR NAMEANDTYPE)
(CAR NAMEANDVALUE))
then (ERROR "Illegal Courier value for record type" ITEM)
)
(COURIER.WRITE.REP (CADR NAMEANDVALUE)
PROGRAM
(CADR NAMEANDTYPE]
[CHOICE (PROG [(WHICH (ASSOC (CAR ITEM)
(CDR TYPE]
(if (NULL WHICH)
then (ERROR "Illegal Courier value for choice type" ITEM))
(RETURN (CONS (CADR WHICH)
(if (CADDR WHICH)
then (COURIER.WRITE.REP (CADR ITEM)
PROGRAM
(CADDR WHICH]
(ERROR "Unknown Courier type" TYPE)))
(ERROR "Unknown Courier type" TYPE])
(COURIER.READ.REP
[LAMBDA (LIST.OF.WORDS PROGRAM TEMPLATE) (* ecc " 7-JUL-83 14:43")
(* Like COURIER.READ but "reads" from a list of integers
corresponding to the words in the Courier
representation.)
(CAR (\COURIER.READ.REP.INTERNAL LIST.OF.WORDS PROGRAM TEMPLATE])
(\COURIER.READ.REP.INTERNAL
[LAMBDA (LIST.OF.WORDS PROGRAM TYPE) (* bvm: "18-OCT-83 11:20")
(* Internal function for COURIER.READ.REP. Because it's called recursively, we need to update our copy of
LIST.OF.WORDS somehow. So the value returned is a list whose CAR is the Courier value, and whose CDR is the list
of still unread words from the original list.)
(if (COURIER.QUALIFIED.NAMEP TYPE)
then (\COURIER.READ.REP.INTERNAL LIST.OF.WORDS (CAR TYPE)
(CDR TYPE))
else
(SELECTQ
(TYPENAME TYPE)
[LITATOM
(SELECTQ
TYPE
[BOOLEAN (PROG ((X (pop LIST.OF.WORDS)))
(RETURN (CONS (NOT (ZEROP X))
LIST.OF.WORDS]
((CARDINAL INTEGER UNSPECIFIED)
LIST.OF.WORDS)
[(LONGCARDINAL LONGINTEGER)
(PROG ((HI (pop LIST.OF.WORDS))
LO)
(SETQ LO (pop LIST.OF.WORDS))
(RETURN (CONS (LOGOR (LLSH HI (CONSTANT (ITIMES BitsPerByte BYTESPERWORD)))
LO)
LIST.OF.WORDS]
[STRING
(PROG ((LENGTH (pop LIST.OF.WORDS))
STRING)
[SETQ STRING
(MKSTRING
(PACK (bind WORD for I from 1 to LENGTH by 2
join (SETQ WORD (pop LIST.OF.WORDS))
(if (IEQP I LENGTH)
then (LIST (CHARACTER (LRSH WORD BitsPerByte)))
else (LIST (CHARACTER (LRSH WORD BitsPerByte))
(CHARACTER (LOGAND WORD
(CONSTANT (SUB1 (LLSH 1
BitsPerByte]
(RETURN (CONS STRING LIST.OF.WORDS]
[TIME (PROG [(X (\COURIER.READ.REP.INTERNAL LIST.OF.WORDS PROGRAM (QUOTE LONGCARDINAL]
(RETURN (CONS (ALTO.TO.LISP.DATE (CAR X))
(CDR X]
(if (\GET.COURIER.TYPE PROGRAM TYPE)
then (\COURIER.READ.REP.INTERNAL LIST.OF.WORDS PROGRAM (\GET.COURIER.TYPE PROGRAM
TYPE))
else (ERROR "Unknown Courier type" TYPE]
[LISTP (PROG ((RESULT))
(SETQ RESULT (SELECTQ (CAR TYPE)
(ENUMERATION (bind (ITEM ←(pop LIST.OF.WORDS))
for DEF in (CDR TYPE)
do (if (IEQP ITEM (CADR DEF))
then (RETURN (CAR DEF)))
finally (RETURN ITEM)))
(ARRAY (bind (X (BASETYPE ←(CADDR TYPE)))
to (CADR TYPE)
collect (SETQ X (\COURIER.READ.REP.INTERNAL
LIST.OF.WORDS PROGRAM BASETYPE))
(SETQ LIST.OF.WORDS (CDR X))
(CAR X)))
(SEQUENCE (* We ignore the maximum length of the sequence.)
(bind [X (BASETYPE ←(if (CADDR TYPE)
elseif (CADR TYPE]
to (pop LIST.OF.WORDS)
collect (SETQ X (\COURIER.READ.REP.INTERNAL
LIST.OF.WORDS PROGRAM BASETYPE))
(SETQ LIST.OF.WORDS (CDR X))
(CAR X)))
[RECORD (bind X for NAMEANDTYPE in (CDR TYPE)
collect (SETQ X (\COURIER.READ.REP.INTERNAL
LIST.OF.WORDS PROGRAM
(CADR NAMEANDTYPE)))
(SETQ LIST.OF.WORDS (CDR X))
(LIST (CAR NAMEANDTYPE)
(CAR X]
[CHOICE
(bind (X (WHICH ←(pop LIST.OF.WORDS))) for DEF
in (CDR TYPE)
do [if (IEQP WHICH (CADR DEF))
then (RETURN (if (CADDR DEF)
then (SETQ X
(
\COURIER.READ.REP.INTERNAL LIST.OF.WORDS PROGRAM (CADDR DEF)))
(SETQ LIST.OF.WORDS
(CDR X))
(LIST (CAR DEF)
(CAR X))
else (LIST (CAR DEF]
finally (RETURN (LIST WHICH (QUOTE ???]
(ERROR "Unknown Courier type" TYPE)))
(RETURN (CONS RESULT LIST.OF.WORDS]
(ERROR "Unknown Courier type" TYPE])
(COURIER.READ.BULKDATA
[LAMBDA (STREAM PROGRAM TYPE) (* ecc " 7-JUL-83 14:30")
(* Read a Bulk Data object which is a stream of the specified type. This can be done by declaring the stream type
in Courier, as is done in the protocol specs, but that causes COURIER.READ to produce a deeply nested structure.
Instead, this function returns a list of objects making up the stream. See the Bulk Data Transfer spec.)
(bind (SEQUENCETYPE ←(LIST (QUOTE SEQUENCE)
TYPE))
(SEGMENT ←(GETWORD STREAM)) while SEGMENT join (PROG1 (COURIER.READ STREAM PROGRAM
SEQUENCETYPE)
(SETQ SEGMENT
(SELECTQ SEGMENT
(0 (GETWORD STREAM))
(1 NIL)
(ERROR
"Unknown segment choice in stream"
SEGMENT])
)
(* Debugging)
(ADDTOVAR XIPPRINTMACROS (5 . PRINTSPP))
(RPAQ? COURIERTRACEFILE )
(RPAQ? COURIERTRACEFLG )
(DEFINEQ
(PPSPP
[LAMBDA (CON) (* bvm: "16-OCT-83 16:45")
(printout T " local ID: " (fetch SPPMYID of CON)
" remote ID: "
(fetch SPPHISID of CON)
T " established: " (fetch SPPESTABLISHEDP of CON)
" request pending: "
(fetch SPPACKREQUESTED of CON)
" close pending: "
(fetch SPP.PENDING.CLOSE of CON)
" terminated: "
(fetch SPPTERMINATEDP of CON)
T " local seq: " (fetch SPPSEQNO of CON)
" ack: "
(fetch SPPACKNO of CON)
" alloc: "
(fetch SPPACCEPTNO of CON)
" ds: "
(SELECTC (fetch SPPDSTYPE of CON)
(\SPPDSTYPE.COURIER "courier")
(\SPPDSTYPE.BULKDATA "bulkdata")
(fetch SPPDSTYPE of CON))
T " remote ack: " (fetch SPPACKEDSEQNO of CON)
" alloc: "
(fetch SPPALLOCNO of CON)
" round trip: "
(fetch SPPROUNDTRIPTIME of CON)
T " input pkt:" # [COND
((fetch SPPINPKT of CON)
(PRINTSPP (fetch SPPINPKT of CON]
" input queue: " # (PRINTPACKETQUEUE (fetch SPPINWAIT of CON)
NIL T)
" awaiting ack: " # (PRINTPACKETQUEUE (fetch SPPRETRANSMITQ of CON)
NIL T)
" being retransmitted: " # (PRINTPACKETQUEUE (fetch SPPRETRANSMITTING of CON)
NIL T])
(\SPP.CHECK.INPUT.QUEUE
[LAMBDA (CON) (* bvm: "18-OCT-83 11:32")
(PROG ((ACKNO (fetch SPPACKNO of CON))
(INQ (fetch SPPINWAIT of CON))
N1 N2 CURRENT NEXT) (* Check consistency of input queue.)
(SETQ CURRENT (fetch SYSQUEUEHEAD of INQ))
L (COND
((NULL CURRENT)
(RETURN T)))
(SETQ N1 (GETPACKETSEQNO CURRENT))
(COND
((EQ N1 ACKNO)
(SHOULDNT
"The input queue contains a packet that should have been acknowledged already.")
(RETURN NIL)))
(COND
((NULL (SETQ NEXT (fetch QLINK of CURRENT)))
(RETURN T)))
(SETQ N2 (GETPACKETSEQNO NEXT))
(COND
((EQ N1 N2)
(SHOULDNT "The input queue has duplicates.")
(RETURN NIL)))
(COND
((ILESSP N2 N1)
(SHOULDNT "The input queue is out of order.")
(RETURN NIL)))
(SETQ CURRENT NEXT)
(GO L])
(PRINTSPP
[LAMBDA (EPKT FILE) (* bvm: "12-OCT-83 16:50")
(PROG ((BASE (fetch XIPCONTENTS of EPKT))
CC DS)
(printout FILE (fetch (SPPHEAD SOURCECONID) of BASE)
"/"
(fetch (SPPHEAD DESTCONID) of BASE))
[COND
((NEQ (SETQ CC (fetch (SPPHEAD CC) of BASE))
0)
(PROG ((SEPR " [")
(COMMA ", "))
(COND
((BITTEST CC \SPPHEAD.CC.SYSTEM)
(printout FILE SEPR "sys")
(SETQ SEPR COMMA)))
(COND
((BITTEST CC \SPPHEAD.CC.ACKNOWLEDGE)
(printout FILE SEPR "ack")
(SETQ SEPR COMMA)))
(COND
((BITTEST CC \SPPHEAD.CC.ATTENTION)
(printout FILE SEPR "attn")
(SETQ SEPR COMMA)))
(COND
((BITTEST CC \SPPHEAD.CC.EOM)
(printout FILE SEPR "eom")
(SETQ SEPR COMMA)))
(COND
((NEQ SEPR COMMA)
(printout FILE SEPR "??")))
(printout FILE "]"]
(printout FILE , (SELECTC (SETQ DS (fetch (SPPHEAD DSTYPE) of BASE))
(\SPPDSTYPE.COURIER "courier")
(\SPPDSTYPE.BULKDATA "bulkdata")
(\SPPDSTYPE.END "end")
(\SPPDSTYPE.ENDREPLY "end-reply")
DS)
" seq "
(fetch (SPPHEAD SEQNO) of BASE)
"; ack/alloc = "
(fetch (SPPHEAD ACKNO) of BASE)
"/"
(fetch (SPPHEAD ALLOCNO) of BASE)
"; "
(IDIFFERENCE (fetch XIPLENGTH of EPKT)
(CONSTANT (IPLUS \XIPOVLEN \SPPHEAD.LENGTH)))
" bytes" T T])
(SPP.DRIBBLE
[LAMBDA (FORM FILE) (* ecc "15-AUG-83 17:00")
(if (NULL FILE)
then (SETQ FILE (QUOTE {DSK}SPP.Transcript)))
(RESETLST (RESETSAVE XIPTRACEFILE (OPENFILE FILE (QUOTE OUTPUT)))
(RESETSAVE XIPONLYTYPES (CONSTANT (LIST \XIPT.SPP \XIPT.ERROR)))
(RESETSAVE XIPTRACEFLG T)
(RESETSAVE NIL (LIST (FUNCTION CLOSEF?)
XIPTRACEFILE))
(PRINT FORM XIPTRACEFILE)
(TERPRI XIPTRACEFILE)
(EVAL FORM])
(COURIERTRACE
[LAMBDA (FLG REGION) (* ecc " 4-AUG-83 15:13")
(if (NULL FLG)
then (if (ACTIVEWP COURIERTRACEFILE)
then (CLOSEW COURIERTRACEFILE))
(SETQ COURIERTRACEFILE T)
(SETQ COURIERTRACEFLG NIL)
else (if (NOT (ACTIVEWP COURIERTRACEFILE))
then (SETQ COURIERTRACEFILE (CREATEW REGION "Courier Trace Window")))
[WINDOWPROP COURIERTRACEFILE (QUOTE BUTTONEVENTFN)
(FUNCTION (LAMBDA (WINDOW)
(if (LASTMOUSESTATE (NOT UP))
then (\CHANGE.ETHER.TRACING WINDOW (QUOTE COURIERTRACEFLG]
[WINDOWPROP COURIERTRACEFILE (QUOTE CLOSEFN)
(FUNCTION (LAMBDA (WINDOW)
(if (EQ WINDOW COURIERTRACEFILE)
then (SETQ COURIERTRACEFLG NIL)
(SETQ COURIERTRACEFILE T]
(DSPFONT (FONTCREATE (QUOTE GACHA)
8)
COURIERTRACEFILE)
(SETQ COURIERTRACEFLG FLG)
(DSPSCROLL T COURIERTRACEFILE)
(TOTOPW COURIERTRACEFILE)
COURIERTRACEFILE])
(\COURIER.TRACE
[LAMBDA (EVENT PROGRAM PROCEDURE ARGUMENTS) (* ecc "24-AUG-83 16:31")
(if (EQ COURIERTRACEFLG (QUOTE PEEK))
then (SELECTQ EVENT
(CALL (printout COURIERTRACEFILE " " PROGRAM "." PROCEDURE "("))
(RETURN (printout COURIERTRACEFILE ")"))
(BEGIN.BULK.DATA (printout COURIERTRACEFILE "<"))
(END.BULK.DATA (printout COURIERTRACEFILE ">"))
(SHOULDNT))
else (printout COURIERTRACEFILE .TAB0 0 PROGRAM "." PROCEDURE)
(SELECTQ EVENT
(CALL (printout COURIERTRACEFILE (OR ARGUMENTS "()")))
(RETURN (printout COURIERTRACEFILE " => " ARGUMENTS))
(BEGIN.BULK.DATA (printout COURIERTRACEFILE " beginning Bulk Data transfer"))
(END.BULK.DATA (printout COURIERTRACEFILE " ending Bulk Data transfer"))
(SHOULDNT])
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA DUMP.COURIERPROGRAMS COURIERPROGRAM)
(ADDTOVAR NLAML )
(ADDTOVAR LAMA COURIER.CALL)
)
(PUTPROPS SPP COPYRIGHT ("Xerox Corporation" 1983))
(DECLARE: DONTCOPY
(FILEMAP (NIL (12494 45305 (\SPPCONNECTION 12504 . 13877) (\SPP.SENDPKT 13879 . 16445) (\SPP.FIXPKT
16447 . 17094) (\SPPWEDGED 17096 . 18365) (\SPPATTN 18367 . 18863) (\FILLINSPP 18865 . 19491) (
\SPP.PROBE 19493 . 19836) (\SPP.SYSPKT 19838 . 20878) (\GETSPP 20880 . 22178) (\UNGETSPP 22180 . 22968
) (\SENDSPP 22970 . 24743) (\TERMINATESPP 24745 . 26673) (\SPPWATCHER 26675 . 28555) (\SPPEXIT 28557
. 30370) (\SPPINPUTWORK 30372 . 37086) (\PUT.IN.LINE 37088 . 39497) (\SPPAREYOUTHERE? 39499 . 40197)
(\SPP.RELEASE.ACKED.PACKETS 40199 . 42059) (\SPP.START.RETRANSMIT 42061 . 42553) (\SPP.RETRANSMIT.NEXT
42555 . 43325) (\SPP.WAIT.FOR.RETRANSMIT.FINISH 43327 . 44529) (\SPPGETERROR 44531 . 44932) (
\SPPSENDERROR 44934 . 45303)) (46438 61433 (\INITSPP 46448 . 47341) (SPP.OPEN 47343 . 48083) (
\ACTIVE.SPP.STREAMP 48085 . 48434) (\STREAM.FROM.PACKET 48436 . 49243) (SPP.FLUSH 49245 . 50000) (
SPP.SENDEOM 50002 . 50639) (SPP.SENDATTENTION 50641 . 51300) (SPP.CLOSE 51302 . 52515) (
\SPP.CLOSE.IF.ERROR 52517 . 52687) (\SPP.RESETCLOSE 52689 . 52943) (SPP.GETBYTE 52945 . 53472) (
SPP.PEEKBIN 53474 . 53985) (SPP.BACKFILEPTR 53987 . 54220) (SPP.PUTBYTE 54222 . 54701) (
\GETSPP.FOR.STREAM 54703 . 58737) (\FILLINSPP.FOR.STREAM 58739 . 59401) (SPP.DSTYPE 59403 . 60367) (
SPP.READP 60369 . 60730) (SPP.EOFP 60732 . 61054) (SPP.ATTENTIONP 61056 . 61431)) (62408 67607 (
COURIERPROGRAM 62418 . 63397) (DUMP.COURIERPROGRAMS 63399 . 64927) (\GET.COURIER.PROG#VERS#.PAIR 64929
. 65156) (\GET.COURIER.DEFINITION 65158 . 65575) (COURIER.QUALIFIED.NAMEP 65577 . 65756) (
\GET.COURIER.TYPE 65758 . 65945) (\GET.COURIER.PROCEDURE.ARGS 65947 . 66178) (
\GET.COURIER.PROCEDURE.RESULTS 66180 . 66417) (\GET.COURIER.PROCEDURE.ERRORS 66419 . 66654) (
\GET.COURIER.PROCEDURE.NUMBER 66656 . 67029) (\GET.COURIER.ERROR.ARGS 67031 . 67250) (
\GET.COURIER.ERROR.NUMBER 67252 . 67605)) (67913 95377 (COURIER.OPEN 67923 . 69418) (COURIER.CALL
69420 . 70974) (COURIER.ARGS 70976 . 72646) (COURIER.RESULTS 72648 . 75371) (HANDLE.COURIER.ERROR
75373 . 75665) (\BULK.DATA.STREAM 75667 . 76954) (\BULK.DATA.CLOSE 76956 . 79522) (\FAKE.BULK.DATA.EOF
79524 . 80182) (\BULK.DATA.CLOSE.INTERNAL 80184 . 80669) (\ABORT.BULK.DATA 80671 . 81693) (
COURIER.WRITE 81695 . 84562) (COURIER.READ 84564 . 87050) (COURIER.WRITE.REP 87052 . 90238) (
COURIER.READ.REP 90240 . 90640) (\COURIER.READ.REP.INTERNAL 90642 . 94494) (COURIER.READ.BULKDATA
94496 . 95375)) (95507 102003 (PPSPP 95517 . 96997) (\SPP.CHECK.INPUT.QUEUE 96999 . 98035) (PRINTSPP
98037 . 99599) (SPP.DRIBBLE 99601 . 100109) (COURIERTRACE 100111 . 101132) (\COURIER.TRACE 101134 .
102001)))))
STOP