(FILECREATED "15-Feb-85 22:31:06" {ERIS}<LISPCORE>SOURCES>PUP.;8 250660Q
changes to: (FNS \HANDLE.RAW.PUP \ROUTE.PUP)
previous date: "30-Jan-85 22:33:23" {ERIS}<LISPCORE>SOURCES>PUP.;7)
(* Copyright (c) 1982, 1983, 1984, 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT PUPCOMS)
(RPAQQ PUPCOMS ((E (RESETSAVE (RADIX 8)))
(COMS (* Low level pup)
(DECLARE: DONTCOPY (EXPORT (RECORDS PUP PUPADDRESS)
(MACROS \LOCALPUPADDRESS \LOCALPUPHOSTNUMBER
\LOCALPUPNETNUMBER))
(GLOBALVARS \LOCALPUPNETHOST \OLDPUPHOST#))
(FNS \STARTPUP ASSURE.PUP.READY \FIND.LOCALPUPHOSTNUMBER \PROMPT.FOR.PUP.NUMBER
\HANDLE.RAW.PUP \FORWARD.PUP \SETPUPCHECKSUM)
(INITVARS (\PUP.CHECKSUMFLG T)
(\MAX.EPKTS.ON.PUPSOCKET 16)
(\LOCALPUPNETHOST)
(\OLDPUPHOST# 0)))
(COMS (* Pup error stuff)
(DECLARE: DONTCOPY (EXPORT (RECORDS ERRORPUP)
(CONSTANTS * PUPERRORCODES))
(GLOBALVARS PUPERRORMESSAGES))
(VARS PUPERRORMESSAGES)
(FNS \PUPERROR))
(COMS (* Pup utilities)
(FNS SETUPPUP SWAPPUPPORTS GETPUP SENDPUP EXCHANGEPUPS DISCARDPUPS GETPUPWORD
\PUPINIT)
(FNS ETHERHOSTNAME ETHERHOSTNUMBER ETHERPORT BESTPUPADDRESS NETDAYTIME0
\PUP.SETTIME \SETNEWTIME0 \NET.SETTIME NETDATE \LOOKUPPORT
\PARSE.PORTCONSTANT \FIXLOCALNET)
(FNS PORTSTRING OCTALSTRING)
(INITVARS (\ETHERPORTS (HASHARRAY 20))
(\ETHERTIMEOUT 2000)
(\MAXETHERTRIES 4)
(\PUPCOUNTER 0))
(GLOBALVARS \ETHERPORTS \PUPCOUNTER))
(COMS (* Accessing a PUP's contents)
(FNS CLEARPUP PUTPUPWORD GETPUPBYTE PUTPUPBYTE GETPUPSTRING GETPUPSTREAM
PUTPUPSTRING READPLIST \STOREPLIST)
(MACROS GETPUPWORD PUTPUPWORD GETPUPBYTE PUTPUPBYTE))
(COMS (FNS \CANONICAL.HOSTNAME CANONICAL.HOSTNAME)
(ADDVARS (\HOSTNAMES)
(\SYSTEMCACHEVARS \HOSTNAMES))
(GLOBALVARS \HOSTNAMES))
[COMS (* PUP allocation)
(EXPORT (MACROS BINDPUPS)
(PROP INFO BINDPUPS)
(ALISTS (PRETTYPRINTMACROS BINDPUPS]
(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 3000)
(\PUP.READY)
(\PUP.READY.EVENT (CREATE.EVENT "Pup Ready"))
(\PUP.READY.LOCK (CREATE.MONITORLOCK "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
\PUP.READY.LOCK)))
(COMS (* Sockets)
(DECLARE: DONTCOPY (RECORDS PUPSOCKET)
(MACROS \PUPSOCKET.FROM#)
(GLOBALVARS \PUPSOCKETS.TABLE \MAX.EPKTS.ON.PUPSOCKET
\PUP.CHECKSUMFLG))
(INITRECORDS PUPSOCKET)
(SYSRECORDS PUPSOCKET)
(FNS OPENPUPSOCKET CLOSEPUPSOCKET PUPSOCKETNUMBER PUPSOCKETFROMNUMBER
PUPSOCKETEVENT \FLUSHPUPSOCQUEUE)
(FNS \GETMISCSOCKET)
(GLOBALVARS \MISC.SOCKET \PUPSOCKETS)
(INITVARS (\MISC.SOCKET)
(\PUPSOCKETS)))
(DECLARE: DONTCOPY (EXPORT (RECORDS PORT ERRORPUP)
(GLOBALVARS \ETHERWAIT1 \ETHERTIMEOUT \MAXETHERTRIES
PUPTRACEFLG LOGINPASSWORDS)
(GLOBALVARS PUPTRACEFILE PUPONLYTYPES PUPIGNORETYPES
PUPPRINTMACROS)
(CONSTANTS (\PUPOVLEN 22)
(\MAX.PUPLENGTH 532)
(\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 PUPDEBUGGING)
(ALISTS (PUPPRINTMACROS 136 140 137 139 129 24))
(RECORDS TIMEPUPCONTENTS))
(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))
(GLOBALVARS PUPTRACETIME)
(ADDVARS (PUPPRINTMACROS)
(PUPONLYTYPES)
(PUPIGNORETYPES))
(ALISTS (PUPPRINTMACROS 4 144 145 147 148)))
(COMS (FNS \CENTICLOCK)
[VARS (\CENTICLOCKFACTOR)
(\CENTICLOCKBOX (NCREATE (QUOTE FIXP]
(ADDVARS (\SYSTEMCACHEVARS \CENTICLOCKFACTOR))
(DECLARE: EVAL@COMPILE DONTCOPY (GLOBALVARS \CENTICLOCKFACTOR \CENTICLOCKBOX)
(RECORDS CENTICLOCK)))
(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
(GLOBALVARS \LOCALPUPNETHOST \OLDPUPHOST#)
)
)
(DEFINEQ
(\STARTPUP
[LAMBDA (EVENT) (* bvm: "26-Jul-84 15:57")
(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))
(ASSURE.PUP.READY T])
(ASSURE.PUP.READY
[LAMBDA (QUIET) (* bvm: "26-Jul-84 15:56")
(* Assures that Pup software is enabled.
PUP is turned off after exit until somebody indicates a
need for it)
(WITH.MONITOR \PUP.READY.LOCK (COND
((NULL \PUP.READY)
(PROG ((NDB \LOCALNDBS)
(PROC (FIND.PROCESS (QUOTE \PUPGATELISTENER)))
MYHOST#)
(COND
((NULL NDB)
(SETQ \PUP.READY (QUOTE NO))
(SETQ \LOCALPUPNETHOST 0)
(AND PROC (DEL.PROCESS PROC))
(RETURN)))
LP (COND
((NEQ (fetch NDBPUPHOST# of NDB)
0)
(SETQ MYHOST# (fetch NDBPUPHOST# of NDB)))
([NULL (OR MYHOST# (SETQ MYHOST# (\FIND.LOCALPUPHOSTNUMBER NDB EVENT
QUIET]
(SETQ \LOCALPUPNETHOST 0) (* Don't know our pup number yet, so wait until somebody
actually asks for pup service)
(\DEL.PACKET.FILTER (FUNCTION \HANDLE.RAW.PUP))
(AND PROC (DEL.PROCESS PROC))
(RETURN))
(T (replace NDBPUPHOST# of NDB with MYHOST#)))
(COND
((SETQ NDB (fetch NDBNEXT of NDB))
(GO LP)))
(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]
(COND
(\GATEWAYFLG (AND PROC (DEL.PROCESS PROC)))
(PROC (* Restart proc because it contains local timer that is
now garbage)
(RESTART.PROCESS PROC))
(T (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)
(\LOCATE.PUPNET 0) (* Initiate a probe to find out where we are and get
routing)
(BLOCK])
(\FIND.LOCALPUPHOSTNUMBER
[LAMBDA (NDB EVENT QUIET) (* bvm: "26-Jul-84 16:27")
(* Finds out our pup address on this 10mb NDB)
(PROG (NEWNUMBER)
[COND
[(SETQ NEWNUMBER (\LOOKUPPUPNUMBER \MY.NSHOSTNUMBER NDB))
(COND
(PUPTRACEFLG (printout PUPTRACEFILE "My pup address = " (fetch PUPNET# of NEWNUMBER)
"#"
(fetch PUPHOST# of NEWNUMBER)
"#" T]
(QUIET (RETURN NIL))
(T (SETQ NEWNUMBER (\PROMPT.FOR.PUP.NUMBER (AND (EQ EVENT (QUOTE AFTERLOGOUT))
(NEQ \OLDPUPHOST# 0)
(OCTALSTRING \OLDPUPHOST#]
(* 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])
(\PROMPT.FOR.PUP.NUMBER
[LAMBDA (DEFAULT) (* bvm: "26-Jul-84 16:30")
(RESETLST (PROVIDE.PROMPTING.WINDOW "Ethernet info needed")
(RESETBUFS (PROG (NEWNUMBER)
LP (SETQ NEWNUMBER (PACK* (PROMPTFORWORD
"Please enter my pup host number (in octal):"
DEFAULT NIL NIL NIL T)
(QUOTE Q)))
(TERPRI T)
(COND
((OR (NOT (FIXP NEWNUMBER))
(ILEQ NEWNUMBER 0)
(IGEQ NEWNUMBER 376Q))
(printout T T "Pup host number must be between 1 and 376" T T)
(CLEARBUF T)
(FLASHWINDOW (TTYDISPLAYSTREAM))
(GO LP)))
(RETURN NEWNUMBER])
(\HANDLE.RAW.PUP
[LAMBDA (PACKET TYPE) (* bvm: "15-Feb-85 22:20")
(* 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 (ffetch NDBPUPTYPE of (ffetch EPNETWORK of PACKET)))
[COND
((NULL \PUP.READY)
(RELEASE.PUP PACKET))
(T (PROG ((NDB (fetch EPNETWORK of PACKET))
CSUM PUPSOC DESTNET MYNET)
[COND
((AND (NEQ (fetch PUPDESTHOST of PACKET)
(fetch NDBPUPHOST# of NDB))
(NEQ (fetch PUPDESTHOST of PACKET)
0))
(RETURN (\FORWARD.PUP PACKET]
[COND
((AND (NEQ (SETQ DESTNET (fetch PUPDESTNET of PACKET))
(SETQ MYNET (fetch NDBPUPNET# of NDB)))
(NEQ MYNET 0)
(NEQ DESTNET 0)) (* 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)) (* 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
((EQ DESTNET 0) (* Fill in unspecified destination net
(possibly redundantly with zero))
(replace PUPDESTNET of PACKET with MYNET))
((EQ MYNET 0)
(* 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: "22-SEP-83 14:24")
(* Called when we receive a PUP not addressed to us.
Unless we are a gateway, dump it)
(COND
(\PEEKPUPNUMBER (\MAYBEPEEKPUP PUP))
(\GATEWAYFLG (\GATEWAY.FORWARD.PUP 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
(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: " 5-Jan-85 23:33")
(* * Turn packet around into an error packet with given error)
(COND
(\PEEKPUPNUMBER (\MAYBEPEEKPUP PUP))
((AND (NEQ (fetch PUPDESTHOST of PUP)
0)
(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])
)
(* Pup utilities)
(DEFINEQ
(SETUPPUP
[LAMBDA (PUP DESTHOST DESTSOCKET TYPE ID SOC REQUEUE) (* bvm: " 5-Jan-85 23:34")
(* 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)
(OR \PUP.READY (ASSURE.PUP.READY))
(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)
(NEQ (CDR DESTHOST)
0))
(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: " 5-Jan-85 23:34")
(* 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)
(PROG (NDB)
(\RCLK (LOCF (fetch EPTIMESTAMP of PUP)))
[COND
((AND PUPSOC (EQ (fetch PUPSOURCESOCKETLO of PUP)
0)
(EQ (fetch PUPSOURCESOCKETHI of PUP)
0))
(replace PUPSOURCESOCKETHI of PUP with (fetch PSOCKETHI of PUPSOC))
(replace PUPSOURCESOCKETLO of PUP with (fetch PSOCKETLO of PUPSOC]
(RETURN (COND
((NEQ (OR \PUP.READY (ASSURE.PUP.READY))
T) (* No PUP?)
(\REQUEUE.ETHERPACKET PUP)
(QUOTE NoEther))
((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 (\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])
)
(DEFINEQ
(ETHERHOSTNAME
[LAMBDA (PORT USE.OCTAL.DEFAULT) (* bvm: " 5-Jan-85 23:50")
(* * 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)
(OR (EQ (OR \PUP.READY (ASSURE.PUP.READY))
T)
(RETURN))
[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
((EQ (fetch PUPNET# of NETHOST)
0) (* 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 (SETQ RESULT (GETPUPSTRING IPUP))
(COND
([for C instring RESULT
always (AND (ILESSP C (CHARCODE 10Q))
(IGEQ C (CHARCODE 0]
(* Not really a name, but a Dandelion processor ID.
Pretend is NIL so as not to confuse rest of world with
uninvertable name)
(SETQ RESULT NIL)))
(RETURN))
(\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 (NEQ SOCKET# 0)
SOCKET#])
(ETHERHOSTNUMBER
[LAMBDA (NAME) (* bvm: "26-Jul-84 16:08")
(COND
((NEQ (OR \PUP.READY (ASSURE.PUP.READY))
T) (* No ether, no pup address)
NIL)
((NULL NAME)
(\LOCALPUPADDRESS))
(T (CAR (BESTPUPADDRESS NAME])
(ETHERPORT
[LAMBDA (NAME ERRORFLG MULTFLG) (* bvm: "16-NOV-83 11:40")
(* * 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 (RETURN]
(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])
(BESTPUPADDRESS
[LAMBDA (HOST ERRORSTREAM) (* bvm: " 5-Jan-85 23:36")
(* Returns a pup port for HOST, selecting the one of possibly multiple ports that is closest, returning NIL if there
is no route or name lookup fails. If ERRORSTREAM = ERROR, causes error on failure; otherwise ERRORSTREAM is a stream
to print an appropriate error message to before returning NIL)
(PROG (PORT NET MSG)
(OR (EQ (OR \PUP.READY (ASSURE.PUP.READY))
T)
(RETURN))
RETRY
(COND
[[SETQ PORT (COND
((FIXP HOST) (* A host number. Give it socket zero)
(\FIXLOCALNET (CONS HOST 0)))
[(LISTP HOST) (* An existing port structure)
(COND
((AND (FIXP (CAR HOST))
(FIXP (CDR HOST)))
(\FIXLOCALNET HOST))
(ERRORSTREAM (SETQ MSG "Invalid port specification")
(GO ERROR))
(T (RETURN]
(T (\PARSE.PORTCONSTANT HOST]
(COND
((OR (EQ (SETQ NET (fetch PUPNET# of (CAR PORT)))
0)
(EQ NET (\LOCALPUPNETNUMBER)))
(RETURN PORT))
(T (SETQ PORT (LIST PORT]
((SETQ PORT (OR (GETHASH HOST \ETHERPORTS)
(PUTHASH HOST (\LOOKUPPORT HOST)
\ETHERPORTS))) (* note we always save multiple values in case they are
ever wanted)
)
(ERRORSTREAM (SETQ MSG "Host not found")
(GO ERROR))
(T (RETURN)))
[RETURN (for TRY from 1 to 5 bind NOTLOOKEDUP HOPS BESTHOPS BESTPORT ROUTE
do (SETQ BESTHOPS \RT.INFINITY)
(SETQ NOTLOOKEDUP (SETQ BESTPORT NIL))
[for PAIR in PORT do (COND
((OR [NOT (SETQ ROUTE (\LOCATE.PUPNET
(fetch PUPNET# of (CAR PAIR]
(IGEQ (SETQ HOPS (fetch RTHOPCOUNT of ROUTE))
\RT.INFINITY))
(SETQ NOTLOOKEDUP T))
((ILESSP HOPS BESTHOPS)
(SETQ BESTHOPS HOPS)
(SETQ BESTPORT PAIR]
(* Enter request for routing for all hosts)
(COND
((AND BESTPORT (OR (NOT NOTLOOKEDUP)
(ILEQ BESTHOPS \PUP.ROUTING.TABLE.RADIUS)
(IGREATERP TRY 1)))
(RETURN BESTPORT)))
(BLOCK \ETHERTIMEOUT)
finally (COND
(ERRORSTREAM (SETQ MSG "No route to host")
(GO ERROR]
ERROR
(COND
((EQ ERRORSTREAM (QUOTE ERROR))
(ERROR MSG HOST)
(GO RETRY))
(T (printout ERRORSTREAM T MSG ": " HOST)
(RETURN])
(NETDAYTIME0
[LAMBDA NIL (* bvm: "26-Jul-84 15:26")
(* * Returns a 32-bit unsigned alto time from the network, if possible)
(\NET.SETTIME T])
(\PUP.SETTIME
[LAMBDA (RETFLG) (* bvm: " 1-NOV-83 17:07")
(* * Sets the local time from the network, if possible, or simply returns a 32-bit unsigned alto time if RETFLG is
T)
(DECLARE (GLOBALVARS \TimeZoneComp \BeginDST \EndDST))
(PROG ((SOC (\GETMISCSOCKET))
(OPUP (ALLOCATE.PUP))
RESULT IPUP DATA TIME)
(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))
(SETQ TIME (create FIXP
HINUM ←(fetch
TIMEPUPVALUEHI
of DATA)
LONUM ←(fetch
TIMEPUPVALUELO
of DATA)))
(COND
(RETFLG (RETURN TIME)))
(\SETNEWTIME0 TIME)
(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))
(RELEASE.PUP IPUP)
(RETURN T))
(\PT.ERROR (AND PUPTRACEFLG (PRINTERRORPUP IPUP PUPTRACEFILE)))
NIL)
(RELEASE.PUP IPUP])
(\SETNEWTIME0
[LAMBDA (NEWTIME) (* bvm: "26-Jul-84 15:23")
(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 T "[Time reset to " (DATE (DATEFORMAT TIME.ZONE))
"]"])
(\NET.SETTIME
[LAMBDA (RETFLG) (* bvm: "26-Jul-84 15:25")
(* * Sets the time from local network time server, or just returns said time if RETFLG is true)
(if \LOCALNDBS
then (SELECTQ (fetch (NDB NETTYPE) of \LOCALNDBS)
(3 (OR (\PUP.SETTIME RETFLG)
(\NS.SETTIME RETFLG)))
[12Q (OR (\NS.SETTIME RETFLG)
(AND \PUP.READY (\PUP.SETTIME RETFLG]
NIL])
(NETDATE
[LAMBDA NIL (* bvm: "30-AUG-81 00:30")
(GDATE (ALTO.TO.LISP.DATE (OR (NETDAYTIME0)
(DAYTIME0 (create FIXP])
(\LOOKUPPORT
[LAMBDA (NAME) (* bvm: " 5-Jan-85 23:58")
(* * 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))
NIL)
finally (PUPDEBUGGING "Name lookup timed out" T))
(AND IPUP (RELEASE.PUP IPUP))
(RELEASE.PUP OPUP)
(RETURN RESULT])
(\PARSE.PORTCONSTANT
[LAMBDA (STR) (* bvm: "16-NOV-83 12:01")
(* * If STR is a constant ether address of form net#host#socket, returns a port, else NIL)
(for CH instring (OR (STRINGP STR)
(SETQ STR (MKSTRING STR)))
bind NET HOST VAL do (COND
[(AND (IGEQ CH (CHARCODE 0))
(ILEQ CH (CHARCODE 7)))
(* Add octal digit into value)
(SETQ VAL (IPLUS (COND
(VAL (LLSH VAL 3))
(T 0))
(IDIFFERENCE CH (CHARCODE 0]
((EQ CH (CHARCODE #)) (* # terminates net or host number)
(COND
(NET (RETURN)))
(SETQ NET HOST)
(SETQ HOST (OR VAL 0))
(SETQ VAL NIL))
(T (RETURN)))
finally (* Ran out of chars. Save last value parsed, make sure
we have at least a net and host)
(RETURN (AND (OR HOST VAL)
(CONS (LOGOR (OR HOST 0)
(COND
(NET (LLSH NET 10Q))
(T 0)))
(OR VAL 0])
(\FIXLOCALNET
[LAMBDA (PORT) (* bvm: " 5-Jan-85 23:37")
(* 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)
(NEQ (CAR PORT)
0)
\LOCALNDBS
(SETQ NET (fetch NDBPUPNET# of \LOCALNDBS))
(NEQ NET 0))
(RPLACA PORT (create PUPADDRESS
PUPNET# ← NET
PUPHOST# ←(CAR PORT]
PORT])
)
(DEFINEQ
(PORTSTRING
[LAMBDA (NETHOST SOCKET) (* bvm: " 5-Jan-85 23:40")
[COND
((LISTP NETHOST)
(SETQ SOCKET (CDR NETHOST))
(COND
((EQ SOCKET 0)
(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)))])
)
(RPAQ? \ETHERPORTS (HASHARRAY 24Q))
(RPAQ? \ETHERTIMEOUT 3720Q)
(RPAQ? \MAXETHERTRIES 4)
(RPAQ? \PUPCOUNTER 0)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \ETHERPORTS \PUPCOUNTER)
)
(* 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: "26-Apr-84 10:04")
(PROG [(NC (IDIFFERENCE (IDIFFERENCE [ffetch PUPLENGTH of (SETQ PUP (\DTEST PUP (QUOTE
ETHERPACKET]
\PUPOVLEN)
(OR OFFSET (SETQ OFFSET 0]
(RETURN (COND
((IGREATERP NC 0)
(\GETBASESTRING (ffetch PUPCONTENTS of PUP)
OFFSET NC))
(T (* Could give error if length negative, but the empty
string is a reasonable thing to return)
(ALLOCSTRING 0])
(GETPUPSTREAM
[LAMBDA (PUP OFFSET LENGTH ACCESS WRITEXTENSIONFN) (* bvm: "26-OCT-83 12:10")
(\MAKEBASEBYTESTREAM [fetch PUPCONTENTS of (SETQ PUP (\DTEST PUP (QUOTE ETHERPACKET]
(OR OFFSET (SETQ OFFSET 0))
(OR LENGTH (IDIFFERENCE (IDIFFERENCE (fetch PUPLENGTH of PUP)
\PUPOVLEN)
OFFSET))
(OR ACCESS (QUOTE INPUT))
WRITEXTENSIONFN])
(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 (STREAM NOERRORFLG) (* bvm: " 5-May-84 16:09")
(* * Reads an FTP-style property list from STREAM. If the plist is malformed, causes an error unless NOERRORFLG is
true. FTP-style plists look like lists of two elements in a very rigid syntax: each element of the list is
(property value); spaces are significant except the one immediately following property. READPLIST returns the
property names as uppercase atoms, the values as strings)
(PROG ([READTABLES (DEFERREDCONSTANT (PROG ((TAB1 (COPYREADTABLE (QUOTE ORIG)))
TAB2)
(SETSEPR NIL NIL TAB1)
(* Want to set up two readtables to read properties)
(SETSYNTAX (QUOTE ')
(QUOTE ESCAPE)
TAB1)
(SETSYNTAX (QUOTE %%)
(QUOTE OTHER)
TAB1)
(SETQ TAB2 (COPYREADTABLE TAB1))
(SETBRK (CHARCODE (%)))
NIL TAB2)
(SETBRK (CHARCODE (SPACE))
NIL TAB1)
(RETURN (CONS TAB1 TAB2]
PLIST)
(OR (EQ (BIN STREAM)
(CHARCODE %())
(GO ERROR))
[SETQ PLIST (bind CH while (EQ (SETQ CH (BIN STREAM))
(CHARCODE %())
collect (* Another element)
[PROG1 [LIST (RATOM STREAM (CAR READTABLES))
(PROGN (BIN STREAM)
(* Skip over the space)
(RSTRING STREAM (CDR READTABLES]
(COND
((NEQ (BIN STREAM)
(CHARCODE %)))
(GO ERROR]
finally (COND
((NEQ CH (CHARCODE %)))
(GO ERROR]
[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)
ERROR
(OR NOERRORFLG (ERROR "Malformed property list in stream" STREAM))
(RETURN NIL])
(\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)))
)
(DEFINEQ
(\CANONICAL.HOSTNAME
[LAMBDA (NAME) (* bvm: "15-Sep-84 14:36")
(DECLARE (GLOBALVARS FIXSPELLREL))
(* * Returns the canonical name of a given hostname, in case a server has synonyms)
(OR (LITATOM NAME)
(SETQ NAME (MKATOM NAME)))
(OR (CDR (FASSOC NAME \HOSTNAMES))
(PROG ((PORT (ETHERPORT NAME))
OFFICIALNAME)
(RETURN (COND
(PORT (if [NOT (LITATOM (SETQ OFFICIALNAME (MKATOM
(U-CASE (OR (ETHERHOSTNAME PORT)
NAME]
then (* DLions with no real name come out as large integers,
not litatoms, so use name given)
(SETQ OFFICIALNAME (U-CASE NAME)))
(push \HOSTNAMES (CONS NAME OFFICIALNAME))
(* If no name in database, take what was given)
OFFICIALNAME)
((AND \HOSTNAMES (SETQ NAME (FIXSPELL NAME FIXSPELLREL \HOSTNAMES T)))
(\CANONICAL.HOSTNAME NAME])
(CANONICAL.HOSTNAME
[LAMBDA (HOSTNAME) (* bvm: "15-Sep-84 14:38")
(if (STRPOS ":" HOSTNAME)
then (\CANONICAL.NSHOSTNAME HOSTNAME)
else (\CANONICAL.HOSTNAME HOSTNAME])
)
(ADDTOVAR \HOSTNAMES )
(ADDTOVAR \SYSTEMCACHEVARS \HOSTNAMES)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \HOSTNAMES)
)
(* 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 ")"))))
(* 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 READONLY) (* bvm: "15-Feb-85 22:21")
(* Encapsulates PUP, choosing the right network and immediate destination host. Returns an NDB for the transmission.
Defaults the pup source fields, unless READONLY is set)
(PROG ((NET (fetch PUPDESTNET of PUP))
(HOST (fetch PUPDESTHOST of PUP))
PDH ROUTE NDB)
(COND
[(EQ NET 0)
(COND
((NOT (SETQ NDB \LOCALNDBS))
(RETURN]
((SETQ ROUTE (\LOCATE.PUPNET NET))
(SETQ NDB (fetch RTNDB of ROUTE)))
(T (RETURN)))
[SETQ PDH (COND
((AND ROUTE (NEQ (fetch RTHOPCOUNT of ROUTE)
0))
(fetch RTGATEWAY# of ROUTE))
((EQ (fetch NETTYPE of NDB)
3)
HOST)
((EQ HOST 0) (* Broadcast)
BROADCASTNSHOSTNUMBER)
((\TRANSLATE.3TO10 HOST NDB))
(T (RETURN]
(replace EPNETWORK of PUP with NDB)
(ENCAPSULATE.ETHERPACKET NDB PUP PDH (fetch PUPLENGTH of PUP)
(ffetch NDBPUPTYPE of NDB))
[COND
((NOT READONLY)
[COND
((EQ NET 0)
(replace PUPDESTNET of PUP with (fetch NDBPUPNET# of NDB]
(replace PUPSOURCENET of PUP with (fetch NDBPUPNET# of NDB))
(COND
((EQ (fetch PUPSOURCEHOST of PUP)
0)
(replace PUPSOURCEHOST of PUP with (fetch NDBPUPHOST# of NDB]
(RETURN NDB])
(\LOCATE.PUPNET
[LAMBDA (NET DONTPROBE) (* bvm: " 5-Jan-85 23:39")
(OR (SMALLP NET)
(HELP "Bad network number" NET))
(OR \PUP.READY (ASSURE.PUP.READY))
(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 (EQ NET 0)
(EQ (fetch (ROUTING RTHOPCOUNT) of DATA)
0)))
[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 (EQ NET 0)
(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"))
(RPAQ? \PUP.READY.LOCK (CREATE.MONITORLOCK "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
(GLOBALVARS \PUP.ROUTING.TABLE \PUP.ROUTING.TABLE.RADIUS \PUPROUTER.PROBECOUNT \PUPROUTER.PROBETIMER
\PUPROUTER.PROBEINTERVAL \PUP.READY \PUP.READY.EVENT \PUP.READY.LOCK)
)
)
(* 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
(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)))
[ADDTOVAR SYSTEMRECLST
(DATATYPE PUPSOCKET ((NIL BYTE)
(PUPSOCLINK POINTER)
(PSOCKET# FIXP)
(INQUEUE POINTER)
(INQUEUELENGTH WORD)
(PUPSOC#ALLOCATION WORD)
(PUPSOCHANDLE WORD)
(PUPSOCPUPADDRESS WORD)
(NIL BYTE)
(PUPSOCEVENT POINTER)
(NIL BYTE)
(NIL 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
(GLOBALVARS \MISC.SOCKET \PUPSOCKETS)
)
(RPAQ? \MISC.SOCKET )
(RPAQ? \PUPSOCKETS )
(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
(GLOBALVARS \ETHERWAIT1 \ETHERTIMEOUT \MAXETHERTRIES PUPTRACEFLG LOGINPASSWORDS)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS PUPTRACEFILE PUPONLYTYPES PUPIGNORETYPES PUPPRINTMACROS)
)
(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 PUPDEBUGGING MACRO [(X . Y)
(COND
(PUPTRACEFLG (printout PUPTRACEFILE X . Y])
)
(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)
)
]
)
(* 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: " 1-NOV-83 15:31")
(RESETLST (PROG ((OPUP (ALLOCATE.PUP))
(PORT (BESTPUPADDRESS HOST (OR ECHOSTREAM PROMPTWINDOW)))
(SOC (OPENPUPSOCKET))
(TIMER (SETUPTIMER 0))
IPUP EVENT ECHOPUPLENGTH I)
(RESETSAVE NIL (LIST (QUOTE CLOSEPUPSOCKET)
SOC))
(OR PORT (RETURN))
(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: " 1-NOV-83 15:32")
(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 (BESTPUPADDRESS H PROMPTWINDOW)))
(COND
([AND NETHOST (OR (EQ (fetch PUPNET# of NETHOST)
0)
(EQ (fetch PUPNET# of NETHOST)
(\LOCALPUPNETNUMBER]
(fetch PUPHOST# of NETHOST))
(T (ERROR H "not a host on local network"]
(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: " 5-Jan-85 23:39")
[COND
((AND \PEEKPUPNUMBER PUPTRACEFLG)
(PROG (DIRECTION)
(COND
([OR (EQ \PEEKPUPNUMBER T)
(EQ (fetch PUPDESTHOST of PUP)
0)
(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
(GLOBALVARS \PEEKPUPNUMBER)
)
)
(* Debugging assistance)
(DEFINEQ
(PRINTPUP
[LAMBDA (PACKET CALLER FILE PRE.NOTE DOFILTER) (* bvm: " 5-Jan-85 23:40")
(\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
((EQ (fetch PUPDESTHOST of PACKET)
0) (* 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: "26-OCT-83 15:33")
(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 PACKET))
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 )
(DECLARE: DOEVAL@COMPILE DONTCOPY
(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
(\CENTICLOCK
[LAMBDA (PACKET) (* bvm: "26-OCT-83 15:42")
(* * Returns a relative time in centiseconds. If PACKET is given, the time is a translation of its EPTIMESTAMP;
otherwise the time is now)
(PROG ((CLK \CENTICLOCKBOX))
(COND
(PACKET (\BLT CLK (LOCF (fetch EPTIMESTAMP of PACKET))
WORDSPERCELL))
(T (\RCLK CLK)))
(replace CENTICLOCKSIGNBIT of CLK with 0)
(RETURN (IQUOTIENT CLK (OR \CENTICLOCKFACTOR (SETQ \CENTICLOCKFACTOR (ITIMES 12Q
\RCLKMILLISECOND])
)
(RPAQQ \CENTICLOCKFACTOR NIL)
(RPAQ \CENTICLOCKBOX (NCREATE (QUOTE FIXP)))
(ADDTOVAR \SYSTEMCACHEVARS \CENTICLOCKFACTOR)
(DECLARE: EVAL@COMPILE DONTCOPY
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \CENTICLOCKFACTOR \CENTICLOCKBOX)
)
[DECLARE: EVAL@COMPILE
(BLOCKRECORD CENTICLOCK ((CENTICLOCKSIGNBIT BITS 1)
(CENTICLOCKMAGNITUDE BITS 37Q)))
]
)
(DECLARE: DONTEVAL@LOAD
(\PUPINIT)
)
(DECLARE: EVAL@COMPILE DONTCOPY
(FILESLOAD (LOADCOMP)
LLETHER)
)
(PUTPROPS PUP COPYRIGHT ("Xerox Corporation" 3676Q 3677Q 3700Q 3701Q))
(DECLARE: DONTCOPY
(FILEMAP (NIL (16653Q 42333Q (\STARTPUP 16665Q . 17521Q) (ASSURE.PUP.READY 17523Q . 24026Q) (
\FIND.LOCALPUPHOSTNUMBER 24030Q . 25757Q) (\PROMPT.FOR.PUP.NUMBER 25761Q . 27252Q) (\HANDLE.RAW.PUP
27254Q . 40236Q) (\FORWARD.PUP 40240Q . 41251Q) (\SETPUPCHECKSUM 41253Q . 42331Q)) (46373Q 51433Q (
\PUPERROR 46405Q . 51431Q)) (51466Q 66331Q (SETUPPUP 51500Q . 54110Q) (SWAPPUPPORTS 54112Q . 54676Q) (
GETPUP 54700Q . 56763Q) (SENDPUP 56765Q . 62354Q) (EXCHANGEPUPS 62356Q . 64203Q) (DISCARDPUPS 64205Q
. 65007Q) (GETPUPWORD 65011Q . 65331Q) (\PUPINIT 65333Q . 66327Q)) (66332Q 120775Q (ETHERHOSTNAME
66344Q . 73607Q) (ETHERHOSTNUMBER 73611Q . 74344Q) (ETHERPORT 74346Q . 77026Q) (BESTPUPADDRESS 77030Q
. 104546Q) (NETDAYTIME0 104550Q . 105107Q) (\PUP.SETTIME 105111Q . 110075Q) (\SETNEWTIME0 110077Q .
111030Q) (\NET.SETTIME 111032Q . 111776Q) (NETDATE 112000Q . 112276Q) (\LOOKUPPORT 112300Q . 115430Q)
(\PARSE.PORTCONSTANT 115432Q . 117611Q) (\FIXLOCALNET 117613Q . 120773Q)) (120776Q 122326Q (PORTSTRING
121010Q . 121773Q) (OCTALSTRING 121775Q . 122324Q)) (122713Q 135724Q (CLEARPUP 122725Q . 124243Q) (
PUTPUPWORD 124245Q . 124573Q) (GETPUPBYTE 124575Q . 125116Q) (PUTPUPBYTE 125120Q . 125447Q) (
GETPUPSTRING 125451Q . 126610Q) (GETPUPSTREAM 126612Q . 127436Q) (PUTPUPSTRING 127440Q . 130146Q) (
READPLIST 130150Q . 134241Q) (\STOREPLIST 134243Q . 135722Q)) (137121Q 141715Q (\CANONICAL.HOSTNAME
137133Q . 141312Q) (CANONICAL.HOSTNAME 141314Q . 141713Q)) (143655Q 164443Q (\PUPGATELISTENER 143667Q
. 146323Q) (\HANDLE.PUP.ROUTING.INFO 146325Q . 152722Q) (\ROUTE.PUP 152724Q . 156132Q) (
\LOCATE.PUPNET 156134Q . 161306Q) (SORT.PUPHOSTS.BY.DISTANCE 161310Q . 162727Q) (\PUPNET.CLOSERP
162731Q . 163660Q) (PUPNET.DISTANCE 163662Q . 164441Q)) (172131Q 200515Q (OPENPUPSOCKET 172143Q .
175351Q) (CLOSEPUPSOCKET 175353Q . 176734Q) (PUPSOCKETNUMBER 176736Q . 177166Q) (PUPSOCKETFROMNUMBER
177170Q . 177607Q) (PUPSOCKETEVENT 177611Q . 200075Q) (\FLUSHPUPSOCQUEUE 200077Q . 200513Q)) (200516Q
201350Q (\GETMISCSOCKET 200530Q . 201346Q)) (220062Q 226631Q (PUP.ECHOSERVER 220074Q . 222017Q) (
PUP.ECHOUSER 222021Q . 226627Q)) (226656Q 233006Q (\PEEKPUP 226670Q . 231424Q) (\MAYBEPEEKPUP 231426Q
. 233004Q)) (233377Q 245572Q (PRINTPUP 233411Q . 237157Q) (PRINTPUPROUTE 237161Q . 240670Q) (
PRINTPUPDATA 240672Q . 241306Q) (PRINTERRORPUP 241310Q . 241773Q) (PUPTRACE 241775Q . 243442Q) (
\CHANGE.ETHER.TRACING 243444Q . 244627Q) (PRINTCONSTANT 244631Q . 245570Q)) (246374Q 247560Q (
\CENTICLOCK 246406Q . 247556Q)))))
STOP