(FILECREATED "15-Sep-84 14:41:12" {ERIS}<LISPCORE>SOURCES>PUP.;4 303404Q
changes to: (FNS \CANONICAL.HOSTNAME CANONICAL.HOSTNAME)
(VARS PUPCOMS)
previous date: "26-Jul-84 17:08:32" {ERIS}<LISPCORE>SOURCES>PUP.;3)
(* Copyright (c) 1982, 1983, 1984 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 (FNS SETUPPUP SWAPPUPPORTS GETPUP SENDPUP EXCHANGEPUPS DISCARDPUPS GETPUPWORD
\PUPINIT))
(GLOBALRESOURCES \PUPBOX)
(FNS ETHERHOSTNAME ETHERHOSTNUMBER ETHERPORT BESTPUPADDRESS NETDAYTIME0 \PUP.SETTIME
\SETNEWTIME0 \NET.SETTIME NETDATE \LOOKUPPORT \PARSE.PORTCONSTANT \FIXLOCALNET)
(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))
(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 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)))
(GLOBALVARS \ETHERPORTS \EFTP.TIMEOUT \EFTP.LONGTIMEOUT \PUPCOUNTER)
(DECLARE: DONTCOPY (EXPORT (RECORDS PORT ERRORPUP)
(GLOBALVARS \ETHERWAIT1 \ETHERTIMEOUT \MAXETHERTRIES
PUPTRACEFLG LOGINPASSWORDS NILPUPTRACEFLG)
(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))
(INITVARS (\ETHERPORTS (HASHARRAY 20))
(\ETHERTIMEOUT 2000)
(\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 144 145 147 148)))
(FNS PORTSTRING OCTALSTRING)
(COMS (FNS \CENTICLOCK)
[VARS (\CENTICLOCKFACTOR)
(\CENTICLOCKBOX (NCREATE (QUOTE FIXP]
(ADDVARS (\SYSTEMCACHEVARS \CENTICLOCKFACTOR))
(DECLARE: EVAL@COMPILE DONTCOPY (GLOBALVARS \CENTICLOCKFACTOR \CENTICLOCKBOX)
(RECORDS CENTICLOCK)))
[COMS (* Mail check)
(FNS MAILWATCHER MAILCHECK)
(GLOBALVARS MAILINTERVAL MAILTIME MAILEVENTCOUNT USERNAME DEFAULTCHATHOST)
(DECLARE: EVAL@LOADWHEN (SELECTQ (SYSTEMTYPE)
((ALTO D)
T)
NIL)
(INITVARS (MAILINTERVAL 300000)
(MAILTIME 0)
(MAILEVENTCOUNT 0)
(DEFAULTCHATHOST]
(COMS (* EFTP)
(FNS EFTP \ABORT.EFTP PUP.PRINTER.STATUS PUP.PRINTER.PROPERTIES)
[DECLARE: DONTCOPY (CONSTANTS * EFTPPUPTYPES)
(CONSTANTS * EFTPCONSTANTS)
(ADDVARS * (LIST (CONS (QUOTE PUPTYPES)
EFTPPUPTYPES]
(INITVARS (\EFTP.TIMEOUT 5000)
(\EFTP.LONGTIMEOUT 15000)))
(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: "30-Nov-83 11:11")
(* 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)
[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))
(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)) (* 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: "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: "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: "26-Jul-84 16:10")
(* 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)
(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: "26-Jul-84 16:03")
(* 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 (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]
(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])
)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
[PUTDEF (QUOTE \PUPBOX)
(QUOTE RESOURCES)
(QUOTE (NEW (CREATECELL \FIXP]
)
)
(/SETTOPVAL (QUOTE \\PUPBOX.GLOBALRESOURCE))
(DEFINEQ
(ETHERHOSTNAME
[LAMBDA (PORT USE.OCTAL.DEFAULT) (* bvm: "26-Jul-84 16:07")
(* * 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
((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 (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: "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: "26-Jul-84 16:09")
(* 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 [ZEROP (SETQ NET (fetch PUPNET# of (CAR PORT]
(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: " 1-NOV-83 16:39")
(* * 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)
(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: "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: "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 ")"))))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(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 READONLY) (* bvm: "26-Apr-84 09:46")
(* 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)
((ZEROP HOST) (* Broadcast)
BROADCASTNSHOSTNUMBER)
((\TRANSLATE.3TO10 HOST NDB))
(T (RETURN]
(replace EPNETWORK of PUP with NDB)
(ENCAPSULATE.ETHERPACKET NDB PUP PDH (fetch PUPLENGTH of PUP)
\EPT.PUP)
[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
((ZEROP (fetch PUPSOURCEHOST of PUP))
(replace PUPSOURCEHOST of PUP with (fetch NDBPUPHOST# of NDB]
(RETURN NDB])
(\LOCATE.PUPNET
[LAMBDA (NET DONTPROBE) (* bvm: "26-Jul-84 15:55")
(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 (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"))
(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: DOEVAL@COMPILE DONTCOPY
(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
(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 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)
)
]
)
(RPAQ? \ETHERPORTS (HASHARRAY 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: " 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: "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
(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: "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 )
(RPAQ? NILPUPTRACEFLG )
(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
(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 (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)))
]
)
(* Mail check)
(DEFINEQ
(MAILWATCHER
(LAMBDA (USER HOST LAURELFLG) (* JonL "17-Dec-83 02:44")
(* * Something to put on PROMPTCHARFORMS to periodically check your mail. Checks mailbox of current USER
(defaults to USERNAME). If username has property MAILBOX value host or (host laurelflag), those values are used;
otherwise defaults to DEFAULTCHATHOST)
(if (IGREATERP (add MAILEVENTCOUNT 1)
12Q)
then (SETQ MAILEVENTCOUNT 0)
(PROG (NEWMAIL? INFO)
(if (OR (ZEROP MAILTIME)
(\CLOCKGREATERP MAILTIME MAILINTERVAL))
then (* First case is initialization)
(SETQ MAILTIME (CLOCK 0))
(SETQ INFO (GETPROP (OR USER (SETQ USER USERNAME))
(QUOTE MAILBOX)))
(SETQ NEWMAIL? (MAILCHECK USER (OR HOST
(AND INFO (OR (CAR (LISTP INFO))
INFO))
DEFAULTCHATHOST
(RETURN))
(OR LAURELFLG (CADR (LISTP INFO)))))
(if (AND NEWMAIL? (NEQ NEWMAIL? (QUOTE ?))
(NOT (EQUAL NEWMAIL? (GETPROP USER (QUOTE LASTMAIL)))))
then (printout T "[Mail waiting -- " NEWMAIL? "]" T)
(PUT USER (QUOTE LASTMAIL)
NEWMAIL?)))))))
(MAILCHECK
[LAMBDA (USER HOST LAURELFLG) (* bvm: " 1-NOV-83 16:00")
(* * 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 (BESTPUPADDRESS HOST PROMPTWINDOW))
(SOC (\GETMISCSOCKET))
(OPUP (ALLOCATE.PUP))
RESULT IPUP)
(OR HOSTPORT (RETURN))
(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 PUPTRACEFLG (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
(GLOBALVARS MAILINTERVAL MAILTIME MAILEVENTCOUNT USERNAME DEFAULTCHATHOST)
)
(DECLARE: EVAL@LOADWHEN (SELECTQ (SYSTEMTYPE)
((ALTO D)
T)
NIL)
(RPAQ? MAILINTERVAL 1111740Q)
(RPAQ? MAILTIME 0)
(RPAQ? MAILEVENTCOUNT 0)
(RPAQ? DEFAULTCHATHOST )
)
(* EFTP)
(DEFINEQ
(EFTP
[LAMBDA (HOST FILE PRINTOPTIONS) (* bvm: " 5-May-84 16:13")
(RESETLST (PROG ((HOSTPORT (BESTPUPADDRESS HOST (QUOTE ERROR)))
(TIMEOUT \EFTP.TIMEOUT)
(CHECKSTATUS PRINTOPTIONS)
(OPUP (ALLOCATE.PUP))
(#SIDES (LISTGET (LISTP PRINTOPTIONS)
(QUOTE #SIDES)))
STREAM DATA RESULT ENDING NAMESTRING NC HOSTNAME STATUS NEWSTATUS CURPAGE# ID
SOC LASTPAGE# LASTPAGELENGTH LENGTH THISPAGELENGTH PRESSDATAPAGE# ABORTER CLOSER
CAPABILITIES IPUP)
[SETQ STREAM (COND
((TYPENAMEP FILE (QUOTE STREAM))
FILE)
(T (OPENSTREAM FILE (QUOTE INPUT]
(RESETSAVE NIL (SETQ CLOSER (LIST (QUOTE CLOSEF)
STREAM)))
(SETQ LENGTH (GETFILEINFO STREAM (QUOTE LENGTH)))
(SETQ LASTPAGELENGTH (fetch (BYTEPTR OFFSET) of LENGTH))
(SETQ LASTPAGE# (fetch (BYTEPTR PAGE) of LENGTH))
[COND
(PRINTOPTIONS (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# PUPTRACEFLG)
(PRIN1 " (restarting)" PUPTRACEFILE)))
(SETQ ID 0)
(COND
((NEQ CURPAGE# 0)
[COND
((EQ (GETFILEPTR STREAM)
0))
((RANDACCESSP STREAM)
(SETFILEPTR STREAM 0))
(T (RPLACA (CDR CLOSER)
(SETQ STREAM (OPENSTREAM (CLOSEF STREAM)
(QUOTE INPUT]
(SETQ CURPAGE# 0)))
(replace PUPTYPE of OPUP with \EFTP.DATA)
[COND
((FIXP #SIDES)
[while (NOT CAPABILITIES)
do [do (* Printer capability request only honored while printer
is idle)
[COND
((SETQ NEWSTATUS (PUP.PRINTER.STATUS HOSTPORT))
(COND
((NOT (EQUAL NEWSTATUS STATUS))
(printout PROMPTWINDOW .TAB0 0 (CDR (SETQ STATUS NEWSTATUS]
(COND
((EQ (CAR STATUS)
\PS.IDLE)
(RETURN))
(T (BLOCK \EFTP.TIMEOUT]
(SETQ CHECKSTATUS NIL)
(COND
((NOT (SETQ CAPABILITIES (PUP.PRINTER.PROPERTIES HOSTPORT)))
(printout PROMPTWINDOW .TAB0 0 "[No response from " HOST "]")
(SETQ STATUS]
(COND
([AND (EQ (CHCON1 (CADR (ASSOC (QUOTE PRINT-INSTANCE)
CAPABILITIES)))
(CHARCODE T))
(OR (EQ #SIDES 1)
(EQ (CHCON1 (CADR (ASSOC (QUOTE DUPLEX)
CAPABILITIES)))
(CHARCODE T] (* 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 (SETQ THISPAGELENGTH
LASTPAGELENGTH]
[(ILESSP CURPAGE# LASTPAGE#)
(replace PUPLENGTH of OPUP with (IPLUS \PUPOVLEN (SETQ THISPAGELENGTH
BYTESPERPAGE]
(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 pup's data part)
(\BINS STREAM (SETQ DATA (fetch PUPCONTENTS of OPUP))
0 THISPAGELENGTH)
[COND
((EQ CURPAGE# PRESSDATAPAGE#) (* Fill in print parameters for this run)
(\PUTBASE DATA 11Q (OR (FIXP PRINTOPTIONS)
(FIXP (LISTGET PRINTOPTIONS (QUOTE #COPIES)))
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 (PUP.PRINTER.STATUS HOSTPORT))
(NOT (EQUAL NEWSTATUS STATUS)))
(printout PROMPTWINDOW .TAB0 0 (CDR (SETQ STATUS
NEWSTATUS)))
(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
(PUPTRACEFLG (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 PRINTOPTIONS (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 .TAB0 0 "[No response from " HOST "]")
(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])
(PUP.PRINTER.STATUS
[LAMBDA (PRINTER) (* bvm: "13-Dec-83 15:55")
(* * Checks status of printer, returns a dotted pair (statuscode . string))
(PROG ((HOSTPORT (BESTPUPADDRESS PRINTER PROMPTWINDOW))
(SOC (\GETMISCSOCKET))
(OPUP (ALLOCATE.PUP))
RESULT IPUP)
(OR HOSTPORT (RETURN))
(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 (PROG1 (SETQ RESULT
(CONS (\GETBASE (fetch PUPCONTENTS
of IPUP)
0)
(GETPUPSTRING IPUP 2)))
(RELEASE.PUP IPUP]
(\PT.ERROR (AND PUPTRACEFLG (PRINTERRORPUP IPUP PUPTRACEFILE))
(RETURN (RELEASE.PUP IPUP)))
(RELEASE.PUP IPUP))
finally (PUPDEBUGGING "Printer status request timed out" T))
(RELEASE.PUP OPUP)
(RETURN RESULT])
(PUP.PRINTER.PROPERTIES
[LAMBDA (PRINTER) (* bvm: " 1-NOV-83 16:00")
(* * Asks printer about its capabilities, returns property list)
(PROG ((HOSTPORT (BESTPUPADDRESS PRINTER PROMPTWINDOW))
(SOC (\GETMISCSOCKET))
(OPUP (ALLOCATE.PUP))
RESULT IPUP)
(OR HOSTPORT (RETURN))
(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 (GETPUPSTREAM IPUP]
(\PT.ERROR (AND PUPTRACEFLG (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 3700Q))
(DECLARE: DONTCOPY
(FILEMAP (NIL (20206Q 43245Q (\STARTPUP 20220Q . 21054Q) (ASSURE.PUP.READY 21056Q . 25361Q) (
\FIND.LOCALPUPHOSTNUMBER 25363Q . 27312Q) (\PROMPT.FOR.PUP.NUMBER 27314Q . 30605Q) (\HANDLE.RAW.PUP
30607Q . 41150Q) (\FORWARD.PUP 41152Q . 42163Q) (\SETPUPCHECKSUM 42165Q . 43243Q)) (47305Q 52214Q (
\PUPERROR 47317Q . 52212Q)) (52215Q 66513Q (SETUPPUP 52227Q . 54500Q) (SWAPPUPPORTS 54502Q . 55266Q) (
GETPUP 55270Q . 57353Q) (SENDPUP 57355Q . 62536Q) (EXCHANGEPUPS 62540Q . 64365Q) (DISCARDPUPS 64367Q
. 65171Q) (GETPUPWORD 65173Q . 65513Q) (\PUPINIT 65515Q . 66511Q)) (66764Q 117452Q (ETHERHOSTNAME
66776Q . 73065Q) (ETHERHOSTNUMBER 73067Q . 73622Q) (ETHERPORT 73624Q . 76304Q) (BESTPUPADDRESS 76306Q
. 103401Q) (NETDAYTIME0 103403Q . 103742Q) (\PUP.SETTIME 103744Q . 106730Q) (\SETNEWTIME0 106732Q .
107663Q) (\NET.SETTIME 107665Q . 110631Q) (NETDATE 110633Q . 111131Q) (\LOOKUPPORT 111133Q . 114156Q)
(\PARSE.PORTCONSTANT 114160Q . 116337Q) (\FIXLOCALNET 116341Q . 117450Q)) (117522Q 132533Q (CLEARPUP
117534Q . 121052Q) (PUTPUPWORD 121054Q . 121402Q) (GETPUPBYTE 121404Q . 121725Q) (PUTPUPBYTE 121727Q
. 122256Q) (GETPUPSTRING 122260Q . 123417Q) (GETPUPSTREAM 123421Q . 124245Q) (PUTPUPSTRING 124247Q .
124755Q) (READPLIST 124757Q . 131050Q) (\STOREPLIST 131052Q . 132531Q)) (133730Q 136524Q (
\CANONICAL.HOSTNAME 133742Q . 136121Q) (CANONICAL.HOSTNAME 136123Q . 136522Q)) (140636Q 160754Q (
\PUPGATELISTENER 140650Q . 143304Q) (\HANDLE.PUP.ROUTING.INFO 143306Q . 147703Q) (\ROUTE.PUP 147705Q
. 152704Q) (\LOCATE.PUPNET 152706Q . 155617Q) (SORT.PUPHOSTS.BY.DISTANCE 155621Q . 157240Q) (
\PUPNET.CLOSERP 157242Q . 160171Q) (PUPNET.DISTANCE 160173Q . 160752Q)) (166442Q 175026Q (
OPENPUPSOCKET 166454Q . 171662Q) (CLOSEPUPSOCKET 171664Q . 173245Q) (PUPSOCKETNUMBER 173247Q . 173477Q
) (PUPSOCKETFROMNUMBER 173501Q . 174120Q) (PUPSOCKETEVENT 174122Q . 174406Q) (\FLUSHPUPSOCQUEUE
174410Q . 175024Q)) (175027Q 175661Q (\GETMISCSOCKET 175041Q . 175657Q)) (214615Q 223364Q (
PUP.ECHOSERVER 214627Q . 216552Q) (PUP.ECHOUSER 216554Q . 223362Q)) (223411Q 227432Q (\PEEKPUP 223423Q
. 226157Q) (\MAYBEPEEKPUP 226161Q . 227430Q)) (230023Q 242002Q (PRINTPUP 230035Q . 233367Q) (
PRINTPUPROUTE 233371Q . 235100Q) (PRINTPUPDATA 235102Q . 235516Q) (PRINTERRORPUP 235520Q . 236203Q) (
PUPTRACE 236205Q . 237652Q) (\CHANGE.ETHER.TRACING 237654Q . 241037Q) (PRINTCONSTANT 241041Q . 242000Q
)) (242641Q 244076Q (PORTSTRING 242653Q . 243543Q) (OCTALSTRING 243545Q . 244074Q)) (244077Q 245263Q (
\CENTICLOCK 244111Q . 245261Q)) (246102Q 253131Q (MAILWATCHER 246114Q . 250506Q) (MAILCHECK 250510Q .
253127Q)) (253645Q 300045Q (EFTP 253657Q . 273213Q) (\ABORT.EFTP 273215Q . 274071Q) (
PUP.PRINTER.STATUS 274073Q . 276171Q) (PUP.PRINTER.PROPERTIES 276173Q . 300043Q)))))
STOP