Trailing-Edge
-
PDP-10 Archives
-
-
There are no other files named in the archive.
(FILECREATED "16-May-82 22:31:43" <MASINTER>PUP10.;2 64357Q
changes to: \SENDPUP
previous date: "29-AUG-81 17:18:56" <MASINTER>PUP10.;1)
(PRETTYCOMPRINT PUP10COMS)
(RPAQQ PUP10COMS ((E (RESETSAVE (RADIX 10Q)))
(FNS ETHERPORT \LOCALHOSTNUMBER \SETUPPUP \FILLPUPSOURCE
\EXCHANGEPUPS \GETPUP \SENDPUP)
(COMS (* Accessing a PUP's contents)
(FNS \CLEARPUP \GETPUPWORD \PUTPUPWORD \GETPUPBYTE
\PUTPUPBYTE \GETPUPSTRING \PUTPUPSTRING \GETSTRING
\PUTSTRING OCTALSTRING))
(P (MOVD (QUOTE NILL)
(QUOTE \SETLOCALHOST?)))
(COMS (* Sockets)
(FNS \CREATESOCKET \FLUSHSOCKET \GETMISCSOCKET))
(COMS (* PUP allocation)
(FNS \ALLOCATE.PUP \CREATE.PUP \RELEASE.PUP)
(GLOBALVARS \FREEPUPS)
(VARS (\FREEPUPS))
(MACROS BINDPUPS)
(PROP INFO BINDPUPS)
(ALISTS (PRETTYPRINTMACROS BINDPUPS)))
(GLOBALVARS \MISC.SOCKET \PUPSOCKETS \ETHERPORTS \LOCALHOST
\PUPCOUNTER)
(RECORDS PUP10 8BITBYTES)
(GLOBALVARS \ETHERWAIT1 \ETHERWAIT2 \MAXETHERTRIES PUPTRACEFLG)
(CONSTANTS (\PUPOVLEN 26Q)
(\MAX.PUPLENGTH 1024Q)
(\TIME.GETPUP 5))
(CONSTANTS * PUPCONSTANTS)
(DECLARE: DONTCOPY (RECORDS PORT SOCKET)
(MACROS PUPTRACING))
(VARS (PUPTRACEFLG (QUOTE %.))
(\ETHERPORTS (LIST (HARRAY 24Q)))
(\PUPSOCKETS)
(\MISC.SOCKET)
(\LOCALHOST)
(\ETHERWAIT1 17Q)
(\ETHERWAIT2 3720Q)
(\MAXETHERTRIES 4)
(\PUPCOUNTER 0))
[ADDVARS (AFTERSYSOUTFORMS (CLRHASH \ETHERPORTS)
(SETQ \PUPSOCKETS (SETQ \LOCALHOST]
(FNS PRINTPUP PUPTRACING)
(COMS (* Raw network facilities)
(FNS REMOTEMAILCHECK ETHERHOSTNAME ETHERHOSTNUMBER
\LOOKUPPORT))
(DECLARE: EVAL@COMPILE DONTCOPY (FILES (SYSLOAD FROM VALUEOF
LISPUSERSDIRECTORIES)
CJSYS))))
(DEFINEQ
(ETHERPORT
[LAMBDA (NAME ERRORFLG) (* bvm: "17-APR-81 22:07")
(* * Returns net address of NAME as (nethost . socket). Caches results locally so doesn't have to look all the time.
If ERRORFLG is true, generates error on failure.)
(COND
([OR (FIXP NAME)
(AND (LISTP NAME)
(FIXP (CAR NAME))
(FIXP (CDR NAME]
NAME)
((OR (GETHASH NAME \ETHERPORTS)
(PUTHASH NAME [PROG (NETHOST SOCKET)
(RETURN (ASSEMBLE NIL
(CQ (CONCAT NAME (CHARACTER 0)))
(FASTCALL UPATM)
(MOVE 1 , 3)
(SKIPA 2 , * 1)
(XWD 400002Q 4)
(* Specifies: name lookup, result to go in "table"
starting at 4 for length 2)
(JS PUPNM)
(JRST ERROR)
(PUSHN 5)
(* save socket number)
(HRRZ 1 , 4)
(* Net,,host)
(LSH 4 , -12Q)
(* Shift net number into second 8-bit byte)
(IOR 1 , 4)
(* now have net,host in 20Q bits)
[CQ (SETQ NETHOST (LOC (AC]
(POPN 1)
(CQ (SETQ SOCKET (LOC (AC)))
(CONS NETHOST SOCKET))
(* default socket = 0 for everyone)
(SKIPA)
ERROR
(MOVE 1 , KNIL]
\ETHERPORTS)))
(ERRORFLG (ERROR "host not found" NAME])
(\LOCALHOSTNUMBER
[LAMBDA NIL (* bvm: "17-APR-81 23:23")
(CAR (ETHERPORT HOSTNAME])
(\SETUPPUP
[LAMBDA (PUP DESTHOST DESTSOCKET TYPE ID SOC) (* bvm: "29-AUG-81 17:14")
(* 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)
(* * SOC is ignored in this implementation)
(OR PUP (SETQ PUP (\CREATE.PUP)))
(replace PUPLENGTH of PUP with \PUPOVLEN) (* pup data initially empty)
(replace PUPTYPE of PUP with TYPE)
[replace PUPID of PUP with (OR ID (SETQ \PUPCOUNTER (COND
((IGEQ \PUPCOUNTER 2000Q)
1)
(T (ADD1 \PUPCOUNTER]
(replace DEST of PUP with (OR (FIXP (SETQ DESTHOST (ETHERPORT DESTHOST T)))
(CAR DESTHOST)))
(replace DESTSKT of PUP with (COND
([AND (LISTP DESTHOST)
(NOT (ZEROP (CDR DESTHOST]
(CDR DESTHOST))
(T DESTSOCKET))) (* Jsys PUPO will fill in source port for us, so don't need
to do that)
SOC])
(\FILLPUPSOURCE
[LAMBDA (PUP SOCKET) (* bvm: " 5-MAY-81 22:53")
(* Noop--tenex does this for us)
NIL])
(\EXCHANGEPUPS
[LAMBDA (SOC OUTPUP INPUP IDFILTER TIMEOUT WAITTIME)
(* lmm " 4-AUG-81 21: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 INPUP on success, or NIL on failure. TIMEOUT overrides the default timeout.
WAITTIME is how long to wait between peeks at the ether)
(OR TIMEOUT (SETQ TIMEOUT \ETHERWAIT2))
(OR WAITTIME (SETQ WAITTIME \ETHERWAIT1))
(repeatwhile (\GETPUP SOC INPUP))
(* Flush any pups waiting on this socket)
(\SENDPUP SOC OUTPUP)
(DISMISS WAITTIME)
(bind WAITED_0 do (COND
[(\GETPUP SOC INPUP)
(COND
((OR (NOT IDFILTER)
(IEQP (fetch PUPID of INPUP)
(fetch PUPID of OUTPUP)))
(RETURN INPUP]
(T (COND
((IGREATERP (add WAITED WAITTIME \TIME.GETPUP)
TIMEOUT)
(RETURN NIL))
(T (DISMISS WAITTIME])
(\GETPUP
[LAMBDA (SOC PUP WAIT) (* bvm: "29-AUG-81 17:18")
(PROG ((RESULT (JS PUPI (XWD (COND ((NOT WAIT)
400000Q)
(T 0))
(OPNJFN (OR SOC (\GETMISCSOCKET))))
(XWD (CONSTANT MaxPupWords)
(LOC (OR PUP (ERROR "PUP not supplied to \GETPUP!"))))
NIL T)))
(SELECTQ PUPTRACEFLG
[(T LEAF)
(COND
[RESULT (PRIN1 "\GETPUP:
" T)
(COND
((EQ PUPTRACEFLG (QUOTE LEAF))
(PRINTLEAF PUP))
(T (PRINTPUP PUP]
(T (PRIN1 (QUOTE -)
T]
(PEEK (PRIN1 (COND
(RESULT (QUOTE +))
(T (QUOTE -)))
T))
NIL)
(RETURN (AND RESULT PUP))
(RETURN RESULT])
(\SENDPUP
[LAMBDA (SOC PUP) (* edited:
"16-May-82 22:27")
(OR PUP (ERROR "Pup not supplied to \SENDPUP"))
(replace SOURCESKT of PUP with 0)
(replace SOURCE of PUP with (ETHERHOSTNUMBER))
(OR SOC (SETQ SOC (\GETMISCSOCKET)))
(OR (JS PUPO (XWD 200000Q (OPNJFN SOC))
(XWD (CONSTANT MaxPupWords)
(LOC PUP))
NIL T)
(ERROR (ERSTR)))
(SELECTQ PUPTRACEFLG
[(T LEAF)
(PRIN1 "\SENDPUP:
" T)
(COND
((EQ PUPTRACEFLG (QUOTE LEAF))
(PRINTLEAF PUP))
(T (PRINTPUP PUP]
(PEEK (PRIN1 (QUOTE !)
T))
NIL])
)
(* Accessing a PUP's contents)
(DEFINEQ
(\CLEARPUP
[LAMBDA (PUP) (* bvm: "11-AUG-81 18:13")
(ASSEMBLE NIL
(CQ PUP)
(HRLI 1 , -213Q)
LP (SETZM 0 (1))
(AOBJN 1 , LP])
(\GETPUPWORD
[LAMBDA (PUP WORD#) (* bvm: "11-AUG-81 18:26")
(PROG [(BASE (WORDOFFSET PUP (IPLUS (LRSH WORD# 1)
5]
(RETURN (COND
((ZEROP (LOGAND WORD# 1))
(fetch WORD0 of BASE))
(T (fetch WORD1 of BASE])
(\PUTPUPWORD
[LAMBDA (PUP WORD# VALUE) (* bvm: "11-AUG-81 18:26")
(PROG [(BASE (WORDOFFSET PUP (IPLUS (LRSH WORD# 1)
5]
(RETURN (COND
((ZEROP (LOGAND WORD# 1))
(replace WORD0 of BASE with VALUE))
(T (replace WORD1 of BASE with VALUE])
(\GETPUPBYTE
[LAMBDA (PUP BYTE#) (* bvm: "11-AUG-81 18:26")
(PROG [(BASE (WORDOFFSET PUP (IPLUS (LRSH BYTE# 2)
5]
(RETURN (SELECTQ (LOGAND BYTE# 3)
(0 (fetch BYTE0 of BASE))
(1 (fetch BYTE1 of BASE))
(2 (fetch BYTE2 of BASE))
(3 (fetch BYTE3 of BASE))
(SHOULDNT])
(\PUTPUPBYTE
[LAMBDA (PUP BYTE# VALUE) (* bvm: "11-AUG-81 18:26")
(PROG [(BASE (WORDOFFSET PUP (IPLUS (LRSH BYTE# 2)
5]
(RETURN (SELECTQ (LOGAND BYTE# 3)
(0 (replace BYTE0 of BASE with VALUE))
(1 (replace BYTE1 of BASE with VALUE))
(2 (replace BYTE2 of BASE with VALUE))
(3 (replace BYTE3 of BASE with VALUE))
(SHOULDNT])
(\GETPUPSTRING
[LAMBDA (PUP OFFSET) (* bvm: " 5-MAY-81 16:19")
(\GETSTRING (fetch PUPCONTENTS of PUP)
(OR OFFSET (SETQ OFFSET 0))
(IDIFFERENCE (IDIFFERENCE (fetch PUPLENGTH of PUP)
\PUPOVLEN)
OFFSET])
(\PUTPUPSTRING
[LAMBDA (PUP STR) (* bvm: " 5-MAY-81 16:19")
(add (fetch PUPLENGTH of PUP)
(\PUTSTRING (fetch PUPCONTENTS of PUP)
(IDIFFERENCE (fetch PUPLENGTH of PUP)
\PUPOVLEN)
STR])
(\GETSTRING
[LAMBDA (BASE OFFSET LENGTH) (* bvm: "17-APR-81 23:06")
(* * reads a string starting at BASE, byte OFFSET for LENGTH number of bytes)
(SETQ BASE (WORDOFFSET BASE (IQUOTIENT OFFSET 4)))
(SETQ OFFSET (IREMAINDER OFFSET 4))
(ASSEMBLE NIL
(FASTCALL MKSTRS))
(from 1 to LENGTH do (ASSEMBLE NIL
[CQ (VAG (FIX (SELECTQ OFFSET
(0 (fetch BYTE0 of BASE))
(1 (fetch BYTE1 of BASE))
(2 (fetch BYTE2 of BASE))
(3 (fetch BYTE3 of BASE))
(SHOULDNT]
(SUBI 1 , ASZ)
(FASTCALL MKSTR1) (* append char to string)
)
[SETQ OFFSET (COND
((EQ OFFSET 3)
(SETQ BASE (WORDOFFSET BASE 1))
0)
(T (ADD1 OFFSET]
finally (RETURN (ASSEMBLE NIL
(MOVE 1 , UNP1)
(FASTCALL MKSP])
(\PUTSTRING
[LAMBDA (BASE OFFSET STR) (* bvm: "18-APR-81 00:02")
(* * Write string/atom STR at BASE plus byte OFFSET. Returns number of bytes written)
(SETQ BASE (WORDOFFSET BASE (IQUOTIENT OFFSET 4)))
(SETQ OFFSET (IREMAINDER OFFSET 4))
[for CHAR in (DCHCON STR CHCONLST1) do (SELECTQ OFFSET
(0 (replace BYTE0 of BASE with CHAR))
(1 (replace BYTE1 of BASE with CHAR))
(2 (replace BYTE2 of BASE with CHAR))
(3 (replace BYTE3 of BASE with CHAR))
(SHOULDNT))
(SETQ OFFSET (COND
((EQ OFFSET 3)
(SETQ BASE (WORDOFFSET BASE 1))
0)
(T (ADD1 OFFSET]
(NCHARS STR])
(OCTALSTRING
[LAMBDA (N) (* lmm "30-MAY-78 19:42")
(* converts a number to a string of the octal representation
of it)
(PROG ((J -1)
(S (CONSTANT (CONCAT "000000000000")))
(M N))
LP (RPLSTRING S J (LOGAND M 7))
(COND
([NOT (ZEROP (SETQ M (LRSH M 3]
(SUB1VAR J)
(GO LP)))
(RETURN (COND
((EQ J -1)
N)
(T (CONCAT (SUBSTRING S J -1 (CONSTANT (CONCAT])
)
(MOVD (QUOTE NILL)
(QUOTE \SETLOCALHOST?))
(* Sockets)
(DEFINEQ
(\CREATESOCKET
[LAMBDA (LOCALSOCKET#) (* bvm: " 5-MAY-81 18:40")
(* Create a local socket on which to send/receive raw pups.
If LOCALSOCKET# is omitted, it is defaulted by system)
(PROG [(PACKETFILE (OPENFILE (COND
(LOCALSOCKET# (* absolute socket chosen)
(PACK* (QUOTE PUP:)
(CONCAT (OCTAL LOCALSOCKET#)
"!A")))
(T (QUOTE PUP:!J)))
(QUOTE BOTH)
NIL 10Q (QUOTE ((MODE 16Q]
(WHENCLOSE PACKETFILE (QUOTE CLOSEALL)
(QUOTE NO))
(SETQ \PUPSOCKETS (CONS PACKETFILE \PUPSOCKETS))
(RETURN PACKETFILE])
(\FLUSHSOCKET
[LAMBDA (SOC) (* bvm: "17-APR-81 22:42")
(* Closes a local socket. Soc=T means close all sockets)
(COND
[(EQ SOC T)
(while \PUPSOCKETS do (CLOSEF (CAR \PUPSOCKETS))
(SETQ \PUPSOCKETS (CDR \PUPSOCKETS]
((MEMB SOC \PUPSOCKETS)
(SETQ \PUPSOCKETS (DREMOVE SOC \PUPSOCKETS))
(CLOSEF SOC))
(T (ERROR SOC "not an open socket"])
(\GETMISCSOCKET
[LAMBDA NIL (* bvm: "10-FEB-81 11:41")
(* 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 (\CREATESOCKET])
)
(* PUP allocation)
(DEFINEQ
(\ALLOCATE.PUP
[LAMBDA NIL (* bvm: " 5-MAY-81 16:52")
(* Returns a PUP, either new or recycled from the heap of
pups that have been given to \RELEASE.PUP)
(OR (pop \FREEPUPS)
(\CREATE.PUP])
(\CREATE.PUP
[LAMBDA (DUMMY) (* bvm: " 5-MAY-81 16:50")
(create PUP10])
(\RELEASE.PUP
[LAMBDA (PUP) (* bvm: " 5-MAY-81 16:53")
(AND PUP (push \FREEPUPS PUP))
NIL])
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \FREEPUPS)
)
(RPAQQ \FREEPUPS NIL)
(DECLARE: EVAL@COMPILE
(PUTPROPS BINDPUPS MACRO [X
(CONS [LIST (QUOTE LAMBDA)
(CAR X)
(CONS (QUOTE PROG1)
(CONS (CONS (QUOTE PROGN)
(CDR X))
(for PUP in (CAR X)
collect (LIST (QUOTE
\RELEASE.PUP)
PUP]
(in (CAR X) collect (LIST (QUOTE \ALLOCATE.PUP])
)
(PUTPROPS BINDPUPS INFO BINDS)
(ADDTOVAR PRETTYPRINTMACROS (BINDPUPS LAMBDA
(FORM)
(PROG [(POS (IPLUS 2 (POSITION]
(PRIN1 "(")
(PRIN2 (CAR FORM))
(SPACES 1)
(PRINTDEF (CADR FORM)
(POSITION))
(OR [EQ COMMENTFLG
(CAAR (SETQ FORM
(CDDR FORM]
(TAB POS 0))
(PRINTDEF FORM POS T T FNSLST)
(PRIN1 ")"))))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \MISC.SOCKET \PUPSOCKETS \ETHERPORTS \LOCALHOST
\PUPCOUNTER)
)
[DECLARE: EVAL@COMPILE
(BLOCKRECORD PUP10 ((PUPLENGTH BITS 20Q)
(TCONTROL BITS 10Q)
(PUPTYPE BITS 10Q)
(PUPID BITS 40Q)
(DEST BITS 20Q)
(DESTSKTHI BITS 20Q)
(DESTSKTLO BITS 20Q)
(SOURCE BITS 20Q)
(SOURCESKTHI BITS 20Q)
(SOURCESKTLO BITS 20Q))
[ACCESSFNS ((PUPCONTENTS (WORDOFFSET DATUM 5))
(SOURCESKT (LOGOR (LLSH (fetch SOURCESKTHI
of DATUM)
20Q)
(fetch SOURCESKTLO
of DATUM))
(PROGN (replace SOURCESKTHI
of DATUM
with (LRSH NEWVALUE 20Q))
(replace SOURCESKTLO
of DATUM
with (LOGAND NEWVALUE
177777Q))
NEWVALUE))
(DESTSKT (LOGOR (LLSH (fetch DESTSKTHI
of DATUM)
20Q)
(fetch DESTSKTLO of DATUM))
(PROGN (replace DESTSKTHI
of DATUM
with (LRSH NEWVALUE 20Q))
(replace DESTSKTLO
of DATUM
with (LOGAND NEWVALUE
177777Q))
NEWVALUE]
(CREATE (WORDOFFSET (ARRAY 213Q 213Q)
2)) (* This is the PUP10
format straight out of
the document)
)
(BLOCKRECORD 8BITBYTES ((BYTE0 BITS 10Q)
(BYTE1 BITS 10Q)
(BYTE2 BITS 10Q)
(BYTE3 BITS 10Q)) (* used to refer to the
bytes in a PDP-10 word
right-justified)
(BLOCKRECORD 8BITBYTES ((WORD0 BITS 20Q)
(WORD1 BITS 20Q))))
]
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \ETHERWAIT1 \ETHERWAIT2 \MAXETHERTRIES PUPTRACEFLG)
)
(DECLARE: EVAL@COMPILE
(RPAQQ \PUPOVLEN 26Q)
(RPAQQ \MAX.PUPLENGTH 1024Q)
(RPAQQ \TIME.GETPUP 5)
(CONSTANTS (\PUPOVLEN 26Q)
(\MAX.PUPLENGTH 1024Q)
(\TIME.GETPUP 5))
)
(RPAQQ PUPCONSTANTS ((MaxPupWords 206Q)
(\PUPHEADERLEN 24Q)
(\PUPPAGELEN 1000Q)
(\NetMask 177400Q)
(\HILOCALSOCKET 1)
(\SOCKET.MISCSERVICES 4)
(\PT.NAMELOOKUP 220Q)
(\PT.NAMERESPONSE 221Q)
(\PT.ADDRLOOKUP 223Q)
(\PT.ADDRRESPONSE 224Q)
(\PT.NAME/ADDRERROR 222Q)
(\PT.MSGCHECK 210Q)
(\PT.LAURELCHECK 214Q)
(\PT.NEWMAIL 211Q)
(\PT.NONEWMAIL 212Q)
(\PT.NOMAILBOX 213Q)
(\PT.ALTOTIMEREQ 206Q)
(\PT.ALTOTIMERESPONSE 207Q)
(\PT.STRINGTIMEREQ 200Q)
(\PT.STRINGTIMERESPONSE 201Q)))
(DECLARE: EVAL@COMPILE
(RPAQQ MaxPupWords 206Q)
(RPAQQ \PUPHEADERLEN 24Q)
(RPAQQ \PUPPAGELEN 1000Q)
(RPAQQ \NetMask 177400Q)
(RPAQQ \HILOCALSOCKET 1)
(RPAQQ \SOCKET.MISCSERVICES 4)
(RPAQQ \PT.NAMELOOKUP 220Q)
(RPAQQ \PT.NAMERESPONSE 221Q)
(RPAQQ \PT.ADDRLOOKUP 223Q)
(RPAQQ \PT.ADDRRESPONSE 224Q)
(RPAQQ \PT.NAME/ADDRERROR 222Q)
(RPAQQ \PT.MSGCHECK 210Q)
(RPAQQ \PT.LAURELCHECK 214Q)
(RPAQQ \PT.NEWMAIL 211Q)
(RPAQQ \PT.NONEWMAIL 212Q)
(RPAQQ \PT.NOMAILBOX 213Q)
(RPAQQ \PT.ALTOTIMEREQ 206Q)
(RPAQQ \PT.ALTOTIMERESPONSE 207Q)
(RPAQQ \PT.STRINGTIMEREQ 200Q)
(RPAQQ \PT.STRINGTIMERESPONSE 201Q)
(CONSTANTS (MaxPupWords 206Q)
(\PUPHEADERLEN 24Q)
(\PUPPAGELEN 1000Q)
(\NetMask 177400Q)
(\HILOCALSOCKET 1)
(\SOCKET.MISCSERVICES 4)
(\PT.NAMELOOKUP 220Q)
(\PT.NAMERESPONSE 221Q)
(\PT.ADDRLOOKUP 223Q)
(\PT.ADDRRESPONSE 224Q)
(\PT.NAME/ADDRERROR 222Q)
(\PT.MSGCHECK 210Q)
(\PT.LAURELCHECK 214Q)
(\PT.NEWMAIL 211Q)
(\PT.NONEWMAIL 212Q)
(\PT.NOMAILBOX 213Q)
(\PT.ALTOTIMEREQ 206Q)
(\PT.ALTOTIMERESPONSE 207Q)
(\PT.STRINGTIMEREQ 200Q)
(\PT.STRINGTIMERESPONSE 201Q))
)
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(BLOCKRECORD PORT ((NETHOST BITS 20Q)
(SOCKET0 BITS 20Q)
(SOCKET1 BITS 20Q))
(ACCESSFNS (SOCKET (LOGOR (LLSH (fetch SOCKET0
of DATUM)
20Q)
(fetch SOCKET1
of DATUM))
(PROGN (replace SOCKET0
of DATUM
with (LRSH NEWVALUE 20Q))
(replace SOCKET1
of DATUM
with (LOGAND NEWVALUE
177777Q))
NEWVALUE))))
(RECORD SOCKET (SOCKET# . SOCKETHANDLE))
]
(DECLARE: EVAL@COMPILE
(PUTPROPS PUPTRACING MACRO [NIL (AND PUPTRACEFLG (NEQ PUPTRACEFLG
(QUOTE %.])
)
)
(RPAQQ PUPTRACEFLG %.)
(RPAQ \ETHERPORTS (LIST (HARRAY 24Q)))
(RPAQQ \PUPSOCKETS NIL)
(RPAQQ \MISC.SOCKET NIL)
(RPAQQ \LOCALHOST NIL)
(RPAQQ \ETHERWAIT1 17Q)
(RPAQQ \ETHERWAIT2 3720Q)
(RPAQQ \MAXETHERTRIES 4)
(RPAQQ \PUPCOUNTER 0)
(ADDTOVAR AFTERSYSOUTFORMS (CLRHASH \ETHERPORTS)
(SETQ \PUPSOCKETS (SETQ \LOCALHOST)))
(DEFINEQ
(PRINTPUP
[LAMBDA (PUP) (* bvm: " 5-MAY-81 18:36")
(PROG (PORT)
(printout T "From " (LRSH (SETQ PORT (fetch SOURCE of PUP))
10Q)
"#"
(LOGAND PORT 377Q)
"#"
(fetch SOURCESKT of PUP)
" to "
(LRSH (SETQ PORT (fetch DEST of PUP))
10Q)
"#"
(LOGAND PORT 377Q)
"#"
(fetch DESTSKT of PUP)
T "Length = " (fetch PUPLENGTH of PUP)
" bytes" " (header + " (IDIFFERENCE (fetch PUPLENGTH of PUP)
\PUPOVLEN)
")" T "Type = " (fetch PUPTYPE of PUP)
", ID = "
(fetch PUPID of PUP)
T)
(COND
((NEQ (fetch TCONTROL of PUP)
0)
(printout T "Transport control = " (fetch TCONTROL of PUP)
T)))
(TERPRI T)
PUP])
(PUPTRACING
[LAMBDA NIL (* bvm: "20-FEB-81 20:44")
(* True if we are doing a high enough level of tracing. PUPTRACEFLG can be -
NIL: no tracing at all -
.: (dot) print dots sometimes to show progress -
PEEK: print ! for each pup sent, + for each pup received, "-" for each failed \READPUP -
T: most general tracing, printing contents of each pup sent and received)
(AND PUPTRACEFLG (NEQ PUPTRACEFLG (QUOTE %.])
)
(* Raw network facilities)
(DEFINEQ
(REMOTEMAILCHECK
[LAMBDA (USER HOST LAURELFLG) (* bvm: " 5-MAY-81 16:48")
(* * Does a mail check for USER on machine HOST, returning NIL or a string describing the new mail.
LAURELFLG is true for Laurel-style mailcheck.)
(PROG ((HOSTPORT (ETHERPORT (OR HOST (QUOTE MAXC2))
T))
(IPUP (\ALLOCATE.PUP))
(OPUP (\ALLOCATE.PUP))
(SOC (\GETMISCSOCKET))
RESULT)
(OR USER (SETQ USER USERNAME))
(\SETUPPUP OPUP HOSTPORT \SOCKET.MISCSERVICES (COND
(LAURELFLG \PT.LAURELCHECK)
(T \PT.MSGCHECK))
NIL SOC)
(\PUTPUPSTRING OPUP USER)
[to \MAXETHERTRIES when (\EXCHANGEPUPS SOC OPUP IPUP 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))
NIL)
finally (COND
((PUPTRACING)
(printout T "Mail check timed out" T]
(\RELEASE.PUP IPUP)
(\RELEASE.PUP OPUP)
(RETURN RESULT])
(ETHERHOSTNAME
[LAMBDA (PORT) (* bvm: "27-APR-81 22:01")
(* * Looks up the name of the host at address PORT. PORT may be a numeric address, or (host . socket) as returned by
ETHERPORT)
(PROG ([NETHOST (COND
((FIXP PORT)
(COND
((ILESSP PORT 400Q) (* Net not specified, default to local net)
(LOGOR (LOGAND (\LOCALHOSTNUMBER)
\NetMask)
PORT))
(T PORT)))
((NULL PORT)
(\LOCALHOSTNUMBER))
((CAR (LISTP PORT)))
(T (LISPERROR "ILLEGAL ARG" PORT]
(OPUP (\ALLOCATE.PUP))
(IPUP (\ALLOCATE.PUP))
(SOC (\GETMISCSOCKET))
RESULT BUF)
(\SETUPPUP OPUP 0 \SOCKET.MISCSERVICES \PT.ADDRLOOKUP NIL SOC)
(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 (OR (CDR (LISTP PORT))
0))
[to \MAXETHERTRIES when (\EXCHANGEPUPS SOC OPUP IPUP T)
do (\SETLOCALHOST?)
(SELECTC (fetch PUPTYPE of IPUP)
[\PT.ADDRRESPONSE (RETURN (SETQ RESULT (MKATOM (\GETPUPSTRING IPUP]
(\PT.NAME/ADDRERROR (COND
((PUPTRACING)
(printout T "Address lookup error for " PORT ": "
(\GETPUPSTRING IPUP)
T)))
(RETURN))
NIL)
finally (COND
((PUPTRACING)
(printout T "Address lookup timed out" T]
(\RELEASE.PUP IPUP)
(\RELEASE.PUP OPUP)
(RETURN RESULT])
(ETHERHOSTNUMBER
[LAMBDA (NAME) (* bvm: "20-FEB-81 20:17")
(COND
((NULL NAME)
(\LOCALHOSTNUMBER))
(T (CAR (ETHERPORT NAME])
(\LOOKUPPORT
[LAMBDA (NAME) (* bvm: "27-APR-81 22:01")
(* * Looks up the ether address of NAME, returning a dotted pair (nethost . socket) or NIL on failure)
(PROG ((IPUP (\ALLOCATE.PUP))
(OPUP (\ALLOCATE.PUP))
(SOC (\GETMISCSOCKET))
RESULT BUF)
(\SETUPPUP OPUP 0 \SOCKET.MISCSERVICES \PT.NAMELOOKUP NIL SOC)
(\PUTPUPSTRING OPUP NAME)
[to \MAXETHERTRIES when (\EXCHANGEPUPS SOC OPUP IPUP T)
do (\SETLOCALHOST? IPUP)
(SELECTC (fetch PUPTYPE of IPUP)
[\PT.NAMERESPONSE [COND
((IGREATERP (IDIFFERENCE (fetch PUPLENGTH of IPUP)
\PUPOVLEN)
6)
(COND
((PUPTRACING)
(printout T "Multiple response received for " NAME
T]
(RETURN (SETQ RESULT
(CONS (fetch (PORT NETHOST)
of (SETQ BUF
(fetch PUPCONTENTS of IPUP)))
(fetch (PORT SOCKET) of BUF]
(\PT.NAME/ADDRERROR (COND
((PUPTRACING)
(printout T "Name lookup error for " NAME ": "
(\GETPUPSTRING IPUP)
T)))
(RETURN))
(HELP))
finally (COND
((PUPTRACING)
(printout T "Name lookup timed out" T]
(\RELEASE.PUP IPUP)
(\RELEASE.PUP OPUP)
(RETURN RESULT])
)
(DECLARE: EVAL@COMPILE DONTCOPY
(FILESLOAD (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES)
CJSYS)
)
(DECLARE: DONTCOPY
(FILEMAP (NIL (3502Q 16724Q (ETHERPORT 3516Q . 7107Q) (\LOCALHOSTNUMBER
7113Q . 7340Q) (\SETUPPUP 7344Q . 11472Q) (\FILLPUPSOURCE 11476Q . 12020Q
) (\EXCHANGEPUPS 12024Q . 14137Q) (\GETPUP 14143Q . 15525Q) (\SENDPUP
15531Q . 16721Q)) (16776Q 30166Q (\CLEARPUP 17012Q . 17336Q) (
\GETPUPWORD 17342Q . 20025Q) (\PUTPUPWORD 20031Q . 20556Q) (\GETPUPBYTE
20562Q . 21376Q) (\PUTPUPBYTE 21402Q . 22322Q) (\GETPUPSTRING 22326Q .
22771Q) (\PUTPUPSTRING 22775Q . 23441Q) (\GETSTRING 23445Q . 25415Q) (
\PUTSTRING 25421Q . 27067Q) (OCTALSTRING 27073Q . 30163Q)) (30300Q 33472Q
(\CREATESOCKET 30314Q . 31641Q) (\FLUSHSOCKET 31645Q . 32635Q) (
\GETMISCSOCKET 32641Q . 33467Q)) (33530Q 34731Q (\ALLOCATE.PUP 33544Q .
34263Q) (\CREATE.PUP 34267Q . 34467Q) (\RELEASE.PUP 34473Q . 34726Q)) (
50003Q 52702Q (PRINTPUP 50017Q . 51656Q) (PUPTRACING 51662Q . 52677Q)) (
52750Q 64156Q (REMOTEMAILCHECK 52764Q . 55270Q) (ETHERHOSTNAME 55274Q .
60673Q) (ETHERHOSTNUMBER 60677Q . 61215Q) (\LOOKUPPORT 61221Q . 64153Q))
)))
STOP