(FILECREATED "11-AUG-83 15:26:55" {PHYLUM}<LISPCORE>SOURCES>PUP.;41 257262Q
changes to: (VARS PUPERRORMESSAGES PUPCOMS \ETHERHOSTLOC)
(FNS \PUPERROR \FORWARD.PUP \PEEKPUP \MAYBEPEEKPUP PRINTPUPROUTE)
(ALISTS (PUPPRINTMACROS 4))
previous date: " 7-AUG-83 01:42:32" {PHYLUM}<LISPCORE>SOURCES>PUP.;38)
(* Copyright (c) 1982, 1983 by Xerox Corporation)
(PRETTYCOMPRINT PUPCOMS)
(RPAQQ PUPCOMS ((E (RESETSAVE (RADIX 10Q)))
(COMS (* Low level pup)
(DECLARE: DONTCOPY (EXPORT (RECORDS PUP PUPADDRESS)
(MACROS \LOCALPUPADDRESS \LOCALPUPHOSTNUMBER
\LOCALPUPNETNUMBER))
(GLOBALVARS \LOCALPUPNETHOST \OLDPUPHOST#))
(FNS \STARTPUP \FIND.LOCALPUPHOSTNUMBER \HANDLE.RAW.PUP \FORWARD.PUP
\SETPUPCHECKSUM)
(INITVARS (\PUP.CHECKSUMFLG T)
(\MAX.EPKTS.ON.PUPSOCKET 20Q)
(\LOCALPUPNETHOST)
(\OLDPUPHOST# 0)))
(COMS (* Pup error stuff)
(DECLARE: DONTCOPY (EXPORT (RECORDS ERRORPUP)
(CONSTANTS * PUPERRORCODES))
(GLOBALVARS PUPERRORMESSAGES))
(VARS PUPERRORMESSAGES)
(FNS \PUPERROR))
(COMS (FNS SETUPPUP SWAPPUPPORTS GETPUP SENDPUP EXCHANGEPUPS DISCARDPUPS GETPUPWORD
\PUPINIT))
(GLOBALRESOURCES (\PUPBOX (CREATECELL \FIXP)))
(FNS ETHERHOSTNAME ETHERHOSTNUMBER ETHERPORT NETDAYTIME0 \PUP.SETTIME \SETNEWTIME0
NETDATE \LOOKUPPORT \PARSE.PORTCONSTANT \FIXLOCALNET)
(COMS (* Accessing a PUP's contents)
(FNS CLEARPUP PUTPUPWORD GETPUPBYTE PUTPUPBYTE GETPUPSTRING PUTPUPSTRING
READPLIST \STOREPLIST)
(MACROS GETPUPWORD PUTPUPWORD GETPUPBYTE PUTPUPBYTE))
(COMS (* PUP allocation)
(EXPORT (MACROS BINDPUPS)
(PROP INFO BINDPUPS)
(ALISTS (PRETTYPRINTMACROS BINDPUPS))
(GLOBALVARS PUPTRACEFILE PUPONLYTYPES PUPIGNORETYPES PUPPRINTMACROS)))
(COMS (* Pup routing)
(FNS \PUPGATELISTENER \HANDLE.PUP.ROUTING.INFO \ROUTE.PUP \LOCATE.PUPNET
SORT.PUPHOSTS.BY.DISTANCE \PUPNET.CLOSERP PUPNET.DISTANCE)
(INITVARS (\PUP.ROUTING.TABLE (CONS))
(\PUP.ROUTING.TABLE.RADIUS 2)
(\PUPROUTER.PROBECOUNT 0)
(\PUPROUTER.PROBETIMER)
(\PUPROUTER.PROBEINTERVAL 5670Q)
(\PUP.READY)
(\PUP.READY.EVENT (CREATE.EVENT "Pup Ready")))
(ADDVARS (\SYSTEMCACHEVARS \PUP.READY))
(DECLARE: DONTCOPY (RECORDS PUPROUTINGINFO)
(CONSTANTS \PUP.ROUTINGINFO.WORDS)
(GLOBALVARS \PUP.ROUTING.TABLE \PUP.ROUTING.TABLE.RADIUS
\PUPROUTER.PROBECOUNT \PUPROUTER.PROBETIMER
\PUPROUTER.PROBEINTERVAL \PUP.READY \PUP.READY.EVENT)))
(COMS (* Sockets)
(DECLARE: DONTCOPY (RECORDS PUPSOCKET)
(MACROS \PUPSOCKET.FROM#)
(GLOBALVARS \PUPSOCKETS.TABLE \MAX.EPKTS.ON.PUPSOCKET
\PUP.CHECKSUMFLG))
(INITRECORDS PUPSOCKET)
(FNS OPENPUPSOCKET CLOSEPUPSOCKET PUPSOCKETNUMBER PUPSOCKETFROMNUMBER
PUPSOCKETEVENT \FLUSHPUPSOCQUEUE)
(FNS \GETMISCSOCKET)
(GLOBALVARS \MISC.SOCKET \PUPSOCKETS)
(INITVARS (\MISC.SOCKET)
(\PUPSOCKETS)))
(GLOBALVARS \ETHERPORTS \EFTP.TIMEOUT \EFTP.LONGTIMEOUT \PUPCOUNTER)
(DECLARE: DONTCOPY (EXPORT (RECORDS PORT ERRORPUP)
(GLOBALVARS \ETHERWAIT1 \ETHERTIMEOUT \MAXETHERTRIES
PUPTRACEFLG LOGINPASSWORDS NILPUPTRACEFLG)
(CONSTANTS (\PUPOVLEN 26Q)
(\MAX.PUPLENGTH 1024Q)
(\TIME.GETPUP 5))
(PROP VARTYPE PUPPRINTMACROS)
(I.S.OPRS INCHARS)
(MACROS \GETPUPWORD \PUTPUPWORD \GETPUPBYTE \PUTPUPBYTE)
(CONSTANTS * RAWPUPTYPES)
(INITVARS (PUPTYPES RAWPUPTYPES))
(CONSTANTS * WELLKNOWNPUPSOCKETS))
(CONSTANTS * PUPCONSTANTS)
(MACROS PUPTRACING PUPDEBUGGING TESTSOC)
(ALISTS (PUPPRINTMACROS 210Q 214Q 211Q 213Q 201Q 30Q))
(RECORDS TIMEPUPCONTENTS))
(INITVARS (\ETHERPORTS (LIST (HARRAY 24Q)))
(\ETHERTIMEOUT 3720Q)
(\MAXETHERTRIES 4)
(\PUPCOUNTER 0))
(COMS (* echo utilities)
(FNS PUP.ECHOSERVER PUP.ECHOUSER))
(COMS (* Peeking)
(FNS \PEEKPUP \MAYBEPEEKPUP)
(INITVARS (\PEEKPUPNUMBER))
(DECLARE: EVAL@COMPILE DONTCOPY (CONSTANTS \ETHERHOSTLOC)
(GLOBALVARS \PEEKPUPNUMBER)))
(COMS (* Debugging assistance)
(FNS PRINTPUP PRINTPUPROUTE PRINTPUPDATA PRINTERRORPUP PUPTRACE
\CHANGE.ETHER.TRACING PRINTCONSTANT)
(INITVARS (PUPTRACEFLG)
(PUPTRACEFILE T)
(PUPTRACETIME)
(NILPUPTRACEFLG))
(GLOBALVARS PUPTRACETIME)
(ADDVARS (PUPPRINTMACROS)
(PUPONLYTYPES)
(PUPIGNORETYPES))
(ALISTS (PUPPRINTMACROS 4 220Q 221Q 223Q 224Q)))
(FNS PORTSTRING OCTALSTRING)
(COMS (FNS \CENTICLOCK)
[VARS (\CENTICLOCKFACTOR)
(\CENTICLOCKBOX (NCREATE (QUOTE FIXP]
(GLOBALVARS \CENTICLOCKFACTOR \CENTICLOCKBOX)
(ADDVARS (\SYSTEMCACHEVARS \CENTICLOCKFACTOR)))
[COMS (* Mail check)
(FNS MAILWATCHER MAILCHECK)
(GLOBALVARS MAILINTERVAL MAILTIME MAILEVENTCOUNT USERNAME)
(DECLARE: EVAL@LOADWHEN (SELECTQ (SYSTEMTYPE)
((ALTO D)
T)
NIL)
(INITVARS (MAILINTERVAL 1111740Q)
(MAILTIME 0)
(MAILEVENTCOUNT 0]
(COMS (* EFTP)
(FNS EFTP \ABORT.EFTP PRINTERSTATUS PRINTERCAPABILITY)
[DECLARE: DONTCOPY (CONSTANTS * EFTPPUPTYPES)
(CONSTANTS * EFTPCONSTANTS)
(ADDVARS * (LIST (CONS (QUOTE PUPTYPES)
EFTPPUPTYPES]
(INITVARS (\EFTP.TIMEOUT 11610Q)
(\EFTP.LONGTIMEOUT 35230Q)))
(DECLARE: DONTEVAL@LOAD (P (\PUPINIT)))
(DECLARE: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
LLETHER))))
(* Low level pup)
(DECLARE: DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
[DECLARE: EVAL@COMPILE
(ACCESSFNS PUP [(PUPBASE (LOCF (fetch (ETHERPACKET EPBODY) of DATUM]
[BLOCKRECORD PUPBASE ((PUPLENGTH WORD)
(PUPTCONTROL BYTE)
(PUPTYPE BYTE)
(PUPID FIXP)
(PUPDEST WORD)
(PUPDESTSOCKET FIXP)
(PUPSOURCE WORD)
(PUPSOURCESOCKET FIXP)
(PUPDATASTART 412Q WORD))
(BLOCKRECORD PUPBASE ((NIL WORD)
(TYPEWORD WORD)
(PUPIDHI WORD)
(PUPIDLO WORD)
(PUPDESTNET BYTE)
(PUPDESTHOST BYTE)
(PUPDESTSOCKETHI WORD)
(PUPDESTSOCKETLO WORD)
(PUPSOURCENET BYTE)
(PUPSOURCEHOST BYTE)
(PUPSOURCESOCKETHI WORD)
(PUPSOURCESOCKETLO WORD))
(* Temporary extra synonyms)
(SYNONYM PUPDESTNET (DESTNET))
(SYNONYM PUPDESTHOST (DESTHOST))
(SYNONYM PUPDESTSOCKETHI (DESTSKTHI))
(SYNONYM PUPDESTSOCKETLO (DESTSKTLO))
(SYNONYM PUPSOURCENET (SOURCENET))
(SYNONYM PUPSOURCEHOST (SOURCEHOST))
(SYNONYM PUPSOURCESOCKETHI (SOURCESKTHI))
(SYNONYM PUPSOURCESOCKETLO (SOURCESKTLO)))
(SYNONYM PUPDEST (DEST))
(SYNONYM PUPDESTSOCKET (DESTSKT))
(SYNONYM PUPSOURCE (SOURCE))
(SYNONYM PUPSOURCESOCKET (SOURCESKT))
(ACCESSFNS PUPDATASTART ((PUPCONTENTS (LOCF DATUM]
[ACCESSFNS PUP [(PUPCHECKSUMBASE (fetch PUPBASE of DATUM))
(PUPCHECKSUMLOC (\ADDBASE (fetch PUPBASE of DATUM)
(FOLDLO (SUB1 (fetch PUPLENGTH of DATUM))
BYTESPERWORD]
(BLOCKRECORD PUPCHECKSUMLOC ((PUPCHECKSUM WORD]
(TYPE? (type? ETHERPACKET DATUM)))
(ACCESSFNS PUPADDRESS ((PUPNET# (LRSH DATUM 10Q))
(PUPHOST# (LOGAND DATUM 377Q)))
(CREATE (IPLUS (LLSH PUPNET# 10Q)
PUPHOST#)))
]
(DECLARE: EVAL@COMPILE
(PUTPROPS \LOCALPUPADDRESS MACRO (NIL \LOCALPUPNETHOST))
(PUTPROPS \LOCALPUPHOSTNUMBER MACRO (NIL (fetch PUPHOST# of \LOCALPUPNETHOST)))
(PUTPROPS \LOCALPUPNETNUMBER MACRO (NIL (fetch PUPNET# of \LOCALPUPNETHOST)))
)
(* END EXPORTED DEFINITIONS)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \LOCALPUPNETHOST \OLDPUPHOST#)
)
)
(DEFINEQ
(\STARTPUP
[LAMBDA (EVENT) (* bvm: " 4-AUG-83 22:46")
(for SOC in \PUPSOCKETS
do (* Flush any pups waiting on existing sockets.
Not only are they stale, but they will have the wrong
NDB)
(\FLUSHPUPSOCQUEUE SOC))
(COND
((NULL \LOCALNDBS)
(SETQ \LOCALPUPNETHOST 0))
(T (PROG ((NDB \LOCALNDBS)
MYHOST#)
LP [COND
((NEQ (fetch NDBPUPHOST# of NDB)
0)
(SETQ MYHOST# (fetch NDBPUPHOST# of NDB)))
(T (replace NDBPUPHOST# of NDB with (OR MYHOST# (SETQ MYHOST# (
\FIND.LOCALPUPHOSTNUMBER NDB EVENT]
(COND
((SETQ NDB (fetch NDBNEXT of NDB))
(GO LP)))
(OR MYHOST# (SETQ MYHOST# 0))
(SETQ \LOCALPUPNETHOST (create PUPADDRESS
PUPNET# ←(fetch NDBPUPNET# of \LOCALNDBS)
PUPHOST# ← MYHOST#))
(SETQ \OLDPUPHOST# MYHOST#)
[COND
(\10MBFLG (\ADD.PACKET.FILTER (FUNCTION \HANDLE.RAW.3TO10)))
(T (\DEL.PACKET.FILTER (FUNCTION \HANDLE.RAW.3TO10]
(\LOCATE.PUPNET 0) (* Initiate a probe to find out where we are and get
routing)
(OR (FIND.PROCESS (QUOTE \PUPGATELISTENER))
(ADD.PROCESS (QUOTE (\PUPGATELISTENER))
(QUOTE RESTARTABLE)
(QUOTE SYSTEM)
(QUOTE AFTEREXIT)
\PUP.READY.EVENT))
(\ADD.PACKET.FILTER (FUNCTION \HANDLE.RAW.PUP))
(SETQ \PUP.READY T)
(NOTIFY.EVENT \PUP.READY.EVENT)
(BLOCK])
(\FIND.LOCALPUPHOSTNUMBER
[LAMBDA (NDB EVENT) (* bvm: "10-JUL-83 23:35")
(* Finds out our pup address on this 10mb NDB)
(PROG (NEWNUMBER)
LP [COND
[(SETQ NEWNUMBER (\LOOKUPPUPNUMBER \MY.NSHOSTNUMBER NDB))
(COND
(PUPTRACEFLG (printout PUPTRACEFILE "My pup address = " (fetch PUPNET# of NEWNUMBER)
"#"
(fetch PUPHOST# of NEWNUMBER)
"#" T]
(T (SETQ NEWNUMBER (PACK* (PROMPTFORWORD "Please enter my pup host number (in octal):"
(AND (EQ EVENT (QUOTE AFTERLOGOUT))
(NOT (ZEROP \OLDPUPHOST#))
(OCTALSTRING \OLDPUPHOST#)))
(QUOTE Q)))
(COND
((OR (NOT (FIXP NEWNUMBER))
(ILEQ NEWNUMBER 0)
(IGEQ NEWNUMBER 376Q))
(CLEARBUF T)
(PRINTBELLS)
(GO LP] (* Only rely on the host number part of reply.
There is confusion for machines that exist on more than
one net)
(RETURN (fetch PUPHOST# of NEWNUMBER])
(\HANDLE.RAW.PUP
[LAMBDA (PACKET TYPE) (* bvm: " 7-AUG-83 01:08")
(* Handles the arrival of a PUP.
If it is destined for a local socket that has room,
queues it there, else releases it)
(COND
((EQ TYPE \EPT.PUP)
[PROG ((NDB (fetch EPNETWORK of PACKET))
CSUM PUPSOC DESTNET MYNET)
[COND
([AND (NEQ (fetch PUPDESTHOST of PACKET)
(fetch NDBPUPHOST# of NDB))
(NOT (ZEROP (fetch PUPDESTHOST of PACKET]
(RETURN (\FORWARD.PUP PACKET]
[COND
((AND (NEQ (SETQ DESTNET (fetch PUPDESTNET of PACKET))
(SETQ MYNET (fetch NDBPUPNET# of NDB)))
(NOT (ZEROP MYNET))
(NOT (ZEROP DESTNET))) (* Destination net is not us, so packet not for us)
(RETURN (\FORWARD.PUP PACKET]
(COND
[[NULL (SETQ PUPSOC (\PUPSOCKET.FROM# (fetch PUPDESTSOCKETHI of PACKET)
(fetch PUPDESTSOCKETLO of PACKET]
(* Packets addressed to non-active sockets are just
ignored.)
(COND
(PUPTRACEFLG (PRIN1 (QUOTE &)
PUPTRACEFILE)))
(COND
((AND (EQ (fetch PUPTYPE of PACKET)
\PT.ECHOME)
(EQ (fetch PUPDESTSOCKETLO of PACKET)
\PUPSOCKET.ECHO)
(EQ (fetch PUPDESTSOCKETHI of PACKET)
0)
\PUP.READY) (* Play echo server)
(replace TYPEWORD of PACKET
with (COND
([AND (NEQ (SETQ CSUM (fetch PUPCHECKSUM of PACKET))
MASKWORD1'S)
(NEQ CSUM (\CHECKSUM (fetch PUPCHECKSUMBASE of PACKET)
(SUB1 (FOLDHI (fetch PUPLENGTH
of PACKET)
BYTESPERWORD]
\PT.IAMBADECHO)
(T \PT.IAMECHO)))
(SWAPPUPPORTS PACKET)
(replace EPREQUEUE of PACKET with (QUOTE FREE))
(SENDPUP NIL PACKET))
(T (\PUPERROR PACKET \PUPE.NOSOCKET]
((IGEQ (fetch (PUPSOCKET INQUEUELENGTH) of PUPSOC)
(fetch (PUPSOCKET PUPSOC#ALLOCATION) of PUPSOC))
(* Note that packets are just "dropped" when the queue
overflows.)
(\PUPERROR PACKET \PUPE.SOCKETFULL))
([AND \PUP.CHECKSUMFLG (NEQ (SETQ CSUM (fetch PUPCHECKSUM of PACKET))
MASKWORD1'S)
(NEQ CSUM (\CHECKSUM (fetch PUPCHECKSUMBASE of PACKET)
(SUB1 (FOLDHI (fetch PUPLENGTH of PACKET)
BYTESPERWORD]
(\PUPERROR PACKET \PUPE.CHECKSUM))
(T [COND
((ZEROP DESTNET) (* Fill in unspecified destination net
(possibly redundantly with zero))
(replace PUPDESTNET of PACKET with MYNET))
((ZEROP MYNET)
(* Packet of specific destination net has arrived on a socket that we listen to. If we don't know our own net
number, assume sender is telling the truth)
(replace NDBPUPNET# of NDB with DESTNET)
(SETQ \LOCALPUPNETHOST (create PUPADDRESS
PUPNET# ← DESTNET
PUPHOST# ←(fetch NDBPUPHOST# of NDB)))
(* This variable only for backward compatibility.
Delete it some day)
(PROG ((ENTRY (\LOCATE.PUPNET DESTNET T)))
[OR ENTRY (push (CDR \PUP.ROUTING.TABLE)
(SETQ ENTRY (create ROUTING
RTNET# ← DESTNET]
(replace RTHOPCOUNT of ENTRY with 0)
(replace RTGATEWAY# of ENTRY with NIL)
(replace RTNDB of ENTRY with NDB)
(replace RTRECENT of ENTRY with T]
(UNINTERRUPTABLY
(\ENQUEUE (fetch (PUPSOCKET INQUEUE) of PUPSOC)
PACKET)
(add (fetch (PUPSOCKET INQUEUELENGTH) of PUPSOC)
1)
(NOTIFY.EVENT (fetch PUPSOCEVENT of PUPSOC)))]
T])
(\FORWARD.PUP
[LAMBDA (PUP) (* bvm: "11-AUG-83 14:20")
(* Called when we receive a PUP not addressed to us.
Unless we are a gateway, dump it)
(COND
(\PEEKPUPNUMBER (\MAYBEPEEKPUP PUP))
(T (COND
(PUPTRACEFLG (PRINTPUP PUP (QUOTE GET)
NIL "PUP not addressed to this host: ")))
(\RELEASE.ETHERPACKET PUP])
(\SETPUPCHECKSUM
[LAMBDA (PUP) (* bvm: "11-FEB-83 12:28")
(* Sets the PUPCHECKSUM field of PUP to checksum over
its current contents)
(replace PUPCHECKSUM of PUP with (COND
[\PUP.CHECKSUMFLG (\CHECKSUM (fetch PUPCHECKSUMBASE
of PUP)
(SUB1 (FOLDHI (fetch PUPLENGTH
of PUP)
BYTESPERWORD]
(T \NULLCHECKSUM)))
T])
)
(RPAQ? \PUP.CHECKSUMFLG T)
(RPAQ? \MAX.EPKTS.ON.PUPSOCKET 20Q)
(RPAQ? \LOCALPUPNETHOST )
(RPAQ? \OLDPUPHOST# 0)
(* Pup error stuff)
(DECLARE: DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
[DECLARE: EVAL@COMPILE
(ACCESSFNS ERRORPUP ((ERRORPUPBASE (fetch PUPCONTENTS of DATUM)))
(BLOCKRECORD ERRORPUPBASE ((ERRORPUPCOPY 12Q WORD)
(* Copy of pup header)
(ERRORPUPCODE WORD)
(ERRORPUPARG WORD) (* Usually zero)
(ERRORPUPSTRINGBASE WORD)
(* Human readable message)
)))
]
(RPAQQ PUPERRORCODES ((\PUPE.CHECKSUM 1)
(\PUPE.NOSOCKET 2)
(\PUPE.SOCKETFULL 3)
(\PUPE.GATEWAY.BADPUP 1001Q)
(\PUPE.NOROUTE 1002Q)
(\PUPE.NOHOST 1003Q)
(\PUPE.LOOPED 1004Q)
(\PUPE.TOOLARGE 1005Q)
(\PUPE.WRONG.GATEWAY 1006Q)
(\PUPE.GATEWAYFULL 1007Q)))
(DECLARE: EVAL@COMPILE
(RPAQQ \PUPE.CHECKSUM 1)
(RPAQQ \PUPE.NOSOCKET 2)
(RPAQQ \PUPE.SOCKETFULL 3)
(RPAQQ \PUPE.GATEWAY.BADPUP 1001Q)
(RPAQQ \PUPE.NOROUTE 1002Q)
(RPAQQ \PUPE.NOHOST 1003Q)
(RPAQQ \PUPE.LOOPED 1004Q)
(RPAQQ \PUPE.TOOLARGE 1005Q)
(RPAQQ \PUPE.WRONG.GATEWAY 1006Q)
(RPAQQ \PUPE.GATEWAYFULL 1007Q)
(CONSTANTS (\PUPE.CHECKSUM 1)
(\PUPE.NOSOCKET 2)
(\PUPE.SOCKETFULL 3)
(\PUPE.GATEWAY.BADPUP 1001Q)
(\PUPE.NOROUTE 1002Q)
(\PUPE.NOHOST 1003Q)
(\PUPE.LOOPED 1004Q)
(\PUPE.TOOLARGE 1005Q)
(\PUPE.WRONG.GATEWAY 1006Q)
(\PUPE.GATEWAYFULL 1007Q))
)
(* END EXPORTED DEFINITIONS)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS PUPERRORMESSAGES)
)
)
(RPAQQ PUPERRORMESSAGES ((1 "Bad Checksum")
(2 "No such socket")
(3 "Socket full")
(1001Q "Inconsistent pup")
(1002Q "No route to that host")
(1003Q "Host is down")
(1004Q "Too many hops")
(1005Q "Pup too long")
(1006Q "Wrong gateway for that host")
(1007Q "Gateway IQ full")))
(DEFINEQ
(\PUPERROR
[LAMBDA (PUP ERRCODE MSG) (* bvm: "11-AUG-83 14:19")
(* * Turn packet around into an error packet with given error)
(COND
(\PEEKPUPNUMBER (\MAYBEPEEKPUP PUP))
((AND (NOT (ZEROP (fetch PUPDESTHOST of PUP)))
(NEQ (fetch PUPTYPE of PUP)
\PT.ERROR)) (* Don't respond to errors or to broadcasts!)
[COND
((AND PUPTRACEFLG (NEQ PUPTRACEFLG (QUOTE PEEK)))
(printout PUPTRACEFILE "Incoming packet dropped because: "
(OR (CADR (ASSOC ERRCODE PUPERRORMESSAGES))
ERRCODE)
T)
(OR (EQ PUPTRACEFLG (QUOTE RAW))
(PRINTPUP PUP]
(\BLT (fetch PUPCONTENTS of PUP)
(fetch PUPBASE of PUP)
(FOLDLO \PUPHEADERLEN BYTESPERWORD)) (* Copy pup header into body)
(replace ERRORPUPCODE of PUP with ERRCODE)
(replace ERRORPUPARG of PUP with 0)
[replace PUPLENGTH of PUP with (IPLUS \PUPOVLEN \PUPHEADERLEN (ITIMES 2 BYTESPERWORD)
(\PUTBASESTRING (LOCF (fetch ERRORPUPSTRINGBASE
of PUP))
0
(OR MSG (CADR (ASSOC ERRCODE
PUPERRORMESSAGES))
""]
(replace PUPTYPE of PUP with \PT.ERROR)
(SWAPPUPPORTS PUP)
(replace EPREQUEUE of PUP with (QUOTE FREE))
(SENDPUP NIL PUP))
(T (\RELEASE.ETHERPACKET PUP])
)
(DEFINEQ
(SETUPPUP
[LAMBDA (PUP DESTHOST DESTSOCKET TYPE ID SOC REQUEUE) (* bvm: "11-JUL-83 16:01")
(* Initialize pup header PUP with indicated destination HOST, DESTSOCKET and TYPE. A local socket and ID
(if not supplied) are assigned. Returns a "socket" datum)
(replace PUPLENGTH of (SETQ PUP (\DTEST PUP (QUOTE ETHERPACKET))) with \PUPOVLEN)
(* pup data initially empty)
(replace (PUP TYPEWORD) of PUP with TYPE) (* Clears PUPTCONTROL)
[replace PUPID of PUP with (OR ID (SETQ \PUPCOUNTER (COND
((IGEQ \PUPCOUNTER 177777Q)
1)
(T (ADD1 \PUPCOUNTER]
(replace PUPDEST of PUP with (OR (FIXP (SETQ DESTHOST (ETHERPORT DESTHOST T)))
(CAR DESTHOST)))
(replace PUPDESTSOCKET of PUP with (COND
([AND (LISTP DESTHOST)
(NOT (ZEROP (CDR DESTHOST]
(CDR DESTHOST))
(T DESTSOCKET)))
(AND REQUEUE (replace EPREQUEUE of PUP with REQUEUE))
(OR SOC (SETQ SOC (OPENPUPSOCKET])
(SWAPPUPPORTS
[LAMBDA (PUP) (* bvm: "12-FEB-83 16:21")
(swap (fetch PUPSOURCE of PUP)
(fetch DEST of PUP))
(swap (fetch PUPSOURCESOCKETHI of PUP)
(fetch DESTSKTHI of PUP))
(swap (fetch PUPSOURCESOCKETLO of PUP)
(fetch DESTSKTLO of PUP])
(GETPUP
[LAMBDA (PUPSOC WAIT) (* bvm: "24-MAY-83 17:42")
(SETQ PUPSOC (\DTEST PUPSOC (QUOTE PUPSOCKET)))
(PROG (PUP TIMER)
LP (UNINTERRUPTABLY
(COND
((SETQ PUP (\DEQUEUE (ffetch (PUPSOCKET INQUEUE) of PUPSOC)))
(add (ffetch (PUPSOCKET INQUEUELENGTH) of PUPSOC)
-1))))
(COND
[(NULL PUP)
(COND
(WAIT (COND
((EQ WAIT T))
[TIMER (COND
((TIMEREXPIRED? TIMER)
(RETURN]
(T (OR (FIXP WAIT)
(LISPERROR "NON-NUMERIC ARG" WAIT))
(SETQ TIMER (SETUPTIMER WAIT))
T))
(AWAIT.EVENT (ffetch PUPSOCEVENT of PUPSOC)
TIMER T)
(GO LP))
(T (* Let ether procs run)
(BLOCK]
[(EQ \EPT.PUP (fetch EPTYPE of PUP))
(AND PUPTRACEFLG (\MAYBEPRINTPACKET PUP (QUOTE GET]
(T (AND PUPTRACEFLG (printout PUPTRACEFILE T "Non-PUP packet " PUP " arrived on " PUPSOC
T))
(SETQ PUP)))
(RETURN PUP])
(SENDPUP
[LAMBDA (PUPSOC PUP) (* bvm: "11-JUL-83 16:01")
(* Returns the PUP arg iff packet can be sent;
returns a litatom explaining error otherwise.)
(SETQ PUP (\DTEST PUP (QUOTE ETHERPACKET)))
[AND PUPSOC (SETQ PUPSOC (\DTEST PUPSOC (QUOTE PUPSOCKET]
(replace EPTYPE of PUP with \EPT.PUP)
(replace PUPTCONTROL of PUP with 0)
(until \PUP.READY do (AWAIT.EVENT \PUP.READY.EVENT))
(PROG (NDB)
(RETURN (COND
((fetch EPTRANSMITTING of PUP)
(AND PUPTRACEFLG (printout PUPTRACEFILE
"[Packet not sent--already being transmitted]"
T))
(QUOTE AlreadyQueued))
((NULL (SETQ NDB (\ROUTE.PUP PUP)))
(AND PUPTRACEFLG (PRINTPUPROUTE PUP "[Put fails: no routing]" PUPTRACEFILE))
(\REQUEUE.ETHERPACKET PUP)
(QUOTE NoRouting))
(T [COND
((AND PUPSOC (ZEROP (fetch PUPSOURCESOCKETLO of PUP))
(ZEROP (fetch PUPSOURCESOCKETHI of PUP)))
(replace PUPSOURCESOCKETHI of PUP with (fetch PSOCKETHI of PUPSOC))
(replace PUPSOURCESOCKETLO of PUP with (fetch PSOCKETLO of PUPSOC]
(\SETPUPCHECKSUM PUP)
(AND PUPTRACEFLG (\MAYBEPRINTPACKET PUP (QUOTE PUT)))
(TRANSMIT.ETHERPACKET NDB PUP)
(BLOCK)
NIL])
(EXCHANGEPUPS
[LAMBDA (SOC OUTPUP DUMMY IDFILTER TIMEOUT) (* bvm: "24-MAY-83 23:19")
(* Sends out OUTPUP on SOC and waits for a reply, which it puts in INPUP. If IDFILTER is true, only replies with
the same ID are accepted. Returns input pup on success, or NIL on failure. TIMEOUT overrides the default timeout.)
(DISCARDPUPS (\DTEST SOC (QUOTE PUPSOCKET))) (* Flush any pups waiting on this socket)
(SENDPUP SOC OUTPUP)
(bind INPUP (TIMER ←(SETUPTIMER (OR TIMEOUT \ETHERTIMEOUT)))
(EVENT ←(ffetch PUPSOCEVENT of SOC)) do (COND
([AND (SETQ INPUP (GETPUP SOC))
(OR (NOT IDFILTER)
(IEQP (fetch PUPID of INPUP)
(fetch PUPID of OUTPUP]
(RETURN INPUP))
(T (AWAIT.EVENT EVENT TIMER T)))
repeatuntil (TIMEREXPIRED? TIMER])
(DISCARDPUPS
[LAMBDA (SOC) (* bvm: " 5-MAY-83 23:51")
(SETQ SOC (\DTEST SOC (QUOTE PUPSOCKET)))
(UNINTERRUPTABLY
(PROG1 (fetch (PUPSOCKET INQUEUELENGTH) of SOC)
(\FLUSH.PACKET.QUEUE (fetch (PUPSOCKET INQUEUE) of SOC))
(replace (PUPSOCKET INQUEUELENGTH) of SOC with 0)))])
(GETPUPWORD
[LAMBDA (PUP WORD#) (* bvm: "31-JAN-83 15:27")
(\GETBASE [fetch PUPCONTENTS of (SETQ PUP (\DTEST PUP (QUOTE ETHERPACKET]
WORD#])
(\PUPINIT
[LAMBDA NIL (* bvm: "22-JUN-83 10:36")
(for FN in (QUOTE (SETUPPUP EXCHANGEPUPS GETPUP SENDPUP CLEARPUP GETPUPSTRING PUTPUPSTRING
ALLOCATE.PUP RELEASE.PUP CREATESOCKET FLUSHSOCKET))
bind NEWFN unless (GETD (SETQ NEWFN (PACK* (QUOTE \)
FN)))
do (* make dummy defs for old \ fns)
(PUTD NEWFN (GETD FN)
T))
(INITPUPLEVEL1 T])
)
(RPAQQ \PUPBOX NIL)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \PUPBOX)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(PUTDEF (QUOTE \PUPBOX)
(QUOTE GLOBALRESOURCES)
(QUOTE (CREATECELL \FIXP)))
)
(DEFINEQ
(ETHERHOSTNAME
[LAMBDA (PORT USE.OCTAL.DEFAULT) (* bvm: "22-MAY-83 23:43")
(* * Looks up the name of the host at address PORT. PORT may be a numeric address, or (host . socket) as returned
by ETHERPORT)
(PROG ((SOC (\GETMISCSOCKET))
(SOCKET# 0)
(OPUP (ALLOCATE.PUP))
NETHOST RESULT BUF IPUP)
[SETQ NETHOST (COND
((NULL PORT)
(\LOCALPUPHOSTNUMBER))
((FIXP PORT))
[(AND (LISTP PORT)
(FIXP (SETQ SOCKET# (CDR PORT)))
(FIXP (CAR PORT]
((AND (NLISTP PORT)
(SETQ NETHOST (\PARSE.PORTCONSTANT PORT)))
(SETQ SOCKET# (CDR NETHOST))
(CAR NETHOST))
(T (LISPERROR "ILLEGAL ARG" PORT]
[COND
((ZEROP (fetch PUPNET# of NETHOST)) (* Net not specified, default to local net)
(SETQ NETHOST (create PUPADDRESS
PUPNET# ←(\LOCALPUPNETNUMBER)
PUPHOST# ← NETHOST]
(SETUPPUP OPUP 0 \PUPSOCKET.MISCSERVICES \PT.ADDRLOOKUP NIL SOC T)
(add (fetch PUPLENGTH of OPUP)
6) (* port is 6 bytes long)
(replace (PORT NETHOST) of (SETQ BUF (fetch PUPCONTENTS of OPUP)) with NETHOST)
(replace (PORT SOCKET) of BUF with SOCKET#)
(to \MAXETHERTRIES when (SETQ IPUP (EXCHANGEPUPS SOC OPUP NIL T))
do (SELECTC (fetch PUPTYPE of IPUP)
[\PT.ADDRRESPONSE (RETURN (SETQ RESULT (MKATOM (GETPUPSTRING IPUP]
(\PT.NAME/ADDRERROR (PUPDEBUGGING "Address lookup error for "
(PORTSTRING NETHOST SOCKET#)
": "
(GETPUPSTRING IPUP)
T)
(RETURN))
NIL)
finally (PUPDEBUGGING "Address lookup timed out" T))
(AND IPUP (RELEASE.PUP IPUP))
(RELEASE.PUP OPUP)
(RETURN (OR RESULT (AND USE.OCTAL.DEFAULT (PORTSTRING NETHOST (AND (NOT (ZEROP SOCKET#))
SOCKET#])
(ETHERHOSTNUMBER
[LAMBDA (NAME) (* bvm: "14-APR-83 21:54")
(COND
((NULL NAME)
(\LOCALPUPADDRESS))
(T (CAR (ETHERPORT NAME])
(ETHERPORT
[LAMBDA (NAME ERRORFLG MULTFLG) (* bvm: " 5-MAR-82 16:03")
(* * Returns net address of NAME as (nethost . socket), or list of same if MULTFLG is true %.
Caches results locally so doesn't have to look all the time. If ERRORFLG is true, generates error on failure.)
(* If MULTFLG is nonNIL, fives a list of results -
singleton unless perhaps from \LOOKUPP%ORT)
(PROG (VAL)
(RETURN (COND
([SETQ VAL (COND
((FIXP NAME) (* A host number. Give it socket zero)
(\FIXLOCALNET (CONS NAME 0)))
[(LISTP NAME) (* An existing port structure)
(COND
((AND (FIXP (CAR NAME))
(FIXP (CDR NAME)))
(\FIXLOCALNET NAME))
(ERRORFLG (\ILLEGAL.ARG NAME]
(T (\PARSE.PORTCONSTANT NAME]
(COND
(MULTFLG (LIST VAL))
(T VAL)))
[(SETQ VAL (OR (GETHASH NAME \ETHERPORTS)
(PUTHASH NAME (\LOOKUPPORT NAME)
\ETHERPORTS))) (* note we always save multiple values in case they are
ever wanted)
(COND
(MULTFLG VAL)
(T (CAR VAL]
(ERRORFLG (ERROR "host not found" NAME])
(NETDAYTIME0
[LAMBDA NIL (* bvm: "17-FEB-83 15:54")
(* * Returns a 32-bit unsigned alto time from the network, if possible)
(PROG ((SOC (\GETMISCSOCKET))
(OPUP (ALLOCATE.PUP))
RESULT IPUP)
(SETUPPUP OPUP 0 \PUPSOCKET.MISCSERVICES \PT.ALTOTIMEREQUEST NIL SOC T)
(RETURN (to \MAXETHERTRIES when (SETQ IPUP (EXCHANGEPUPS SOC OPUP NIL T))
do (SELECTC (fetch PUPTYPE of IPUP)
[\PT.ALTOTIMERESPONSE (RETURN (fetch DATEDATUM
of (fetch PUPCONTENTS of IPUP]
(\PT.ERROR (AND (PUPTRACING)
(PRINTERRORPUP IPUP PUPTRACEFILE)))
NIL])
(\PUP.SETTIME
[LAMBDA NIL (* bvm: "27-MAY-83 07:44")
(* * Returns a 32-bit unsigned alto time from the network, if possible)
(PROG ((SOC (\GETMISCSOCKET))
(OPUP (ALLOCATE.PUP))
RESULT IPUP DATA)
(SETUPPUP OPUP 0 \PUPSOCKET.MISCSERVICES \PT.ALTOTIMEREQUEST NIL SOC T)
(RETURN (to \MAXETHERTRIES when (SETQ IPUP (EXCHANGEPUPS SOC OPUP NIL T))
do (SELECTC (fetch PUPTYPE of IPUP)
(\PT.ALTOTIMERESPONSE (SETQ DATA (fetch PUPCONTENTS of IPUP))
(\SETNEWTIME0 (create FIXP
HINUM ←(fetch
TIMEPUPVALUEHI
of DATA)
LONUM ←(fetch
TIMEPUPVALUELO
of DATA)))
(SETQ \TimeZoneComp
(ITIMES (COND
((fetch TIMEPUPEASTP of DATA)
-1)
(T 1))
(fetch TIMEPUPHOURS of DATA)))
(SETQ \BeginDST (fetch TIMEPUPBEGINDST
of DATA))
(SETQ \EndDST (fetch TIMEPUPENDDST
of DATA))
(RETURN T))
(\PT.ERROR (AND (PUPTRACING)
(PRINTERRORPUP IPUP PUPTRACEFILE)))
NIL])
(\SETNEWTIME0
[LAMBDA (NEWTIME) (* bvm: "26-MAY-83 15:36")
(PROG [(OLDTIME (\DAYTIME0 (create FIXP]
(\SETDAYTIME0 NEWTIME)
(COND
((IGREATERP (IABS (IDIFFERENCE NEWTIME OLDTIME))
454Q) (* Time changed by more than 5 minutes, maybe mention
it)
(printout PROMPTWINDOW "[Time reset to " (DATE)
"]" T])
(NETDATE
[LAMBDA NIL (* bvm: "30-AUG-81 00:30")
(GDATE (ALTO.TO.LISP.DATE (OR (NETDAYTIME0)
(DAYTIME0 (create FIXP])
(\LOOKUPPORT
[LAMBDA (NAME) (* bvm: " 5-MAY-83 23:51")
(* * Looks up the ether address of NAME, returning a list of dotted pairs (nethost . socket), or NIL on failure)
(PROG ((SOC (\GETMISCSOCKET))
(OPUP (ALLOCATE.PUP))
RESULT BUF LEN IPUP)
(SETUPPUP OPUP 0 \PUPSOCKET.MISCSERVICES \PT.NAMELOOKUP NIL SOC T)
(PUTPUPSTRING OPUP NAME)
(to \MAXETHERTRIES when (SETQ IPUP (EXCHANGEPUPS SOC OPUP NIL T))
do (SELECTC (fetch PUPTYPE of IPUP)
[\PT.NAMERESPONSE (COND
((IGREATERP (SETQ LEN
(IQUOTIENT (FOLDLO (IDIFFERENCE
(fetch PUPLENGTH
of IPUP)
\PUPOVLEN)
BYTESPERWORD)
\PORTIDLEN))
1)
(PUPDEBUGGING "Multiple response received for " NAME T)
))
(RETURN (SETQ RESULT (from 1 to LEN
as (PTR ←(fetch PUPCONTENTS
of IPUP))
by (\ADDBASE PTR \PORTIDLEN)
collect
(CONS (fetch (PORT NETHOST)
of PTR)
(fetch (PORT SOCKET)
of PTR]
(\PT.NAME/ADDRERROR (PUPDEBUGGING "Name lookup error for " NAME ": "
(GETPUPSTRING IPUP)
T)
(RETURN))
(HELP))
finally (PUPDEBUGGING "Name lookup timed out" T))
(AND IPUP (RELEASE.PUP IPUP))
(RELEASE.PUP OPUP)
(AND (CDR RESULT)
(SORT.PUPHOSTS.BY.DISTANCE RESULT))
(RETURN RESULT])
(\PARSE.PORTCONSTANT
[LAMBDA (STR)
(DECLARE (GLOBALVARS CHCONLST1)) (* bvm: "18-JUN-81 13:02")
(* * If STR is a constant ether address of form net#host#socket, returns a port, else NIL)
(AND (FIXP (NTHCHAR STR 1))
(PROG ((CHARS (DCHCON STR CHCONLST1))
NET HOST VAL)
LP [COND
((NULL CHARS) (* Ran out of chars. Save last value parsed, make sure we
have at least a net and host)
(COND
((NOT NET)
(RETURN))
((NOT HOST)
(SETQ HOST VAL)
(SETQ VAL)))
(RETURN (AND HOST (CONS (LOGOR HOST (LLSH NET 10Q))
(OR VAL 0]
(COND
[(AND (IGEQ (CAR CHARS)
(CHARCODE 0))
(ILEQ (CAR CHARS)
(CHARCODE 7))) (* Add octal digit into value)
(SETQ VAL (IPLUS (COND
(VAL (LLSH VAL 3))
(T 0))
(IDIFFERENCE (CAR CHARS)
(CHARCODE 0]
((EQ (CAR CHARS)
(CHARCODE #)) (* # terminates net or host number)
(COND
((NOT VAL)
(RETURN))
((NOT NET)
(SETQ NET VAL))
((NOT HOST)
(SETQ HOST VAL))
(T (RETURN)))
(SETQ VAL NIL))
(T (RETURN)))
(SETQ CHARS (CDR CHARS))
(GO LP])
(\FIXLOCALNET
[LAMBDA (PORT) (* bvm: "20-JUN-83 14:11")
(* Port is a dotted pair (nethost . socket). We force the nethost to have a nonzero net if we know our net by now.
Returns the possibly modified PORT)
[PROG (NET)
(COND
((AND (ILESSP (CAR PORT)
400Q)
(NOT (ZEROP (CAR PORT)))
\LOCALNDBS
(SETQ NET (fetch NDBPUPNET# of \LOCALNDBS))
(NOT (ZEROP NET)))
(RPLACA PORT (create PUPADDRESS
PUPNET# ← NET
PUPHOST# ←(CAR PORT]
PORT])
)
(* Accessing a PUP's contents)
(DEFINEQ
(CLEARPUP
[LAMBDA (PUP) (* bvm: "31-JAN-83 15:31")
(replace EPLINK of (SETQ PUP (\DTEST PUP (QUOTE ETHERPACKET))) with NIL)
(* de-reference the pointers)
[replace EPUSERFIELD of PUP with (replace EPPLIST of PUP
with (replace EPREQUEUE of PUP
with (replace EPSOCKET of PUP
with (replace EPNETWORK of PUP with NIL]
(\ZEROWORDS (fetch PUPBASE of PUP)
(\ADDBASE (LOCF (fetch SOURCESKT of PUP))
1))
(\ZEROBYTES (fetch PUPCONTENTS of PUP)
0
(SUB1 \MAX.PUPLENGTH])
(PUTPUPWORD
[LAMBDA (PUP WORD# VALUE) (* bvm: "31-JAN-83 15:31")
(\PUTBASE [fetch PUPCONTENTS of (SETQ PUP (\DTEST PUP (QUOTE ETHERPACKET]
WORD# VALUE])
(GETPUPBYTE
[LAMBDA (PUP BYTE#) (* bvm: "31-JAN-83 15:31")
(\GETBASEBYTE [fetch PUPCONTENTS of (SETQ PUP (\DTEST PUP (QUOTE ETHERPACKET]
BYTE#])
(PUTPUPBYTE
[LAMBDA (PUP BYTE# VALUE) (* bvm: "31-JAN-83 15:31")
(\PUTBASEBYTE [fetch PUPCONTENTS of (SETQ PUP (\DTEST PUP (QUOTE ETHERPACKET]
BYTE# VALUE])
(GETPUPSTRING
[LAMBDA (PUP OFFSET) (* bvm: "31-JAN-83 15:34")
(\GETBASESTRING [fetch PUPCONTENTS of (SETQ PUP (\DTEST PUP (QUOTE ETHERPACKET]
(OR OFFSET (SETQ OFFSET 0))
(IDIFFERENCE (IDIFFERENCE (fetch PUPLENGTH of PUP)
\PUPOVLEN)
OFFSET])
(PUTPUPSTRING
[LAMBDA (PUP STR) (* bvm: "31-JAN-83 15:35")
(add [fetch PUPLENGTH of (SETQ PUP (\DTEST PUP (QUOTE ETHERPACKET]
(\PUTBASESTRING (fetch PUPCONTENTS of PUP)
(IDIFFERENCE (fetch PUPLENGTH of PUP)
\PUPOVLEN)
STR])
(READPLIST
[LAMBDA (OFD) (* bvm: "13-NOV-81 15:28")
(PROG [(PLIST (READ OFD (DEFERREDCONSTANT (PROG [(RT (COPYREADTABLE (QUOTE ORIG]
(SETBRK (CHARCODE (%( %)))
NIL RT)
(SETSYNTAX (QUOTE ')
(QUOTE ESCAPE)
RT)
(SETSYNTAX (QUOTE %%)
(QUOTE OTHER)
RT)
(SETSEPR (CHARCODE (SPACE NULL))
NIL RT)
(RETURN RT]
[for PAIR in PLIST do (RPLACA PAIR (AND (CAR PAIR)
(OR (GETPROP (CAR PAIR)
(QUOTE U-CASE))
(PUTPROP (CAR PAIR)
(QUOTE U-CASE)
(U-CASE (CAR PAIR]
(RETURN PLIST])
(\STOREPLIST
[LAMBDA (LST BASE LIMIT) (* lmm "30-JUN-82 22:22")
(PROG ((CNT 0)
PRE)
(\PUTBASEBYTE BASE 0 (CHARCODE "("))
(for PAIR in LST do (SETQ PRE (CHARCODE "("))
(for X in PAIR do (\PUTBASEBYTE BASE (add CNT 1)
PRE)
(SETQ PRE (CHARCODE SPACE))
(for CH inchars X
do (SELCHARQ CH
((%( %) ')
(* need to quote these)
(\PUTBASEBYTE BASE
(add CNT 1)
(CHARCODE ')))
NIL)
(\PUTBASEBYTE BASE (add CNT 1)
CH)))
(\PUTBASEBYTE BASE (add CNT 1)
(CHARCODE ")")))
(\PUTBASEBYTE BASE (add CNT 1)
(CHARCODE ")"))
(RETURN (ADD1 CNT])
)
(DECLARE: EVAL@COMPILE
(PUTPROPS GETPUPWORD DMACRO ((PUPARG WORD#)
(\GETBASE (fetch PUPCONTENTS of (\DTEST PUPARG (QUOTE ETHERPACKET)))
WORD#)))
(PUTPROPS PUTPUPWORD DMACRO ((PUPARG WORD# VALUE)
(\PUTBASE (fetch PUPCONTENTS of (\DTEST PUPARG (QUOTE ETHERPACKET)))
WORD# VALUE)))
(PUTPROPS GETPUPBYTE DMACRO ((PUPARG BYTE#)
(\GETBASEBYTE (fetch PUPCONTENTS of (\DTEST PUPARG (QUOTE ETHERPACKET)))
BYTE#)))
(PUTPROPS PUTPUPBYTE DMACRO ((PUPARG BYTE# VALUE)
(\PUTBASEBYTE (fetch PUPCONTENTS of (\DTEST PUPARG (QUOTE ETHERPACKET)))
BYTE# VALUE)))
)
(* PUP allocation)
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(PUTPROPS BINDPUPS MACRO [X (CONS (LIST (QUOTE LAMBDA)
(CAR X)
(CONS (QUOTE PROGN)
(CDR X)))
(in (CAR X) collect (LIST (QUOTE ALLOCATE.PUP])
)
(PUTPROPS BINDPUPS INFO BINDS)
(ADDTOVAR PRETTYPRINTMACROS (BINDPUPS LAMBDA
(FORM)
(PROG [(POS (IPLUS 2 (POSITION]
(PRIN1 "(")
(PRIN2 (CAR FORM))
(SPACES 1)
(PRINTDEF (CADR FORM)
(POSITION))
(OR [EQ COMMENTFLG (CAAR (SETQ FORM (CDDR FORM]
(TAB POS 0))
(PRINTDEF FORM POS T T FNSLST)
(PRIN1 ")"))))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS PUPTRACEFILE PUPONLYTYPES PUPIGNORETYPES PUPPRINTMACROS)
)
(* END EXPORTED DEFINITIONS)
(* Pup routing)
(DEFINEQ
(\PUPGATELISTENER
[LAMBDA NIL (* bvm: "10-JUN-83 11:25")
(PROG ((SOCKET (OPENPUPSOCKET \PUPSOCKET.ROUTING T))
(TIMER (SETUPTIMER 0))
PUP EVENT BASE)
(SETQ EVENT (fetch PUPSOCEVENT of SOCKET))
LP (COND
((SETQ PUP (GETPUP SOCKET))
(\HANDLE.PUP.ROUTING.INFO PUP)
(BLOCK))
((EQ (AWAIT.EVENT EVENT (COND
((IGREATERP \PUPROUTER.PROBECOUNT 0)
\PUPROUTER.PROBETIMER)
(T TIMER))
T)
EVENT) (* Waiting for pup to arrive or timer to expire--pup
arrived.)
(GO LP)))
(COND
((TIMEREXPIRED? TIMER)
(\AGE.ROUTING.TABLE \PUP.ROUTING.TABLE)
(SETUPTIMER \RT.AGEINTERVAL TIMER)))
[COND
((AND (IGREATERP \PUPROUTER.PROBECOUNT 0)
(TIMEREXPIRED? \PUPROUTER.PROBETIMER)) (* Routing info desired. Broadcast a routing request on
each directly-connected net)
(SETUPPUP (SETQ PUP (ALLOCATE.PUP))
0 \PUPSOCKET.ROUTING \PT.GATEWAYREQUEST NIL SOCKET)
(SENDPUP SOCKET PUP)
(SETUPTIMER \PUPROUTER.PROBEINTERVAL \PUPROUTER.PROBETIMER)
(SETQ \PUPROUTER.PROBECOUNT (SUB1 \PUPROUTER.PROBECOUNT]
(GO LP])
(\HANDLE.PUP.ROUTING.INFO
[LAMBDA (PUP) (* bvm: "10-JUN-83 14:20")
(* Processes a routing info PUP)
[COND
((EQ (fetch PUPTYPE of PUP)
\PT.GATEWAYRESPONSE) (* Unless we're a gateway, we only handle responses)
(PROG ((HOST (fetch PUPSOURCEHOST of PUP))
(NDB (fetch EPNETWORK of PUP))
(LENGTH (FOLDLO (IDIFFERENCE (fetch PUPLENGTH of PUP)
\PUPOVLEN)
BYTESPERWORD))
(BASE (fetch PUPCONTENTS of PUP))
ENTRY NET HOPS)
[COND
((NEQ (fetch NETTYPE of NDB)
3)
(OR (SETQ HOST (\TRANSLATE.3TO10 HOST NDB))
(RETURN]
(SETQ \PUPROUTER.PROBECOUNT 0)
(while (IGEQ LENGTH \PUP.ROUTINGINFO.WORDS)
do (SETQ NET (fetch (PUPROUTINGINFO NET#) of BASE))
(SETQ HOPS (ADD1 (fetch (PUPROUTINGINFO #HOPS) of BASE)))
[COND
((OR (SETQ ENTRY (.RTLOOKUP. NET \PUP.ROUTING.TABLE))
(COND
((ILEQ HOPS \PUP.ROUTING.TABLE.RADIUS)
[push (CDR \PUP.ROUTING.TABLE)
(SETQ ENTRY (create ROUTING
RTNET# ← NET
RTTIMER ←(SETUPTIMER 0]
T)))
(* Update the entry if this entry not for directly connected net and -
current entry timed out, or -
new gateway same as old, or -
new route has fewer hops than old)
(COND
([AND (NEQ (fetch RTHOPCOUNT of ENTRY)
0)
(OR (NOT (fetch RTRECENT of ENTRY))
(AND (EQUAL HOST (fetch RTGATEWAY# of ENTRY))
(EQ NDB (fetch RTNDB of ENTRY)))
(ILESSP HOPS (fetch RTHOPCOUNT of ENTRY]
(replace RTGATEWAY# of ENTRY with HOST)
(replace RTNDB of ENTRY with NDB)
(replace RTHOPCOUNT of ENTRY with HOPS)
(COND
((ILESSP HOPS \RT.INFINITY)
(replace RTRECENT of ENTRY with T)
(SETUPTIMER \RT.TIMEOUTINTERVAL (fetch RTTIMER of ENTRY]
(SETQ LENGTH (IDIFFERENCE LENGTH \PUP.ROUTINGINFO.WORDS))
(SETQ BASE (\ADDBASE BASE \PUP.ROUTINGINFO.WORDS]
(\RELEASE.ETHERPACKET PUP])
(\ROUTE.PUP
[LAMBDA (PUP) (* bvm: " 2-AUG-83 15:50")
(* Encapsulates PUP, choosing the right network and
immediate destination host. Returns an NDB for the
transmission)
(PROG ((NET (fetch PUPDESTNET of PUP))
(HOST (fetch PUPDESTHOST of PUP))
PDH ROUTE NDB)
(OR (SMALLP NET)
(SETQ NET (HELP "Bad net number" NET)))
(COND
[(ZEROP NET)
(COND
((NOT (SETQ NDB (OR \3MBLOCALNDB \10MBLOCALNDB)))
(RETURN]
((SETQ ROUTE (\LOCATE.PUPNET NET))
(SETQ NDB (fetch RTNDB of ROUTE)))
(T (RETURN)))
(replace EPNETWORK of PUP with NDB)
[SETQ PDH (COND
((AND ROUTE (NEQ (fetch RTHOPCOUNT of ROUTE)
0))
(fetch RTGATEWAY# of ROUTE))
((EQ (fetch NETTYPE of NDB)
3)
HOST)
((ZEROP HOST) (* Broadcast)
BROADCASTNSHOSTNUMBER)
((\TRANSLATE.3TO10 HOST NDB))
(T (RETURN]
(ENCAPSULATE.ETHERPACKET NDB PUP PDH (fetch PUPLENGTH of PUP)
\EPT.PUP)
[COND
((ZEROP NET)
(replace PUPDESTNET of PUP with (fetch NDBPUPNET# of NDB]
(replace PUPSOURCENET of PUP with (fetch NDBPUPNET# of NDB))
[COND
((ZEROP (fetch PUPSOURCEHOST of PUP))
(replace PUPSOURCEHOST of PUP with (fetch NDBPUPHOST# of NDB]
(RETURN NDB])
(\LOCATE.PUPNET
[LAMBDA (NET DONTPROBE) (* bvm: "10-JUN-83 12:08")
(OR (SMALLP NET)
(HELP "Bad network number" NET))
(for (PREVTAIL ← \PUP.ROUTING.TABLE) bind TAIL DATA while (LISTP (SETQ TAIL (CDR PREVTAIL)))
do (SETQ DATA (CAR TAIL))
[COND
([OR (EQ NET (fetch (ROUTING RTNET#) of DATA))
(AND (ZEROP NET)
(ZEROP (fetch (ROUTING RTHOPCOUNT) of DATA]
[COND
((NEQ PREVTAIL \PUP.ROUTING.TABLE) (* Promote this entry to the front, so we find it faster
in the future)
(FRPLACD \PUP.ROUTING.TABLE (PROG1 TAIL (FRPLACD PREVTAIL (CDR TAIL))
(FRPLACD TAIL (CDR \PUP.ROUTING.TABLE]
(RETURN (AND (ILESSP (fetch RTHOPCOUNT of DATA)
\RT.INFINITY)
DATA]
(SETQ PREVTAIL TAIL)
finally (COND
((NOT DONTPROBE)
[OR (ZEROP NET)
(push (CDR \PUP.ROUTING.TABLE)
(create ROUTING
RTNET# ← NET
RTHOPCOUNT ← \RT.INFINITY
RTTIMER ←(SETUPTIMER 72460Q]
(* Insert an entry for the net, to be purged in 36Q sec
if router process hasn't filled it by then)
(SETQ \PUPROUTER.PROBECOUNT 5)
(SETQ \PUPROUTER.PROBETIMER (SETUPTIMER 0 \PUPROUTER.PROBETIMER))
(WAKE.PROCESS (QUOTE \PUPGATELISTENER))
(BLOCK])
(SORT.PUPHOSTS.BY.DISTANCE
[LAMBDA (HOSTLIST) (* bvm: " 6-MAY-83 00:18")
(COND
((NULL (CDR (LISTP HOSTLIST)))
HOSTLIST)
(T
(* HOSTLIST is a list each of whose elements has a pup nethost in its CAR and anything in its CDR.
In particular, standard pup PORT pairs work)
[for PAIR in HOSTLIST do (\LOCATE.PUPNET (fetch PUPNET# of (CAR PAIR]
(* Enter request for routing for all hosts)
(BLOCK)
(COND
((NOT (for PAIR in HOSTLIST always (\LOCATE.PUPNET (fetch PUPNET# of (CAR PAIR))
T)))
(BLOCK \ETHERTIMEOUT)))
(SORT HOSTLIST (FUNCTION \PUPNET.CLOSERP])
(\PUPNET.CLOSERP
[LAMBDA (X Y) (* edited: "12-APR-83 12:44")
(PROG ((ROUTEX (\LOCATE.PUPNET (fetch PUPNET# of (CAR X))
T))
ROUTEY)
(RETURN (COND
((NULL ROUTEX)
NIL)
((SETQ ROUTEY (\LOCATE.PUPNET (fetch PUPNET# of (CAR Y))
T))
(ILESSP (fetch RTHOPCOUNT of ROUTEX)
(fetch RTHOPCOUNT of ROUTEY)))
(T T])
(PUPNET.DISTANCE
[LAMBDA (NET#) (* bvm: " 1-MAR-83 16:15")
(PROG ((ROUTE (\LOCATE.PUPNET NET#)))
[COND
((NULL ROUTE)
(to 4 do (BLOCK \ETHERTIMEOUT) repeatuntil (SETQ ROUTE (\LOCATE.PUPNET NET#]
(RETURN (COND
(ROUTE (fetch RTHOPCOUNT of ROUTE])
)
(RPAQ? \PUP.ROUTING.TABLE (CONS))
(RPAQ? \PUP.ROUTING.TABLE.RADIUS 2)
(RPAQ? \PUPROUTER.PROBECOUNT 0)
(RPAQ? \PUPROUTER.PROBETIMER )
(RPAQ? \PUPROUTER.PROBEINTERVAL 5670Q)
(RPAQ? \PUP.READY )
(RPAQ? \PUP.READY.EVENT (CREATE.EVENT "Pup Ready"))
(ADDTOVAR \SYSTEMCACHEVARS \PUP.READY)
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(BLOCKRECORD PUPROUTINGINFO ( (* Format of each entry in a pup routing info packet.
We only actually use NET# and #HOPS)
(NET# BYTE)
(GATENET# BYTE)
(GATEHOST# BYTE)
(#HOPS BYTE)))
]
(DECLARE: EVAL@COMPILE
(RPAQQ \PUP.ROUTINGINFO.WORDS 2)
(CONSTANTS \PUP.ROUTINGINFO.WORDS)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \PUP.ROUTING.TABLE \PUP.ROUTING.TABLE.RADIUS \PUPROUTER.PROBECOUNT
\PUPROUTER.PROBETIMER \PUPROUTER.PROBEINTERVAL \PUP.READY \PUP.READY.EVENT)
)
)
(* Sockets)
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(DATATYPE PUPSOCKET ((NIL BYTE)
(PUPSOCLINK POINTER) (* So that we can Queue them)
(PSOCKET# FIXP)
(INQUEUE POINTER)
(INQUEUELENGTH WORD)
(PUPSOC#ALLOCATION WORD)
(PUPSOCHANDLE WORD) (* Back-fitting for Bcpl)
(PUPSOCPUPADDRESS WORD) (* Local net/host)
(NIL BYTE)
(PUPSOCEVENT POINTER) (* Event that is notified when a pup arrives on this
socket)
(NIL BYTE)
(NIL POINTER))
(BLOCKRECORD PUPSOCKET ((NIL BYTE)
(NIL POINTER)
(PSOCKETHI WORD)
(PSOCKETLO WORD)))
INQUEUE ←(create SYSQUEUE)
PUPSOC#ALLOCATION ← \MAX.EPKTS.ON.PUPSOCKET)
]
(/DECLAREDATATYPE (QUOTE PUPSOCKET)
(QUOTE (BYTE POINTER FIXP POINTER WORD WORD WORD WORD BYTE POINTER BYTE POINTER)))
(DECLARE: EVAL@COMPILE
(PUTPROPS \PUPSOCKET.FROM# MACRO (OPENLAMBDA (SOCHI SOCLO)
(for SOC in \PUPSOCKETS
when (AND (EQ (fetch PSOCKETLO of SOC)
SOCLO)
(EQ (fetch PSOCKETHI of SOC)
SOCHI))
do (RETURN SOC))))
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \PUPSOCKETS.TABLE \MAX.EPKTS.ON.PUPSOCKET \PUP.CHECKSUMFLG)
)
)
(/DECLAREDATATYPE (QUOTE PUPSOCKET)
(QUOTE (BYTE POINTER FIXP POINTER WORD WORD WORD WORD BYTE POINTER BYTE POINTER)))
(DEFINEQ
(OPENPUPSOCKET
[LAMBDA (SKT# IFCLASH) (* bvm: "21-JUL-83 10:36")
(* Creates a new local PUPSOCKET If SKT# is supplied, it is the identifying number (32-bit) of the socket, and an
error occurs if that socket is already in use.)
(PROG ((ID#EXPLICIT? (FIXP SKT#))
PUPSOC CLASHP SOCHI SOCLO)
[COND
[(type? PUPSOCKET SKT#)
(SETQ PUPSOC SKT#)
(\FLUSHPUPSOCQUEUE PUPSOC)
(COND
((NEQ PUPSOC (\PUPSOCKET.FROM# (fetch PSOCKETHI of PUPSOC)
(fetch PSOCKETLO of PUPSOC)))
(ERROR PUPSOC "Attempt to re-open a released PUPSOCKET."]
(T (COND
(ID#EXPLICIT? (SETQ SOCHI (\HINUM SKT#))
(SETQ SOCLO (\LONUM SKT#)))
(T (* Pick a socket that is reasonably random but won't
conflict with well-known sockets)
[SETQ SOCLO (LOGOR 100000Q (\LONUM (DAYTIME]
(SETQ SOCHI 1)))
(UNINTERRUPTABLY
[do (COND
((NOT (SETQ CLASHP (\PUPSOCKET.FROM# SOCHI SOCLO)))
(SETQ PUPSOC (create PUPSOCKET
PSOCKETHI ← SOCHI
PSOCKETLO ← SOCLO))
(replace PUPSOCEVENT of PUPSOC with (CREATE.EVENT PUPSOC))
(push \PUPSOCKETS PUPSOC)
(RETURN))
[(NOT ID#EXPLICIT?)
(SETQ SOCLO (LOGOR 100000Q (ADD1 (LOGAND SOCLO 77777Q]
(T (RETURN])
(COND
(CLASHP (SELECTQ IFCLASH
((T ACCEPT)
(\FLUSHPUPSOCQUEUE (SETQ PUPSOC CLASHP)))
((DON'T FAIL)
(RETURN NIL))
(ERROR "Socket number is already in use" SKT#]
(RETURN PUPSOC])
(CLOSEPUPSOCKET
[LAMBDA (PUPSOC NOERRORFLG) (* bvm: " 5-MAY-83 23:58")
(* Closes a local PUPSOCKET -- argument = T means close
all sockets)
(COND
((EQ PUPSOC T)
(while \PUPSOCKETS
do (\FLUSHPUPSOCQUEUE (SETQ PUPSOC (pop \PUPSOCKETS)))
(replace PUPSOCEVENT of PUPSOC with NIL)))
(T (\FLUSHPUPSOCQUEUE (\DTEST PUPSOC (QUOTE PUPSOCKET)))
(PROG1 (COND
((FMEMB PUPSOC \PUPSOCKETS)
(SETQ \PUPSOCKETS (DREMOVE PUPSOC \PUPSOCKETS))
T)
((NOT NOERRORFLG)
(ERROR PUPSOC "not an open PUP socket")))
(replace PUPSOCEVENT of PUPSOC with NIL])
(PUPSOCKETNUMBER
[LAMBDA (PUPSOC) (* bvm: "14-FEB-83 15:21")
(fetch PSOCKET# of PUPSOC])
(PUPSOCKETFROMNUMBER
[LAMBDA (SOC#orSOCLO SOCHI) (* bvm: "21-JUL-83 11:39")
[COND
((NULL SOCHI)
(SETQ SOCHI (\HINUM SOC#orSOCLO))
(SETQ SOC#orSOCLO (LOGAND SOC#orSOCLO 177777Q]
(\PUPSOCKET.FROM# SOCHI SOC#orSOCLO])
(PUPSOCKETEVENT
[LAMBDA (PUPSOC) (* bvm: "10-MAY-83 22:32")
(ffetch PUPSOCEVENT of (\DTEST PUPSOC (QUOTE PUPSOCKET])
(\FLUSHPUPSOCQUEUE
[LAMBDA (PUPSOC) (* bvm: "11-FEB-83 12:55")
(\FLUSH.PACKET.QUEUE (fetch (PUPSOCKET INQUEUE) of PUPSOC))
(replace (PUPSOCKET INQUEUELENGTH) of PUPSOC with 0)
PUPSOC])
)
(DEFINEQ
(\GETMISCSOCKET
[LAMBDA NIL (* bvm: "14-FEB-83 15:29")
(* Opens a socket for miscellaneous services, if we
don't have it open yet)
(COND
((AND \MISC.SOCKET (FMEMB \MISC.SOCKET \PUPSOCKETS))
\MISC.SOCKET)
(T (SETQ \MISC.SOCKET (OPENPUPSOCKET])
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \MISC.SOCKET \PUPSOCKETS)
)
(RPAQ? \MISC.SOCKET )
(RPAQ? \PUPSOCKETS )
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \ETHERPORTS \EFTP.TIMEOUT \EFTP.LONGTIMEOUT \PUPCOUNTER)
)
(DECLARE: DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
[DECLARE: EVAL@COMPILE
(BLOCKRECORD PORT ((NETHOST WORD)
(SOCKET FIXP))
(BLOCKRECORD PORT ((NET BYTE)
(HOST BYTE)
(SOCKETHI WORD)
(SOCKETLO WORD))))
(ACCESSFNS ERRORPUP ((ERRORPUPBASE (fetch PUPCONTENTS of DATUM)))
(BLOCKRECORD ERRORPUPBASE ((ERRORPUPCOPY 12Q WORD)
(* Copy of pup header)
(ERRORPUPCODE WORD)
(ERRORPUPARG WORD) (* Usually zero)
(ERRORPUPSTRINGBASE WORD)
(* Human readable message)
)))
]
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \ETHERWAIT1 \ETHERTIMEOUT \MAXETHERTRIES PUPTRACEFLG LOGINPASSWORDS
NILPUPTRACEFLG)
)
(DECLARE: EVAL@COMPILE
(RPAQQ \PUPOVLEN 26Q)
(RPAQQ \MAX.PUPLENGTH 1024Q)
(RPAQQ \TIME.GETPUP 5)
(CONSTANTS (\PUPOVLEN 26Q)
(\MAX.PUPLENGTH 1024Q)
(\TIME.GETPUP 5))
)
(PUTPROPS PUPPRINTMACROS VARTYPE ALIST)
(DECLARE: EVAL@COMPILE
(I.S.OPR (QUOTE INCHARS)
NIL
[QUOTE (SUBPAIR (QUOTE ($BASE $OFF $END))
(LIST (GETDUMMYVAR)
(GETDUMMYVAR)
(GETDUMMYVAR))
(QUOTE (bind $BASE $OFF $END first [COND
((LITATOM BODY)
(SETQ $OFF 1)
(SETQ $BASE (fetch (LITATOM PNAMEBASE)
of BODY))
(SETQ $END (fetch (LITATOM PNAMELENGTH)
of BODY)))
(T [SETQ $OFF (fetch (STRINGP OFFST)
of
(OR (STRINGP BODY)
(SETQ BODY (MKSTRING BODY]
(SETQ $BASE (fetch (STRINGP BASE)
of BODY))
(SETQ $END (IPLUS $OFF (fetch (STRINGP LENGTH)
of BODY)
-1]
eachtime
(COND ((IGREATERP $OFF $END)
(GO $$OUT))
(T (SETQ I.V. (\GETBASEBYTE $BASE $OFF))
(SETQ $OFF (ADD1 $OFF]
T)
)
(DECLARE: EVAL@COMPILE
(PUTPROPS \GETPUPWORD DMACRO ((PUP WORD#)
(\GETBASE (fetch PUPCONTENTS of PUP)
WORD#)))
(PUTPROPS \PUTPUPWORD DMACRO ((PUP WORD# VALUE)
(\PUTBASE (fetch PUPCONTENTS of PUP)
WORD# VALUE)))
(PUTPROPS \GETPUPBYTE DMACRO ((PUP BYTE#)
(\GETBASEBYTE (fetch PUPCONTENTS of PUP)
BYTE#)))
(PUTPROPS \PUTPUPBYTE DMACRO ((PUP BYTE# VALUE)
(\PUTBASEBYTE (fetch PUPCONTENTS of PUP)
BYTE# VALUE)))
)
(RPAQQ RAWPUPTYPES ((\PT.ECHOME 1)
(\PT.IAMECHO 2)
(\PT.IAMBADECHO 3)
(\PT.ERROR 4)
(\PT.RFC 10Q)
(\PT.ABORT 11Q)
(\PT.END 12Q)
(\PT.ENDREPLY 13Q)
(\PT.DATA 20Q)
(\PT.ADATA 21Q)
(\PT.ACK 22Q)
(\PT.MARK 23Q)
(\PT.INTERRUPT 24Q)
(\PT.INTERRUPTREPLY 25Q)
(\PT.AMARK 26Q)
(\PT.GATEWAYREQUEST 200Q)
(\PT.GATEWAYRESPONSE 201Q)
(\PT.ALTOTIMEREQUEST 206Q)
(\PT.ALTOTIMERESPONSE 207Q)
(\PT.MSGCHECK 210Q)
(\PT.NEWMAIL 211Q)
(\PT.NONEWMAIL 212Q)
(\PT.NOMAILBOX 213Q)
(\PT.LAURELCHECK 214Q)
(\PT.NAMELOOKUP 220Q)
(\PT.NAMERESPONSE 221Q)
(\PT.NAME/ADDRERROR 222Q)
(\PT.ADDRLOOKUP 223Q)
(\PT.ADDRRESPONSE 224Q)
(\PT.PRINTERSTATUS 200Q)
(\PT.STATUSRESPONSE 201Q)
(\PT.PRINTERCAPABILITY 202Q)
(\PT.CAPABILITYRESPONSE 203Q)
(\PT.PRINTJOBSTATUS 204Q)
(\PT.PRINTJOBRESPONSE 205Q)))
(DECLARE: EVAL@COMPILE
(RPAQQ \PT.ECHOME 1)
(RPAQQ \PT.IAMECHO 2)
(RPAQQ \PT.IAMBADECHO 3)
(RPAQQ \PT.ERROR 4)
(RPAQQ \PT.RFC 10Q)
(RPAQQ \PT.ABORT 11Q)
(RPAQQ \PT.END 12Q)
(RPAQQ \PT.ENDREPLY 13Q)
(RPAQQ \PT.DATA 20Q)
(RPAQQ \PT.ADATA 21Q)
(RPAQQ \PT.ACK 22Q)
(RPAQQ \PT.MARK 23Q)
(RPAQQ \PT.INTERRUPT 24Q)
(RPAQQ \PT.INTERRUPTREPLY 25Q)
(RPAQQ \PT.AMARK 26Q)
(RPAQQ \PT.GATEWAYREQUEST 200Q)
(RPAQQ \PT.GATEWAYRESPONSE 201Q)
(RPAQQ \PT.ALTOTIMEREQUEST 206Q)
(RPAQQ \PT.ALTOTIMERESPONSE 207Q)
(RPAQQ \PT.MSGCHECK 210Q)
(RPAQQ \PT.NEWMAIL 211Q)
(RPAQQ \PT.NONEWMAIL 212Q)
(RPAQQ \PT.NOMAILBOX 213Q)
(RPAQQ \PT.LAURELCHECK 214Q)
(RPAQQ \PT.NAMELOOKUP 220Q)
(RPAQQ \PT.NAMERESPONSE 221Q)
(RPAQQ \PT.NAME/ADDRERROR 222Q)
(RPAQQ \PT.ADDRLOOKUP 223Q)
(RPAQQ \PT.ADDRRESPONSE 224Q)
(RPAQQ \PT.PRINTERSTATUS 200Q)
(RPAQQ \PT.STATUSRESPONSE 201Q)
(RPAQQ \PT.PRINTERCAPABILITY 202Q)
(RPAQQ \PT.CAPABILITYRESPONSE 203Q)
(RPAQQ \PT.PRINTJOBSTATUS 204Q)
(RPAQQ \PT.PRINTJOBRESPONSE 205Q)
(CONSTANTS (\PT.ECHOME 1)
(\PT.IAMECHO 2)
(\PT.IAMBADECHO 3)
(\PT.ERROR 4)
(\PT.RFC 10Q)
(\PT.ABORT 11Q)
(\PT.END 12Q)
(\PT.ENDREPLY 13Q)
(\PT.DATA 20Q)
(\PT.ADATA 21Q)
(\PT.ACK 22Q)
(\PT.MARK 23Q)
(\PT.INTERRUPT 24Q)
(\PT.INTERRUPTREPLY 25Q)
(\PT.AMARK 26Q)
(\PT.GATEWAYREQUEST 200Q)
(\PT.GATEWAYRESPONSE 201Q)
(\PT.ALTOTIMEREQUEST 206Q)
(\PT.ALTOTIMERESPONSE 207Q)
(\PT.MSGCHECK 210Q)
(\PT.NEWMAIL 211Q)
(\PT.NONEWMAIL 212Q)
(\PT.NOMAILBOX 213Q)
(\PT.LAURELCHECK 214Q)
(\PT.NAMELOOKUP 220Q)
(\PT.NAMERESPONSE 221Q)
(\PT.NAME/ADDRERROR 222Q)
(\PT.ADDRLOOKUP 223Q)
(\PT.ADDRRESPONSE 224Q)
(\PT.PRINTERSTATUS 200Q)
(\PT.STATUSRESPONSE 201Q)
(\PT.PRINTERCAPABILITY 202Q)
(\PT.CAPABILITYRESPONSE 203Q)
(\PT.PRINTJOBSTATUS 204Q)
(\PT.PRINTJOBRESPONSE 205Q))
)
(RPAQ? PUPTYPES RAWPUPTYPES)
(RPAQQ WELLKNOWNPUPSOCKETS ((\PUPSOCKET.TELNET 1)
(\PUPSOCKET.ROUTING 2)
(\PUPSOCKET.FTP 3)
(\PUPSOCKET.MISCSERVICES 4)
(\PUPSOCKET.ECHO 5)
(\PUPSOCKET.EFTP 20Q)
(\PUPSOCKET.PRINTERSTATUS 21Q)
(\PUPSOCKET.LEAF 43Q)))
(DECLARE: EVAL@COMPILE
(RPAQQ \PUPSOCKET.TELNET 1)
(RPAQQ \PUPSOCKET.ROUTING 2)
(RPAQQ \PUPSOCKET.FTP 3)
(RPAQQ \PUPSOCKET.MISCSERVICES 4)
(RPAQQ \PUPSOCKET.ECHO 5)
(RPAQQ \PUPSOCKET.EFTP 20Q)
(RPAQQ \PUPSOCKET.PRINTERSTATUS 21Q)
(RPAQQ \PUPSOCKET.LEAF 43Q)
(CONSTANTS (\PUPSOCKET.TELNET 1)
(\PUPSOCKET.ROUTING 2)
(\PUPSOCKET.FTP 3)
(\PUPSOCKET.MISCSERVICES 4)
(\PUPSOCKET.ECHO 5)
(\PUPSOCKET.EFTP 20Q)
(\PUPSOCKET.PRINTERSTATUS 21Q)
(\PUPSOCKET.LEAF 43Q))
)
(* END EXPORTED DEFINITIONS)
(RPAQQ PUPCONSTANTS ((\PUPHEADERLEN 24Q)
(\NetMask 177400Q)
(\HILOCALSOCKET 1)
(\PORTIDLEN 3)))
(DECLARE: EVAL@COMPILE
(RPAQQ \PUPHEADERLEN 24Q)
(RPAQQ \NetMask 177400Q)
(RPAQQ \HILOCALSOCKET 1)
(RPAQQ \PORTIDLEN 3)
(CONSTANTS (\PUPHEADERLEN 24Q)
(\NetMask 177400Q)
(\HILOCALSOCKET 1)
(\PORTIDLEN 3))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS PUPTRACING MACRO [NIL (AND PUPTRACEFLG (NEQ PUPTRACEFLG (QUOTE %.])
(PUTPROPS PUPDEBUGGING MACRO [(X . Y)
(COND
((PUPTRACING)
(printout PUPTRACEFILE X . Y])
(PUTPROPS TESTSOC MACRO [OPENLAMBDA (SOCKET)
(COND
((FMEMB SOCKET \PUPSOCKETS)
SOCKET)
(T (ERROR "Not an Open Socket" SOCKET])
)
(ADDTOVAR PUPPRINTMACROS (210Q CHARS)
(214Q CHARS)
(211Q CHARS)
(213Q CHARS)
(201Q WORDS 2 CHARS 24Q ...)
(30Q CHARS))
[DECLARE: EVAL@COMPILE
(BLOCKRECORD TIMEPUPCONTENTS ((TIMEPUPVALUEHI WORD)
(TIMEPUPVALUELO WORD)
(TIMEPUPEASTP FLAG)
(TIMEPUPHOURS BITS 7)
(TIMEPUPMINUTES BITS 10Q)
(TIMEPUPBEGINDST WORD)
(TIMEPUPENDDST WORD)) (* format of alto time response)
)
]
)
(RPAQ? \ETHERPORTS (LIST (HARRAY 24Q)))
(RPAQ? \ETHERTIMEOUT 3720Q)
(RPAQ? \MAXETHERTRIES 4)
(RPAQ? \PUPCOUNTER 0)
(* echo utilities)
(DEFINEQ
(PUP.ECHOSERVER
[LAMBDA (ECHOWINDOW FLG) (* bvm: " 7-AUG-83 01:11")
(RESETLST (PROG ((SOC (OPENPUPSOCKET \PUPSOCKET.ECHO T))
PUP EVENT ISGOOD)
(RESETSAVE NIL (LIST (QUOTE CLOSEPUPSOCKET)
SOC))
(OR FLG (SETQ FLG (QUOTE PEEK)))
(SETQ EVENT (fetch PUPSOCEVENT of SOC))
LP (COND
((SETQ PUP (GETPUP SOC))
(SETQ ISGOOD (EQ (fetch PUPTYPE of PUP)
\PT.ECHOME))
[COND
(ECHOWINDOW (SELECTQ FLG
(NIL)
(PEEK (PRIN1 (COND
(ISGOOD (QUOTE !))
(T (QUOTE ?)))
ECHOWINDOW))
(PRINTPUP PUP NIL ECHOWINDOW]
(COND
(ISGOOD (replace TYPEWORD of PUP with \PT.IAMECHO)
(SWAPPUPPORTS PUP)
(replace EPREQUEUE of PUP with (QUOTE FREE))
(SENDPUP SOC PUP))
(T (RELEASE.PUP PUP)))
(BLOCK))
(T (AWAIT.EVENT EVENT)))
(GO LP])
(PUP.ECHOUSER
[LAMBDA (HOST ECHOSTREAM INTERVAL NTIMES) (* bvm: " 7-AUG-83 01:42")
(RESETLST (PROG ((OPUP (ALLOCATE.PUP))
(PORT (ETHERPORT HOST))
(SOC (OPENPUPSOCKET))
(TIMER (SETUPTIMER 0))
IPUP EVENT ECHOPUPLENGTH I)
(RESETSAVE NIL (LIST (QUOTE CLOSEPUPSOCKET)
SOC))
(OR INTERVAL (SETQ INTERVAL 1750Q))
(OR NTIMES (SETQ NTIMES 1750Q))
(SETQ ECHOSTREAM (GETSTREAM (OR ECHOSTREAM T)
(QUOTE OUTPUT)))
(SETUPPUP OPUP PORT \PUPSOCKET.ECHO \PT.ECHOME NIL SOC T)
(PUTPUPWORD OPUP 0 (SETQ I 1))
(add (fetch PUPLENGTH of OPUP)
BYTESPERWORD)
(PUTPUPSTRING OPUP "Random string for echo")
(SETQ ECHOPUPLENGTH (fetch PUPLENGTH of OPUP))
(SETQ EVENT (fetch PUPSOCEVENT of SOC))
LP (SENDPUP SOC OPUP)
(PRIN1 (QUOTE !)
ECHOSTREAM)
(SETUPTIMER INTERVAL TIMER)
(do (COND
[(SETQ IPUP (GETPUP SOC))
(COND
((PROG1 (SELECTC (fetch PUPTYPE of IPUP)
(\PT.IAMBADECHO (PRIN1 (QUOTE x)
ECHOSTREAM))
(\PT.IAMECHO (COND
((NOT (AND (EQ (fetch PUPIDHI
of IPUP)
(fetch PUPIDHI
of OPUP))
(EQ (fetch PUPIDLO
of IPUP)
(fetch PUPIDLO
of OPUP))
(EQ (fetch PUPLENGTH
of IPUP)
ECHOPUPLENGTH)))
(PRIN1 (QUOTE ?)
ECHOSTREAM)
NIL)
((IEQP (GETPUPWORD IPUP 0)
I)
(PRIN1 (QUOTE +)
ECHOSTREAM))
(T (PRIN1 "(late)" ECHOSTREAM)
NIL)))
(\PT.ERROR (PRINTERRORPUP IPUP ECHOSTREAM)
NIL)
(PROGN (PRIN1 (QUOTE ?)
ECHOSTREAM)
NIL))
(RELEASE.PUP IPUP))
(RETURN]
(T (AWAIT.EVENT EVENT TIMER T)))
repeatuntil (TIMEREXPIRED? TIMER)
finally (COND
((fetch EPTRANSMITTING of OPUP)
(PRIN1 "[not yet transmitted; maybe transmitter is off]"
ECHOSTREAM)))
(PRIN1 (QUOTE %.)
ECHOSTREAM))
(COND
((IGREATERP (OR (EQ NTIMES T)
(add NTIMES -1))
0)
(PUTPUPWORD OPUP 0 (add I 1))
(GO LP])
)
(* Peeking)
(DEFINEQ
(\PEEKPUP
[LAMBDA (HOST FILE) (* bvm: "11-AUG-83 14:44")
(PROG (NETHOST L)
[COND
((NULL HOST)
(SELECTQ (fetch NETTYPE of \LOCALNDBS)
(3 (\PUTBASE (EMADDRESS \ETHERHOSTLOC)
0
(fetch NDBPUPHOST# of \LOCALNDBS)))
(12Q)
NIL)
(RPTQ 24Q (BLOCK)) (* empty the pipe)
(SETQ \PEEKPUPNUMBER))
(T [COND
((EQ HOST T)
(SETQ \PEEKPUPNUMBER T))
(T [SETQ L (for H inside HOST collect (PROGN (SETQ NETHOST (CAR (ETHERPORT H)))
(COND
((AND (NEQ (fetch PUPNET#
of NETHOST)
0)
(NEQ (fetch PUPNET#
of NETHOST)
(\LOCALPUPNETNUMBER)))
(ERROR H
"not a host on local network"))
(T (fetch PUPHOST# of NETHOST]
(SETQ \PEEKPUPNUMBER (COND
((CDR L)
L)
(T (CAR L] (* Now make us promiscuous)
(SELECTQ (fetch NETTYPE of \LOCALNDBS)
(3 (\PUTBASE (EMADDRESS \ETHERHOSTLOC)
0 0))
(12Q)
NIL)
[COND
(FILE (SETQ PUPTRACEFILE (OR (OPENP FILE (QUOTE OUTPUT))
(OPENFILE FILE (QUOTE OUTPUT]
(OR PUPTRACEFLG (SETQ PUPTRACEFLG T]
(RETURN \PEEKPUPNUMBER])
(\MAYBEPEEKPUP
[LAMBDA (PUP) (* bvm: "11-AUG-83 14:18")
[COND
((AND \PEEKPUPNUMBER PUPTRACEFLG)
(PROG (DIRECTION)
(COND
([OR (EQ \PEEKPUPNUMBER T)
(ZEROP (fetch PUPDESTHOST of PUP))
(for HOST inside \PEEKPUPNUMBER thereis (OR [COND
((EQ (fetch PUPSOURCEHOST
of PUP)
HOST)
(SETQ DIRECTION (QUOTE PUT]
(COND
((EQ (fetch PUPDESTHOST
of PUP)
HOST)
(SETQ DIRECTION (QUOTE GET]
(PRINTPUP PUP DIRECTION PUPTRACEFILE NIL T]
(\RELEASE.ETHERPACKET PUP])
)
(RPAQ? \PEEKPUPNUMBER )
(DECLARE: EVAL@COMPILE DONTCOPY
(DECLARE: EVAL@COMPILE
(RPAQQ \ETHERHOSTLOC 610Q)
(CONSTANTS \ETHERHOSTLOC)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \PEEKPUPNUMBER)
)
)
(* Debugging assistance)
(DEFINEQ
(PRINTPUP
[LAMBDA (PACKET CALLER FILE PRE.NOTE DOFILTER) (* bvm: "18-JUN-83 20:44")
(\DTEST PACKET (QUOTE ETHERPACKET))
(OR FILE (SETQ FILE PUPTRACEFILE))
(PROG ((TYPE (fetch PUPTYPE of PACKET))
MACRO LENGTH)
(COND
([AND DOFILTER (COND
(PUPONLYTYPES (NOT (FMEMB TYPE PUPONLYTYPES)))
(PUPIGNORETYPES (FMEMB TYPE PUPIGNORETYPES]
(PRIN1 (SELECTQ CALLER
[(GET RAWGET)
(COND
((ZEROP (fetch PUPDESTHOST of PACKET))
(* Broadcast)
(QUOTE *))
(T (QUOTE +]
((PUT RAWPUT)
(QUOTE !))
(QUOTE ?))
PUPTRACEFILE)
(RETURN)))
(AND PRE.NOTE (PRIN1 PRE.NOTE FILE))
(PRINTPUPROUTE PACKET CALLER FILE)
[COND
((SETQ MACRO (CDR (FASSOC TYPE PUPPRINTMACROS)))
(COND
((NLISTP MACRO)
(RETURN (RESETFORM (OUTPUT FILE)
(APPLY* MACRO PACKET FILE]
(printout FILE "Length = " .P2 (SETQ LENGTH (fetch PUPLENGTH of PACKET))
" bytes" " (header + " .P2 (IDIFFERENCE LENGTH \PUPOVLEN)
")" T "Type = ")
(PRINTCONSTANT TYPE PUPTYPES FILE "\PT.")
(printout FILE ", ID = " .P2 (fetch PUPID of PACKET)
T)
(COND
((IGREATERP LENGTH \PUPOVLEN) (* Tells how to print data. Consists of elements in
pairs: a byte offset followed by a type)
(PRIN1 "Contents: " FILE)
(PRINTPACKETDATA (fetch PUPCONTENTS of PACKET)
0
(OR MACRO (QUOTE (BYTES 14Q ...)))
(IDIFFERENCE LENGTH \PUPOVLEN)
FILE)))
(TERPRI FILE))
PACKET])
(PRINTPUPROUTE
[LAMBDA (PACKET CALLER FILE) (* bvm: "10-AUG-83 11:41")
(TAB 0 0 FILE)
(AND CALLER (printout FILE CALLER ": "))
(PROG ((CONTROL (fetch PUPTCONTROL of PACKET))
CSECS)
(printout FILE "From " (PORTSTRING (fetch PUPSOURCE of PACKET)
(fetch PUPSOURCESOCKET of PACKET))
" to "
(PORTSTRING (fetch PUPDEST of PACKET)
(fetch PUPDESTSOCKET of PACKET)))
[COND
((NEQ CONTROL 0)
(printout FILE ", Hops = " .P2 (LRSH CONTROL 4]
(COND
(PUPTRACETIME (printout FILE " [" .I4 (IQUOTIENT (SETQ CSECS (\CENTICLOCK))
144Q)
(QUOTE %.)
.I2..T
(IREMAINDER CSECS 144Q)
"]")))
(TERPRI FILE])
(PRINTPUPDATA
[LAMBDA (PUP MACRO OFFSET FILE) (* bvm: "26-MAY-83 12:13")
(PRINTPACKETDATA (fetch PUPCONTENTS of PUP)
OFFSET MACRO (IDIFFERENCE (fetch PUPLENGTH of PUP)
\PUPOVLEN)
FILE])
(PRINTERRORPUP
[LAMBDA (PUP FILE) (* bvm: "12-FEB-83 16:24")
(printout FILE "From " (PORTSTRING (fetch PUPSOURCE of PUP))
": [Error " .P2 (fetch ERRORPUPCODE of PUP)
"] "
(GETPUPSTRING PUP 30Q)
T])
(PUPTRACE
[LAMBDA (FLG REGION) (* bvm: "11-JUL-83 17:19")
(COND
((NULL FLG)
(COND
((ACTIVEWP PUPTRACEFILE)
(CLOSEW PUPTRACEFILE)))
(SETQ PUPTRACEFILE T)
(SETQ PUPTRACEFLG))
(T (SETQ PUPTRACEFILE (CREATEW REGION "Pup traffic"))
[WINDOWPROP PUPTRACEFILE (QUOTE BUTTONEVENTFN)
(FUNCTION (LAMBDA (WINDOW)
(COND
((LASTMOUSESTATE (NOT UP))
(\CHANGE.ETHER.TRACING WINDOW (QUOTE PUPTRACEFLG]
[WINDOWPROP PUPTRACEFILE (QUOTE CLOSEFN)
(FUNCTION (LAMBDA (WINDOW)
(COND
((EQ WINDOW PUPTRACEFILE)
(SETQ PUPTRACEFLG)
(SETQ PUPTRACEFILE T]
(DSPFONT (FONTCREATE (QUOTE GACHA)
10Q)
PUPTRACEFILE)
(SETQ PUPTRACEFLG FLG)
(DSPSCROLL T PUPTRACEFILE)
PUPTRACEFILE])
(\CHANGE.ETHER.TRACING
[LAMBDA (WINDOW FLGNAME) (* bvm: "11-JUL-83 17:14")
(printout WINDOW .TAB0 0 "[Tracing " (COND
[(LASTMOUSESTATE LEFT)
(SELECTQ (EVALV FLGNAME)
(NIL (SET FLGNAME T)
"On]")
(T (SET FLGNAME (QUOTE PEEK))
"Brief]")
(COND
((OR (NOT \RAWTRACING)
(EQ (EVALV FLGNAME)
(QUOTE RAW)))
(SET FLGNAME NIL)
"Off]")
(T (SET FLGNAME (QUOTE RAW))
"only Raw]"]
(T (COND
(\RAWTRACING (SETQ \RAWTRACING NIL)
"Raw Off]")
(T (SETQ \RAWTRACING T)
"Raw On]"])
(PRINTCONSTANT
[LAMBDA (VAR CONSTANTLIST FILE PREFIX) (* bvm: " 4-APR-83 16:11")
(PRIN2 VAR FILE)
(COND
((LISTP CONSTANTLIST)
(PRIN1 " (" FILE)
(PRIN1 (OR [for X in CONSTANTLIST when (EQ (CADR X)
VAR)
do (RETURN (COND
[(AND PREFIX (STRPOS PREFIX (CAR X)
1 NIL T))
(SUBSTRING (CAR X)
(ADD1 (NCHARS PREFIX]
(T (CAR X]
(QUOTE ?))
FILE)
(PRIN1 ")" FILE])
)
(RPAQ? PUPTRACEFLG )
(RPAQ? PUPTRACEFILE T)
(RPAQ? PUPTRACETIME )
(RPAQ? NILPUPTRACEFLG )
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS PUPTRACETIME)
)
(ADDTOVAR PUPPRINTMACROS )
(ADDTOVAR PUPONLYTYPES )
(ADDTOVAR PUPIGNORETYPES )
(ADDTOVAR PUPPRINTMACROS (4 . PRINTERRORPUP)
(220Q CHARS)
(221Q REPEAT BYTES -2 WORDS -4)
(223Q BYTES -2 WORDS)
(224Q CHARS))
(DEFINEQ
(PORTSTRING
[LAMBDA (NETHOST SOCKET) (* bvm: "21-JUL-81 12:11")
[COND
((LISTP NETHOST)
(SETQ SOCKET (CDR NETHOST))
(COND
((ZEROP SOCKET)
(SETQ SOCKET NIL)))
(SETQ NETHOST (CAR NETHOST]
(CONCAT (OCTALSTRING (LRSH NETHOST 10Q))
(QUOTE #)
(OCTALSTRING (LOGAND NETHOST 377Q))
(QUOTE #)
(COND
(SOCKET (OCTALSTRING SOCKET))
(T ""])
(OCTALSTRING
[LAMBDA (N) (* bvm: "21-JUL-81 12:16")
(GLOBALRESOURCE (\NUMSTR \NUMSTR1)
(CONCAT (\CONVERTNUMBER N 10Q NIL NIL \NUMSTR \NUMSTR1)))])
)
(DEFINEQ
(\CENTICLOCK
[LAMBDA NIL (* bvm: " 8-JUN-83 14:48")
(PROG ((CLK (\RCLK \CENTICLOCKBOX)))
(RETURN (IQUOTIENT (COND
((ILESSP CLK 0)
(\BOXIPLUS CLK MIN.INTEGER))
(T CLK))
(OR \CENTICLOCKFACTOR (SETQ \CENTICLOCKFACTOR (ITIMES 12Q
\RCLKMILLISECOND])
)
(RPAQQ \CENTICLOCKFACTOR NIL)
(RPAQ \CENTICLOCKBOX (NCREATE (QUOTE FIXP)))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \CENTICLOCKFACTOR \CENTICLOCKBOX)
)
(ADDTOVAR \SYSTEMCACHEVARS \CENTICLOCKFACTOR)
(* Mail check)
(DEFINEQ
(MAILWATCHER
[LAMBDA NIL (* bvm: "20-JAN-83 12:36")
(* * Something to put on PROMPTCHARFORMS to periodically check your mail. Checks mailbox of current USERNAME.
If username has property MAILBOX value host or (host laurelflag), those values are used; otherwise defaults to
MAXC2)
(COND
((IGREATERP (add MAILEVENTCOUNT 1)
12Q)
(SETQ MAILEVENTCOUNT 0)
(PROG (NEWMAIL? INFO)
(COND
((OR (ZEROP MAILTIME)
(IGREATERP (CLOCKDIFFERENCE MAILTIME)
MAILINTERVAL)) (* First case is initialization)
(SETQ MAILTIME (CLOCK 0))
(SETQ INFO (GETPROP USERNAME (QUOTE MAILBOX)))
[SETQ NEWMAIL? (MAILCHECK USERNAME (AND INFO (OR (CAR (LISTP INFO))
INFO))
(CADR (LISTP INFO]
(COND
([AND NEWMAIL? (NEQ NEWMAIL? (QUOTE ?))
(NOT (EQUAL NEWMAIL? (GETPROP USERNAME (QUOTE LASTMAIL]
(printout T "[Mail waiting -- " NEWMAIL? "]" T)
(PUT USERNAME (QUOTE LASTMAIL)
NEWMAIL?])
(MAILCHECK
[LAMBDA (USER HOST LAURELFLG) (* bvm: "17-FEB-83 16:26")
(* * Does a mail check for USER on machine HOST, returning NIL or a string describing the new mail.
LAURELFLG is true for Laurel-style mailcheck.)
(PROG ((HOSTPORT (ETHERPORT (OR HOST (QUOTE MAXC))
T))
(SOC (\GETMISCSOCKET))
(OPUP (ALLOCATE.PUP))
RESULT IPUP)
(OR USER (SETQ USER USERNAME))
(SETUPPUP OPUP HOSTPORT \PUPSOCKET.MISCSERVICES (COND
(LAURELFLG \PT.LAURELCHECK)
(T \PT.MSGCHECK))
NIL SOC T)
(PUTPUPSTRING OPUP USER)
(to \MAXETHERTRIES when (SETQ IPUP (EXCHANGEPUPS SOC OPUP NIL T))
do (SELECTC (fetch PUPTYPE of IPUP)
[\PT.NEWMAIL (RETURN (SETQ RESULT (GETPUPSTRING IPUP]
(\PT.NONEWMAIL (RETURN))
(\PT.NOMAILBOX (printout T (GETPUPSTRING IPUP)
T)
(RETURN))
[\PT.ERROR (AND (PUPTRACING)
(PRINTERRORPUP IPUP PUPTRACEFILE))
(RETURN (SETQ RESULT (QUOTE ?]
NIL)
finally (PUPDEBUGGING "Mail check timed out" T)
(SETQ RESULT (QUOTE ?)))
(AND IPUP (RELEASE.PUP IPUP))
(RELEASE.PUP OPUP)
(RETURN RESULT])
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS MAILINTERVAL MAILTIME MAILEVENTCOUNT USERNAME)
)
(DECLARE: EVAL@LOADWHEN (SELECTQ (SYSTEMTYPE)
((ALTO D)
T)
NIL)
(RPAQ? MAILINTERVAL 1111740Q)
(RPAQ? MAILTIME 0)
(RPAQ? MAILEVENTCOUNT 0)
)
(* EFTP)
(DEFINEQ
(EFTP
[LAMBDA (HOST FILE PRINTERFLG #SIDES) (* bvm: "23-MAR-83 11:42")
(RESETLST (PROG ((HOSTPORT (ETHERPORT HOST T))
(TIMEOUT \EFTP.TIMEOUT)
(CHECKSTATUS PRINTERFLG)
(OPUP (ALLOCATE.PUP))
STREAM DATA RESULT ENDING NAMESTRING NC HOSTNAME STATUS NEWSTATUS CURPAGE# ID
SOC LASTPAGE# LASTPAGELENGTH PRESSDATAPAGE# ABORTER CAPABILITIES IPUP)
[SETQ STREAM (OR (\GETOFD FILE (QUOTE INPUT)
T)
(\GETOFD (SETQ FILE (INPUT (INFILE FILE)))
(QUOTE INPUT]
(RESETSAVE NIL (LIST (QUOTE CLOSEF)
STREAM))
(SETQ LASTPAGELENGTH (fetch (STREAM EOFFSET) of STREAM))
(SETQ LASTPAGE# (fetch (STREAM EPAGE) of STREAM))
[COND
(PRINTERFLG (COND
((NEQ LASTPAGELENGTH 0)
(HELP "Press file with non-integral number of pages?" FILE)))
(* Final page of press file holds special printing
parameters)
(SETQ PRESSDATAPAGE# (SUB1 LASTPAGE#]
[RESETSAVE NIL (LIST (QUOTE CLOSEPUPSOCKET)
(SETQ SOC (OPENPUPSOCKET]
(SETUPPUP OPUP HOSTPORT \PUPSOCKET.EFTP \EFTP.DATA -1 SOC T)
(RESETSAVE NIL (SETQ ABORTER (LIST (QUOTE \ABORT.EFTP)
SOC OPUP)))
RESTART
(COND
((AND CURPAGE# (PUPTRACING))
(PRIN1 " (restarting)" PUPTRACEFILE)))
(SETQ ID 0)
(SETQ CURPAGE# 0)
(replace PUPTYPE of OPUP with \EFTP.DATA)
[COND
((FIXP #SIDES)
[while (NOT CAPABILITIES)
do [while (NEQ (CAR STATUS)
\PS.IDLE)
do (* Printer capability request only honored while printer
is idle)
(COND
((SETQ NEWSTATUS (PRINTERSTATUS HOSTPORT))
(COND
((NOT (EQUAL NEWSTATUS STATUS))
(printout PROMPTWINDOW (CDR (SETQ STATUS NEWSTATUS))
.TAB0 0]
(SETQ CHECKSTATUS NIL)
(COND
((NOT (SETQ CAPABILITIES (PRINTERCAPABILITY HOSTPORT)))
(printout PROMPTWINDOW "[No response from " HOST "]
")
(SETQ STATUS]
(COND
([AND (EQ (CADR (ASSOC (QUOTE PRINT-INSTANCE)
CAPABILITIES))
(QUOTE TRUE))
(OR (EQ #SIDES 1)
(EQ (CADR (ASSOC (QUOTE DUPLEX)
CAPABILITIES))
(QUOTE TRUE] (* Prepare capabilities)
(SETQ DATA (fetch PUPCONTENTS of OPUP))
(\PUTBASE DATA 0 \SPRUCEPWD1)
(\PUTBASE DATA 1 \SPRUCEPWD2)
(replace PUPLENGTH of OPUP
with (IPLUS (\STOREPLIST [LIST (LIST (QUOTE DUPLEX)
(COND
((EQ #SIDES 1)
(QUOTE FALSE))
(T (QUOTE TRUE]
(\ADDBASE DATA 2))
\PUPOVLEN 4)) (* Length of pup = length of plist plus overhead plus
two code words)
(SETQ CURPAGE# -1)
(GO SENDPAGE))
(T (printout T HOST " does not support #sides specification" T]
NEWPAGE
(COND
[(EQ CURPAGE# LASTPAGE#)
(COND
((ZEROP LASTPAGELENGTH)
(SETQ ENDING T))
(T (replace PUPLENGTH of OPUP with (IPLUS \PUPOVLEN LASTPAGELENGTH]
((ILESSP CURPAGE# LASTPAGE#)
(replace PUPLENGTH of OPUP with (IPLUS \PUPOVLEN 1000Q)))
(T (SETQ ENDING T)))
(COND
(ENDING (replace PUPTYPE of OPUP with \EFTP.END)
(replace PUPLENGTH of OPUP with \PUPOVLEN))
((NEQ (fetch PUPID of OPUP)
ID) (* Read CURPAGE#'th page of file into a buffer.
Make that buffer be pup contents)
(\MOVEWORDS (\MAPPAGE CURPAGE# STREAM)
0
(SETQ DATA (fetch PUPCONTENTS of OPUP))
0 WORDSPERPAGE)
[COND
((EQ CURPAGE# PRESSDATAPAGE#) (* Fill in print parameters for this run)
(\PUTBASE DATA 11Q (OR (FIXP PRINTERFLG)
1)) (* Number of copies)
(SETQ NAMESTRING (USERNAME NIL NIL T))
(SetBcplString (\ADDBASE DATA 232Q)
(COND
((IGREATERP (SETQ NC (NCHARS NAMESTRING))
37Q)
(SUBSTRING NAMESTRING 1 37Q))
((ILESSP [IPLUS NC (NCHARS (SETQ HOSTNAME
(ETHERHOSTNAME NIL T]
44Q)
(CONCAT NAMESTRING " on " HOSTNAME))
(T NAMESTRING]
(* Set "printed by")
))
SENDPAGE
(replace PUPID of OPUP with ID)
[to \MAXETHERTRIES
do (COND
(CHECKSTATUS (COND
((AND (SETQ NEWSTATUS (PRINTERSTATUS HOSTPORT))
(NOT (EQUAL NEWSTATUS STATUS)))
(printout PROMPTWINDOW (CDR (SETQ STATUS NEWSTATUS))
.TAB0 0)
(SELECTC (CAR STATUS)
((LIST \PS.BUSY \PS.NOTSPOOLING)
(* It may be a while. Maybe I should abort in case of
NOT SPOOLING, but by convention we just wait)
(SETQ TIMEOUT \EFTP.LONGTIMEOUT))
NIL)))
(SETQ CHECKSTATUS NIL)))
[COND
((SETQ IPUP (EXCHANGEPUPS SOC OPUP NIL NIL TIMEOUT))
(SELECTC (fetch PUPTYPE of IPUP)
[\EFTP.ACK (COND
((EQ (PROG1 (fetch PUPID of IPUP)
(RELEASE.PUP IPUP))
ID)
(* Packet acknowledged, proceed normally)
(add ID 1)
(add CURPAGE# 1)
(COND
(ENDING
(* Acknowledged the END signal.
We now echo the END one bigger, so that the receiver can
stop dallying)
(replace PUPID of OPUP with ID)
(SENDPUP SOC OPUP)
(GO DONE))
(T (GO NEWPAGE]
(\EFTP.ABORT (COND
((PUPTRACING)
(PRIN1 "[abort]" PUPTRACEFILE)))
(SELECTC (PROG1 (\GETPUPWORD IPUP 0)
(* EFTP abort code)
(RELEASE.PUP IPUP))
(\EABORT.RECEIVER
(* it didn't like the file for some reason)
(SETQ RESULT
(CONS (QUOTE REJECT)
(GETPUPSTRING
IPUP 2)))
(GO ABORT))
(\EABORT.BUSY (DISMISS \EFTP.LONGTIMEOUT)
)
(\EABORT.SYNCH
(* Out of synch--start over))
NIL)
(GO RESTART))
(RELEASE.PUP IPUP]
(COND
((AND PRINTERFLG (ZEROP ID)) (* What's going on? Check status again)
(SETQ CHECKSTATUS T)))
finally (COND
(ENDING (* Well , we never got the end acknowledged, but it
probably worked)
(GO DONE))
(T (printout PROMPTWINDOW "No response from " HOST T)
(GO RESTART]
DONE (* succeeded, flush abort code)
(FRPLACA ABORTER (QUOTE *))
(SETQ RESULT (fetch FULLNAME of STREAM))
ABORT
(RETURN RESULT])
(\ABORT.EFTP
[LAMBDA (SOC PUP) (* bvm: " 3-NOV-82 11:17")
(* * Aborts the EFTP transfer in progress to SOC, using PUP for an output pup)
(replace PUPTYPE of PUP with \EFTP.ABORT)
(replace PUPLENGTH of PUP with (ADD1 \PUPOVLEN))
(\PUTBASE (fetch PUPCONTENTS of PUP)
0 \EABORT.SENDER)
(SENDPUP SOC PUP])
(PRINTERSTATUS
[LAMBDA (PRINTER) (* bvm: "14-FEB-83 10:49")
(* * Checks status of printer, returns a dotted pair (statuscode . string))
(PROG ((HOSTPORT (ETHERPORT PRINTER T))
(SOC (\GETMISCSOCKET))
(OPUP (ALLOCATE.PUP))
RESULT IPUP)
(SETUPPUP OPUP HOSTPORT \PUPSOCKET.PRINTERSTATUS \PT.PRINTERSTATUS NIL SOC)
(to \MAXETHERTRIES when (SETQ IPUP (EXCHANGEPUPS SOC OPUP NIL T))
do (SELECTC (fetch PUPTYPE of IPUP)
[\PT.STATUSRESPONSE (RETURN (SETQ RESULT
(CONS (\GETBASE (fetch PUPCONTENTS
of IPUP)
0)
(GETPUPSTRING IPUP 2]
(\PT.ERROR (AND (PUPTRACING)
(PRINTERRORPUP IPUP PUPTRACEFILE))
(RETURN))
NIL)
finally (PUPDEBUGGING "Printer status request timed out" T))
(AND IPUP (RELEASE.PUP IPUP))
(RETURN RESULT])
(PRINTERCAPABILITY
[LAMBDA (PRINTER) (* bvm: "14-FEB-83 10:49")
(* * Asks printer about its capabilities, returns property list)
(PROG ((HOSTPORT (ETHERPORT PRINTER T))
(SOC (\GETMISCSOCKET))
(OPUP (ALLOCATE.PUP))
RESULT IPUP)
(SETUPPUP OPUP HOSTPORT \PUPSOCKET.PRINTERSTATUS \PT.PRINTERCAPABILITY NIL SOC)
(to \MAXETHERTRIES when (SETQ IPUP (EXCHANGEPUPS SOC OPUP NIL T))
do (SELECTC (fetch PUPTYPE of IPUP)
[\PT.CAPABILITYRESPONSE (RETURN (SETQ RESULT (READPLIST (GETPUPSTRING IPUP]
(\PT.ERROR (AND (PUPTRACING)
(PRINTERRORPUP IPUP PUPTRACEFILE))
(RETURN))
NIL)
finally (PUPDEBUGGING "Printer capability request timed out" T))
(AND IPUP (RELEASE.PUP IPUP))
(RETURN RESULT])
)
(DECLARE: DONTCOPY
(RPAQQ EFTPPUPTYPES ((\EFTP.DATA 30Q)
(\EFTP.ACK 31Q)
(\EFTP.END 32Q)
(\EFTP.ABORT 33Q)))
(DECLARE: EVAL@COMPILE
(RPAQQ \EFTP.DATA 30Q)
(RPAQQ \EFTP.ACK 31Q)
(RPAQQ \EFTP.END 32Q)
(RPAQQ \EFTP.ABORT 33Q)
(CONSTANTS (\EFTP.DATA 30Q)
(\EFTP.ACK 31Q)
(\EFTP.END 32Q)
(\EFTP.ABORT 33Q))
)
(RPAQQ EFTPCONSTANTS ((\EABORT.SENDER 1)
(\EABORT.RECEIVER 2)
(\EABORT.BUSY 3)
(\EABORT.SYNCH 4)
(\EABORT.LONGWAIT 6)
(\EABORT.MEDWAIT 7)
(\EABORT.SUSPEND 10Q)
(\PS.NOTSPOOLING 1)
(\PS.IDLE 2)
(\PS.BUSY 3)
(\SPRUCEPWD1 125314Q)
(\SPRUCEPWD2 170377Q)))
(DECLARE: EVAL@COMPILE
(RPAQQ \EABORT.SENDER 1)
(RPAQQ \EABORT.RECEIVER 2)
(RPAQQ \EABORT.BUSY 3)
(RPAQQ \EABORT.SYNCH 4)
(RPAQQ \EABORT.LONGWAIT 6)
(RPAQQ \EABORT.MEDWAIT 7)
(RPAQQ \EABORT.SUSPEND 10Q)
(RPAQQ \PS.NOTSPOOLING 1)
(RPAQQ \PS.IDLE 2)
(RPAQQ \PS.BUSY 3)
(RPAQQ \SPRUCEPWD1 125314Q)
(RPAQQ \SPRUCEPWD2 170377Q)
(CONSTANTS (\EABORT.SENDER 1)
(\EABORT.RECEIVER 2)
(\EABORT.BUSY 3)
(\EABORT.SYNCH 4)
(\EABORT.LONGWAIT 6)
(\EABORT.MEDWAIT 7)
(\EABORT.SUSPEND 10Q)
(\PS.NOTSPOOLING 1)
(\PS.IDLE 2)
(\PS.BUSY 3)
(\SPRUCEPWD1 125314Q)
(\SPRUCEPWD2 170377Q))
)
(ADDTOVAR PUPTYPES (\EFTP.DATA 30Q)
(\EFTP.ACK 31Q)
(\EFTP.END 32Q)
(\EFTP.ABORT 33Q))
)
(RPAQ? \EFTP.TIMEOUT 11610Q)
(RPAQ? \EFTP.LONGTIMEOUT 35230Q)
(DECLARE: DONTEVAL@LOAD
(\PUPINIT)
)
(DECLARE: EVAL@COMPILE DONTCOPY
(FILESLOAD (LOADCOMP)
LLETHER)
)
(PUTPROPS PUP COPYRIGHT ("Xerox Corporation" 3676Q 3677Q))
(DECLARE: DONTCOPY
(FILEMAP (NIL (17351Q 37151Q (\STARTPUP 17363Q . 22545Q) (\FIND.LOCALPUPHOSTNUMBER 22547Q . 24756Q) (
\HANDLE.RAW.PUP 24760Q . 35133Q) (\FORWARD.PUP 35135Q . 36067Q) (\SETPUPCHECKSUM 36071Q . 37147Q)) (
43216Q 46125Q (\PUPERROR 43230Q . 46123Q)) (46126Q 62111Q (SETUPPUP 46140Q . 50336Q) (SWAPPUPPORTS
50340Q . 51124Q) (GETPUP 51126Q . 53211Q) (SENDPUP 53213Q . 56134Q) (EXCHANGEPUPS 56136Q . 57763Q) (
DISCARDPUPS 57765Q . 60567Q) (GETPUPWORD 60571Q . 61111Q) (\PUPINIT 61113Q . 62107Q)) (62431Q 105440Q
(ETHERHOSTNAME 62443Q . 66421Q) (ETHERHOSTNUMBER 66423Q . 66731Q) (ETHERPORT 66733Q . 71365Q) (
NETDAYTIME0 71367Q . 72703Q) (\PUP.SETTIME 72705Q . 75315Q) (\SETNEWTIME0 75317Q . 76221Q) (NETDATE
76223Q . 76521Q) (\LOOKUPPORT 76523Q . 101662Q) (\PARSE.PORTCONSTANT 101664Q . 104325Q) (\FIXLOCALNET
104327Q . 105436Q)) (105510Q 114532Q (CLEARPUP 105522Q . 107040Q) (PUTPUPWORD 107042Q . 107370Q) (
GETPUPBYTE 107372Q . 107713Q) (PUTPUPBYTE 107715Q . 110244Q) (GETPUPSTRING 110246Q . 110766Q) (
PUTPUPSTRING 110770Q . 111476Q) (READPLIST 111500Q . 113047Q) (\STOREPLIST 113051Q . 114530Q)) (
117464Q 137672Q (\PUPGATELISTENER 117476Q . 122132Q) (\HANDLE.PUP.ROUTING.INFO 122134Q . 126531Q) (
\ROUTE.PUP 126533Q . 131675Q) (\LOCATE.PUPNET 131677Q . 134535Q) (SORT.PUPHOSTS.BY.DISTANCE 134537Q .
136156Q) (\PUPNET.CLOSERP 136160Q . 137107Q) (PUPNET.DISTANCE 137111Q . 137670Q)) (144506Q 153072Q (
OPENPUPSOCKET 144520Q . 147726Q) (CLOSEPUPSOCKET 147730Q . 151311Q) (PUPSOCKETNUMBER 151313Q . 151543Q
) (PUPSOCKETFROMNUMBER 151545Q . 152164Q) (PUPSOCKETEVENT 152166Q . 152452Q) (\FLUSHPUPSOCQUEUE
152454Q . 153070Q)) (153073Q 153725Q (\GETMISCSOCKET 153105Q . 153723Q)) (173307Q 201763Q (
PUP.ECHOSERVER 173321Q . 175244Q) (PUP.ECHOUSER 175246Q . 201761Q)) (202010Q 206050Q (\PEEKPUP 202022Q
. 204575Q) (\MAYBEPEEKPUP 204577Q . 206046Q)) (206452Q 220422Q (PRINTPUP 206464Q . 212016Q) (
PRINTPUPROUTE 212020Q . 213520Q) (PRINTPUPDATA 213522Q . 214136Q) (PRINTERRORPUP 214140Q . 214623Q) (
PUPTRACE 214625Q . 216272Q) (\CHANGE.ETHER.TRACING 216274Q . 217457Q) (PRINTCONSTANT 217461Q . 220420Q
)) (221272Q 222527Q (PORTSTRING 221304Q . 222174Q) (OCTALSTRING 222176Q . 222525Q)) (222530Q 223314Q (
\CENTICLOCK 222542Q . 223312Q)) (223710Q 230375Q (MAILWATCHER 223722Q . 225776Q) (MAILCHECK 226000Q .
230373Q)) (231044Q 253731Q (EFTP 231056Q . 247333Q) (\ABORT.EFTP 247335Q . 250211Q) (PRINTERSTATUS
250213Q . 252134Q) (PRINTERCAPABILITY 252136Q . 253727Q)))))
STOP