(FILECREATED "14-AUG-83 18:01:48" {PHYLUM}<LISPCORE>SOURCES>SPP.;14 95444
changes to: (VARS SPPCOMS)
(FNS COURIERPROGRAM \GET.COURIER.PROG#VERS#.PAIR \GET.COURIER.DEFINITION)
previous date: "12-AUG-83 10:03:03" {PHYLUM}<LISPCORE>SOURCES>SPP.;13)
(* Copyright (c) 1983 by Xerox Corporation)
(PRETTYCOMPRINT SPPCOMS)
(RPAQQ SPPCOMS [(COMS (DECLARE: DONTCOPY EVAL@COMPILE (FILES (LOADCOMP)
LLNS)))
(COMS (* Sequenced Packet Protocol.)
(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 10)
(\SPP.INITIAL.ROUNDTRIP 2500))
(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))
(INITRECORDS SPPCON SPPHEAD)
(INITVARS (SPP.USER.TIMEOUT 15000))
(FNS \SPPCONNECTION \SPP.SENDPKT \SPP.FIXPKT \SPPWEDGED \SPPATTN \FILLINSPP \SPP.PROBE
\SPP.SYSPKT \GETSPP \SENDSPP \TERMINATESPP \SPPWATCHER \SPPEXIT \SPPINPUTWORK
\PUT.IN.LINE \SPPOUTPUTWORK \SPPAREYOUTHERE? \SPPRETRANSMIT \SPP.FIX.RETRANSMITQ
\SPPGETERROR \SPPSENDERROR))
(COMS (* Stream interface to Sequenced Packet Protocol.)
(DECLARE: DONTCOPY (RECORDS SPPSTREAM)
(CONSTANTS (\MAX.LEVEL3.DATALENGTH (DIFFERENCE \MAX.XIPDATALENGTH
\SPPHEAD.LENGTH)))
(MACROS GETSPPCON)
(GLOBALVARS \SPPDEVICE \SPP.BULKDATA.DEVICE))
(INITRECORDS SPPSTREAM)
(FNS \INITSPP SPP.OPEN \STREAM.FROM.PACKET SPP.FLUSH SPP.SENDEOM SPP.SENDATTENTION
SPP.CLOSE SPP.GETBYTE SPP.PEEKBIN SPP.BACKFILEPTR SPP.PUTBYTE GETWORD PUTWORD
GETLONG PUTLONG \GETSPP.FOR.STREAM \FILLINSPP.FOR.STREAM SPP.DSTYPE SPP.READP
SPP.EOFP SPP.EOMP 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 COURIER.QUALIFIED.NAME))
(INITRECORDS BULKDATASTREAM)
(* Facilities for manipulating Courier definitions.)
(FNS COURIERPROGRAM \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)
(* Functions for calling Courier procedures.)
[INITVARS (NSWIZARDFLG NIL)
(COURIERPROGRAM (LIST (HARRAY 100]
(PROP ARGNAMES COURIER.CALL)
(FNS COURIER.OPEN COURIER.CALL COURIER.ARGS COURIER.RESULTS HANDLE.COURIER.ERROR
\BULK.DATA.STREAM \BULK.DATA.CLOSE \BULK.DATA.CLOSE.INTERNAL \ABORT.BULK.DATA
\HANDLE.TRUNCATED.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 NIL)
(COURIERTRACEFLG NIL))
(FNS PPSPP PRINTSPP SPP.DRIBBLE COURIERTRACE \COURIER.TRACE))
(ADDVARS (LITATOM.HIT.LIST COURIERPROGRAM \BULK.DATA.STREAM \BULK.DATA.CLOSE
\BULK.DATA.CLOSE.INTERNAL \ABORT.BULK.DATA
\HANDLE.TRUNCATED.BULK.DATA))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA COURIERPROGRAM)
(NLAML)
(LAMA COURIER.CALL])
(DECLARE: DONTCOPY EVAL@COMPILE
(FILESLOAD (LOADCOMP)
LLNS)
)
(* Sequenced Packet Protocol.)
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(DATATYPE SPPCON ((NIL POINTER) (* Used for SYSQUEUEing.)
(SPPESTABLISHEDP FLAG) (* True when connection is 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.)
(SPPRETRANSMIT 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.)
(SPPDRIVERQUEUE 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.)
(SPPSEQNOACK 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.)
(SPPREQUEST.PENDING FLAG) (* 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.)
(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.)
(SPPATTNFN POINTER) (* Function to apply to the connection and packet when
an attention packet is received.)
(SPPERRORPKTFN POINTER) (* Function to apply to the connection and packet when
an error packet arrives. Third arg may be an additional
message.)
(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.)
)
SPPINWAIT ←(create SYSQUEUE)
SPPRETRANSMIT ←(create SYSQUEUE)
SPPDRIVERQUEUE ←(create SYSQUEUE)
SPPLOCK ←(CREATE.MONITORLOCK)
SPP.NEWALLOCATION ←(CREATE.EVENT)
SPP.PACKETARRIVED ←(CREATE.EVENT)
SPPACCEPTNO ← \SPP.INITIAL.ALLOCATION SPPROUNDTRIPTIME ← \SPP.INITIAL.ROUNDTRIP)
(BLOCKRECORD SPPHEAD ((CC BYTE)
(DSTYPE BYTE)
(SOURCECONID WORD)
(DESTCONID WORD)
(SEQNO WORD)
(ACKNO WORD)
(ALLOCNO WORD)))
]
(/DECLAREDATATYPE (QUOTE SPPCON)
(QUOTE (POINTER FLAG POINTER FLAG POINTER BYTE POINTER POINTER POINTER POINTER WORD
WORD WORD WORD WORD WORD WORD POINTER FLAG 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 10)
(RPAQQ \SPP.INITIAL.ROUNDTRIP 2500)
(CONSTANTS (\SPP.INITIAL.ALLOCATION 10)
(\SPP.INITIAL.ROUNDTRIP 2500))
)
(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)
)
)
(/DECLAREDATATYPE (QUOTE SPPCON)
(QUOTE (POINTER FLAG POINTER FLAG POINTER BYTE POINTER POINTER POINTER POINTER WORD
WORD WORD WORD WORD WORD WORD POINTER FLAG POINTER POINTER POINTER
POINTER POINTER POINTER POINTER FLAG POINTER POINTER POINTER
POINTER POINTER POINTER POINTER)))
(RPAQ? SPP.USER.TIMEOUT 15000)
(DEFINEQ
(\SPPCONNECTION
[LAMBDA (HOST SOCKET NAME) (* ecc "13-JUN-83 16:39")
(* Create an active connection if HOST is specified, or
a passive connection if HOST is NIL.)
(PROG ((CON (create SPPCON))
(HOSTNSADDRESS (create NSADDRESS))
NSOC)
(if (NULL HOST)
then (* If host is NIL, we want to listen on the specified
socket.)
(SETQ NSOC (OPENNSOCKET SOCKET T))
else (* User wants to initiate connection to host.)
(\MOVENSADDRESSES (\NS.FINDNSADDRESS HOST)
HOSTNSADDRESS)
(if (AND (ZEROP (fetch NSSOCKET of HOSTNSADDRESS))
(NOT (NULL SOCKET)))
then (replace NSSOCKET of HOSTNSADDRESS with SOCKET))
(SETQ NSOC (OPENNSOCKET)))
(replace SPPMYNSOCKET of CON with NSOC)
[replace SPPMYID of CON with (LOGOR 32768 (\LONUM (DAYTIME]
(replace SPPDESTNSADDRESS of CON with HOSTNSADDRESS)
(replace SPPATTNFN of CON with (FUNCTION \SPPATTN))
[replace SPP.PROCESS of CON with (ADD.PROCESS (LIST (QUOTE \SPPWATCHER)
(KWOTE CON))
(QUOTE NAME)
(OR NAME (QUOTE SPP]
(RETURN CON])
(\SPP.SENDPKT
[LAMBDA (CON EPKT RETRANSMITP) (* ecc "27-JUL-83 15:30")
(* 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)
(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))
[if (BITTEST CC \SPPHEAD.CC.ACKNOWLEDGE)
then
(* 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.)
(if (NOT (fetch SPPREQUEST.PENDING of CON))
then (replace SPPREQUEST.PENDING of CON with T)
(replace SPPREQUEST.TIMEOUT of CON
with (SETUPTIMER (MAX SPP.USER.TIMEOUT (ITIMES (fetch SPPROUNDTRIPTIME
of CON)
2))
(fetch SPPREQUEST.TIMEOUT of CON)))
(replace SPPREQUEST.TIME of CON with (SETUPTIMER 0 (fetch SPPREQUEST.TIME
of CON]
(replace EPREQUEUE of EPKT with (if RETRANSMITP
then (fetch SPPDRIVERQUEUE of CON)
else NIL))
(while (fetch EPTRANSMITTING of EPKT)
do (* This packet might still be in use by the driver.)
(BLOCK))
(SENDXIP (fetch SPPMYNSOCKET of CON)
EPKT)
(replace SPPTIMETOPOKE of CON with (SETUPTIMER (fetch SPPROUNDTRIPTIME of CON)
(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) (* ecc " 7-JUN-83 16:40")
(* This is a separate function only to provide a
convenient breakpoint for debugging.)
(replace SPPTERMINATEDP of CON with T])
(\SPPATTN
[LAMBDA (CON BYTE) (* ecc "26-MAY-83 15:59")
(ERROR "An Attention packet has arrived:" BYTE])
(\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) (* ecc "31-MAY-83 13:50")
(* Return a System packet for the connection with the
specified control bits set. Uses the cached packet if
there is one.)
(PROG ((EPKT (fetch SPPSYSPKT of CON))
BASE)
(if (NULL EPKT)
then [SETQ EPKT (\FILLINXIP \XIPT.SPP (fetch SPPMYNSOCKET of CON)
(fetch SPPDESTNSADDRESS of CON)
NIL NIL (CONSTANT (IPLUS \XIPOVLEN \SPPHEAD.LENGTH]
(\SPP.FIXPKT CON EPKT)
(replace SPPSYSPKT of CON with EPKT))
(SETQ BASE (fetch XIPCONTENTS of EPKT))
(replace (SPPHEAD CC) of BASE with (LOGOR \SPPHEAD.CC.SYSTEM (OR CCBITS 0)))
(replace (SPPHEAD SEQNO) of BASE with (MIN (MAX 0 (SUB1 (fetch SPPSEQNO of CON)))
(fetch SPPALLOCNO of CON)))
(RETURN EPKT])
(\GETSPP
[LAMBDA (CON TIMEOUT) (* ecc "14-JUN-83 14:09")
(WITH.MONITOR (fetch SPPLOCK of CON)
(bind EPKT EXPIRED 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)
(RETURN EPKT)
elseif (AND TIMEOUT EXPIRED)
then (RETURN NIL)
else (MONITOR.AWAIT.EVENT (fetch SPPLOCK of CON)
(fetch SPP.PACKETARRIVED of CON)
(OR TIMEOUT SPP.USER.TIMEOUT))
(SETQ EXPIRED T])
(\SENDSPP
[LAMBDA (CON EPKT) (* ecc "12-AUG-83 09:42")
(PROG (SEQNO)
(CHECK (type? ETHERPACKET EPKT)
(NOT (BITTEST (GETPACKETCC EPKT)
\SPPHEAD.CC.SYSTEM)))
(RETURN (WITH.MONITOR (fetch SPPLOCK of CON)
(\SPP.FIXPKT CON EPKT) (* Fill in "constant" connection data.)
(SETQ SEQNO (fetch SPPSEQNO of CON))
(replace (SPPHEAD SEQNO) of (fetch XIPCONTENTS of EPKT) with SEQNO)
(* Fill in and advance the packet sequence number.)
(replace SPPSEQNO of CON with (ADD1 SEQNO))
(while (NOT (fetch SPPTERMINATEDP of CON))
do (if (OR (ILEQ SEQNO (fetch SPPALLOCNO of CON))
(BITTEST (GETPACKETCC EPKT)
\SPPHEAD.CC.ATTENTION))
then (* We can send the packet now if it's within the
allocation window, or if it's an Attention packet.)
(if (EQP SEQNO (fetch SPPALLOCNO of CON))
then (ORINCCBITS EPKT \SPPHEAD.CC.ACKNOWLEDGE))
(\SPP.SENDPKT CON EPKT T)
(RETURN T)
else (* 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)
SPP.USER.TIMEOUT])
(\TERMINATESPP
[LAMBDA (CON ACTIVEP) (* ecc "19-JUL-83 10:28")
(* Reliable connection termination, as in section 7.5 of
the spec.)
(PROG (EPKT DSTYPE)
(if (NOT (fetch SPPESTABLISHEDP of CON))
then (replace SPPTERMINATEDP of CON with T)
(RETURN NIL))
(if (fetch SPPTERMINATEDP of CON)
then (RETURN NIL))
(if ACTIVEP
then (* We initiate the termination by sending an END
packet.)
(\SENDSPP CON (\FILLINSPP CON (CONSTANT (LOGOR \SPPHEAD.CC.ACKNOWLEDGE
\SPPHEAD.CC.EOM))
\SPPDSTYPE.END))
(while (SETQ EPKT (\GETSPP CON SPP.USER.TIMEOUT))
do (* Throw away any incoming data packets.)
(SETQ DSTYPE (GETPACKETDSTYPE EPKT))
(if (OR (EQ DSTYPE \SPPDSTYPE.END)
(EQ DSTYPE \SPPDSTYPE.ENDREPLY))
then (RETURN)))
(if (NULL DSTYPE)
then (GO DONE)))
(\SENDSPP CON (\FILLINSPP CON (LOGOR \SPPHEAD.CC.ACKNOWLEDGE \SPPHEAD.CC.EOM)
\SPPDSTYPE.ENDREPLY))
[if (OR (NOT ACTIVEP)
(EQ DSTYPE \SPPDSTYPE.END))
then (* The other end initiated the termination with an END
packet.)
(while (SETQ EPKT (\GETSPP CON SPP.USER.TIMEOUT))
do (SETQ DSTYPE (GETPACKETDSTYPE EPKT))
(if (EQ DSTYPE \SPPDSTYPE.ENDREPLY)
then (RETURN]
DONE(replace SPPTERMINATEDP of CON with T)
(RETURN (EQ DSTYPE \SPPDSTYPE.ENDREPLY])
(\SPPWATCHER
[LAMBDA (CON) (* ecc " 9-AUG-83 16:36")
(RESETLST (RESETSAVE NIL (LIST (QUOTE \SPPEXIT)
CON))
(WITH.MONITOR (fetch SPPLOCK of CON)
(until (fetch SPPTERMINATEDP of CON)
do (if (AND (fetch SPPREQUEST.PENDING of CON)
(TIMEREXPIRED? (fetch SPPREQUEST.TIMEOUT of CON)))
then (\SPPWEDGED CON)
else (MONITOR.AWAIT.EVENT (fetch SPPLOCK of CON)
(NSOCKETEVENT (fetch SPPMYNSOCKET
of CON))
(fetch SPPTIMETOPOKE of CON)
T)
(if (\SPPINPUTWORK CON)
then (* There was input activity. Now perform any output
work. No need to probe.)
(\SPPOUTPUTWORK CON)
elseif (NOT (\SPPOUTPUTWORK CON))
then (* There was neither input nor output activity, so probe
if necessary.)
(\SPPAREYOUTHERE? CON])
(\SPPEXIT
[LAMBDA (CON) (* ecc " 9-AUG-83 15:47")
(* Called when \SPPWATCHER exits.)
(PROG ((PROC (fetch SPP.PROCESS of CON)))
[MAPC (LIST (fetch SPPSTREAM of CON)
(fetch SPPSUBSTREAM of CON))
(FUNCTION (LAMBDA (STREAM)
(if STREAM
then (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 SPPRETRANSMIT of CON)
(fetch SPPDRIVERQUEUE of CON))
(FUNCTION (LAMBDA (Q)
(replace SYSQUEUEHEAD of Q with (replace SYSQUEUETAIL of Q with NIL]
(replace SPPINPKT of CON with (replace SPPOUTPKT of CON
with (replace SPPSYSPKT of CON with NIL)))
(replace SPPMYNSOCKET of CON with NIL)
(replace SPP.PROCESS of CON with NIL)
(DEL.PROCESS PROC])
(\SPPINPUTWORK
[LAMBDA (CON) (* ecc "27-JUL-83 15:31")
(* Handle all queued input packets.
Returns T if there was activity on the connection.)
(PROG (EPKT SPPBASE PKTSEQNO CC ATTNFN ACTIVE?)
LOOP(SETQ EPKT (GETXIP (fetch SPPMYNSOCKET of CON)))
(if (NULL EPKT)
then (RETURN ACTIVE?))
(if (NEQ (fetch XIPTYPE of EPKT)
\XIPT.SPP)
then (if (EQ (fetch XIPTYPE of EPKT)
\XIPT.ERROR)
then (\SPPGETERROR CON EPKT)
else (\SPPSENDERROR CON EPKT
"Random packet to Sequenced Packet Protocol socket."))
(GO DROPIT))
(SETQ SPPBASE (fetch XIPCONTENTS of EPKT))
(if [NOT (AND (OR (NOT (fetch SPPESTABLISHEDP of CON))
(EQP (fetch (SPPHEAD SOURCECONID) of SPPBASE)
(fetch SPPHISID of CON)))
(OR (ZEROP (fetch (SPPHEAD DESTCONID) of SPPBASE))
(EQP (fetch (SPPHEAD DESTCONID) of SPPBASE)
(fetch SPPMYID of CON]
then
(* 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 EPKT "Wrong connection ID.")
(GO DROPIT))
(SETQ PKTSEQNO (fetch (SPPHEAD SEQNO) of SPPBASE))
(if (OR (ILESSP (IPLUS PKTSEQNO 3000)
(fetch SPPACKNO of CON))
(IGREATERP PKTSEQNO (IPLUS (fetch SPPACCEPTNO of CON)
2)))
then
(* 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 EPKT "Packet out of allocation sequence.")
(GO DROPIT)) (* We have a legal packet for this connection.)
(SETQ ACTIVE? T)
(if (NOT (fetch SPPESTABLISHEDP of CON))
then (* We're just now establishing the connection.)
(replace SPPDESTNSADDRESS of CON with (fetch XIPSOURCENSADDRESS of EPKT))
(* 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))
(if (fetch SPPSYSPKT of CON)
then (* Make sure the info in the cached System packet is
correct.)
(\SPP.FIXPKT CON (fetch SPPSYSPKT of CON)))
(\SPP.FIX.RETRANSMITQ CON)
(bind (PKT ←(\QUEUEHEAD (fetch SPPRETRANSMIT 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))
(SETQ CC (fetch (SPPHEAD CC) of SPPBASE))
(if (BITTEST CC \SPPHEAD.CC.ATTENTION)
then (if (BITTEST CC \SPPHEAD.CC.SYSTEM)
then (\SPPSENDERROR CON EPKT "Both System and Attention control bits?")
(GO DROPIT))
(if (IGREATERP (IDIFFERENCE (fetch XIPLENGTH of EPKT)
(IPLUS \XIPOVLEN \SPPHEAD.LENGTH))
1)
then (\SPPSENDERROR CON EPKT "More than 1 byte of data in Attention packet?")
(GO DROPIT))
(SETQ ATTNFN (fetch SPPATTNFN of CON)))
(if (IGREATERP (fetch (SPPHEAD ACKNO) of SPPBASE)
(fetch SPPSEQNOACK of CON))
then (replace SPPSEQNOACK of CON with (fetch (SPPHEAD ACKNO) of SPPBASE)))
(if (IGREATERP (fetch (SPPHEAD ALLOCNO) of SPPBASE)
(fetch SPPALLOCNO of CON))
then (replace SPPALLOCNO of CON with (fetch (SPPHEAD ALLOCNO) of SPPBASE))
(NOTIFY.EVENT (fetch SPP.NEWALLOCATION of CON)))
(if (NOT (BITTEST CC \SPPHEAD.CC.SYSTEM))
then (\PUT.IN.LINE CON EPKT) (* Note that this call may increment the connection's
ACKNO field.))
(if (BITTEST CC \SPPHEAD.CC.ACKNOWLEDGE)
then (\SPP.SENDPKT CON (\SPP.SYSPKT CON)
NIL))
(if (fetch SPPREQUEST.PENDING of CON)
then
(* 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, but that won't hurt.)
[replace SPPROUNDTRIPTIME of CON with (IPLUS (IQUOTIENT (fetch SPPROUNDTRIPTIME
of CON)
2)
(CLOCKDIFFERENCE (fetch
SPPREQUEST.TIME
of CON]
(replace SPPREQUEST.PENDING of CON with NIL))
(if ATTNFN
then (APPLY* ATTNFN CON (\GETBASEBYTE (EPKT.LEVEL3.CONTENTS EPKT)
0)))
(GO LOOP)
DROPIT
(RELEASE.XIP EPKT)
(GO LOOP])
(\PUT.IN.LINE
[LAMBDA (CON EPKT) (* ecc "27-JUL-83 11:43")
(* 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))
(EPKTNO (GETPACKETSEQNO EPKT))
CURRENT NEXT PKTNO)
(CHECK (PROG (N1 N2) (* Check consistency of input queue.)
(SETQ CURRENT (fetch SYSQUEUEHEAD of INQ))
L (if (NULL CURRENT)
then (RETURN T))
(SETQ N1 (GETPACKETSEQNO CURRENT))
(if (EQP N1 ACKNO)
then (SHOULDNT
"The input queue contains a packet that should have been acknowledged already.")
(RETURN NIL))
(if (NULL (SETQ NEXT (fetch QLINK of CURRENT)))
then (RETURN T))
(SETQ N2 (GETPACKETSEQNO NEXT))
(if (EQP N1 N2)
then (SHOULDNT "The input queue has duplicates.")
(RETURN NIL))
(if (ILESSP N2 N1)
then (SHOULDNT "The input queue is out of order.")
(RETURN NIL))
(SETQ CURRENT NEXT)
(GO L)))
(if (ILESSP EPKTNO ACKNO)
then (* This packet is a duplicate, so drop it.)
(RELEASE.XIP EPKT)
(RETURN))
(SETQ CURRENT (\QUEUEHEAD INQ))
(if [OR (NULL CURRENT)
(IGREATERP EPKTNO (GETPACKETSEQNO (fetch SYSQUEUETAIL of INQ]
then (* Goes at tail end of queue.)
(\ENQUEUE INQ EPKT)
(if (EQ EPKTNO ACKNO)
then (* This was the packet we were waiting for, so increment
the acknowledge number and notify anyone waiting.)
(replace SPPACKNO of CON with (ADD1 ACKNO))
(NOTIFY.EVENT (fetch SPP.PACKETARRIVED of CON)))
(RETURN))
(SETQ PKTNO (GETPACKETSEQNO CURRENT))
(if (ILESSP EPKTNO PKTNO)
then (* Goes right at head of queue.)
(replace QLINK of EPKT with CURRENT)
(replace SYSQUEUEHEAD of INQ with EPKT)
(if (EQP EPKTNO 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 (NOT (NULL CURRENT))
(EQP (SETQ PKTNO (GETPACKETSEQNO CURRENT))
(ADD1 EPKTNO)))
do (SETQ EPKT CURRENT)
(SETQ EPKTNO PKTNO)
(SETQ CURRENT (fetch QLINK of CURRENT)))
(replace SPPACKNO of CON with (ADD1 EPKTNO)))
(RETURN))
(do (* Loop until the correct place is found for this
packet.)
(if (EQP EPKTNO PKTNO)
then (* This packet is a duplicate, so drop it.)
(RELEASE.XIP EPKT)
(RETURN))
(SETQ NEXT (fetch QLINK of CURRENT))
(SETQ PKTNO (GETPACKETSEQNO NEXT))
(if (ILESSP EPKTNO PKTNO)
then (* Here's where it goes.)
(replace QLINK of EPKT with NEXT)
(replace QLINK of CURRENT with EPKT)
(RETURN))
(SETQ CURRENT NEXT])
(\SPPOUTPUTWORK
[LAMBDA (CON) (* ecc "28-JUN-83 11:12")
(* Handle packets to be retransmitted.
Returns T if there was activity.)
(\SPP.FIX.RETRANSMITQ CON)
(if (AND [OR (fetch SPPREQUEST.PENDING of CON)
(ILESSP (fetch SPPSEQNOACK of CON)
(fetch SPPSEQNO of CON))
(ILESSP (fetch SPPALLOCNO of CON)
(SUB1 (fetch SPPSEQNO of CON]
(TIMEREXPIRED? (fetch SPPTIMETOPOKE of CON)))
then (* It's time to poke the other end, either by
retransmitting a packet if we have one, or by probing
with a system packet.)
(if (NOT (\SPPRETRANSMIT CON))
then (\SPP.PROBE CON))
T])
(\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])
(\SPPRETRANSMIT
[LAMBDA (CON) (* ecc "27-JUL-83 11:25")
(* Retransmit the first packet in the retransmit queue.
Must be called with the connection locked.
Returns non-NIL iff a packet was sent.)
(CHECK (PROG (SEQNOACK CURRENT NEXT N1 N2) (* Check consistency of retransmit queue.)
(SETQ SEQNOACK (fetch SPPSEQNOACK of CON))
(SETQ CURRENT (fetch SYSQUEUEHEAD of (fetch SPPRETRANSMIT of CON)))
(while CURRENT
do (SETQ N1 (GETPACKETSEQNO CURRENT))
(if (ILESSP N1 SEQNOACK)
then (SHOULDNT
"The retransmit queue contains a packet that has been acknowledged already."))
(if (NULL (SETQ NEXT (fetch QLINK of CURRENT)))
then (RETURN))
(SETQ N2 (GETPACKETSEQNO NEXT))
(if (EQP N1 N2)
then (SHOULDNT "The retransmit queue has duplicates."))
(if (ILESSP N2 N1)
then (SHOULDNT "The retransmit queue is out of order."))
(SETQ CURRENT NEXT))
(RETURN T)))
(PROG ((RETRANSMITQ (fetch SPPRETRANSMIT of CON))
EPKT HEAD TAIL)
(SETQ EPKT (\DEQUEUE RETRANSMITQ))
(if (NULL EPKT)
then (RETURN NIL))
(ORINCCBITS EPKT \SPPHEAD.CC.ACKNOWLEDGE)
(\SPP.SENDPKT CON EPKT T)
(RETURN EPKT])
(\SPP.FIX.RETRANSMITQ
[LAMBDA (CON) (* ecc "27-JUL-83 11:35")
(* Merge any packets that we've gotten back from the
driver into the retransmit queue.)
(PROG ((RETRANSMITQ (fetch SPPRETRANSMIT of CON))
(DRIVERQ (fetch SPPDRIVERQUEUE of CON))
(SEQNOACK (fetch SPPSEQNOACK of CON))
HEAD REMAINDER EPKT EPKTNO CURRENT PKTNO NEXT)
(while (AND (SETQ EPKT (\QUEUEHEAD RETRANSMITQ))
(ILESSP (GETPACKETSEQNO EPKT)
SEQNOACK))
do (* Remove acknowledged packets from the retransmit
queue.)
(\DEQUEUE RETRANSMITQ)
(RELEASE.XIP EPKT))
(UNINTERRUPTABLY (* Remove the driver queue.)
(SETQ HEAD (fetch SYSQUEUEHEAD of DRIVERQ))
(replace SYSQUEUEHEAD of DRIVERQ with NIL)
(replace SYSQUEUETAIL of DRIVERQ with NIL))
(SETQ EPKT HEAD)
(while EPKT
do (while (fetch EPTRANSMITTING of EPKT)
do (* This packet might still be in use by the driver.)
(BLOCK))
(SETQ REMAINDER (fetch QLINK of EPKT))
(SETQ EPKTNO (GETPACKETSEQNO EPKT))
(if (ILEQ SEQNOACK EPKTNO)
then (* Only bother to merge this packet in if it hasn't been
acknowledged yet.)
(SETQ CURRENT (fetch SYSQUEUEHEAD of RETRANSMITQ))
(if [OR (NULL CURRENT)
(IGREATERP EPKTNO (GETPACKETSEQNO (fetch SYSQUEUETAIL of RETRANSMITQ]
then (* Goes at tail end of queue.)
(\ENQUEUE RETRANSMITQ EPKT)
(RETURN))
(SETQ PKTNO (GETPACKETSEQNO CURRENT))
(if (ILESSP EPKTNO PKTNO)
then (* Goes right at head of queue.)
(replace QLINK of EPKT with CURRENT)
(replace SYSQUEUEHEAD of RETRANSMITQ with EPKT)
(RETURN))
(do (* Loop until the correct place is found for this
packet.)
(if (EQP EPKTNO PKTNO)
then (SHOULDNT
"Duplicate packet in both retransmit and driver queues"))
(SETQ NEXT (fetch QLINK of CURRENT))
(SETQ PKTNO (GETPACKETSEQNO NEXT))
(if (ILESSP EPKTNO PKTNO)
then (* Here's where it goes.)
(replace QLINK of EPKT with NEXT)
(replace QLINK of CURRENT with EPKT)
(RETURN))
(SETQ CURRENT NEXT))
else (* This packet has already been acknowledged, so drop
it.)
(RELEASE.XIP EPKT))
(SETQ EPKT REMAINDER])
(\SPPGETERROR
[LAMBDA (CON TRIALPKT MOREMSG) (* ecc "11-JUL-83 14:53")
(if (fetch SPPERRORPKTFN of CON)
then (NLSETQ (APPLY* (fetch SPPERRORPKTFN of CON)
CON TRIALPKT MOREMSG))
else (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))
(replace SPPTERMINATEDP of CON with T])
(\SPPSENDERROR
[LAMBDA (CON EPKT MSG) (* ecc "22-MAR-83 12:16")
(* Stub for now)
(PROG ((FILE (OR (AND XIPTRACEFLG XIPTRACEFILE)
T)))
(PRINT MSG FILE)
(TERPRI FILE)
(PRINTPACKET EPKT NIL FILE)
(TERPRI FILE)
(PRINTSPPCON CON 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
ACCESSBITS ← BothBits
DEVICE ← \SPPDEVICE)))
]
(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)))
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \SPPDEVICE \SPP.BULKDATA.DEVICE)
)
)
(DEFINEQ
(\INITSPP
[LAMBDA NIL (* ecc "28-JUN-83 15:47")
(* 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)
EOFP ←(FUNCTION SPP.EOMP)))
(\DEFINEDEVICE NIL \SPPDEVICE)
(\DEFINEDEVICE NIL \SPP.BULKDATA.DEVICE])
(SPP.OPEN
[LAMBDA (HOST SOCKET PROBEP NAME) (* ecc "25-JUL-83 13:34")
(RESETLST (PROG ((CON (\SPPCONNECTION HOST SOCKET NAME))
STREAM)
(RESETSAVE NIL (LIST [QUOTE (LAMBDA (X)
(if RESETSTATE
then (\SPPEXIT X]
CON)) (* This should be changed to do an AWAIT.EVENT on a
connection-established event which \SPPINPUTWORK
signals.)
(if (AND HOST PROBEP)
then (forDuration SPP.USER.TIMEOUT until (OR (fetch SPPESTABLISHEDP
of CON)
(fetch SPPTERMINATEDP
of CON))
do (\SPP.PROBE CON)
(BLOCK 1000))
(if (OR (NOT (fetch SPPESTABLISHEDP of CON))
(fetch SPPTERMINATEDP of CON))
then (\SPPEXIT CON)
(RETURN NIL)))
(SETQ STREAM (create SPPSTREAM))
(replace SPPSTREAM of CON with STREAM)
(replace SPP.CONNECTION of STREAM with CON)
(RETURN STREAM])
(\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 "14-JUL-83 17:47")
(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)
(if (NOT (\SENDSPP CON EPKT))
then (LISPERROR "FILE NOT OPEN" STREAM])
(SPP.SENDEOM
[LAMBDA (STREAM) (* ecc "11-JUL-83 16:36")
(* Send the End of Message indication.)
(PROG ((CON (GETSPPCON STREAM))
EPKT)
(if (NOT (WRITEABLE STREAM))
then (LISPERROR "FILE NOT OPEN" 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 "14-JUL-83 17:43")
(* Send an Attention packet with the specified data byte
and control bits.)
(* Can't do this now, because input and output sides
share the same buffer: (SPP.FLUSH STREAM))
(\FILLINSPP.FOR.STREAM STREAM (if CC
then (LOGOR CC \SPPHEAD.CC.ATTENTION)
else \SPPHEAD.CC.ATTENTION))
(SPP.PUTBYTE STREAM ATTENTIONBYTE)
(SPP.FLUSH STREAM])
(SPP.CLOSE
[LAMBDA (STREAM ABORT?) (* ecc "19-JUL-83 10:28")
(* Close an SPP stream. Don't close it if there's still
an open Bulk Data stream, unless the user is aborting
the connection.)
(PROG ((CON (GETSPPCON STREAM))
STATUS)
(if (NULL CON)
then (RETURN NIL))
(if (OR (NULL (fetch SPPSUBSTREAM of CON))
ABORT?)
then (if (AND (NOT ABORT?)
(WRITEABLE STREAM))
then (SPP.FLUSH STREAM))
(SETQ STATUS (\TERMINATESPP CON (READABLE STREAM)))
(* If an END message has been seen already, the stream
will no longer be readable.)
(replace ACCESSBITS of STREAM with NoBits)
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.GETBYTE
[LAMBDA (STREAM) (* ecc "23-MAR-83 12:16")
(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 (LISPERROR "END OF FILE" STREAM])
(SPP.PEEKBIN
[LAMBDA (STREAM NOERRORFLG) (* ecc "28-JUN-83 15:40")
(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 (AND NOERRORFLG SPP.USER.TIMEOUT)))
then (LISPERROR "END OF FILE" 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])
(GETWORD
[LAMBDA (STREAM) (* ecc "24-MAR-83 11:10")
(PROG ((HI (BIN STREAM)))
(RETURN (LOGOR (LLSH HI BitsPerByte)
(BIN STREAM])
(PUTWORD
[LAMBDA (STREAM WORD) (* ecc "12-JUL-83 11:53")
[BOUT STREAM (LOGAND (LRSH WORD BitsPerByte)
(CONSTANT (SUB1 (LLSH 1 BitsPerByte]
(BOUT STREAM (LOGAND WORD (CONSTANT (SUB1 (LLSH 1 BitsPerByte])
(GETLONG
[LAMBDA (STREAM) (* ecc "24-MAR-83 11:03")
(PROG ((HI (GETWORD STREAM)))
(RETURN (LOGOR (LLSH HI (CONSTANT (ITIMES BitsPerByte BYTESPERWORD)))
(GETWORD STREAM])
(PUTLONG
[LAMBDA (STREAM LONG) (* ecc "12-JUL-83 11:53")
[PUTWORD STREAM (LOGAND (LRSH LONG (CONSTANT (ITIMES BitsPerByte BYTESPERWORD)))
(CONSTANT (SUB1 (LLSH 1 (CONSTANT (ITIMES BitsPerByte BYTESPERWORD]
(PUTWORD STREAM (LOGAND LONG (CONSTANT (SUB1 (LLSH 1 (CONSTANT (ITIMES BitsPerByte BYTESPERWORD])
(\GETSPP.FOR.STREAM
[LAMBDA (STREAM TIMEOUT) (* edited: " 2-AUG-83 15:37")
(* Gets the next input packet for the stream interface. Returns NIL if the packet's datastream type is END,
otherwise returns the packet. If TIMEOUT is specified, also returns NIL if timeout expires.)
(PROG ((CON (GETSPPCON STREAM))
EPKT X)
(if (SETQ EPKT (fetch SPPINPKT of CON))
then (RELEASE.XIP (fetch SPPINPKT of CON)))
(replace SPPINPKT of CON with NIL)
(replace CPPTR of STREAM with NIL)
(replace CBUFSIZE of STREAM with 0)
(SETQ EPKT (\GETSPP CON TIMEOUT))
(if (NULL EPKT)
then (if TIMEOUT
then (RETURN NIL)
else (LISPERROR "FILE NOT OPEN" STREAM)))
(if (EQ (GETPACKETDSTYPE EPKT)
\SPPDSTYPE.END)
then (replace ACCESSBITS of STREAM with (if (WRITEABLE STREAM)
then OutputBits
else NoBits))
(* Don't allow user to read anything more.)
(RETURN NIL))
(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 (EQ STREAM (fetch SPPSUBSTREAM of CON))
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.)
(\BULK.DATA.CLOSE STREAM T))
(if (SETQ X (STKPOS (QUOTE COURIER.READ.BULKDATA)))
then (RETFROM X NIL T)
else (ERROR "Attention packet received")))
(RETURN EPKT])
(\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) (* ecc "26-MAY-83 15:58")
(* Get or set datastream type of current packet.)
(PROG ((CON (GETSPPCON STREAM)))
(if DSTYPE
then (if (NOT (WRITEABLE STREAM))
then (LISPERROR "FILE NOT OPEN" STREAM))
(replace SPPDSTYPE of CON with DSTYPE)
(if (fetch SPPOUTPKT of CON)
then (replace (SPPHEAD DSTYPE) of (fetch XIPCONTENTS
of (fetch SPPOUTPKT of CON))
with DSTYPE))
(RETURN DSTYPE)
else (if (NOT (READABLE STREAM))
then (LISPERROR "FILE NOT OPEN" STREAM))
(if (AND (ZEROP (fetch CBUFSIZE of STREAM))
(NULL (\GETSPP.FOR.STREAM STREAM)))
then (LISPERROR "END OF FILE" STREAM)
else (RETURN (GETPACKETDSTYPE (fetch SPPINPKT of CON])
(SPP.READP
[LAMBDA (STREAM) (* ecc " 7-APR-83 17:47")
(if (NOT (READABLE STREAM))
then (LISPERROR "FILE NOT OPEN" STREAM)
elseif (ILESSP (fetch COFFSET of STREAM)
(fetch CBUFSIZE of STREAM))
then T
else (NOT (NULL (\GETSPP.FOR.STREAM STREAM 1000])
(SPP.EOFP
[LAMBDA (STREAM) (* ecc "23-MAR-83 14:33")
(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.EOMP
[LAMBDA (STREAM) (* ecc "27-JUL-83 16:55")
(PROG NIL
LOOP(RETURN (if (NOT (READABLE STREAM))
then (* Return T in this case to be compatible with EOFP)
T
elseif (ILESSP (fetch COFFSET of STREAM)
(fetch CBUFSIZE of STREAM))
then (* User hasn't read all the data in the current packet
yet, so we're not "at" the EOM.)
NIL
elseif (BITTEST (GETPACKETCC (fetch SPPINPKT of (GETSPPCON STREAM)))
\SPPHEAD.CC.EOM)
then T
elseif (NULL (\GETSPP.FOR.STREAM STREAM))
then (LISPERROR "END OF FILE" STREAM)
else (GO LOOP])
(SPP.ATTENTIONP
[LAMBDA (STREAM) (* ecc "27-JUL-83 15:32")
(if (AND (ZEROP (fetch CBUFSIZE of STREAM))
(NULL (\GETSPP.FOR.STREAM STREAM)))
then (LISPERROR "END OF FILE" STREAM)
else (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 OLD.ATTENTION.FUNCTION))
(RECORD COURIER.QUALIFIED.NAME (PROGRAM NAME)
[TYPE? (FUNCTION (LAMBDA (X)
(AND (LISTP X)
(EQLENGTH X 2])
]
)
(* Facilities for manipulating Courier definitions.)
(DEFINEQ
(COURIERPROGRAM
[NLAMBDA X (* lmm "14-AUG-83 17:38")
(* 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 PROGRAMNAME COURIERPROGRAM))
(if (AND OLDINFO (NOT (EQUAL OLDINFO NEWINFO)))
then (printout T "Warning: Courier program " PROGRAMNAME " redefined." T))
(PUTHASH PROGRAMNAME (COPY NEWINFO)
COURIERPROGRAM) (* Don't want to share list structure with what is
probably part of the FILECOMS.)
(RETURN PROGRAMNAME])
(\GET.COURIER.PROG#VERS#.PAIR
[LAMBDA (PROGRAMNAME) (* lmm "14-AUG-83 17:39")
(OR (CAR (GETHASH PROGRAMNAME COURIERPROGRAM))
(ERROR "Undefined Courier program" PROGRAMNAME])
(\GET.COURIER.DEFINITION
[LAMBDA (PROGRAM NAME TYPE) (* lmm "14-AUG-83 17:39")
(if (COURIER.QUALIFIED.NAMEP NAME)
then (\GET.COURIER.DEFINITION (CAR NAME)
(CDR NAME)
TYPE)
else (OR (CDR (ASSOC NAME (LISTGET (CDR (GETHASH PROGRAM COURIERPROGRAM))
TYPE)))
(ERROR (PACK* "No " TYPE " definition for")
(LIST PROGRAM NAME])
(COURIER.QUALIFIED.NAMEP
[LAMBDA (X) (* ecc " 7-JUL-83 15:08")
(AND (LISTP X)
(LITATOM (CAR X))
(LITATOM (CDR 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) (* ecc "12-JUL-83 15:05")
(PROG [(N (CAR (REVERSE (\GET.COURIER.DEFINITION PROGRAMNAME PROCEDURENAME (QUOTE PROCEDURES]
(RETURN (if (COURIER.QUALIFIED.NAMEP N)
then (\GET.COURIER.PROCEDURE.NUMBER (CAR N)
(CDR N))
else 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) (* ecc "12-JUL-83 15:05")
(PROG [(N (CAR (REVERSE (\GET.COURIER.DEFINITION PROGRAMNAME ERRORNAME (QUOTE ERRORS]
(RETURN (if (COURIER.QUALIFIED.NAMEP N)
then (\GET.COURIER.ERROR.NUMBER (CAR N)
(CDR N))
else N])
)
(* Functions for calling Courier procedures.)
(RPAQ? NSWIZARDFLG NIL)
(RPAQ? COURIERPROGRAM (LIST (HARRAY 100)))
(PUTPROPS COURIER.CALL ARGNAMES (NIL (STREAM PROGRAM PROCEDURE ARGS ... NOERRORFLG)
STREAM PROGRAM PROCEDURE ARGS ... NOERRORFLG))
(DEFINEQ
(COURIER.OPEN
[LAMBDA (HOSTNAME SERVERTYPE NOERRORFLG NAME) (* ecc "19-JUL-83 10:39")
(* Open a Courier connection to the specified host.)
(RESETLST (PROG (ADDRESS STREAM LOW.VERSION HIGH.VERSION)
(if (NULL HOSTNAME)
then (if NOERRORFLG
then (RETURN NIL)
else (ERROR "No host specified" NIL T))
elseif (OR (LITATOM HOSTNAME)
(STRINGP HOSTNAME))
then (SETQ ADDRESS (LOOKUP.NS.SERVER HOSTNAME SERVERTYPE))
elseif (type? NSADDRESS HOSTNAME)
then (SETQ ADDRESS HOSTNAME))
(if (NULL ADDRESS)
then (if NOERRORFLG
then (RETURN NIL)
else (ERROR "Unknown host" HOSTNAME T)))
(to \MAXETHERTRIES
do (SETQ STREAM (SPP.OPEN ADDRESS \NS.WKS.Courier T NAME))
(if (NOT (NULL STREAM))
then (RETURN))
(printout PROMPTWINDOW .TAB0 0 "[" HOSTNAME " not responding; will retry]")
(BLOCK 1000))
(if (NULL STREAM)
then (if NOERRORFLG
then (RETURN NIL)
else (ERROR "Host not responding" HOSTNAME T)))
(RESETSAVE NIL (LIST [QUOTE (LAMBDA (X)
(if RESETSTATE
then (SPP.CLOSE X T]
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))
(if (NOT (AND (ILEQ LOW.VERSION COURIER.VERSION#)
(ILEQ COURIER.VERSION# HIGH.VERSION)))
then (SPP.CLOSE STREAM)
(if NOERRORFLG
then (RETURN NIL)
else (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) (* ecc " 4-AUG-83 15:09")
(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 (if (EQ (LENGTH RESULTTYPES)
1)
then (COURIER.READ STREAM PROGRAM
(CAR RESULTTYPES))
else (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 (if (EQP (\GET.COURIER.ERROR.NUMBER PROGRAM ERR)
NUMBER)
then (SETQ NAME ERR)
(SETQ ARGTYPES (\GET.COURIER.ERROR.ARGS
PROGRAM ERR))
(RETURN)))
[if NAME
then (SETQ ARGVALUES (for TYPE in ARGTYPES
collect (COURIER.READ
STREAM PROGRAM
TYPE]
(RETURN (SELECTQ NOERRORFLG
(RETURNERRORS
(CONS (QUOTE ERROR)
(CONS (if NAME
elseif NUMBER)
ARGVALUES)))
(NIL (ERROR (PACK*
"Error in Courier program "
PROGRAM
", procedure "
PROCEDURE ": "
(if NAME
elseif NUMBER))
ARGVALUES))
(PROGN (HANDLE.COURIER.ERROR
PROGRAM PROCEDURE
(if NAME
elseif NUMBER)
ARGVALUES)
NIL]
[\COURIERMSG.REJECT (GETWORD STREAM) (* Skip the Transaction ID.)
(ERROR (PACK* "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)))
(if COURIERTRACEFLG
then (\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 " 4-AUG-83 15:11")
(* 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
OLD.ATTENTION.FUNCTION ←(fetch
SPPATTNFN of CON]
(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)
(replace SPPATTNFN of CON with (FUNCTION \HANDLE.TRUNCATED.BULK.DATA))
(if (EQ MODE (QUOTE OUTPUT))
then (SPP.DSTYPE SUBSTREAM \SPPDSTYPE.BULKDATA)
elseif (NEQ (SPP.DSTYPE SUBSTREAM)
\SPPDSTYPE.BULKDATA)
then (* Some servers violate the protocol;
we don't want to hang waiting for them.)
(ERROR "Protocol error: not receiving bulk data"))
(if COURIERTRACEFLG
then (\COURIER.TRACE (QUOTE BEGIN.BULK.DATA)
PROGRAM PROCEDURE))
(RETURN SUBSTREAM])
(\BULK.DATA.CLOSE
[LAMBDA (STREAM REMOTEABORT?) (* ecc " 4-AUG-83 15:16")
(* Close a Bulk Data stream after the transfer has taken place. REMOTEABORT? should be T if we're closing in
response to the other end's Attention packet. If a result function was specified in COURIER.CALL, call it on the
stream and the result or list of results. If the user has tried to close the Courier stream already, go ahead and
really close it.)
(PROG ((CON (GETSPPCON STREAM))
(CONTINUATION (GET.BULK.DATA.CONTINUATION STREAM))
COURIERSTREAM RESULTS RESULT.FUNCTION)
(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 (OR REMOTEABORT? (SPP.EOMP STREAM)))
then (* Closing before all the data has been read -- abort
the transfer.)
(\ABORT.BULK.DATA STREAM))
(replace SPPATTNFN of CON with (fetch OLD.ATTENTION.FUNCTION of CONTINUATION))
(SETQ COURIERSTREAM (fetch SPPSTREAM of CON))
[RESETLST (RESETSAVE NIL (LIST (QUOTE \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.)
(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]
(RETURN RESULTS])
(\BULK.DATA.CLOSE.INTERNAL
[LAMBDA (SUBSTREAM) (* ecc "27-JUL-83 12:06")
(PROG ((CON (GETSPPCON SUBSTREAM)))
(if (NULL CON)
then (RETURN))
(replace ACCESSBITS of SUBSTREAM with NoBits)
(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 " 4-AUG-83 15:58")
(* Truncate a bulk data stream by sending an Attention packet with a one in it. Then ignore any remaining bulk
data packets -- there shouldn't be many if the other end is obeying the protocol.)
(if (SETQ STREAM (fetch SPPSTREAM of (GETSPPCON STREAM)))
then (* Get Courier stream for this bulk data stream.)
(* This tends to crash NS fileservers.
(SPP.SENDATTENTION STREAM 1 \SPPHEAD.CC.EOM))
(while (AND (EQP (SPP.DSTYPE STREAM)
\SPPDSTYPE.BULKDATA)
(\GETSPP.FOR.STREAM STREAM))
do (* Get and throw away the remaining bulk data packets.
There shouldn't be too many if the other end is obeying
the protocol.)
NIL])
(\HANDLE.TRUNCATED.BULK.DATA
[LAMBDA (CON BYTE) (* ecc "12-AUG-83 10:02")
(if (NEQ BYTE 1)
then (ERROR "Unexpected Attention packet" BYTE))
(if NSWIZARDFLG
then (printout PROMPTWINDOW .TAB0 0 "[Bulk data stream truncated]"])
(COURIER.WRITE
[LAMBDA (STREAM ITEM PROGRAM TYPE) (* ecc "11-JUL-83 14:30")
(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 (EQP 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) (* ecc "11-JUL-83 14:29")
(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 (EQP 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 (EQP 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) (* ecc "11-JUL-83 14:32")
(* Like COURIER.WRITE but returns a list of integers
corresponding to the sequence of 16 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 (EQP 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) (* ecc "11-JUL-83 14:33")
(* 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 (EQP 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 (EQP 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 (EQP 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 NIL)
(RPAQ? COURIERTRACEFLG NIL)
(DEFINEQ
(PPSPP
[LAMBDA (CON) (* ecc " 9-AUG-83 16:23")
(printout T " local ID: " (fetch SPPMYID of CON)
" remote ID: "
(fetch SPPHISID of CON)
T " established: " (fetch SPPESTABLISHEDP of CON)
" request pending: "
(fetch SPPREQUEST.PENDING 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 SPPSEQNOACK of CON)
" alloc: "
(fetch SPPALLOCNO of CON)
" round trip: "
(fetch SPPROUNDTRIPTIME of CON)
T " input pkt:" # (if (fetch SPPINPKT of CON)
then (PRINTSPP (fetch SPPINPKT of CON)))
" input queue: " # (PRINTPACKETQUEUE (fetch SPPINWAIT of CON)
NIL T)
" retransmit queue: " # (PRINTPACKETQUEUE (fetch SPPRETRANSMIT of CON)
NIL T)
" driver queue: " # (PRINTPACKETQUEUE (fetch SPPDRIVERQUEUE of CON)
NIL T])
(PRINTSPP
[LAMBDA (EPKT FILE) (* ecc "27-JUL-83 15:51")
(PROG ((BASE (fetch XIPCONTENTS of EPKT))
CC DS)
(SETQ CC (fetch (SPPHEAD CC) of BASE))
(SETQ DS (fetch (SPPHEAD DSTYPE) of BASE))
(printout FILE " src: " (fetch (SPPHEAD SOURCECONID) of BASE)
" dest: "
(fetch (SPPHEAD DESTCONID) of BASE)
" flags: [")
(if (BITTEST CC \SPPHEAD.CC.SYSTEM)
then (printout FILE " sys"))
(if (BITTEST CC \SPPHEAD.CC.ACKNOWLEDGE)
then (printout FILE " ack"))
(if (BITTEST CC \SPPHEAD.CC.ATTENTION)
then (printout FILE " attn"))
(if (BITTEST CC \SPPHEAD.CC.EOM)
then (printout FILE " eom"))
(printout FILE " ] ds: " (SELECTC DS
(\SPPDSTYPE.COURIER "courier")
(\SPPDSTYPE.BULKDATA "bulkdata")
DS)
" seq: "
(fetch (SPPHEAD SEQNO) of BASE)
" ack: "
(fetch (SPPHEAD ACKNO) of BASE)
" alloc: "
(fetch (SPPHEAD ALLOCNO) of BASE)
" length: "
(IDIFFERENCE (fetch XIPLENGTH of EPKT)
(CONSTANT (IPLUS \XIPOVLEN \SPPHEAD.LENGTH)))
" bytes" T])
(SPP.DRIBBLE
[LAMBDA (FORM FILE) (* ecc " 2-MAY-83 16:06")
(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 (QUOTE 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 " 4-AUG-83 15:26")
(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 ARGUMENTS))
(RETURN (printout COURIERTRACEFILE " => " ARGUMENTS))
(BEGIN.BULK.DATA (printout COURIERTRACEFILE " beginning Bulk Data transfer"))
(END.BULK.DATA (printout COURIERTRACEFILE " ending Bulk Data transfer"))
(SHOULDNT])
)
(ADDTOVAR LITATOM.HIT.LIST COURIERPROGRAM \BULK.DATA.STREAM \BULK.DATA.CLOSE
\BULK.DATA.CLOSE.INTERNAL \ABORT.BULK.DATA
\HANDLE.TRUNCATED.BULK.DATA)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA COURIERPROGRAM)
(ADDTOVAR NLAML )
(ADDTOVAR LAMA COURIER.CALL)
)
(PUTPROPS SPP COPYRIGHT ("Xerox Corporation" 1983))
(DECLARE: DONTCOPY
(FILEMAP (NIL (11354 41470 (\SPPCONNECTION 11364 . 12813) (\SPP.SENDPKT 12815 . 15241) (\SPP.FIXPKT
15243 . 15890) (\SPPWEDGED 15892 . 16223) (\SPPATTN 16225 . 16382) (\FILLINSPP 16384 . 17010) (
\SPP.PROBE 17012 . 17355) (\SPP.SYSPKT 17357 . 18396) (\GETSPP 18398 . 19357) (\SENDSPP 19359 . 20898)
(\TERMINATESPP 20900 . 22721) (\SPPWATCHER 22723 . 23804) (\SPPEXIT 23806 . 25071) (\SPPINPUTWORK
25073 . 30637) (\PUT.IN.LINE 30639 . 34315) (\SPPOUTPUTWORK 34317 . 35217) (\SPPAREYOUTHERE? 35219 .
35917) (\SPPRETRANSMIT 35919 . 37441) (\SPP.FIX.RETRANSMITQ 37443 . 40435) (\SPPGETERROR 40437 . 41064
) (\SPPSENDERROR 41066 . 41468)) (42270 56938 (\INITSPP 42280 . 43207) (SPP.OPEN 43209 . 44287) (
\STREAM.FROM.PACKET 44289 . 45096) (SPP.FLUSH 45098 . 45748) (SPP.SENDEOM 45750 . 46335) (
SPP.SENDATTENTION 46337 . 46998) (SPP.CLOSE 47000 . 48185) (SPP.GETBYTE 48187 . 48685) (SPP.PEEKBIN
48687 . 49148) (SPP.BACKFILEPTR 49150 . 49383) (SPP.PUTBYTE 49385 . 49864) (GETWORD 49866 . 50064) (
PUTWORD 50066 . 50327) (GETLONG 50329 . 50576) (PUTLONG 50578 . 50951) (\GETSPP.FOR.STREAM 50953 .
53393) (\FILLINSPP.FOR.STREAM 53395 . 54057) (SPP.DSTYPE 54059 . 55049) (SPP.READP 55051 . 55415) (
SPP.EOFP 55417 . 55739) (SPP.EOMP 55741 . 56560) (SPP.ATTENTIONP 56562 . 56936)) (58039 61790 (
COURIERPROGRAM 58049 . 59073) (\GET.COURIER.PROG#VERS#.PAIR 59075 . 59300) (\GET.COURIER.DEFINITION
59302 . 59734) (COURIER.QUALIFIED.NAMEP 59736 . 59914) (\GET.COURIER.TYPE 59916 . 60103) (
\GET.COURIER.PROCEDURE.ARGS 60105 . 60336) (\GET.COURIER.PROCEDURE.RESULTS 60338 . 60575) (
\GET.COURIER.PROCEDURE.ERRORS 60577 . 60812) (\GET.COURIER.PROCEDURE.NUMBER 60814 . 61196) (
\GET.COURIER.ERROR.ARGS 61198 . 61417) (\GET.COURIER.ERROR.NUMBER 61419 . 61788)) (62067 89707 (
COURIER.OPEN 62077 . 64023) (COURIER.CALL 64025 . 65579) (COURIER.ARGS 65581 . 67251) (COURIER.RESULTS
67253 . 70023) (HANDLE.COURIER.ERROR 70025 . 70317) (\BULK.DATA.STREAM 70319 . 72109) (
\BULK.DATA.CLOSE 72111 . 74035) (\BULK.DATA.CLOSE.INTERNAL 74037 . 74645) (\ABORT.BULK.DATA 74647 .
75673) (\HANDLE.TRUNCATED.BULK.DATA 75675 . 75979) (COURIER.WRITE 75981 . 78874) (COURIER.READ 78876
. 81387) (COURIER.WRITE.REP 81389 . 84572) (COURIER.READ.REP 84574 . 84974) (
\COURIER.READ.REP.INTERNAL 84976 . 88824) (COURIER.READ.BULKDATA 88826 . 89705)) (89843 95042 (PPSPP
89853 . 91337) (PRINTSPP 91339 . 92651) (SPP.DRIBBLE 92653 . 93158) (COURIERTRACE 93160 . 94181) (
\COURIER.TRACE 94183 . 95040)))))
STOP