(FILECREATED " 2-Jan-85 12:03:33" {ERIS}<LISPCORE>LIBRARY>EVALSERVER.;21 87454
changes to: (RESOURCES \P4S.SCRATCHLIST \P4S.STR.BYTEPOINTER \PIP.SCRATCHSPTR \GFP.TIMER
\READPUPSTREAM \WRITEPUPSTREAM)
(RECORDS BVM.LOSES.PUPSOCKET)
(MACROS \UNTCONC \ALLOCATE.BIGPUP RECLAIM.PUP RECLAIM.OUTPUT.PUP HOSTNUMBERP
PROBABLYSOCKETP HOST#.FROM.ADDRESS NTWK#.FROM.ADDRESS \ES.LOCALHOSTNUMBER)
(FNS \ES.BSPSENDFORM \ES.BSPSENDFORMPROC)
previous date: " 2-Jan-85 11:06:20" {ERIS}<LISPCORE>STAGING>LIBRARY>EVALSERVER.;31)
(* Copyright (c) 1982, 1983, 1984, 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT EVALSERVERCOMS)
(RPAQQ EVALSERVERCOMS ((LOCALVARS . T)
(FILES (SYSLOAD FROM LISPUSERS)
PLURAL)
(COMS (* "Generally useful utilities")
(FNS PRIN4.INTO.STRING \P4S.FOOT \P4S.PERCHAR \UNTCONC \BOUNDNCHARSP)
(DECLARE: EVAL@COMPILE DONTCOPY (MACROS \FILLINSTRPTR \UNTCONC)
(RESOURCES \P4S.SCRATCHLIST \P4S.STR.BYTEPOINTER))
(INITRESOURCES \P4S.SCRATCHLIST \P4S.STR.BYTEPOINTER))
(COMS (* "Pup/Net assistance")
(DECLARE: EVAL@COMPILE DONTCOPY (MACROS \ALLOCATE.BIGPUP RECLAIM.PUP RECLAIM.OUTPUT.PUP
HOSTNUMBERP PROBABLYSOCKETP HOST#.FROM.ADDRESS
NTWK#.FROM.ADDRESS \ES.LOCALHOSTNUMBER)
(RECORDS BVM.LOSES.PUPSOCKET)
(RESOURCES \PIP.SCRATCHSPTR \GFP.TIMER \READPUPSTREAM \WRITEPUPSTREAM)
(FILES (LOADCOMP)
BSP))
(MACROS #PUPDATABYTES #PUPDATABYTES.LEFT)
(INITRESOURCES \PIP.SCRATCHSPTR \GFP.TIMER \READPUPSTREAM \WRITEPUPSTREAM)
(FNS READ.FROM.PUP PRINT.INTO.PUP \HNM.MEMBER \NORMALIZEHOSTNUM
\BROADCASTADDRESS.ON.MYNET \GETFILTEREDPUP \SENDUNFILTEREDPUP \ES.GETSOCKET
\ES.RECLAIM.PUP \ES.RELEASE.OUTPUT.PUP)
(FNS \ES.BSPREAD \ES.BSPSENDFORM \ES.BSPSENDFORMPROC)
(GLOBALVARS \PUPSOCKETS \LOCALPUPNETHOST \FREE.PACKET.QUEUE))
(DECLARE: EVAL@COMPILE DONTCOPY (RECORDS TRANSACTIONNOTE)
(MACROS TYPE\ID.OF.PUP? CONNECTIONIDP TRACEAPUP 1BYTETOPUP
\BROADCASTADDRESS.ON.MYNET))
(VARS (\BROADCASTADDRESS.ON.MYNET NIL))
(DECLARE: EVAL@COMPILE DONTCOPY (CONSTANTS (TOOBIGPASSWORD 43690))
(CONSTANTS (\SOCKET#.EVALREQUEST 668)
(\PT.EVALREQUEST 200)
(\PT.ACKNOWLEDGE 201)
(\PT.EVALRESPONSE 202)
(\PT.EVALREQUEST.NORESULT 203)
(\PT.EVALERROR 204)
(\PT.EVALREQUEST.CERTIFY 205)))
(INITVARS (EvalServerClientHosts NIL)
(EvalServerGaggedHosts (QUOTE (T)))
(\EVALREQUEST.SOCKET NIL)
(\ES.TTYWINDOW NIL)
(\ES.TTYWINDOWSTREAM NIL)
(\ES.MESSAGESTREAM NIL)
(\ES.PURGEINTERVAL.SECS 180)
(\ES.PENDINGSERVICES NIL)
(\ES.COMPLETEDSERVICES NIL)
(\PUPINQUEUE NIL)
(\PUPINQUEUE.MAXLENGTH 50)
(\PUPINQUEUE.MAXAGE (TIMES 6 60 1000))
(\ES.LOSTSOCKETSLST NIL)
(\ES.CurrentlyPendingService NIL))
(GLOBALVARS \PUPINQUEUE \PUPINQUEUE.MAXLENGTH \PUPINQUEUE.MAXAGE \EVALREQUEST.SOCKET
\ES.TTYWINDOW \ES.TTYWINDOWSTREAM \ES.MESSAGESTREAM \ES.PURGEINTERVAL.SECS
\ES.COMPLETEDSERVICES \ES.PENDINGSERVICES \ES.LOSTSOCKETSLST
\BROADCASTADDRESS.ON.MYNET)
(FNS REMOTEVAL \ES.SENDREQUEST \ES.CERTIFYBROADWORKER \ES.BSERRORHANDLER \ES.BSPUPHANDLER
\ES.EXITREMOTEVAL \ES.CLOSEOUTSOCKET \ES.UNCACHE REMOTEABORT REMOTEAPPLY \ES.APPLYQQ
EVALSERVER \ES.RESTART \ES.LISTENER \ES.DO1THING \ES.WAITFORCERTIFICATION
\ES.DO1THING.TIMEOUT \ES.ABORTQQ EVALSERVER.ABORT EVALSERVER.STATUS
\ES.MakeClientHostInfo \ES.DELETE1PENDING \ES.ABORTPENDING \ES.PURGEOLDTHINGS)
(P (MOVD? (QUOTE SHOULDNT)
(QUOTE \ES.BSPINFO)))
(COMS (* "Things related to coordination of Broadcast case of REMOTEVAL")
(DECLARE: EVAL@COMPILE DONTCOPY (RECORDS BROADAPNOTE))
(INITVARS (\ES.BroadSweepQ (LIST NIL))
(\ES.BroadAppEVENT (CREATE.EVENT (QUOTE \ES.BroadAppEVENT))))
(GLOBALVARS \ES.BroadSweepQ \ES.BroadAppEVENT \ES.BroadAppSweeper)
(FNS \ES.BroadAppSweeper \ES.AddSweeping \ES.Re-acknowledge.service
\ES.IgnoreApplicants \ES.RejectApplicants \ES.WatchSocket \ES.ApplicantValid?))
(DECLARE: DONTEVAL@LOAD DONTEVAL@COMPILE DOCOPY
(P (MAPC (QUOTE (LOGOUTFORMS SYSOUTFORMS MAKESYSFORMS))
(FUNCTION (LAMBDA (X)
(MAPC (QUOTE ((BEFORE (\ES.UNCACHE))
(AFTER (\ES.RESTART))))
(FUNCTION (LAMBDA
(Y)
(APPLY (QUOTE ADDTOVAR)
(CONS (PACK* (CAR Y)
X)
(CDR Y)))))))))))
(ALISTS (PUPPRINTMACROS 200 202 203 204 205))
(COMS (* "Debugging aids")
(VARS (\ES.TRACE?)
(EVALSERVER.STATUS.WINDOW)
(\ES.LASTSTATUSLIST)
(\ES.IQMENU)
(\ES.RUNMENU)
(\ES.DONEMENU))
(FNS EVALSERVER.TRACE \ES.BUGGERTRACEWINDOW \ES.PRINTRACE)
(FNS EVALSERVER.STATUS.WINDOW \ES.STATUSW.GETITEMS \ES.STATUSW.SELECTEDFN
\ES.STATUSW.HELDFN \ES.INVALIDATE.STATUSW \ES.UPDATE.STATUSW)
(DECLARE: EVAL@COMPILE DONTCOPY (GLOBALVARS \ES.TRACE? EVALSERVER.STATUS.WINDOW
\ES.LASTSTATUSLIST \ES.IQMENU \ES.RUNMENU
\ES.DONEMENU)
(CONSTANTS LIGHTGRAYSHADE FUZZYSHADE)))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA \ES.ABORTQQ \ES.APPLYQQ)
(NLAML \ES.ABORTPENDING \ES.DO1THING \ES.LISTENER \ES.BSPSENDFORMPROC)
(LAMA)))))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS)
)
(FILESLOAD (SYSLOAD FROM LISPUSERS)
PLURAL)
(* "Generally useful utilities")
(DEFINEQ
(PRIN4.INTO.STRING
(LAMBDA (FORM MAX#CHARS.WANTED? OLDSTRING) (* JonL "27-MAY-83 17:51")
(* FORM is someting to be prin4'd, MAX#CHARS.WANTED? if non-NULL is a limit on the permissible number of chars to
be printed, OLDSTRING is a working buffer (NIL means cons one up, otherwise use one supplied by caller))
(DECLARE (SPECVARS OLDSTRING))
(PROG (CHARSLIST)
(if (STRINGP OLDSTRING)
then (SETQ MAX#CHARS.WANTED? (IMIN (ffetch (STRINGP LENGTH) of OLDSTRING)
(OR (SMALLP MAX#CHARS.WANTED?)
MAX.SMALLP)))
else (SETQ OLDSTRING (ALLOCSTRING (if (SMALLPOSP MAX#CHARS.WANTED?)
then MAX#CHARS.WANTED?
else (GLOBALRESOURCE (\P4S.SCRATCHLIST)
(SETQ \P4S.SCRATCHLIST
(DCHCON FORM \P4S.SCRATCHLIST
T))
(SETQ CHARSLIST \P4S.SCRATCHLIST)
)
(ADD1 (SETQ MAX#CHARS.WANTED? (LENGTH CHARSLIST))
)))))
(GLOBALRESOURCE (\P4S.STR.BYTEPOINTER)
(PROG ((P4STRPTR \P4S.STR.BYTEPOINTER)
(BASE (ffetch (STRINGP BASE) of OLDSTRING))
(OFFST (ffetch (STRINGP OFFST) of OLDSTRING))
(LEN (ffetch (STRINGP LENGTH) of OLDSTRING)))
(DECLARE (SPECVARS P4STRPTR))
(* P4STRPTR is used as a byte-pointer into OLDSTRING)
(\FILLINSTRPTR P4STRPTR BASE OFFST LEN)
(\P4S.FOOT FORM CHARSLIST)
(PROG ((#PRINTED (IDIFFERENCE (ffetch (STRINGP OFFST) of P4STRPTR)
OFFST)))
(if (AND (NOT (LISTP FORM))
(ILESSP #PRINTED LEN))
then (\PUTBASEBYTE BASE (IPLUS OFFST #PRINTED)
(CHARCODE SPACE))
(add #PRINTED 1))
(freplace (STRINGP LENGTH) of OLDSTRING with #PRINTED)))))
OLDSTRING))
(\P4S.FOOT
(LAMBDA (FORM CHARSLIST FN) (* JonL "18-JUN-83 16:08")
(* Here's a "foot" to stand on while mapping over the characters in form. A "foot" is needed so that RETFROM can
be used in the limiting case.)
(if CHARSLIST
then (MAPC CHARSLIST (QUOTE \P4S.PERCHAR))
else (\MAPCHARS (QUOTE \P4S.PERCHAR)
FORM T))))
(\P4S.PERCHAR
(LAMBDA (C) (* JonL "18-JUN-83 16:08")
(DECLARE (SPECVARS P4STRPTR))
((LAMBDA (OFFST NEWLEN)
(OR (IGEQ NEWLEN 0)
(RETFROM (QUOTE \P4S.FOOT)))
(\PUTBASEBYTE (ffetch (STRINGP BASE) of P4STRPTR)
OFFST C)
(freplace (STRINGP LENGTH) of P4STRPTR with NEWLEN)
(freplace (STRINGP OFFST) of P4STRPTR with (ADD1 OFFST)))
(ffetch (STRINGP OFFST) of P4STRPTR)
(SUB1 (ffetch (STRINGP LENGTH) of P4STRPTR)))))
(\UNTCONC
(LAMBDA (QUEUE ITEM) (* JonL "31-MAY-83 02:47")
(if (NULL QUEUE)
then NIL
elseif (NLISTP QUEUE)
then (\ILLEGAL.ARG QUEUE)
elseif (NULL (CDR QUEUE))
then (* Darnd QUEUE ought to be empty if it has no last
cell.)
(OR (NULL (CAR QUEUE))
(\ILLEGAL.ARG QUEUE))
NIL
elseif (NLISTP (CAR QUEUE))
then (\ILLEGAL.ARG QUEUE)
else (\MACRO.MX (\UNTCONC QUEUE ITEM)))))
(\BOUNDNCHARSP
(LAMBDA (N X FLG RDTBL)
(DECLARE (SPECVARS N)) (* JonL "13-Dec-84 00:46")
(\MAPCHARS (FUNCTION (LAMBDA (C)
(if (IGREATERP 0 (add N -1))
then (RETFROM (QUOTE \BOUNDNCHARSP)))))
X FLG RDTBL)
T))
)
(DECLARE: EVAL@COMPILE DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS \FILLINSTRPTR DMACRO (OPENLAMBDA (STRPTR STRBASE STROFFST STRLENGTH)
(replace (STRINGP BASE) of STRPTR with STRBASE)
(freplace (STRINGP OFFST) of STRPTR with STROFFST)
(freplace (STRINGP LENGTH) of STRPTR with STRLENGTH)
STRPTR))
(PUTPROPS \FILLINSTRPTR MACRO (OPENLAMBDA (STRPTR STRBASE STROFFST STRLENGTH)
(replace (STRINGP BASE) of STRPTR with STRBASE)
(replace (STRINGP OFFST) of STRPTR with STROFFST)
(replace (STRINGP LENGTH) of STRPTR with STRLENGTH)
STRPTR))
(PUTPROPS \UNTCONC MACRO (OPENLAMBDA (QUEUE ITEM)
(PROG ((\List (CAR QUEUE))
(\EndOfQ (CDR QUEUE))
\BackL)
(DECLARE (LOCALVARS \List \EndOfQ \BackL))
\UNTCONCloop
(if (NLISTP \List)
then (RETURN)
elseif (EQ ITEM (CAR \List))
then (if \BackL
then (RPLACD \BackL (CDR \List))
else (RPLACA QUEUE (CDR \List)))
(if (EQ \List \EndOfQ)
then (RPLACD QUEUE \BackL))
(RETURN T)
else (SETQ \BackL \List))
(pop \List)
(GO \UNTCONCloop))))
)
(DECLARE: EVAL@COMPILE
(PUTDEF (QUOTE \P4S.SCRATCHLIST)
(QUOTE RESOURCES)
(QUOTE (NEW (LIST NIL))))
(PUTDEF (QUOTE \P4S.STR.BYTEPOINTER)
(QUOTE RESOURCES)
(QUOTE (NEW (ALLOCSTRING 0))))
)
)
(/SETTOPVAL (QUOTE \\P4S.SCRATCHLIST.GLOBALRESOURCE))
(/SETTOPVAL (QUOTE \\P4S.STR.BYTEPOINTER.GLOBALRESOURCE))
(* "Pup/Net assistance")
(DECLARE: EVAL@COMPILE DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS \ALLOCATE.BIGPUP DMACRO (NIL
((LAMBDA (Pup)
(replace (ETHERPACKET EPREQUEUE) of Pup with T)
Pup)
(ALLOCATE.PUP))))
(PUTPROPS RECLAIM.PUP DMACRO ((PUP)
(\RELEASE.ETHERPACKET PUP)))
(PUTPROPS RECLAIM.OUTPUT.PUP DMACRO (OPENLAMBDA (PUP)
(OR (fetch EPTRANSMITTING of PUP)
(RECLAIM.PUP PUP))))
(PUTPROPS HOSTNUMBERP MACRO ((X) (FIXP X)))
(PUTPROPS PROBABLYSOCKETP MACRO ((X)
(TYPENAMEP X (QUOTE PUPSOCKET))))
(PUTPROPS HOST#.FROM.ADDRESS MACRO ((X)
(fetch (WORD LOBYTE) of X)))
(PUTPROPS NTWK#.FROM.ADDRESS MACRO ((X)
(fetch (WORD HIBYTE) of X)))
(PUTPROPS \ES.LOCALHOSTNUMBER MACRO (NIL
(\LOCALPUPADDRESS)))
)
[DECLARE: EVAL@COMPILE
(BLOCKRECORD BVM.LOSES.PUPSOCKET ((NIL BYTE)
(NIL POINTER)
(PSOCKHI WORD)
(PSOCKLO WORD)))
]
(DECLARE: EVAL@COMPILE
(PUTDEF (QUOTE \PIP.SCRATCHSPTR)
(QUOTE RESOURCES)
(QUOTE (NEW (ALLOCSTRING 0))))
(PUTDEF (QUOTE \GFP.TIMER)
(QUOTE RESOURCES)
(QUOTE (NEW (SETUPTIMER 0))))
(PUTDEF (QUOTE \READPUPSTREAM)
(QUOTE RESOURCES)
(QUOTE (NEW (\MAKEBASEBYTESTREAM 0 0 0 (QUOTE INPUT)))))
(PUTDEF (QUOTE \WRITEPUPSTREAM)
(QUOTE RESOURCES)
(QUOTE (NEW (\MAKEBASEBYTESTREAM 0 0 0 (QUOTE OUTPUT)))))
)
(FILESLOAD (LOADCOMP)
BSP)
)
(DECLARE: EVAL@COMPILE
(PUTPROPS #PUPDATABYTES DMACRO ((Pup)
(IDIFFERENCE (FETCH PUPLENGTH OF Pup)
\PUPOVLEN)))
(PUTPROPS #PUPDATABYTES.LEFT DMACRO (OPENLAMBDA (Pup)
(IDIFFERENCE \MAX.PUPLENGTH (#PUPDATABYTES Pup))))
)
(/SETTOPVAL (QUOTE \\PIP.SCRATCHSPTR.GLOBALRESOURCE))
(/SETTOPVAL (QUOTE \\GFP.TIMER.GLOBALRESOURCE))
(/SETTOPVAL (QUOTE \\READPUPSTREAM.GLOBALRESOURCE))
(/SETTOPVAL (QUOTE \\WRITEPUPSTREAM.GLOBALRESOURCE))
(DEFINEQ
(READ.FROM.PUP
(LAMBDA (PUP DATASTARTBYTE) (* JonL "18-JUL-83 18:18")
(SETQ PUP (\DTEST PUP (QUOTE ETHERPACKET)))
(if (DEFINEDP (QUOTE \MAKEBASEBYTESTREAM))
then (GLOBALRESOURCE (\READPUPSTREAM)
(PROG ((PUPDATAOFFST (UNFOLD (IPLUS (FOLDLO (IDIFFERENCE \PUPOVLEN 2)
BYTESPERWORD)
(INDEXF (ffetch (ETHERPACKET EPBODY)
of PUP)))
BYTESPERWORD)))
(freplace CPPTR of \READPUPSTREAM with PUP)
(freplace CBUFSIZE of \READPUPSTREAM
with (freplace EOFFSET of \READPUPSTREAM
with (IPLUS PUPDATAOFFST (#PUPDATABYTES PUP))))
(freplace COFFSET of \READPUPSTREAM
with (freplace BIASOFFST of \READPUPSTREAM
with (IPLUS PUPDATAOFFST (OR (FIXP DATASTARTBYTE)
0))))
(RETURN (READ \READPUPSTREAM))))
else ((LAMBDA (STR NCHARS)
(DECLARE (GLOBALVARS \STRINGOFDS))
(freplace (STRINGP BASE) of STR with (fetch PUPCONTENTS of PUP))
(freplace (STRINGP LENGTH) of STR with (if (OR (NULL DATASTARTBYTE)
(ZEROP DATASTARTBYTE))
then NCHARS
else (freplace (STRINGP OFFST) of STR
with DATASTARTBYTE)
(IDIFFERENCE NCHARS DATASTARTBYTE)))
(PROG1 (READ STR)
(PUTHASH STR NIL \STRINGOFDS)))
(ALLOCSTRING 0)
(#PUPDATABYTES PUP)))))
(PRINT.INTO.PUP
(LAMBDA (FORM PUP DATASTARTBYTE PRINFN NOERRORFLG) (* JonL " 8-Dec-84 23:28")
(SETQ PUP (\DTEST PUP (QUOTE ETHERPACKET)))
(PROG (WINP)
(if (OR (NULL PRINFN)
(EQ PRINFN (QUOTE PRIN4)))
then (PROG (#LEFT #PRINTED)
(GLOBALRESOURCE (\PIP.SCRATCHSPTR)
(UNINTERRUPTABLY
(SETQ #LEFT (if (NULL DATASTARTBYTE)
then (#PUPDATABYTES.LEFT PUP)
else (IDIFFERENCE \MAX.PUPLENGTH
(IPLUS \PUPOVLEN
DATASTARTBYTE))))
(replace (STRINGP BASE) of \PIP.SCRATCHSPTR
with (fetch PUPCONTENTS of PUP))
(* Make the scratch ptr look like a string pointer into
the remaining data portion of the pup.)
(replace (STRINGP OFFST) of \PIP.SCRATCHSPTR
with (OR (FIXP DATASTARTBYTE)
(#PUPDATABYTES PUP)))
(replace (STRINGP LENGTH) of \PIP.SCRATCHSPTR
with #LEFT)
(PRIN4.INTO.STRING FORM #LEFT \PIP.SCRATCHSPTR)
(* Note that we don't really need the resultant string
pointer -- only need to know if it all got "printed"
into the pup.)
(SETQ #PRINTED (fetch (STRINGP LENGTH) of
\PIP.SCRATCHSPTR))
(if (ILESSP #PRINTED #LEFT)
then (add (fetch PUPLENGTH of PUP)
#PRINTED)
(SETQ WINP T)))))
elseif (NOT (DEFINEDP (QUOTE \MAKEBASEBYTESTREAM)))
then (ERROR (QUOTE \MAKEBASEBYTESTREAM))
else (GLOBALRESOURCE (\WRITEPUPSTREAM)
(PROG ((PUPDATAOFFST
(CONSTANT (UNFOLD (IPLUS (FOLDLO (IDIFFERENCE \PUPOVLEN 2)
BYTESPERWORD)
(INDEXF (ffetch (ETHERPACKET
EPBODY)
of PUP)))
BYTESPERWORD))))
(freplace CPPTR of \WRITEPUPSTREAM with PUP)
(freplace CBUFSIZE of \WRITEPUPSTREAM
with (freplace EOFFSET of \WRITEPUPSTREAM
with (IPLUS \MAX.PUPLENGTH PUPDATAOFFST)))
(add PUPDATAOFFST (OR (FIXP DATASTARTBYTE)
(#PUPDATABYTES PUP)))
(freplace BIASOFFST of \WRITEPUPSTREAM with PUPDATAOFFST)
(freplace COFFSET of \WRITEPUPSTREAM with PUPDATAOFFST)
(freplace BBSNCHARS of \WRITEPUPSTREAM with 0)
(APPLY* (OR PRINFN (FUNCTION PRIN4))
FORM \WRITEPUPSTREAM)
(add (fetch PUPLENGTH of PUP)
(ffetch BBSNCHARS of \WRITEPUPSTREAM))
(SETQ WINP T))))
(if WINP
then (RETURN T)
elseif NOERRORFLG
then NIL
else (ERROR "Form too big to Print into pup" FORM)))))
(\HNM.MEMBER
(LAMBDA (HNM L) (* JonL "27-Nov-84 14:01")
(* HNM is a host number; L is a list of host
specifications, which could be either number, or name,
or T or NIL.)
(OR (HOSTNUMBERP HNM)
(LISPERROR "ILLEGAL ARG" HNM))
(for X in L do (AND (if (NULL X)
then NIL
elseif (EQ X T)
then (EQP HNM (\ES.LOCALHOSTNUMBER))
else (OR (HOSTNUMBERP X)
(SETQ X (ETHERHOSTNUMBER X)))
(EQP HNM X))
(RETURN T)))))
(\NORMALIZEHOSTNUM
(LAMBDA (X DEFAULTADDRESS) (* JonL "18-JUL-83 20:09")
(if (NULL X)
then DEFAULTADDRESS
elseif (EQ X T)
then (\ES.LOCALHOSTNUMBER)
elseif (ZEROP X)
then (\BROADCASTADDRESS.ON.MYNET)
elseif (ETHERHOSTNUMBER X)
elseif DEFAULTADDRESS
else (ERROR X "Not a valid Network Host identification"))))
(\BROADCASTADDRESS.ON.MYNET
(LAMBDA NIL (* JonL "18-JUL-83 20:18")
(SETQ \BROADCASTADDRESS.ON.MYNET (create WORD
HIBYTE ←(\LOCALPUPNETNUMBER)
LOBYTE ← 0))))
(\GETFILTEREDPUP
(LAMBDA (SOC TYPESLST ID PUP? WAITINGTIME? TRACEINFO) (* JonL "19-Nov-84 18:23")
(* The \PUPINQUEUE tconc list has items like
(PUP . ARRIVALTIME))
(GLOBALRESOURCE (\GFP.TIMER)
(PROG (PX TPUP TIMEOUT)
(DECLARE (SPECVARS PX)) (* We could check \PUPINQUEUE for being a TCONC ptr ?)
(if (AND (NEQ PUP? (QUOTE NEW))
(CAR \PUPINQUEUE)
(SETQ PX (find X (SKT#LO ←(fetch PSOCKLO of SOC))
(SKT#HI ←(fetch PSOCKHI of SOC))
in (CAR \PUPINQUEUE)
suchthat (AND (EQ SKT#LO (fetch PUPDESTSOCKETLO
of (CAR X)))
(EQ SKT#HI (fetch PUPDESTSOCKETHI
of (CAR X)))
(TYPE\ID.OF.PUP? TYPESLST ID
(CAR X))))))
then (* Aha, found it alreadly queued up!)
(if (EQ PUP? (QUOTE ?))
then (RETURN T)
else (\UNTCONC \PUPINQUEUE PX)
(BLOCK)
(if (EQ PUP? (QUOTE DELETE))
then (RETURN T)
else (SETQ TPUP (CAR PX))
(GO EXIT))))
SEEKPUP
(if (SETQ TPUP (GETPUP SOC))
then (replace (ETHERPACKET EPREQUEUE) of TPUP with T)
(if (TYPE\ID.OF.PUP? TYPESLST ID TPUP)
then (SELECTQ PUP?
((? NEW)
(SETQ \PUPINQUEUE (TCONC \PUPINQUEUE
(CONS TPUP
(CLOCK 0))))
(RETURN (QUOTE NEW)))
(DELETE (RECLAIM.PUP TPUP)
(RETURN T))
(GO EXIT))
elseif (AND (EQ WAITINGTIME? T)
(TYPE\ID.OF.PUP? (CONSTANT (LIST \PT.ERROR))
ID TPUP))
then (ERROR "Error PUP received during indefinite wait" TPUP)
else (* If we "sucked it off the wires" but don't want it
now, then queue it up on \PUPINQUEUE)
(SETQ \PUPINQUEUE (TCONC \PUPINQUEUE (CONS TPUP
(CLOCK 0))))
(SETQ TPUP NIL)))
(if (if (EQ WAITINGTIME? T)
then (AWAIT.EVENT (PUPSOCKETEVENT SOC))
T
elseif TIMEOUT
then (AWAIT.EVENT (PUPSOCKETEVENT SOC)
TIMEOUT T)
(NOT (TIMEREXPIRED? TIMEOUT))
elseif (FIXP WAITINGTIME?)
then (SETQ TIMEOUT (SETUPTIMER WAITINGTIME? \GFP.TIMER))
T)
then (GO SEEKPUP))
EXIT(if (type? PUP PUP?)
then (RECLAIM.PUP PUP?))
(if (AND TRACEINFO TPUP)
then (TRACEAPUP TPUP TRACEINFO))
(RETURN TPUP)))))
(\SENDUNFILTEREDPUP
(LAMBDA (SOC PUP TRACEINFO) (* JonL " 1-APR-83 19:48")
(SENDPUP SOC PUP)
(TRACEAPUP PUP TRACEINFO (OR (CAR TRACEINFO)
(QUOTE (\SENDUNFILTEREDPUP))))
NIL))
(\ES.GETSOCKET
(LAMBDA NIL (* JonL "20-JUL-83 12:47")
(PROG ((S# (\CLOCK0 (NCREATE (QUOTE FIXP)))))
(if (IGEQ S# 0)
then (* Helps insure no conflict with defaultly-allocated
socket numbers.)
(\BOXIPLUS S# (CONSTANT (MASK.1'S (SUB1 BITS.PER.FIXP)
1))))
A (RETURN (OR (OPENPUPSOCKET S# (QUOTE DONT))
(PROGN (\BOXIPLUS S# 1)
(GO A)))))))
(\ES.RECLAIM.PUP
(LAMBDA (PUP) (* JonL "19-Nov-84 18:47")
(if (\ONQUEUE PUP \FREE.PACKET.QUEUE)
then (SHOULDNT "Reclaiming a PUP already on the free queue"))
(\RELEASE.ETHERPACKET PUP)))
(\ES.RELEASE.OUTPUT.PUP
(LAMBDA (X) (* JonL "19-Nov-84 18:23")
(OR (fetch EPTRANSMITTING of X)
(RECLAIM.PUP X))
NIL))
)
(DEFINEQ
(\ES.BSPREAD
(LAMBDA (FORM) (* JonL "20-Dec-84 09:05")
((LAMBDA (PUPORT)
(OR (AND (LISTP PUPORT)
(FIXP (CAR PUPORT))
(FIXP (CDR PUPORT))
(RESETLST (PROG ((BSPSOC (OR (OPENRTPSOCKET PUPORT)
(ERROR PUPORT "Failed to establish BSP connection")))
STREAM)
(RESETSAVE NIL (LIST (QUOTE CLOSEPUPSOCKET)
(fetch PUPSOC of BSPSOC)
T))
(RESETSAVE (SETQ STREAM (OPENBSPSTREAM BSPSOC
(FUNCTION \ES.BSPUPHANDLER)
(FUNCTION \ES.BSERRORHANDLER))
)
(QUOTE (PROGN (CLOSEBSPSTREAM OLDVALUE))))
(RETURN (READ STREAM)))))
(ERROR "Bad BSP connect message?" MSG)))
(CDDR FORM))))
(\ES.BSPSENDFORM
(LAMBDA (FORM OPUP) (* JonL " 2-Jan-85 11:59")
(* Use BSP channel to transmit a request or result that
is too large to fit into one packet.)
(PROG ((PUPSOC (OPENPUPSOCKET)))
(RESETSAVE NIL (LIST (QUOTE CLOSEPUPSOCKET)
PUPSOC T))
(PRINT.INTO.PUP (LIST* (QUOTE \ES.BSPINFO)
TOOBIGPASSWORD
(CONS (\LOCALPUPADDRESS)
(PUPSOCKETNUMBER PUPSOC)))
OPUP)
(RETURN (ADD.PROCESS (LIST (QUOTE \ES.BSPSENDFORMPROC)
PUPSOC FORM))))))
(\ES.BSPSENDFORMPROC
(NLAMBDA (PUPSOC FORM) (* JonL " 2-Jan-85 11:59")
(PROG (BSPSOC STREAM OUTSTREAM)
(DECLARE (SPECVARS STREAM OUTSTREAM))
(if (AND (SETQ BSPSOC (OPENRTPSOCKET NIL (QUOTE SERVER)
PUPSOC NIL 120000))
(SETQ STREAM (OPENBSPSTREAM BSPSOC (FUNCTION NILL)
(FUNCTION NILL))))
then (RESETLST (DECLARE (SPECVARS STREAM OUTSTREAM))
(RESETSAVE NIL (LIST (QUOTE CLOSEBSPSTREAM)
STREAM))
(SETQ OUTSTREAM (BSPOUTPUTSTREAM STREAM))
(forDuration 120 timerUnits (QUOTE SECONDS)
when (PROGN (BLOCK)
(BSPOPENP OUTSTREAM (QUOTE OUTPUT)))
do (RETURN) finally (ERROR "Timed out"))
(\MAPCHARS (FUNCTION (LAMBDA (C)
(DECLARE (USEDFREE OUTSTREAM))
(BOUT OUTSTREAM C)))
FORM T)
(PROCESS.RETURN T))))))
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \PUPSOCKETS \LOCALPUPNETHOST \FREE.PACKET.QUEUE)
)
(DECLARE: EVAL@COMPILE DONTCOPY
[DECLARE: EVAL@COMPILE
(TYPERECORD TRANSACTIONNOTE (STATE TIME SOCKET HOSTNAME))
]
(DECLARE: EVAL@COMPILE
(PUTPROPS TYPE\ID.OF.PUP? MACRO (OPENLAMBDA (TYPESLST ID PUP)
(* JonL " 1-JUN-82 10:08")
(AND (OR (NULL TYPESLST)
(FMEMB (fetch PUPTYPE of PUP)
TYPESLST))
(OR (NULL ID)
(EQ ID (fetch PUPID of PUP))))))
(PUTPROPS CONNECTIONIDP DMACRO ((X) (SMALLP X)))
(PUTPROPS TRACEAPUP MACRO ((PUP MSG FUN)
(AND \ES.TRACE? (\ES.PRINTRACE PUP MSG FUN))))
(PUTPROPS 1BYTETOPUP DMACRO (OPENLAMBDA (N PUP)
(\PUTBASEBYTE (FETCH PUPCONTENTS OF PUP)
(IDIFFERENCE (ADD (FETCH PUPLENGTH OF PUP)
1)
(CONSTANT (ADD1 \PUPOVLEN)))
N)))
(PUTPROPS \BROADCASTADDRESS.ON.MYNET MACRO (X
(COND
(X (QUOTE IGNOREMACRO))
(T (QUOTE (OR \BROADCASTADDRESS.ON.MYNET (\BROADCASTADDRESS.ON.MYNET T)))))))
)
)
(RPAQQ \BROADCASTADDRESS.ON.MYNET NIL)
(DECLARE: EVAL@COMPILE DONTCOPY
(DECLARE: EVAL@COMPILE
(RPAQQ TOOBIGPASSWORD 43690)
(CONSTANTS (TOOBIGPASSWORD 43690))
)
(DECLARE: EVAL@COMPILE
(RPAQQ \SOCKET#.EVALREQUEST 668)
(RPAQQ \PT.EVALREQUEST 200)
(RPAQQ \PT.ACKNOWLEDGE 201)
(RPAQQ \PT.EVALRESPONSE 202)
(RPAQQ \PT.EVALREQUEST.NORESULT 203)
(RPAQQ \PT.EVALERROR 204)
(RPAQQ \PT.EVALREQUEST.CERTIFY 205)
(CONSTANTS (\SOCKET#.EVALREQUEST 668)
(\PT.EVALREQUEST 200)
(\PT.ACKNOWLEDGE 201)
(\PT.EVALRESPONSE 202)
(\PT.EVALREQUEST.NORESULT 203)
(\PT.EVALERROR 204)
(\PT.EVALREQUEST.CERTIFY 205))
)
)
(RPAQ? EvalServerClientHosts NIL)
(RPAQ? EvalServerGaggedHosts (QUOTE (T)))
(RPAQ? \EVALREQUEST.SOCKET NIL)
(RPAQ? \ES.TTYWINDOW NIL)
(RPAQ? \ES.TTYWINDOWSTREAM NIL)
(RPAQ? \ES.MESSAGESTREAM NIL)
(RPAQ? \ES.PURGEINTERVAL.SECS 180)
(RPAQ? \ES.PENDINGSERVICES NIL)
(RPAQ? \ES.COMPLETEDSERVICES NIL)
(RPAQ? \PUPINQUEUE NIL)
(RPAQ? \PUPINQUEUE.MAXLENGTH 50)
(RPAQ? \PUPINQUEUE.MAXAGE (TIMES 6 60 1000))
(RPAQ? \ES.LOSTSOCKETSLST NIL)
(RPAQ? \ES.CurrentlyPendingService NIL)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \PUPINQUEUE \PUPINQUEUE.MAXLENGTH \PUPINQUEUE.MAXAGE \EVALREQUEST.SOCKET \ES.TTYWINDOW
\ES.TTYWINDOWSTREAM \ES.MESSAGESTREAM \ES.PURGEINTERVAL.SECS \ES.COMPLETEDSERVICES
\ES.PENDINGSERVICES \ES.LOSTSOCKETSLST \BROADCASTADDRESS.ON.MYNET)
)
(DEFINEQ
(REMOTEVAL
(LAMBDA (FORM SERVERHOST MULTIPLE.RESPONSES? TIMEOUT.ms) (* JonL " 2-Jan-85 10:17")
(if (NULL MULTIPLE.RESPONSES?)
then (SETQ MULTIPLE.RESPONSES? 1)) (* Check to be sure that the alleged form is
EVALuable.)
(\CHECKTYPE FORM (OR (FMEMB (NTYPX FORM)
(CONSTANT (LIST \LISTP \LITATOM)))
(NUMBERP FORM)
(DEFEVAL (NTYPX FORM))))
(RESETLST (PROG ((BROADP (\BROADCASTADDRESS.ON.MYNET))
(OPUP (\ALLOCATE.BIGPUP))
(MY.TRANSCEIVER (\ES.GETSOCKET))
MSG IPUP MY.REF.ID HIS.TRANSCEIVER.SOC# REMOTEVAL.timer EXIT.REFCOUNT SENDPROC)
(push \ES.LOSTSOCKETSLST MY.TRANSCEIVER)
(SETQ SERVERHOST (\NORMALIZEHOSTNUM SERVERHOST BROADP))
(SETUPPUP OPUP SERVERHOST (CONSTANT \SOCKET#.EVALREQUEST)
(SELECTQ MULTIPLE.RESPONSES?
(0 \PT.EVALREQUEST.NORESULT)
\PT.EVALREQUEST)
NIL MY.TRANSCEIVER)
(SETQ MY.REF.ID (fetch PUPID OPUP))
(if (AND (NOT (SETQ BROADP (OR (EQ SERVERHOST BROADP)
(EQUAL SERVERHOST BROADP))))
(NOT (\BOUNDNCHARSP 500 FORM T)))
then (SETQ SENDPROC (\ES.BSPSENDFORM FORM OPUP))
else (PRINT.INTO.PUP FORM OPUP))
(if TIMEOUT.ms
then (SETQ REMOTEVAL.timer (SETUPTIMER TIMEOUT.ms)))
(DISCARDPUPS MY.TRANSCEIVER)
(SELECTQ (SETQ IPUP (\ES.SENDREQUEST MY.TRANSCEIVER OPUP TIMEOUT.ms))
(TIMEREXPIRED? (GO TIMEOUTERROR))
(ERROR (GO ERRORPUP))
(OR (type? PUP IPUP)
(SHOULDNT (QUOTE PUP))))
(SETQ HIS.TRANSCEIVER.SOC# (fetch (PUP SOURCESKT) of IPUP))
(SETQ SERVERHOST (fetch (PUP SOURCE) of IPUP))
(\BOXIPLUS (SETQ EXIT.REFCOUNT (NCREATE (QUOTE FIXP)))
1)
(if BROADP
then (if (NEQ MULTIPLE.RESPONSES? 0)
then (* Got to certify the worker first.)
(SETUPPUP OPUP SERVERHOST HIS.TRANSCEIVER.SOC#
\PT.EVALREQUEST.CERTIFY MY.REF.ID MY.TRANSCEIVER))
(SELECTQ (\ES.CERTIFYBROADWORKER MY.TRANSCEIVER MY.REF.ID OPUP
TIMEOUT.ms)
(TIMEREXPIRED? (GO TIMEOUTERROR))
(ERROR (GO ERRORPUP))
(OR (type? PUP IPUP)
(SHOULDNT (QUOTE PUP))))
(\ES.AddSweeping (if (EQ MULTIPLE.RESPONSES? 0)
then (QUOTE \ES.IgnoreApplicants)
else (QUOTE \ES.RejectApplicants))
SERVERHOST MY.TRANSCEIVER MY.REF.ID TIMEOUT.ms
(\BOXIPLUS EXIT.REFCOUNT 1))
elseif SENDPROC
then (* Looks like we needed a BSP connection just to send
the request.)
(during 120 timerUnits (QUOTE SECONDS)
do (* Bug in implementation of PROCESS.RESULT prevents its
use here!)
(SELECTQ (PROCESS.FINISHEDP SENDPROC)
(NIL (BLOCK 500))
(NORMAL (RETURN))
(ERROR (GO TIMEOUTERROR))
(SHOULDNT (QUOTE PROCESS.FINISHEDP)))
finally (GO TIMEOUTERROR)))
(if (EQ MULTIPLE.RESPONSES? 0)
then (* In the broadcast case, we have made sure that at
least one host has acknowledged our request.
Others will just spuriously send acknowledgements.)
(\ES.EXITREMOTEVAL MY.TRANSCEIVER EXIT.REFCOUNT OPUP IPUP)
(RETURN MY.REF.ID)) (* Now, hang around waiting for the result, which might
take hours!)
(SETQ IPUP (\GETFILTEREDPUP MY.TRANSCEIVER (CONSTANT (LIST \PT.EVALRESPONSE
\PT.EVALERROR))
MY.REF.ID IPUP T (QUOTE (
"=== Client Gets Results in Hand!" REMOTEVAL))))
(SETUPPUP OPUP SERVERHOST HIS.TRANSCEIVER.SOC# \PT.ACKNOWLEDGE MY.REF.ID
MY.TRANSCEIVER) (* And now we acknowledge receipt of the results.)
(\SENDUNFILTEREDPUP MY.TRANSCEIVER OPUP (QUOTE (
"Client Sends Acknowledgement for Services Rendered" REMOTEVAL)))
(* Flush any delayed communications from the server.)
(\ES.AddSweeping (QUOTE \ES.Re-acknowledge.service)
SERVERHOST MY.TRANSCEIVER MY.REF.ID TIMEOUT.ms (\BOXIPLUS
EXIT.REFCOUNT 1))
(if (AND IPUP (SETQ MSG (READ.FROM.PUP IPUP)))
then (if (AND (EQ (CAR (LISTP MSG))
(QUOTE \ES.BSPINFO))
(EQ (CADR MSG)
TOOBIGPASSWORD))
then (* Return'd value is indicator of huge result to come
via BSP stream)
(SETQ MSG (\ES.BSPREAD MSG))))
(SELECTC (PROG1 (if IPUP
then (fetch PUPTYPE of IPUP))
(\ES.EXITREMOTEVAL MY.TRANSCEIVER EXIT.REFCOUNT OPUP IPUP))
(\PT.EVALRESPONSE (RETURN MSG))
(\PT.EVALERROR (ERROR (CONCAT
"Returned from Remote EVALuation with Error msg %""
(ERRORSTRING (CAR MSG))
"%"")
(CADR MSG)))
(ERROR "Remote EVALuation failed to return." FORM))
TIMEOUTERROR (* If we did'nt get thru after \MAXETHERTRIES, we're
probably losing badly.)
(\ES.EXITREMOTEVAL MY.TRANSCEIVER EXIT.REFCOUNT OPUP IPUP)
TIMEOUT.E
(ERROR FORM "Remote EVAL request timed out")
(GO TIMEOUT.E)
ERRORPUP
(TRACEAPUP IPUP (QUOTE ("*** Server Errors-out on Connection Request" REMOTEVAL)))
(\ES.EXITREMOTEVAL MY.TRANSCEIVER EXIT.REFCOUNT OPUP IPUP)
ERRORPUP.E
(ERROR IPUP "Error PUP")
(GO ERRORPUP.E)))))
(\ES.SENDREQUEST
(LAMBDA (MY.TRANSCEIVER OPUP TIMER) (* JonL "20-Dec-84 06:12")
(if TIMER
then (SETQ TIMER (SETUPTIMER TIMER)))
(bind IPUP MSG (WAITINTERVAL ← \ETHERTIMEOUT)
(MY.REF.ID ←(fetch PUPID OPUP)) for I from 1 repeatuntil (if TIMER
then (TIMEREXPIRED? TIMER)
else (IGREATERP I \MAXETHERTRIES)
)
do (if (EQ I 1)
then (SETQ MSG (QUOTE ("=== Client Dispatches an Eval Request:" REMOTEVAL)))
else (add WAITINTERVAL (if (IGREATERP I 4)
then (CONSTANT (ITIMES 8 \ETHERTIMEOUT))
else WAITINTERVAL))
(SETQ MSG (CONS (CONCAT "=== Client Re-Dispatches Eval Request for " I (
ORDINALSUFFIXSTRING I)
" time:")
(QUOTE (REMOTEVAL)))))
(\SENDUNFILTEREDPUP MY.TRANSCEIVER OPUP MSG) (* Wait around for a while, for an acknowledgement of
receipt.)
(if (SETQ IPUP (\GETFILTEREDPUP MY.TRANSCEIVER (CONSTANT (LIST \PT.ACKNOWLEDGE \PT.ERROR))
MY.REF.ID NIL WAITINTERVAL))
then (if (EQ \PT.ERROR (fetch PUPTYPE of IPUP))
then (RETURN (QUOTE ERROR))
else (TRACEAPUP IPUP (QUOTE ("=== Client Receives Acknowledgement of Request: "
REMOTEVAL)))
(RETURN IPUP)))
finally (RETURN (QUOTE TIMEREXPIRED?)))))
(\ES.CERTIFYBROADWORKER
(LAMBDA (SOC ID OPUP TIMER) (* JonL "20-Dec-84 10:08")
(1BYTETOPUP 1 OPUP)
(if TIMER
then (SETQ TIMER (SETUPTIMER TIMER TIMER)))
(bind IPUP (WAITINTERVAL ← \ETHERTIMEOUT) for I from 1 repeatuntil (if TIMER
then (TIMEREXPIRED? TIMER)
else (IGREATERP I
\MAXETHERTRIES))
do (* Comment PPlossage)
(\SENDUNFILTEREDPUP SOC OPUP (QUOTE ("=== Client Certifies applicant for broadcast Request"
REMOTEVAL)))
(if (SETQ IPUP (\GETFILTEREDPUP SOC (CONSTANT (LIST \PT.EVALREQUEST.CERTIFY \PT.ERROR))
ID IPUP WAITINTERVAL))
then (if (EQ (fetch PUPTYPE of IPUP)
\PT.ERROR)
then (RETURN (QUOTE ERROR))
else (TRACEAPUP IPUP (QUOTE (
"=== Client knows that applicant knows he's selected." REMOTEVAL)))
(RETURN IPUP))
else (BLOCK))
finally (RETURN (QUOTE TIMEREXPIRED?)))))
(\ES.BSERRORHANDLER
(LAMBDA (STREAM ERRCODE) (* JonL "10-Dec-84 00:32")
(SELECTQ ERRCODE
(MARK.ENCOUNTERED (APPLY* (fetch ENDOFSTREAMOP of STREAM)
STREAM))
NIL)))
(\ES.BSPUPHANDLER
(LAMBDA (PUP STREAM)
(DECLARE (GLOBALVARS PUPTRACEFILE)) (* JonL "10-Dec-84 00:38")
(if (AND (EQ \PT.ERROR (fetch PUPTYPE of PUP))
PUPTRACEFLG)
then (PRINTERRORPUP PUP PUPTRACEFILE))))
(\ES.EXITREMOTEVAL
(LAMBDA (MY.TRANSCEIVER EXIT.REFCOUNT? pup1 pup2) (* JonL "27-Nov-84 14:01")
(* When EXIT.REFCOUNT? goes down to zero
(or is NULL) then we can reclaim the socket in
MY.TRANSCEIVER)
(if (OR (NULL EXIT.REFCOUNT?)
(EQ 0 (\BOXIDIFFERENCE EXIT.REFCOUNT? 1)))
then (UNINTERRUPTABLY
(if (EQ MY.TRANSCEIVER (CAR \ES.LOSTSOCKETSLST))
then (pop \ES.LOSTSOCKETSLST)
else (PROG ((BPTR (find XB on \ES.LOSTSOCKETSLST suchthat (EQ MY.TRANSCEIVER
(CADR XB)))))
(if BPTR
then (RPLACD BPTR (CDDR BPTR)))))
(\ES.CLOSEOUTSOCKET MY.TRANSCEIVER)))
(AND pup1 (RECLAIM.OUTPUT.PUP pup1))
(AND pup2 (RECLAIM.OUTPUT.PUP pup2))
T))
(\ES.CLOSEOUTSOCKET
(LAMBDA (SOC) (* JonL "20-JUL-83 16:45")
(if (PROBABLYSOCKETP SOC)
then (DISCARDPUPS SOC)
(until (NULL (\GETFILTEREDPUP SOC NIL NIL (QUOTE DELETE))))
(CLOSEPUPSOCKET SOC T))))
(\ES.UNCACHE
(LAMBDA NIL (* JonL "19-Nov-84 19:55")
(SETQ \BROADCASTADDRESS.ON.MYNET)
(SETQ \ES.LOSTSOCKETSLST)
(SETQ \ES.PENDINGSERVICES)
(SETQ \ES.COMPLETEDSERVICES)
(SETQ \ES.LASTSTATUSLIST)))
(REMOTEABORT
(LAMBDA (TRANSACTION# SERVERHOST) (* JonL "28-MAR-83 18:45")
(* Remember, a TRANSACTION.ID is a cons of "connection"
id and hostnumber)
(PROG ((CLIENT (if (AND (LISTP TRANSACTION#)
(CONNECTIONIDP (CAR TRANSACTION#)))
then (PROG1 (ETHERHOSTNUMBER (CDR TRANSACTION#))
(SETQ TRANSACTION# (CAR TRANSACTION#)))
elseif (AND (CONNECTIONIDP TRANSACTION#)
(PROGN (* Foo, this really wants to be an IMODLESSP)
(ILESSP (IMOD (IDIFFERENCE \PUPCOUNTER TRANSACTION#)
(CONSTANT (LLSH 1 BITSPERWORD)))
(CONSTANT (LLSH 1 (SUB1 BITSPERWORD))))))
then (* Remember, \PUPCOUNTER is the means that transaction#s
are generated by this host.)
(\ES.LOCALHOSTNUMBER)
else (LISPERROR "ILLEGAL ARG" TRANSACTION#)))
(BADDR (\BROADCASTADDRESS.ON.MYNET))
TRANSACTION.ID)
(SETQ TRANSACTION.ID (CONS TRANSACTION# CLIENT))
(SETQ SERVERHOST (\NORMALIZEHOSTNUM SERVERHOST BADDR))
(if (EQ SERVERHOST BADDR)
then (ERROR TRANSACTION.ID "Can't broadcast a REMOTEABORT."))
(RETURN (REMOTEVAL (LIST (QUOTE \ES.ABORTQQ)
TRANSACTION.ID
(\ES.LOCALHOSTNUMBER))
SERVERHOST)))))
(REMOTEAPPLY
(LAMBDA (FUN ARGS HOST MULTIPLE.RESPONSES?) (* JonL "25-JUN-82 03:54")
(REMOTEVAL (CONS (QUOTE \ES.APPLYQQ)
(CONS FUN ARGS))
HOST MULTIPLE.RESPONSES?)))
(\ES.APPLYQQ
(NLAMBDA L (* JonL "19-JUN-82 06:04")
(APPLY (CAR L)
(CDR L))))
(EVALSERVER
(LAMBDA (DURATION.MINUTES CLIENTSLST GAGGEDCLIENTSLST) (* JonL "19-Nov-84 19:59")
(DEL.PROCESS (FIND.PROCESS (QUOTE EvalServerListening)))
(DEL.PROCESS (FIND.PROCESS (QUOTE \ES.BroadAppSweeper)))
(MAP.PROCESSES (FUNCTION (LAMBDA (X)
((LAMBDA (PN)
(if (STRPOS "EvalService." PN NIL NIL T)
then (DEL.PROCESS X)))
(PROCESS.NAME X))))) (* Delete services still being performed for old
servers)
(SETQ \ES.BroadSweepQ)
(LIST (SETQ EVALSERVER (ADD.PROCESS (LIST (QUOTE \ES.LISTENER)
CLIENTSLST GAGGEDCLIENTSLST (AND (FIXP DURATION.MINUTES)
(TIMES 60000
DURATION.MINUTES)))
(QUOTE NAME)
(QUOTE EvalServerListening)
(QUOTE RESTARTABLE)
T)))))
(\ES.RESTART
(LAMBDA NIL (* JonL "19-Nov-84 19:53")
(PROG NIL
(RESTART.PROCESS (OR (FIND.PROCESS (QUOTE EvalServerListening))
(RETURN))))))
(\ES.LISTENER
(NLAMBDA (CLIENTSLST GAGS DURATION) (* JonL "13-Dec-84 03:53")
(* Args are passed in directly from EVALSERVER.
"Listens" for EvalRequests, and spawns off a process to
do one when it arrives.)
(if \ES.LOSTSOCKETSLST
then (* Each time that the EVALSERVER is restarted, this
swoop over the lost sockets will be done)
(UNINTERRUPTABLY
(MAPC (PROG1 \ES.LOSTSOCKETSLST (SETQ \ES.LOSTSOCKETSLST))
(FUNCTION \ES.CLOSEOUTSOCKET))))
(PROG ((PURGEINTERVAL (TIMES \ES.PURGEINTERVAL.SECS 1000))
(BADDR (HOST#.FROM.ADDRESS (\BROADCASTADDRESS.ON.MYNET)))
REQUESTEVENT NEXTPURGETIME PROMISCUOUS FLIRTATIOUS CLIENTADDRESS IPUP ARGL)
(* First, set up the lists of acceptable and gagged
clients.)
(if (NULL CLIENTSLST)
then (SETQ PROMISCUOUS (SETQ FLIRTATIOUS T))
elseif (LISTP CLIENTSLST)
then (if (MEMB NIL CLIENTSLST)
then (SETQ PROMISCUOUS T)
(SETQ CLIENTSLST (REMOVE NIL CLIENTSLST)))
(if (MEMB T CLIENTSLST)
then (SETQ FLIRTATIOUS T)
(SETQ CLIENTSLST (REMOVE T CLIENTSLST)))
(SETQ CLIENTSLST (MAPCAR CLIENTSLST (FUNCTION \NORMALIZEHOSTNUM)))
elseif (SETQ CLIENTADDRESS (ETHERHOSTNUMBER CLIENTSLST))
then (SETQ CLIENTSLST (LIST CLIENTADDRESS))
else (LISPERROR "ILLEGAL ARG" CLIENTSLST))
(if (MEMB NIL GAGS)
then (SETQ GAGS (REMOVE NIL GAGS))
(SETQ PROMISCUOUS NIL))
(if (MEMB T GAGS)
then (SETQ GAGS (REMOVE T GAGS))
(push GAGS (\ES.LOCALHOSTNUMBER)))
(SETQ GAGS (DREMOVE NIL (MAPCAR GAGS (FUNCTION ETHERHOSTNUMBER))))
(SETQ \EVALREQUEST.SOCKET (OPENPUPSOCKET \SOCKET#.EVALREQUEST T))
(SETQ REQUESTEVENT (PUPSOCKETEVENT \EVALREQUEST.SOCKET))
(DISCARDPUPS \EVALREQUEST.SOCKET) (* Flush any stale requests still on the input queue.)
(SETQ NEXTPURGETIME (SETUPTIMER PURGEINTERVAL))
(OR (AND \ES.TTYWINDOWSTREAM (DISPLAYSTREAMP \ES.TTYWINDOWSTREAM))
(SETQ \ES.TTYWINDOWSTREAM
(if (GETD (QUOTE CREATEW))
then (WINDOWPROP (SETQ \ES.TTYWINDOW
(CREATEW (CONSTANT (create REGION
LEFT ← 150
BOTTOM ← 35
WIDTH ← 500
HEIGHT ← 300))
"TTY Window for REMOTEVAL services" NIL T))
(QUOTE DSP)))))
LOOP(during (OR DURATION MAX.FIXP)
do (AWAIT.EVENT REQUESTEVENT NEXTPURGETIME T)
(if (SETQ IPUP (\GETFILTEREDPUP \EVALREQUEST.SOCKET (CONSTANT (LIST \PT.EVALREQUEST
\PT.EVALREQUEST.NORESULT))
NIL IPUP))
then (if (AND (NOT (ZEROP (SETQ CLIENTADDRESS (fetch (PUP SOURCE) of IPUP))))
(if (EQ BADDR (fetch (PUP DESTHOST) of IPUP))
then (* Ha, A Broadcast packet!)
(AND (OR PROMISCUOUS (FMEMB NIL EvalServerClientHosts))
(NOT (FMEMB NIL EvalServerGaggedHosts)))
else (OR FLIRTATIOUS (MEMBER CLIENTADDRESS CLIENTSLST)
(\HNM.MEMBER CLIENTADDRESS EvalServerClientHosts)))
(AND (NOT (MEMBER CLIENTADDRESS GAGS))
(NOT (\HNM.MEMBER CLIENTADDRESS EvalServerGaggedHosts))))
then (SETQ ARGL (LIST IPUP))
(SETQ IPUP NIL) (* Since IPUP is "eaten up" in the call to
\ES.DO1THING)
(ADD.PROCESS (CONS (QUOTE \ES.DO1THING)
ARGL)
(QUOTE NAME)
(MKATOM (CONCAT "EvalService." (NTWK#.FROM.ADDRESS
CLIENTADDRESS)
"#"
(HOST#.FROM.ADDRESS CLIENTADDRESS)
"."
(fetch (PUP PUPID)
of (CAR ARGL))))
(QUOTE RESTARTABLE)
(QUOTE NO))
else (TRACEAPUP IPUP (QUOTE ("=== EvalServer Rejects Request:"
\ES.LISTENER)))))
(BLOCK)
(if (TIMEREXPIRED? NEXTPURGETIME)
then (\ES.PURGEOLDTHINGS NIL PURGEINTERVAL)
(SETUPTIMER PURGEINTERVAL NEXTPURGETIME)
(AND (NULL DURATION)
(SETQ \ES.EXECTTYWINDOWSTREAM (PROCESSPROP (FIND.PROCESS (QUOTE EXEC))
(QUOTE WINDOW)))
(SETQ \ES.EXECTTYWINDOWSTREAM (WINDOWPROP \ES.EXECTTYWINDOWSTREAM
(QUOTE DSP))))
(* Re-validate the exec tty window, when noting else
much is happening.)
(BLOCK)))
(if (NULL DURATION)
then (* Infinite time to be spent "in service")
(GO LOOP)))))
(\ES.DO1THING
(NLAMBDA (\RequestPUP) (* JonL " 2-Jan-85 11:05")
(DECLARE (SPECVARS \RequestPUP))
(AND \ES.TTYWINDOWSTREAM (TTYDISPLAYSTREAM \ES.TTYWINDOWSTREAM))
(PROG ((OPUP (\ALLOCATE.BIGPUP))
(CLIENTADDRESS (fetch (PUP SOURCE) of \RequestPUP))
(CLIENTS.RECEIVER.SOCKET# (fetch (PUP SOURCESKT) of \RequestPUP))
(CLIENT'S.REF.ID (fetch (PUP PUPID) of \RequestPUP))
(BROADP (EQ (HOST#.FROM.ADDRESS (\BROADCASTADDRESS.ON.MYNET))
(fetch (PUP DESTHOST) of \RequestPUP)))
(FINISHOW? (QUOTE COMPLETED))
(ES.RESPONSE.SOCKET (\ES.GETSOCKET))
TRANSACTION.ID THISPENDINGSERVICE VAL FORM PT DUPLICATEP SENDPROC)
(SETQ TRANSACTION.ID (CONS CLIENT'S.REF.ID CLIENTADDRESS))
(UNINTERRUPTABLY
(if (OR (SASSOC TRANSACTION.ID \ES.PENDINGSERVICES)
(SASSOC TRANSACTION.ID \ES.COMPLETEDSERVICES))
then (* Foo, some "race" condition slipped in a duplicate
request during the short hop from \ES.LISTENER to here)
(SETQ DUPLICATEP T)
else (SETQ THISPENDINGSERVICE (CONS TRANSACTION.ID (create TRANSACTIONNOTE
STATE ←(THIS.PROCESS)
TIME ←(CLOCK 0)
SOCKET ←
ES.RESPONSE.SOCKET)))
(push \ES.PENDINGSERVICES THISPENDINGSERVICE)
(OR (NULL EVALSERVER.STATUS.WINDOW)
(\ES.INVALIDATE.STATUSW))))
(TRACEAPUP (PROG1 \RequestPUP (* Comment PPLossage))
(if DUPLICATEP
then (QUOTE ("=== EvalServer Receives Duplicate Request:" \ES.LISTENER))
else (QUOTE ("=== EvalServer Receives Request:" \ES.LISTENER))))
(SETUPPUP OPUP CLIENTADDRESS CLIENTS.RECEIVER.SOCKET# \PT.ACKNOWLEDGE CLIENT'S.REF.ID
ES.RESPONSE.SOCKET)
(\SENDUNFILTEREDPUP ES.RESPONSE.SOCKET (PROG1 OPUP
(* Comment PPLossage))
(if DUPLICATEP
then (QUOTE ("=== EvalServer Re-Sends Acknowledgement of Receipt:"
\ES.DO1THING))
else (QUOTE ("=== EvalServer Sends Acknowledgement of Receipt:"
\ES.DO1THING))))
(* Acknowledge receipt of the request.)
(if DUPLICATEP
then (\ES.CLOSEOUTSOCKET ES.RESPONSE.SOCKET)
(GO RELEASE&EXIT)
elseif (AND BROADP (NEQ (fetch PUPTYPE of \RequestPUP)
\PT.EVALREQUEST.NORESULT))
then (BLOCK)
(OR (\ES.WAITFORCERTIFICATION ES.RESPONSE.SOCKET CLIENTADDRESS CLIENT'S.REF.ID
OPUP)
(GO ABORT)))
(SETQ FORM (CAR (LISTP (NLSETQ (READ.FROM.PUP \RequestPUP)))))
(if (AND (EQ (CAR (LISTP FORM))
(QUOTE \ES.BSPINFO))
(EQ TOOBIGPASSWORD (CADR FORM)))
then (* Request is indicator of huge request to come via BSP
stream)
(SETQ FORM (\ES.BSPREAD FORM)))
(SETQ VAL (NLSETQ (EVAL FORM)))
(if (EQ (fetch (PUP PUPTYPE) of \RequestPUP)
\PT.EVALREQUEST.NORESULT)
then (SETQ FINISHOW? (QUOTE COMPLETED.NORESULT))
(GO FINISHUP))
(SETQ PT (if (LISTP VAL)
then (SETQ VAL (CAR VAL))
\PT.EVALRESPONSE
else (SETQ VAL (ERRORN))
\PT.EVALERROR))
(if (fetch EPTRANSMITTING of OPUP)
then (* We'd like to re-use OPUP for output again.)
(SETQ OPUP (\ALLOCATE.BIGPUP)))
(SETUPPUP OPUP CLIENTADDRESS CLIENTS.RECEIVER.SOCKET# PT CLIENT'S.REF.ID ES.RESPONSE.SOCKET)
(if (NULL (PRINT.INTO.PUP VAL OPUP NIL NIL (QUOTE NOERROR)))
then (replace PUPLENGTH of OPUP with \PUPOVLEN)
(SETQ SENDPROC (\ES.BSPSENDFORM VAL OPUP)))
(for I to \MAXETHERTRIES as WAITINTERVAL from \ETHERTIMEOUT by \ETHERTIMEOUT
do (if (fetch EPTRANSMITTING of OPUP)
else (\SENDUNFILTEREDPUP ES.RESPONSE.SOCKET OPUP (QUOTE (
"=== EvalServer Sends Result: " \ES.DO1THING))))
(BLOCK)
(if (SETQ \RequestPUP (\GETFILTEREDPUP ES.RESPONSE.SOCKET (CONSTANT (LIST
\PT.ACKNOWLEDGE
\PT.ERROR))
CLIENT'S.REF.ID \RequestPUP WAITINTERVAL))
then (if (NEQ \PT.ERROR (fetch PUPTYPE of \RequestPUP))
then (TRACEAPUP \RequestPUP (QUOTE (
"Ah, Received Client's Acknowledgement of Results:" \ES.DO1THING)))
else (TRACEAPUP \RequestPUP (QUOTE (
"*** Client Aborts Before Receiving Results" \ES.DO1THING)))
(SETQ FINISHOW? (QUOTE COMPLETED.NORESULT)))
(RETURN))
finally (\ES.DO1THING.TIMEOUT CLIENTADDRESS CLIENT'S.REF.ID OPUP))
(if SENDPROC
then (during 120 timerUnits (QUOTE SECONDS)
do (* Bug in implementation of PROCESS.RESULT prevents its
use here!)
(SELECTQ (PROCESS.FINISHEDP SENDPROC)
(NIL (BLOCK 500))
(NORMAL (RETURN))
((ERROR DELETED)
(GO ABORT))
(SHOULDNT (QUOTE PROCESS.FINISHEDP)))
finally (\ES.DO1THING.TIMEOUT CLIENTADDRESS CLIENT'S.REF.ID OPUP)))
FINISHUP
(\ES.DELETE1PENDING THISPENDINGSERVICE FINISHOW?)
RELEASE&EXIT
(AND \RequestPUP (RECLAIM.PUP \RequestPUP))
(AND OPUP (RECLAIM.OUTPUT.PUP OPUP))
(PROCESS.RETURN NIL)
ABORT
(SETQ FINISHOW? (QUOTE ABORTED))
(GO FINISHUP))))
(\ES.WAITFORCERTIFICATION
(LAMBDA (SOC CLIENTADDRESS ID OPUP) (* JonL "20-Dec-84 10:16")
(* * If we accepted a broadcast request, then we have to wait for Client's certification that we are indeed the
selected server. Returns non-NIL if successful.)
(for I to \MAXETHERTRIES as WAITINTERVAL from \ETHERTIMEOUT by \ETHERTIMEOUT bind CPUP
do (if (NOT (SETQ CPUP (\GETFILTEREDPUP SOC (CONSTANT (LIST \PT.EVALREQUEST.CERTIFY))
ID CPUP WAITINTERVAL)))
then (if (fetch EPTRANSMITTING of OPUP)
else (\SENDUNFILTEREDPUP SOC OPUP (QUOTE (
"=== EvalServer Re-Sends Acknowledgement of Receipt:" \ES.DO1THING))))
elseif (AND (OR (ILESSP (fetch PUPLENGTH of CPUP)
(CONSTANT (ADD1 \PUPOVLEN)))
(EQ 0 (\GETBASEBYTE (fetch PUPCONTENTS of CPUP)
0))))
then (* We've been turned down in our application)
(RETURN)
else (* Ah, we are awarded the contract!)
(if (fetch EPTRANSMITTING of OPUP)
then (SHOULDNT "OPUP not ready for re-use?"))
(replace (PUP PUPTYPE) of OPUP with \PT.EVALREQUEST.CERTIFY)
(\SENDUNFILTEREDPUP SOC OPUP (QUOTE (
"=== EvalServer acknowledges certification re broadcast:" \ES.DO1THING)))
(\ES.AddSweeping (QUOTE \ES.ApplicantValid?)
CLIENTADDRESS SOC ID)
(RETURN T))
finally (PROGN (* Sigh, looks like some other applicant got the job
for the broadcast request; or maybe the client died?)
(if (fetch EPTRANSMITTING of OPUP)
then (SHOULDNT "Transmitter lock-up?"))
(RETURN)))))
(\ES.DO1THING.TIMEOUT
(LAMBDA (CLIENTADDRESS CLIENT'S.REF.ID OPUP) (* JonL " 2-Jan-85 10:21")
(printout \ES.MESSAGESTREAM T "No acknowledgement for Remote Eval service performed." T
" HOSTNAME: "
(ETHERHOSTNAME CLIENTADDRESS)
", TRANSACTION# = " CLIENT'S.REF.ID)
(if (fetch EPTRANSMITTING of OPUP)
then (SHOULDNT "Transmitter wedged?"))))
(\ES.ABORTQQ
(NLAMBDA L (* JonL "19-JUN-82 06:04")
(APPLY (FUNCTION EVALSERVER.ABORT)
L)))
(EVALSERVER.ABORT
(LAMBDA (TRANSACTION# GUILTYPARTY ERRORFLG) (* edited: "10-AUG-82 00:31")
(PROG (CLIENTHOST TRANSACTION.ID THISPENDINGSERVICE)
(SETQ CLIENTHOST (if (AND (LISTP TRANSACTION#)
(CONNECTIONIDP (CAR TRANSACTION#)))
then (PROG1 (OR (HOSTNUMBERP (CDR TRANSACTION#))
(ETHERHOSTNUMBER (CDR TRANSACTION#)))
(SETQ TRANSACTION# (CAR TRANSACTION#)))
elseif (CONNECTIONIDP TRANSACTION#)
then (for P in (APPEND \ES.PENDINGSERVICES \ES.COMPLETEDSERVICES)
bind FOUND1 do (if (EQP TRANSACTION# (CAAR P))
then (SETQ FOUND1
(if FOUND1
then T
else (CAR P))))
finally (RETURN (AND (NOT (EQ FOUND1 T))
(CDR FOUND1))))))
(SETQ TRANSACTION.ID (CONS TRANSACTION# CLIENTHOST))
(if (NULL (SETQ THISPENDINGSERVICE (SASSOC TRANSACTION.ID \ES.PENDINGSERVICES)))
then (if (SASSOC TRANSACTION.ID \ES.COMPLETEDSERVICES)
then (RETURN (QUOTE ALREADY.COMPLETED))
else ((LAMBDA (MSG)
(OR (NOT ERRORFLG)
(ERROR TRANSACTION.ID MSG))
MSG)
"No EvalService with this transaction ID in progress."))
elseif (APPLY (QUOTE \ES.ABORTPENDING)
(LIST (PROG1 THISPENDINGSERVICE (* Comment PPlossage))
(if GUILTYPARTY
then (SUBST (if (LITATOM GUILTYPARTY)
then GUILTYPARTY
else (OR (ETHERHOSTNAME GUILTYPARTY)
GUILTYPARTY))
(QUOTE GUILTYPARTY)
(QUOTE (ABORTED REMOTELY BY GUILTYPARTY))))))
then (RETURN (QUOTE ABORTED))
else ((LAMBDA (MSG)
(OR (NOT ERRORFLG)
(ERROR THISPENDINGSERVICE MSG))
MSG)
"EvalService with this transaction ID seems to be wedged.")))))
(EVALSERVER.STATUS
(LAMBDA (WHEREPENDINGFLG ID) (* JonL "27-Nov-84 14:02")
(if (NULL WHEREPENDINGFLG)
then (SETQ WHEREPENDINGFLG (QUOTE ALL)))
(PROG (P L)
(AND (MEMB WHEREPENDINGFLG (QUOTE (ALL T CURRENT RUNNING)))
(SETQ P (MAPCONC \ES.PENDINGSERVICES
(FUNCTION (LAMBDA (X)
(AND (OR (NULL ID)
(EQ ID (CAAR X)))
(LIST (LIST (\ES.MakeClientHostInfo X)
(LIST (QUOTE Process:)
(if (TYPENAMEP (SETQ X
(fetch (TRANSACTIONNOTE
STATE)
of (CDR X)))
(QUOTE PROCESS))
then (PROCESS.NAME X)
else X)))))))))
(push L (CONS (QUOTE CurrentlyRunning.Transactions:)
P)))
(if (MEMB WHEREPENDINGFLG (QUOTE (ALL T INPUT INPUTQUEUE)))
then (OR (AND (PROBABLYSOCKETP \EVALREQUEST.SOCKET)
(FMEMB \EVALREQUEST.SOCKET \PUPSOCKETS))
(SETQ \EVALREQUEST.SOCKET (OPENPUPSOCKET \SOCKET#.EVALREQUEST T)))
(while (EQ (QUOTE NEW)
(\GETFILTEREDPUP \EVALREQUEST.SOCKET (CONSTANT (LIST \PT.EVALREQUEST))
ID
(QUOTE NEW)))
do (* Be sure nothing is left in the BCPL buffers.)
(BLOCK))
(SETQ P (MAPCONC (CAR \PUPINQUEUE)
(FUNCTION (LAMBDA (X)
(SETQ P (CAR X))
(AND (EQ (CONSTANT (\LONUM \SOCKET#.EVALREQUEST))
(fetch PUPDESTSOCKETLO of P))
(EQ (CONSTANT (\HINUM \SOCKET#.EVALREQUEST))
(fetch PUPDESTSOCKETHI of P))
(TYPE\ID.OF.PUP? (CONSTANT (LIST \PT.EVALREQUEST
\PT.EVALREQUEST.NORESULT))
ID P)
(LIST (LIST (QUOTE ID#.ClientHost:)
(fetch (PUP PUPID) of P)
(OR (ETHERHOSTNAME (SETQ P
(fetch (PUP SOURCE)
of P)))
P))
(LIST (QUOTE #Secs.on.this.Queue:)
(IQUOTIENT (CLOCKDIFFERENCE (CDR X))
1000))))))))
(AND P (push L (CONS (QUOTE EvalServer.InputQueue:)
P))))
(AND (MEMB WHEREPENDINGFLG (QUOTE (ALL DONE COMPLETED FINISHED)))
(SETQ P (MAPCONC \ES.COMPLETEDSERVICES
(FUNCTION (LAMBDA (X)
(AND (OR (NULL ID)
(EQP ID (CAAR X)))
(LIST (LIST (\ES.MakeClientHostInfo X)
(LIST (QUOTE HowStop.#Seconds:)
(fetch (TRANSACTIONNOTE STATE)
of (CDR X))
(if (FIXP (SETQ P (fetch (TRANSACTIONNOTE
TIME)
of (CDR X))))
then (IQUOTIENT (CLOCKDIFFERENCE
P)
1000)
else (QUOTE ?))))))))))
(push L (CONS (QUOTE Completed.Transactions:)
P)))
(RETURN L))))
(\ES.MakeClientHostInfo
(LAMBDA (X) (* JonL " 5-NOV-82 21:45")
(LIST (QUOTE ID#.ClientHost:)
(CAAR X)
(OR (fetch (TRANSACTIONNOTE HOSTNAME) of (CDR X))
((LAMBDA (HNAME)
(if HNAME
then (replace (TRANSACTIONNOTE HOSTNAME) of (CDR X) with HNAME)
HNAME))
(ETHERHOSTNAME (CDAR X)))
(CDAR X)))))
(\ES.DELETE1PENDING
(LAMBDA (THISPENDINGSERVICE FINISHOW?) (* JonL "20-JUL-83 16:47")
(UNINTERRUPTABLY
(\ES.CLOSEOUTSOCKET (fetch (TRANSACTIONNOTE SOCKET) of (CDR THISPENDINGSERVICE)))
(replace (TRANSACTIONNOTE SOCKET) of (CDR THISPENDINGSERVICE) with NIL)
(replace (TRANSACTIONNOTE STATE) of (CDR THISPENDINGSERVICE) with FINISHOW?)
(SETQ \ES.PENDINGSERVICES (DREMOVE THISPENDINGSERVICE \ES.PENDINGSERVICES))
(replace (TRANSACTIONNOTE TIME) of (CDR THISPENDINGSERVICE) with (CLOCK 0))
(OR (MEMB THISPENDINGSERVICE \ES.COMPLETEDSERVICES)
(push \ES.COMPLETEDSERVICES THISPENDINGSERVICE))
(AND (NOT (NULL EVALSERVER.STATUS.WINDOW))
(\ES.INVALIDATE.STATUSW))
THISPENDINGSERVICE)))
(\ES.ABORTPENDING
(NLAMBDA (THISPENDINGSERVICE ABORTWHY) (* JonL "28-MAR-83 17:34")
(PROG ((STATE (fetch (TRANSACTIONNOTE STATE) of (CDR THISPENDINGSERVICE))))
(\ES.DELETE1PENDING THISPENDINGSERVICE (OR ABORTWHY (QUOTE (ABORTED LOCALLY BY ERROR/QUIT)))
)
(RETURN (OR (EQ STATE (QUOTE RUNNING))
(if (TYPENAMEP STATE (QUOTE PROCESS))
then (DEL.PROCESS STATE)
T))))))
(\ES.PURGEOLDTHINGS
(LAMBDA (SECONDSOLD MILLISECONDSOLD) (* JonL "18-JUL-83 19:39")
(OR
(AND (NULL \ES.PENDINGSERVICES)
(NULL \ES.COMPLETEDSERVICES)
(NULL (CAR \PUPINQUEUE)))
(PROG ((#DELETIONS 0)
(OLDTIME (CLOCKDIFFERENCE (if MILLISECONDSOLD
then (AND (FIXP SECONDSOLD)
(NOT (EQ 0 SECONDSOLD))
(add MILLISECONDSOLD (TIMES SECONDSOLD 1000)))
MILLISECONDSOLD
else (TIMES 1000 (OR (FIXP SECONDSOLD)
\ES.PURGEINTERVAL.SECS)))))
(OLDPUPTIME (CLOCKDIFFERENCE \PUPINQUEUE.MAXAGE))
COMPLETIONTIME)
(DECLARE (SPECVARS #DELETIONS))
(MAPC (MAPCONC \ES.PENDINGSERVICES (FUNCTION (LAMBDA (X)
(PROG ((PROC (fetch (TRANSACTIONNOTE STATE) of (CDR X))))
(AND (if (TYPENAMEP PROC (QUOTE PROCESS))
then (RELPROCESSP PROC)
else (NOT (EQ PROC (QUOTE RUNNING))))
(RETURN (LIST X)))))))
(FUNCTION \ES.DELETE1PENDING)) (* These services are "losers" because they are still on
the PENDINGSERVICES list, but their underlying process
is dead.)
(OR (NULL \ES.COMPLETEDSERVICES)
(if (OR (NULL (SETQ COMPLETIONTIME (fetch (TRANSACTIONNOTE TIME)
of (CDR (CAR \ES.COMPLETEDSERVICES)))))
(TIMEREXPIRED? COMPLETIONTIME OLDTIME))
then (* Note the \ES.COMPLETEDSERVICES is a list wherein the
more recent actions are cons'd onto the front.)
(AND \ES.TRACE? (add #DELETIONS (LENGTH \ES.COMPLETEDSERVICES)))
(SETQ \ES.COMPLETEDSERVICES NIL)
else (for L on \ES.COMPLETEDSERVICES bind X
do (if (AND (SETQ X (CADR L))
(SETQ COMPLETIONTIME (fetch (TRANSACTIONNOTE TIME)
of (CDR X)))
(TIMEREXPIRED? COMPLETIONTIME OLDTIME))
then (AND \ES.TRACE? (add #DELETIONS (LENGTH (CDR L))))
(RPLACD L NIL)
(RETURN))))) (* Trim down the record of already-completed services.
Newer entries are at the head.)
(UNINTERRUPTABLY
(PROG ((LEN (LENGTH (CAR \PUPINQUEUE))))
(if (IGREATERP LEN \PUPINQUEUE.MAXLENGTH)
then (AND \ES.TRACE? (add #DELETIONS (IDIFFERENCE LEN \PUPINQUEUE.MAXLENGTH)
))
(RPLACA \PUPINQUEUE (NTH (CAR \PUPINQUEUE)
\PUPINQUEUE.MAXLENGTH))))
(OR (NULL (CDR \PUPINQUEUE))
(if (TIMEREXPIRED? (CDR (CAR (CDR \PUPINQUEUE)))
OLDPUPTIME)
then (* Even the most recent entry on \PUPINQUEUE is too
old.)
(AND \ES.TRACE? (add #DELETIONS (LENGTH (CAR \PUPINQUEUE))))
(RPLACA \PUPINQUEUE NIL)
(RPLACD \PUPINQUEUE NIL)
else (for L on (CAR \PUPINQUEUE) as I from 0
do (if (NOT (TIMEREXPIRED? (CDR (CAR L))
OLDPUPTIME))
then (* So all the pups up until here are "oldies" too.)
(RPLACA \PUPINQUEUE L)
(AND (NULL L)
(RPLACD \PUPINQUEUE NIL))
(AND \ES.TRACE? (add I 1))
(RETURN)))
(if (CAR \PUPINQUEUE)
then (if (NOT \ES.TRACE?)
then (* Just to reduce lossage on following add command)
(SETQ #DELETIONS 0))
(PROG ((\List (CAR \PUPINQUEUE))
(\EndOfQ (CDR \PUPINQUEUE))
\BackL)
(DECLARE (LOCALVARS \Count \List \EndOfQ \BackL))
\REMTCONCloop
(if (NLISTP \List)
then (RETURN)
elseif (NOT (find X (S#LO ←(fetch PUPDESTSOCKETLO
of (CAR (CAR \List))))
(S#HI ←(fetch PUPDESTSOCKETHI
of (CAR (CAR \List))))
in \PUPSOCKETS
suchthat (AND (EQ S#LO
(fetch PSOCKLO
of X))
(EQ S#HI
(fetch PSOCKHI
of X)))))
then (* Hmmmm somebody on \PUPINQUEUE addressed to a dead
socket)
(if \BackL
then (RPLACD \BackL (CDR \List))
else (RPLACA \PUPINQUEUE \List))
(if (EQ \List \EndOfQ)
then (RPLACD \PUPINQUEUE \BackL))
(add #DELETIONS 1)
else (SETQ \BackL \List))
(pop \List)
(GO \REMTCONCloop))))))
(if \ES.TRACE?
then (printout \ES.MESSAGESTREAM .TAB0 0 "Deleted " #DELETIONS
" old things -- \ES.PURGEOLDTHINGS."))))))
)
(MOVD? (QUOTE SHOULDNT)
(QUOTE \ES.BSPINFO))
(* "Things related to coordination of Broadcast case of REMOTEVAL")
(DECLARE: EVAL@COMPILE DONTCOPY
[DECLARE: EVAL@COMPILE
(RECORD BROADAPNOTE (BROADLIMIT SERVERHOST REFID OPUP TRANSCEIVER EXITCOUNT)
(RECORD BROADLIMIT (UPROC FINALTIME)))
]
)
(RPAQ? \ES.BroadSweepQ (LIST NIL))
(RPAQ? \ES.BroadAppEVENT (CREATE.EVENT (QUOTE \ES.BroadAppEVENT)))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \ES.BroadSweepQ \ES.BroadAppEVENT \ES.BroadAppSweeper)
)
(DEFINEQ
(\ES.BroadAppSweeper
(LAMBDA NIL (* JonL "22-Nov-84 18:28")
(* This is a "broom" process for broadcast applications, which "sweeps out" any old requests which either didn't get
certified, or which thought they were certified, but the remote process is acting strangely.
Actually, other non-broadcast uses are in place now.)
(until (NULL (CAR \ES.BroadSweepQ)) bind NOTE
do (for SWEEPENTRY OPUP in (for SWEEPENTRY FINALCALL? in (CAR \ES.BroadSweepQ)
eachtime (SETQ FINALCALL? (OR (TIMEREXPIRED?
(fetch FINALTIME
of (SETQ NOTE (CDR SWEEPENTRY)
)))
(RELPROCESSP (fetch UPROC
of NOTE))))
(APPLY* (CAR SWEEPENTRY)
SWEEPENTRY FINALCALL?)
(BLOCK)
when FINALCALL? collect SWEEPENTRY)
do
(* Having made one pass down the queue, running the various item, we have collected all the ones that have
"timed out" and need to be deleted)
(UNINTERRUPTABLY
(SETQ NOTE (CDR SWEEPENTRY))
(SETQ OPUP (PROG1 (fetch OPUP of NOTE) (* Just to make sure that no one else gets to look at
this PUP after it's released.)
(replace OPUP of NOTE with NIL)))
(if (type? PUP OPUP)
then (RECLAIM.OUTPUT.PUP OPUP))
(\UNTCONC \ES.BroadSweepQ SWEEPENTRY)))
(AWAIT.EVENT \ES.BroadAppEVENT \ETHERTIMEOUT))
(SETQ \ES.BroadSweepQ) (* Its been at least \ETHERTIMEOUT ms since we were
needed, so we may as well pack it in.)
(PROCESS.RETURN)))
(\ES.AddSweeping
(LAMBDA (FUN SERVERHOST TRANSCEIVER REFID TIMEOUT.ms EXITCOUNT)
(* JonL "20-JUL-83 13:24")
(OR (LISTP \ES.BroadSweepQ)
(PROGN (OR (FIND.PROCESS (QUOTE \ES.BroadAppSweeper))
(SETQ \ES.BroadAppSweeper (ADD.PROCESS (QUOTE (\ES.BroadAppSweeper))
(QUOTE RESTARTABLE)
T)))
(SETQ \ES.BroadSweepQ (LIST NIL))))
(TCONC \ES.BroadSweepQ (CONS FUN
(create BROADAPNOTE
SERVERHOST ← SERVERHOST
TRANSCEIVER ← TRANSCEIVER
REFID ← REFID
FINALTIME ←(SETUPTIMER (OR TIMEOUT.ms
(CONSTANT (ITIMES \MAXETHERTRIES
\ETHERTIMEOUT))))
UPROC ←(THIS.PROCESS)
EXITCOUNT ← EXITCOUNT)))
(NOTIFY.EVENT \ES.BroadAppEVENT T)))
(\ES.Re-acknowledge.service
(LAMBDA (SWEEPENTRY FINALCALL?) (* JonL "18-JUL-83 17:54")
(\ES.WatchSocket SWEEPENTRY FINALCALL? NIL)))
(\ES.IgnoreApplicants
(LAMBDA (SWEEPENTRY FINALCALL?) (* JonL "18-JUL-83 18:35")
(\ES.WatchSocket SWEEPENTRY FINALCALL? (QUOTE IGNORE))))
(\ES.RejectApplicants
(LAMBDA (SWEEPENTRY FINALCALL?) (* JonL "18-JUL-83 17:55")
(\ES.WatchSocket SWEEPENTRY FINALCALL? T)))
(\ES.WatchSocket
(LAMBDA (SWEEPENTRY FINALCALL? BROADRejectAP?) (* JonL "22-Nov-84 18:21")
((LAMBDA (NOTE)
(PROG ((MY.REF.ID (fetch REFID of NOTE))
(MY.TRANSCEIVER (fetch TRANSCEIVER of NOTE))
IPUP OPUP)
A (if (AND (SETQ IPUP (\GETFILTEREDPUP MY.TRANSCEIVER (if BROADRejectAP?
then (CONSTANT (LIST
\PT.ACKNOWLEDGE))
else (CONSTANT (LIST
\PT.EVALRESPONSE
\PT.EVALERROR)))
MY.REF.ID))
(NEQ BROADRejectAP? (QUOTE IGNORE))
(OR (NULL BROADRejectAP?)
(NOT (EQP (fetch SERVERHOST of NOTE)
(fetch (PUP SOURCE) of IPUP)))))
then (SETQ OPUP (fetch OPUP of NOTE))
(if (NOT (type? PUP OPUP))
then (PROG ((ADDRESS (fetch (PUP SOURCE) of IPUP))
(SKT# (fetch (PUP SOURCESKT) of IPUP)))
(* Reclaim this guy now so that he will be available to
\ALLOCATE.BIGPUP)
(RECLAIM.PUP (PROG1 IPUP (SETQ IPUP)))
(SETUPPUP (SETQ OPUP (\ALLOCATE.BIGPUP))
ADDRESS SKT# (if (NULL BROADRejectAP?)
then \PT.ACKNOWLEDGE
else \PT.EVALREQUEST.CERTIFY)
MY.REF.ID MY.TRANSCEIVER)
(if BROADRejectAP?
then (1BYTETOPUP 0 OPUP))
(replace OPUP of NOTE with OPUP)))
(\SENDUNFILTEREDPUP MY.TRANSCEIVER OPUP (if (NULL BROADRejectAP?)
then (QUOTE (
"Late acknowledgement for services rendered" REMOTEVAL))
else (QUOTE (
"=== Losing broadcast applicant is rejected." REMOTEVAL))))
(if FINALCALL?
then (* Just to be sure)
(BLOCK)
(GO A)))
(if IPUP
then (RELEASE.PUP IPUP))
(if FINALCALL?
then (* Don't reclaim the OPUP here, since the FINALCALL?
clause of \ES.BroadAppSweeper will do so)
(\ES.EXITREMOTEVAL MY.TRANSCEIVER (fetch EXITCOUNT of NOTE)))))
(CDR SWEEPENTRY))))
(\ES.ApplicantValid?
(LAMBDA (SWEEPENTRY FINALCALL?) (* JonL " 3-Aug-84 17:46")
((LAMBDA (NOTE)
(PROG ((TRANSCEIVER (fetch TRANSCEIVER of NOTE))
(CLIENT'S.REF.ID (fetch REFID of NOTE))
CERTIFICATION.TIMER)
(if (\GETFILTEREDPUP TRANSCEIVER (CONSTANT (LIST \PT.EVALREQUEST.CERTIFY))
CLIENT'S.REF.ID
(QUOTE DELETE))
then (* The problem is that if we keep getting
"certifications" from the client, then maybe he didn't hear our acknowledgement)
(PROG ((OPUP (fetch OPUP of NOTE)))
(\SENDUNFILTEREDPUP TRANSCEIVER (if (type? PUP OPUP)
then OPUP
else (replace OPUP of NOTE
with (\ALLOCATE.BIGPUP)))
(QUOTE (
"=== EvalServer acknowledges certification re broadcast:" \ES.DO1THING)))
(replace EXITCOUNT of NOTE
with (SETUPTIMER (CONSTANT (ITIMES 2 \ETHERTIMEOUT))
(if (\TIMER.TIMERP (SETQ CERTIFICATION.TIMER
(fetch EXITCOUNT of NOTE)))
then CERTIFICATION.TIMER)))))
(if FINALCALL?
then
(* Abort service if he keeps sending requests for certification. i.e., if we got a request for certification in
the most recent half-life before exiting here)
(AND (SETQ CERTIFICATION.TIMER (fetch EXITCOUNT of NOTE))
(NOT (TIMEREXPIRED? CERTIFICATION.TIMER))
(DEL.PROCESS (fetch UPROC of NOTE))))))
(CDR SWEEPENTRY))))
)
(DECLARE: DONTEVAL@LOAD DONTEVAL@COMPILE DOCOPY
(MAPC (QUOTE (LOGOUTFORMS SYSOUTFORMS MAKESYSFORMS))
(FUNCTION (LAMBDA (X)
(MAPC (QUOTE ((BEFORE (\ES.UNCACHE))
(AFTER (\ES.RESTART))))
(FUNCTION (LAMBDA (Y)
(APPLY (QUOTE ADDTOVAR)
(CONS (PACK* (CAR Y)
X)
(CDR Y)))))))))
)
(ADDTOVAR PUPPRINTMACROS (200 CHARS 32 ...)
(202 CHARS 32 ...)
(203 CHARS 32 ...)
(204 CHARS 32 ...)
(205 BYTES 1 ...))
(* "Debugging aids")
(RPAQQ \ES.TRACE? NIL)
(RPAQQ EVALSERVER.STATUS.WINDOW NIL)
(RPAQQ \ES.LASTSTATUSLIST NIL)
(RPAQQ \ES.IQMENU NIL)
(RPAQQ \ES.RUNMENU NIL)
(RPAQQ \ES.DONEMENU NIL)
(DEFINEQ
(EVALSERVER.TRACE
(LAMBDA (FLG REGION) (* JonL "26-SEP-83 21:16")
(if (NULL FLG)
then (SETQ \ES.TRACE? NIL)
(AND (DISPLAYSTREAMP \ES.MESSAGESTREAM)
(CLOSEW (WFROMDS \ES.MESSAGESTREAM)))
NIL
else (if (OR REGION (AND (NOT (WINDOWP \ES.MESSAGESTREAM))
(NOT (DISPLAYSTREAMP \ES.MESSAGESTREAM))))
then (SETQ \ES.MESSAGESTREAM (CREATEW REGION "Remote Eval Service Actions")))
(WINDOWPROP \ES.MESSAGESTREAM (QUOTE BUTTONEVENTFN)
(FUNCTION \ES.BUGGERTRACEWINDOW))
(SETQ \ES.MESSAGESTREAM (WINDOWPROP \ES.MESSAGESTREAM (QUOTE DSP)))
(DSPFONT (FONTCREATE (QUOTE GACHA)
8)
\ES.MESSAGESTREAM)
(SETQ \ES.TRACE? T)
(DSPSCROLL T \ES.MESSAGESTREAM)
(TOTOPW \ES.MESSAGESTREAM) (* Just to be sure that the window is visible.)
\ES.MESSAGESTREAM)))
(\ES.BUGGERTRACEWINDOW
(LAMBDA (WINDOW) (* JonL "12-JUN-82 07:29")
(AND WINDOW (NOT (ACTIVEWP WINDOW))
(OPENW WINDOW))
(COND
((OR (NULL WINDOW)
(LASTMOUSESTATE LEFT))
(printout WINDOW .TAB0 0 "[Traceing " (COND
(\ES.TRACE? (SETQ \ES.TRACE? NIL)
"Off]")
(T (SETQ \ES.TRACE? T)
"On]"))))
((LASTMOUSESTATE MIDDLE)
(DSPRESET WINDOW)))
NIL))
(\ES.PRINTRACE
(LAMBDA (TPUP TRACEINFO FUN) (* JonL "14-JUN-82 17:26")
(if (AND \ES.TRACE? TRACEINFO)
then (if (LISTP TRACEINFO)
then (TERPRI \ES.MESSAGESTREAM)
(PRIN1 (pop TRACEINFO)
\ES.MESSAGESTREAM))
(PRINTPUP TPUP (if (LISTP TRACEINFO)
then (CAR TRACEINFO)
else (OR TRACEINFO FUN))
\ES.MESSAGESTREAM))))
)
(DEFINEQ
(EVALSERVER.STATUS.WINDOW
(LAMBDA (WIN/REG)
(DECLARE (GLOBALVARS WBorder WindowTitleDisplayStream))
(* JonL "28-MAY-83 22:54")
(PROG ((BLACKPART (FOLDHI WBorder 2))
(WHITEPART (FOLDLO WBorder 2))
(WHOLEWINDOWTITLE "EvalServer Status")
(TBHEIGHT (IPLUS WBorder (IMINUS (DSPLINEFEED NIL WindowTitleDisplayStream))))
INNERBORDERSIZE CUR.YPOS LEFT BOTTOM HEIGHT WIDTH)
(SETQ INNERBORDERSIZE (IPLUS WHITEPART BLACKPART WHITEPART))
(if EVALSERVER.STATUS.WINDOW
then (DELETEMENU \ES.IQMENU)
(DELETEMENU \ES.RUNMENU)
(DELETEMENU \ES.DONEMENU)
(CLEARW EVALSERVER.STATUS.WINDOW))
(SETQ \ES.LASTSTATUSLIST (EVALSERVER.STATUS))
(SETQ \ES.IQMENU (create MENU
TITLE ← "Input Queue"
ITEMS ←(\ES.STATUSW.GETITEMS (CDR (ASSOC (QUOTE
EvalServer.InputQueue:)
\ES.LASTSTATUSLIST)))
CENTERFLG ← T
WHENSELECTEDFN ←(QUOTE \ES.STATUSW.SELECTEDFN)
WHENHELDFN ←(QUOTE \ES.STATUSW.HELDFN)
MENUFONT ←(FONTCREATE (QUOTE GACHA)
10)))
(SETQ \ES.RUNMENU (create MENU
TITLE ← "Currently Running"
ITEMS ←(\ES.STATUSW.GETITEMS (CDR (ASSOC (QUOTE
CurrentlyRunning.Transactions:)
\ES.LASTSTATUSLIST)))
CENTERFLG ← T
WHENSELECTEDFN ←(QUOTE \ES.STATUSW.SELECTEDFN)
WHENHELDFN ←(QUOTE \ES.STATUSW.HELDFN)
MENUFONT ←(FONTCREATE (QUOTE GACHA)
10)))
(SETQ \ES.DONEMENU (create MENU
TITLE ← "Completed Services"
ITEMS ←(\ES.STATUSW.GETITEMS (CDR (ASSOC (QUOTE
Completed.Transactions:)
\ES.LASTSTATUSLIST)))
CENTERFLG ← T
WHENSELECTEDFN ←(QUOTE \ES.STATUSW.SELECTEDFN)
WHENHELDFN ←(QUOTE \ES.STATUSW.HELDFN)
MENUFONT ←(FONTCREATE (QUOTE GACHA)
10)))
(SETQ WIDTH (IPLUS (PROG1 WBorder (* Comment PPLossage))
(IMAX (fetch IMAGEWIDTH of \ES.IQMENU)
(fetch IMAGEWIDTH of \ES.RUNMENU)
(fetch IMAGEWIDTH of \ES.DONEMENU)
(STRINGWIDTH WHOLEWINDOWTITLE (DSPFONT NIL
WindowTitleDisplayStream)))
WBorder))
(SETQ HEIGHT (IPLUS TBHEIGHT WHITEPART (fetch IMAGEHEIGHT of \ES.IQMENU)
INNERBORDERSIZE
(fetch IMAGEHEIGHT of \ES.RUNMENU)
INNERBORDERSIZE
(fetch IMAGEHEIGHT of \ES.DONEMENU)
WBorder))
(if EVALSERVER.STATUS.WINDOW
then ((LAMBDA (OREG)
(SETQ LEFT (fetch (REGION LEFT) of OREG))
(SETQ BOTTOM (fetch (REGION BOTTOM) of OREG)))
(WINDOWPROP EVALSERVER.STATUS.WINDOW (QUOTE REGION)))
else (* Create the window "quietly" since SHAPEW will open
it.)
(SETQ EVALSERVER.STATUS.WINDOW
(CREATEW (OR WIN/REG
(CONSTANT (create REGION
LEFT ← 0
BOTTOM ← 0
WIDTH ← 100
HEIGHT ← 100)))
WHOLEWINDOWTITLE WBorder T))
(PROMPTPRINT "Position the EvalServer Status Window.")
((LAMBDA (POS)
(SETQ LEFT (fetch XCOORD of POS))
(SETQ BOTTOM (fetch YCOORD of POS)))
(GETBOXPOSITION WIDTH HEIGHT)))
(SHAPEW EVALSERVER.STATUS.WINDOW
(create REGION
LEFT ← LEFT
BOTTOM ← BOTTOM
WIDTH ← WIDTH
HEIGHT ← HEIGHT))
(SETQ CUR.YPOS (IDIFFERENCE (PROG1 HEIGHT (* Comment PPLossage))
(IPLUS TBHEIGHT WHITEPART (fetch IMAGEHEIGHT of \ES.IQMENU))))
(ADDMENU \ES.IQMENU (PROG1 EVALSERVER.STATUS.WINDOW
(* Comment PPLossage))
(create POSITION
XCOORD ←(IDIFFERENCE (IQUOTIENT (IDIFFERENCE WIDTH (fetch IMAGEWIDTH
of \ES.IQMENU))
2)
WBorder)
YCOORD ←(IDIFFERENCE CUR.YPOS WBorder)))
(SETQ CUR.YPOS (IDIFFERENCE CUR.YPOS WBorder))
(BITBLT NIL NIL NIL (SCREENBITMAP)
(IPLUS LEFT BLACKPART)
(IPLUS BOTTOM CUR.YPOS)
(IDIFFERENCE WIDTH (ITIMES 2 BLACKPART))
BLACKPART
(QUOTE TEXTURE)
(QUOTE REPLACE)
BLACKSHADE)
(SETQ CUR.YPOS (IDIFFERENCE (IDIFFERENCE CUR.YPOS WHITEPART)
(fetch IMAGEHEIGHT of \ES.RUNMENU)))
(ADDMENU \ES.RUNMENU (PROG1 EVALSERVER.STATUS.WINDOW
(* Comment PPLossage))
(create POSITION
XCOORD ←(IDIFFERENCE (IQUOTIENT (IDIFFERENCE WIDTH (fetch IMAGEWIDTH
of \ES.RUNMENU))
2)
WBorder)
YCOORD ←(IDIFFERENCE CUR.YPOS WBorder)))
(SETQ CUR.YPOS (IDIFFERENCE CUR.YPOS WBorder))
(BITBLT NIL NIL NIL (SCREENBITMAP)
(IPLUS LEFT BLACKPART)
(IPLUS BOTTOM CUR.YPOS)
(IDIFFERENCE WIDTH (ITIMES 2 BLACKPART))
BLACKPART
(QUOTE TEXTURE)
(QUOTE REPLACE)
BLACKSHADE)
(SETQ CUR.YPOS (IDIFFERENCE (IDIFFERENCE CUR.YPOS WHITEPART)
(fetch IMAGEHEIGHT of \ES.DONEMENU)))
(ADDMENU \ES.DONEMENU (PROG1 EVALSERVER.STATUS.WINDOW
(* Comment PPLossage))
(create POSITION
XCOORD ←(IDIFFERENCE (IQUOTIENT (IDIFFERENCE WIDTH (fetch IMAGEWIDTH
of \ES.DONEMENU))
2)
WBorder)
YCOORD ←(IDIFFERENCE CUR.YPOS WBorder))))))
(\ES.STATUSW.GETITEMS
(LAMBDA (L) (* JonL " 5-NOV-82 23:27")
(* Each item on L is like ((ID#.ClientHost: <nnn>
<hostname>) (...)))
(MAPCAR L (FUNCTION (LAMBDA (X)
(SETQ X (CDAR X))
(LIST (CONCAT (CADR X)
(QUOTE %.)
(CAR X))
(CONS (CAR X)
(CADR X))))))))
(\ES.STATUSW.SELECTEDFN
(LAMBDA (ITEM MENU BUTTON) (* JonL " 8-NOV-82 19:11")
(SELECT MENU ((\ES.IQMENU)
(SELECTQ BUTTON
(LEFT (* Someday, have it print out the waiting time)
)
(MIDDLE (while (\GETFILTEREDPUP \EVALREQUEST.SOCKET (CONSTANT (LIST
\PT.EVALREQUEST
\PT.EVALREQUEST.NORESULT))
(CAR (CADR ITEM))
(QUOTE DELETE))))
NIL))
((\ES.RUNMENU)
(SELECTQ BUTTON
(LEFT (* Someday have to print out more things)
)
(MIDDLE (EVALSERVER.ABORT (CADR ITEM)))
NIL))
((\ES.DONEMENU)
(SELECTQ BUTTON
(LEFT (* Someday have to print out more things)
)
(MIDDLE (PROG ((ID#.CLIENT (CONS (CAR (CADR ITEM))
(ETHERHOSTNUMBER (CDR (CADR ITEM)))))
LOSER)
(AND (SETQ LOSER (SASSOC ID#.CLIENT \ES.COMPLETEDSERVICES))
(SETQ \ES.COMPLETEDSERVICES (DREMOVE LOSER
\ES.COMPLETEDSERVICES)))))
NIL))
(SHOULDNT))
(AND (EQ BUTTON (QUOTE MIDDLE))
(SHADEITEM ITEM MENU FUZZYSHADE))))
(\ES.STATUSW.HELDFN
(LAMBDA (ITEM MENU BUTTON) (* JonL " 6-NOV-82 00:12")
(PROMPTPRINT (SELECTQ BUTTON
(LEFT "Shows more detailed information about this item.")
(MIDDLE (SELECT MENU ((\ES.IQMENU)
"Removes this request from the input queue.")
((\ES.RUNMENU)
"Aborts this service.")
((\ES.DONEMENU)
"Deletes this item from the status lists")
(QUOTE ??)))
(QUOTE ??)))))
(\ES.INVALIDATE.STATUSW
(LAMBDA NIL (* JonL " 8-NOV-82 21:42")
(AND (type? WINDOW EVALSERVER.STATUS.WINDOW)
(NEQ (WINDOWPROP EVALSERVER.STATUS.WINDOW (QUOTE BUTTONEVENTFN))
(QUOTE \ES.UPDATE.STATUSW))
(UNINTERRUPTABLY
(WINDOWPROP EVALSERVER.STATUS.WINDOW (QUOTE OLDBUTTONEVENTFN)
(WINDOWPROP EVALSERVER.STATUS.WINDOW (QUOTE BUTTONEVENTFN)
(QUOTE \ES.UPDATE.STATUSW)))
(if (ACTIVEWP EVALSERVER.STATUS.WINDOW)
then (DSPFILL NIL LIGHTGRAYSHADE (QUOTE INVERT)
EVALSERVER.STATUS.WINDOW)
else NIL)))))
(\ES.UPDATE.STATUSW
(LAMBDA (WINDOW) (* JonL " 5-NOV-82 22:36")
(PROG ((OLDBUTTONFN (WINDOWPROP WINDOW (QUOTE OLDBUTTONFN)
NIL)))
(WINDOWPROP WINDOW (QUOTE BUTTONEVENTFN)
OLDBUTTONFN) (* Restore original button fn, and apply it after fixing
up.)
(EVALSERVER.STATUS.WINDOW)
(if OLDBUTTONFN
then (APPLY* OLDBUTTONFN WINDOW)))))
)
(DECLARE: EVAL@COMPILE DONTCOPY
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \ES.TRACE? EVALSERVER.STATUS.WINDOW \ES.LASTSTATUSLIST \ES.IQMENU \ES.RUNMENU
\ES.DONEMENU)
)
(DECLARE: EVAL@COMPILE
(RPAQQ LIGHTGRAYSHADE 1)
(RPAQQ FUZZYSHADE 2564)
(CONSTANTS LIGHTGRAYSHADE FUZZYSHADE)
)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA \ES.ABORTQQ \ES.APPLYQQ)
(ADDTOVAR NLAML \ES.ABORTPENDING \ES.DO1THING \ES.LISTENER \ES.BSPSENDFORMPROC)
(ADDTOVAR LAMA )
)
(PUTPROPS EVALSERVER COPYRIGHT ("Xerox Corporation" 1982 1983 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (5477 9306 (PRIN4.INTO.STRING 5487 . 7436) (\P4S.FOOT 7438 . 7849) (\P4S.PERCHAR 7851 .
8406) (\UNTCONC 8408 . 8977) (\BOUNDNCHARSP 8979 . 9304)) (12867 23144 (READ.FROM.PUP 12877 . 14427) (
PRINT.INTO.PUP 14429 . 17563) (\HNM.MEMBER 17565 . 18246) (\NORMALIZEHOSTNUM 18248 . 18679) (
\BROADCASTADDRESS.ON.MYNET 18681 . 18922) (\GETFILTEREDPUP 18924 . 21910) (\SENDUNFILTEREDPUP 21912 .
22148) (\ES.GETSOCKET 22150 . 22673) (\ES.RECLAIM.PUP 22675 . 22945) (\ES.RELEASE.OUTPUT.PUP 22947 .
23142)) (23145 25768 (\ES.BSPREAD 23155 . 24020) (\ES.BSPSENDFORM 24022 . 24721) (\ES.BSPSENDFORMPROC
24723 . 25766)) (28465 67701 (REMOTEVAL 28475 . 34573) (\ES.SENDREQUEST 34575 . 36113) (
\ES.CERTIFYBROADWORKER 36115 . 37257) (\ES.BSERRORHANDLER 37259 . 37508) (\ES.BSPUPHANDLER 37510 .
37794) (\ES.EXITREMOTEVAL 37796 . 38717) (\ES.CLOSEOUTSOCKET 38719 . 39002) (\ES.UNCACHE 39004 . 39296
) (REMOTEABORT 39298 . 40746) (REMOTEAPPLY 40748 . 40961) (\ES.APPLYQQ 40963 . 41105) (EVALSERVER
41107 . 42010) (\ES.RESTART 42012 . 42256) (\ES.LISTENER 42258 . 47568) (\ES.DO1THING 47570 . 53674) (
\ES.WAITFORCERTIFICATION 53676 . 55626) (\ES.DO1THING.TIMEOUT 55628 . 56054) (\ES.ABORTQQ 56056 .
56212) (EVALSERVER.ABORT 56214 . 58094) (EVALSERVER.STATUS 58096 . 61301) (\ES.MakeClientHostInfo
61303 . 61721) (\ES.DELETE1PENDING 61723 . 62516) (\ES.ABORTPENDING 62518 . 62988) (\ES.PURGEOLDTHINGS
62990 . 67699)) (68238 75396 (\ES.BroadAppSweeper 68248 . 70096) (\ES.AddSweeping 70098 . 70898) (
\ES.Re-acknowledge.service 70900 . 71077) (\ES.IgnoreApplicants 71079 . 71261) (\ES.RejectApplicants
71263 . 71432) (\ES.WatchSocket 71434 . 73777) (\ES.ApplicantValid? 73779 . 75394)) (76104 77916 (
EVALSERVER.TRACE 76114 . 77029) (\ES.BUGGERTRACEWINDOW 77031 . 77480) (\ES.PRINTRACE 77482 . 77914)) (
77917 86834 (EVALSERVER.STATUS.WINDOW 77927 . 83539) (\ES.STATUSW.GETITEMS 83541 . 83974) (
\ES.STATUSW.SELECTEDFN 83976 . 85225) (\ES.STATUSW.HELDFN 85227 . 85700) (\ES.INVALIDATE.STATUSW 85702
. 86338) (\ES.UPDATE.STATUSW 86340 . 86832)))))
STOP