(FILECREATED "17-FEB-83 23:16:43" <NEWLISP>MAC.;2 50762
changes to: (FNS SUBSYS)
previous date: "17-FEB-83 23:00:13" <NEWLISP>MAC.;1)
(* Copyright (c) 1983 by Xerox Corporation)
(PRETTYCOMPRINT MACCOMS)
(RPAQQ MACCOMS ((DECLARE: FIRST (ADDVARS (NOSWAPFNS KFORK1 RFSTS GDATE DIRECTORYBLOCK)))
(FNS * MACFNS)
[P (MOVD (QUOTE CHARACTER)
(QUOTE FCHARACTER))
(SETQ FCHARAR (ARRAY 128))
(RPTQ 128 (SETA FCHARAR RPTN (CHARACTER (SUB1 RPTN]
(VARS (USERFORKLST)
(CFORKTIME (CLOCK 3))
(USERFORKS (LIST (HARRAY 25)))
(EXECFORK)
(MACSCRATCHSTRING (QUOTE
"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
))
(SUBSYSSPELLINGS (QUOTE (LISPX EXEC MACRO SRCCOM TECO SNDMSG LISP TELNET FTP NETSTAT
READMAIL CALENDAR HOSTAT RSEXEC FAIL)))
(SUBSYSRESCANFLG))
[ADDVARS (AFTERSYSOUTFORMS (PROGN (CLRHASH USERFORKS)
(SETQ USERFORKLST]
(BLOCKS * MACBLOCKS)))
(DECLARE: FIRST
(ADDTOVAR NOSWAPFNS KFORK1 RFSTS GDATE DIRECTORYBLOCK)
)
(RPAQQ MACFNS (DCHCON DUNPACK TENEX SUBSYS CFORK GCFORKS GDATE KFORK KFORK1 RFSTS GEVEC GPJFN GTJFN
RLJFN FILDIR GNJFN JFNS DELFILE RENAMEFILE PAGEFAULTS LOADAV GETAB SIXBIT GETER
ERSTR IDATE HOSTNUMBER HOSTNAME ATMCONC0 STRCONC0 STRCONC1 RPLSTR0 RAND RANDSET
CONNECTDIR DIRECTORYNAME DIRECTORYNAMEP DIRECTORYNUMBER INTERNALDIRNUM
INTERNALUSERNUM USERNAME USERNUMBER RPLSTR1 USERNAMEP))
(DEFINEQ
(DCHCON
[LAMBDA (X SCRATCHLIST FLG RDTBL) (* dcl: 27 JAN 76 20:46)
(* E (AND (OPENP)
(RADIX 10Q)))
(* Destructive CHCON. Returns value equal to value
of (CHCON X FLG) but uses conses from SCRATCHLIST.
Communicates internally by global variable DCHCONGV.
Does not erode SCRATCHLIST, i.e. conses not lost.
If SCRATCHLIST not long enough returns a real CHCON.
Works for all data-types.)
(PROG (X1 X2 X3)
(ASSEMBLE NIL
[CQ (SETQ DCHCONGV
(OR (LISTP SCRATCHLIST)
(ERROR (QUOTE
"DCHCON: SCRATCHLIST not a list")
SCRATCHLIST]
(LDV2 (QUOTE FLG)
SP 3)
(MOVEI 2 , DCHCONSUBROUTINE)
(CQ X)
(CAME 3 , KNIL)
(JRST USEPRIN2)
(FASTCALL IPRE)
(JRST DONE)
USEPRIN2
(VAR (HRRZ 3 , RDTBL))
(FASTCALL IPRE2)
DONE[CQ (RETURN (COND
((NLISTP (SETQ X1 DCHCONGV))
(* SCRATCHLIST was not
long enough. Pass the
buck to a real CHCON)
(CHCON X FLG))
((EQ X1 SCRATCHLIST)
(* In the case where X is a NULL string and FLG is
NIL, 0 chars get written out and X1 is EQ to
SCRATCHLIST. This causes the code in the last
condclause to circularize SCRATCHLIST, which can be
generally regarded as a BAD THING.
So check, and return NIL.)
NIL)
((NLISTP (SETQ X2 (CDR X1)))
(* SCRATCHLIST was just
long enough. No
cons-scrambling to do.)
(CDR SCRATCHLIST))
(T
(* The usual exit case: there were some conses left
over at the end of SCRATCHLIST.
splice them in between the first and second CONS --
this is the reason for never using the first CONS --
and return what used to be the second CONS.
All the frplacs are into values which have been
tested LISTP, except the value of FLAST, so check
that.)
(SETQ X3 (CDR SCRATCHLIST))
(FRPLACD X1 NIL)
(FRPLACD SCRATCHLIST X2)
(SETQ X2 (FLAST X2))
(COND
((LISTP X2)
(FRPLACD X2 X3))
(T (ERROR (QUOTE
"DCHCON - Unusual CDR on SCRATCHLIST: ")
X2)))
X3]
DCHCONSUBROUTINE
(PUSHN)
(CQ (CDR DCHCONGV))
(STE (QUOTE LISTT))
(JRST FRETURN)
(NREF (EXCH 2 , 0))
(ADDI 2 , ASZ)
(HRRM 2 , 0 (1))
EXIT(STV (QUOTE DCHCONGV))
(POPN 2)
(RET)
(* When you run out of conses on SCRATCHLIST,
DCHCONGV becomes NLISTP. Would like to just return a
real CHCON at that point but there is no clean way
to do equivalent of RETFROM from internal routines
(IPRE). So instead just keep doing NOP'S for each
character until IPRE unwinds.)
FRETURN
(MOVE 1 , KNIL)
(JRST EXIT])
(DUNPACK
[LAMBDA (X SCRATCHLIST FLG RDTBL) (* Like DCHCON but
returns UNPACK instead
of CHCON.)
[MAP (SETQ SCRATCHLIST (DCHCON X SCRATCHLIST FLG RDTBL))
(FUNCTION (LAMBDA (TAIL)
(FRPLACA TAIL (FCHARACTER (CAR TAIL]
SCRATCHLIST])
(TENEX
[LAMBDA (STR FILEFLG) (* lmm "11-SEP-78 02:56"
)
(PROG [BUFS VAL (20P (EQ (SYSTEMTYPE)
(QUOTE TOPS20]
(AND (NULL FILEFLG)
(SETQ BUFS (CLBUFS NIL T READBUF)))
TOP [COND
((OR (NULL EXECFORK)
(NEQ (CAR (RFSTS EXECFORK))
2)) (* Initialize the
EXECFORK.)
(SETQ EXECFORK (COND
(20P (SUBSYS (QUOTE EXEC)
(QUOTE "POP
")
(QUOTE NUL:)))
(T (SUBSYS (QUOTE EXEC)
(QUOTE "QUIT
")
(QUOTE NIL:]
[COND
((NULL FILEFLG)
(BKSYSBUF (MKSTRING STR))
(* By implementing TENEX with BKSYSBUF instead of
giving the inputs as the second rgument to SUBSYS<,
we can tell if the commands were actually executed,
or the user control-C'ed and thQUIT manually
(by the appearance of the carriage return in the
buffer).)
(BKSYSBUF (COND
(20P (QUOTE "
POP
"))
(T (QUOTE "
QUIT
"]
(TERPRI T)
(COND
([NULL (NLSETQ (SETQ EXECFORK
(SUBSYS (AND EXECFORK
(EQ (CAR (RFSTS EXECFORK))
2)
EXECFORK)
[COND
(FILEFLG (CONCAT STR
(COND
(20P "
POP
")
(T "
QUIT
"]
NIL
(QUOTE CONTINUE]
(* can occur following sysout or after a kfork
because a subsequent subsys produced a handle EQ to
EXECFORK.)
(AND (NULL FILEFLG)
(CLEARBUF T))
(SETQ EXECFORK NIL)
(GO TOP)))
(COND
(FILEFLG (RETURN T))
((AND (READP T)
(EQ (PEEKC T)
(QUOTE %
)))
(SETQ VAL T)
(READC T)))
(BKBUFS BUFS)
(RETURN VAL])
(SUBSYS
[LAMBDA (FILE/FORK INCOMFILE OUTCOMFILE ENTRYPOINTFLG)
(* lmm "17-FEB-83 23:16")
(PROG (FORK TTYMODE SAVEJFN IJFN OJFN ICLOSE OCLOSE STARTADR TEMP)
TOP (COND
((EQ FILE/FORK T) (* Continue last FORK.)
(SETQ FILE/FORK LASTSUBSYS)
(SETQQ ENTRYPOINTFLG CONTINUE)))
[COND
[(FIXP FILE/FORK) (* User restarting old one.)
(COND
((OR (NOT (GETHASH FILE/FORK USERFORKS))
(NEQ [CAR (SETQ TEMP (RFSTS (SETQ FORK FILE/FORK]
2)) (* FORK mysteriously died (like there was a SYSOUT overnite.))
(KFORK FILE/FORK)
(ERROR (QUOTE "ILLEGAL FORK:")
FILE/FORK)))
(SETQ STARTADR (SELECTQ ENTRYPOINTFLG
((NIL CONTINUE)
(CADDR TEMP))
(START -2)
(REENTER -1)
(DONTSTART (RETURN FORK))
(ERROR (QUOTE
"SUBSYS - ENTRYPOINTFLG NOT ONE OF START, REENTER, CONTINUE OR NIL:")
ENTRYPOINTFLG]
(T [SETQ SAVEJFN (COND
((OR (NULL FILE/FORK)
(EQ FILE/FORK (QUOTE EXEC)))
(GTJFN (COND
((EQ (SYSTEMTYPE)
(QUOTE TOPS20))
(QUOTE SYSTEM:EXEC.EXE))
(T (QUOTE <SYSTEM>EXEC.SAV)))
NIL NIL 32768))
((GTJFN FILE/FORK (SELECTQ SYSTEMTYPE
(TOPS20 (QUOTE EXE))
(QUOTE SAV))
NIL 32768))
((GTJFN (PACK* (SELECTQ (SYSTEMTYPE)
(TOPS20 (QUOTE SYS:))
(QUOTE <SUBSYS>))
FILE/FORK)
(SELECTQ (SYSTEMTYPE)
(TOPS20 (QUOTE EXE))
(QUOTE SAV))
NIL 32768))
((AND (SETQ SAVEJFN (FIXSPELL FILE/FORK 60 SUBSYSSPELLINGS))
(NEQ FILE/FORK SAVEJFN))
(SETQ FILE/FORK SAVEJFN)
(GO TOP))
(T (ERROR (QUOTE "SUBSYS - BAD FILE/FORK")
FILE/FORK]
(SETQ FORK (CFORK))
(ASSEMBLE NIL
(CQ (VAG FORK))
(PUSHN)
(CQ (VAG SAVEJFN))
(POPN 2)
(HRLM 2 , 1)
(* JSYS GET, takes fork,,jfn in ac1.)
(JSYS 200Q))
(SETQ STARTADR (SELECTQ ENTRYPOINTFLG
(DONTSTART (RETURN FORK))
-2]
[SETQ IJFN (COND
((NULL INCOMFILE)
(CAR (GPJFN)))
[(STRINGP INCOMFILE)
(* INCOMFILE is a command string. Set up a temporary file, print the string on it with PRIN1, close;
then open for input and return jfn.)
[SETQ IJFN (OUTPUT (OUTFILE (QUOTE SUBSYS.INCOMFILE;T]
(* Next higher version, temporary.)
(PRIN1 INCOMFILE IJFN)
(OPNJFN (SETQ ICLOSE (INPUT (INFILE (CLOSEF IJFN]
((OPENP INCOMFILE (QUOTE INPUT))
(OPNJFN (SETQ ICLOSE INCOMFILE)))
((INFILEP INCOMFILE)
(INPUT (INFILE INCOMFILE))
(OPNJFN (SETQ ICLOSE INCOMFILE)))
(T (ERROR (QUOTE "SUBSYS - BAD INCOMFILE:")
INCOMFILE]
[SETQ OJFN (COND
((NULL OUTCOMFILE)
(CDR (GPJFN)))
((OPENP OUTCOMFILE (QUOTE OUTPUT))
(OPNJFN (SETQ OCLOSE OUTCOMFILE)))
((OUTFILEP OUTCOMFILE)
(OUTPUT (OUTFILE OUTCOMFILE))
(OPNJFN (SETQ OCLOSE OUTCOMFILE)))
(T (ERROR (QUOTE "SUBSYS - BAD OUTCOMFILE:")
OUTCOMFILE]
(ASSEMBLE NIL
(CQ SUBSYSRESCANFLG)
(CAMN 1 , KNIL)
(SKIPN KL20FLG)
(JRST R0)
(HRROI 1 , 2)
(SETZ 2 , 0)
(JSYS 500Q) (* RSCAN, CLEAR THE RESCAN BUFFER)
(JFCL)
R0 (MOVEI 1 , 101Q)
(JSYS 107Q) (* RFMOD. Jfn for tty in 1, mode bits returned in 2, save on TTYMODE so can
restore after lower FORK run.)
(MOVE 1 , 2)
(FASTCALL MKN)
(SETQ TTYMODE)
(MOVE 7 , CTCTP)
T1 (HLRZ 1 , 0 (7))
(TRNN 1 , 400000Q)
(* Skip if not assigned.)
(JSYS 140Q)
(* JSYS DTI. Deassigns Terminal Interrupt code. Stepping thru the Lisp interrupt table pointed to by CTCTP
(which stands for Channel Table ConTrol Pointer or something like that and just contains pointer to CHNTAB). Effect
is to turn off all Lisp-activated interrupts I think.)
(AOBJN 7 , T1)
(* Done turning interrupts off; set up primary JFNS.)
(CQ (ASSEMBLE NIL
(* Save system dependent stuff.)
(JSYS 177Q)
(* GETNM)
(PUSHN)))
(CQ (VAG OJFN))
(PUSHN)
(CQ (VAG IJFN))
(NREF (HRLM 1 , 0))
(CQ (VAG FORK))
(POPN 2)
(JSYS 207Q) (* SPJFN. Fork handle in ac1, IJFN,,OJFN in AC2.)
(* Now start FORK at STARTADR.)
(PUSHN)
(CQ (VAG STARTADR))
(MOVE 2 , 1)
(POPN)
(CAMG 2 , = -1)
(CAMGE 2 , = -2)
(JRST S1)
(ADDI 2 , 2)
(JSYS 201Q) (* SFRKV)
(SKIPA)
S1 (JSYS 157Q) (* SFORK)
(JSYS 163Q) (* WFORK. Causes LISP to wait until lower FORK terminates.
Takes forkhandle in ac1.)
(CQ (ASSEMBLE NIL
(* Restore system dependent stuff.)
(POPN)
(JSYS 210Q)
(* SETNM)
))
(CQ (VAG TTYMODE))
(* Restore tty mode.)
(MOVE 2 , 1)
(MOVEI 1 , 101Q)
(JSYS 110Q) (* SFMOD.)
(PUSHJ CP , SETINT)
(PUSHJ CP , SETMOD)
(* Both sfmod and SETMOD are necessary: SETMOD does an sfcoc, and a sfmod as
well, but doesn't reset all bits.)
)
[COND
(ICLOSE (CLOSEF ICLOSE)
(AND (STRINGP INCOMFILE)
(DELFILE ICLOSE]
(AND OCLOSE (CLOSEF OCLOSE))
(POSITION T (LOGAND 262143 (JSYS 111Q 100Q NIL NIL 2)))
(* In case lower fork left us in the middle of a line, e.g. SNDMSG)
(RETURN (/SETATOMVAL (QUOTE LASTSUBSYS)
FORK])
(CFORK
[LAMBDA NIL (* lmm " 8-MAY-78 17:20"
)
(PROG (HANDLE)
(AND USERFORKLST [NOT (IEQP CFORKTIME (SETQ CFORKTIME
(CLOCK 3]
(GCFORKS))
(* A gc has occurred since last call to CFORK, so
there may be some forks to collect.)
(SETQ HANDLE
(LOC (ASSEMBLE NIL
(HRLZI 1 , 200000Q)
(JSYS 152Q) (* CFORK. Bit sez pass
any special capabilities
down.)
(SKIPA)
(JRST END)
(CQ (ERROR (ERSTR (LOC (AC)))
(QUOTE "TRY KILLING SOME FORKS."))
)
END)))
(PUTHASH HANDLE (CAR (SETQ USERFORKLST
(CONS (CONS (IDIFFERENCE HANDLE
400000Q))
USERFORKLST)))
USERFORKS)
(RETURN HANDLE])
(GCFORKS
[LAMBDA NIL
(MAPC USERFORKLST (FUNCTION FRPLACD)) (* Clear the marks.)
[MAPHASH USERFORKS (FUNCTION (LAMBDA (VALUE)
(FRPLACD VALUE T] (* Mark the 'live'
ones.)
[MAP USERFORKLST (FUNCTION (LAMBDA (TAIL)
(COND
((NULL (CDAR TAIL)) (* Not marked, must be
dead)
(KFORK1 (CAAR TAIL))
(* Instead of dremoving each guy from the list and
probably confusing MAP someday,)
(FRPLACA TAIL) (* Just replace them
with NIL's.)
]
(SETQ USERFORKLST (DREMOVE NIL USERFORKLST))
(* And clear all the
oils afterward in one
big DREMOVE.)
NIL])
(GDATE
[LAMBDA (DATE FORMATBITS STRPTR) (* lmm "24-JAN-79 17:30"
) (* CANNOT BE SWAPPED)
(ASSEMBLE NIL
(* Translates from internal TENEX format date to
string, smashing into STRPTR if necessary)
[CQ (VAG (FIX (OR FORMATBITS 0]
(PUSHN)
[CQ (VAG (FIX (OR DATE -1]
(PUSHN)
(CQ MACSCRATCHSTRING)
(FASTCALL UPATM)
(MOVE 1 , 3) (* string pointer)
(POPN 2) (* date)
(POPN 3) (* flags)
(JSYS 220Q) (* ODTIM)
(JUMP 16Q , RETNIL) (* if traps (>24 hours)
just return NIL)
(MOVEI 2 , 0)
(IDPB 2 , 1) (* insert extra null,
just in case)
[CQ (COND
((STRINGP STRPTR)
(STRCONC1 STRPTR))
(T (STRCONC0]
(JRST OUT)
RETNIL
(CQ NIL)
OUT])
(KFORK
[LAMBDA (FORK) (* lmm " 8-MAY-78 17:17"
)
(* Two cautions: if FORK is not legally entered in
my array and list, do not do a real KFORK since that
would allow the experimenters to bomb the forks used
by LISP internally, for overlays etc. -
Secondly always remove forks from the lists because
otherwise user has no way to clear them if he should
do his own KFORK, or after SYSIN, etc.)
(PROG (V)
(COND
[(EQ FORK T) (* Clear all user
forks.)
(MAPHASH USERFORKS (FUNCTION (LAMBDA (VALUE ITEM)
(KFORK ITEM]
((SETQ V (GETHASH FORK USERFORKS))
(KFORK1 FORK)
(SETQ USERFORKLST (DREMOVE V USERFORKLST))
(PUTHASH FORK NIL USERFORKS])
(KFORK1
[LAMBDA (FORK) (* lmm " 8-MAY-78 17:19"
)
(* Entry for killing forks without taking them off
of USERFORKLST, for GCFORKS' use ONLY, because you
can't map that list and DREMOVE guys at the same
time.)
(COND
((AND (FIXP FORK)
(NOT (IGREATERP FORK 400034Q))
(NOT (ILESSP FORK 400001Q))) (* Range check, don't
allow 400000Q since that
is 'this fork.')
(ASSEMBLE NIL
(CQ (VAG FORK))
(PUSHN)
(JSYS 156Q)
(* RFSTS. If FORK not alive, lh1 set to -1 and KFORK
will trap.)
(JUMP 16Q , ZIT) (* SO WONT TRAP ON
TOPS20 IF NO SUCH FORK)
(JRST ZIT2)
ZIT (MOVNI 1 , 1)
ZIT2(HLRE 2 , 1)
(POPN 1)
(AOJE 2 , END -1 (2))
(JSYS 153Q) (* KFORK)
END])
(RFSTS
[LAMBDA (FORK)
(* Returns list of RFSTS info, in form
(status channel pc) where status is lh1, channel is
rh1, and pc is pc; see JSYS manual.)
(ASSEMBLE NIL
(CQ (VAG (OR FORK 400000Q)))
(CAIL 1 , 400000Q)
(CAIL 1 , 400035Q)
(JRST LOSE)
(JSYS 156Q) (* RFSTS)
(JUMP 16Q , LOSE) (* ON TOPS20 WILL TRAP
IF INVALID FORK HANDLE
UNLESS THIS FROTZ
FOLLOWS)
(PUSHN)
(HLRE 1 , 1)
(CAIN 1 , -1)
(JRST LOSE)
(MOVE 1 , 2)
(FASTCALL MKN)
[CQ (SETQ FORK (CONS (AC]
(NREF (HRRE 1 , 0))
(FASTCALL MKN)
(CQ (SETQ FORK (CONS (AC)
FORK)))
(POPN)
(HLRE 1 , 1)
(FASTCALL MKN)
(CQ (CONS (AC)
FORK))
(JRST OUT)
LOSE(CQ NIL)
OUT])
(GEVEC
[LAMBDA (FORK)
(AND (RFSTS FORK)
(LOC (ASSEMBLE NIL
(CQ (VAG FORK))
(JSYS 205Q) (* GEVEC)
(MOVE 1 , 2])
(GPJFN
[LAMBDA (FORK)
(ASSEMBLE NIL
(CQ (VAG (OR FORK 400000Q)))
(JSYS 206Q)
(HLRE 1 , 2)
(PUSHN)
(HRREI 1 , 0 (2))
[CQ (SETQ FORK (LOC (AC]
(POPN)
(CQ (CONS (LOC (AC))
FORK])
(GTJFN
[LAMBDA (FILE EXT V FLAGS)
(* General scheme: create a table on numberstack to
use for long GTJFN call. Below table write the
strings for the name and extension, converting
internal alt-modes to control F'S.)
[DECLARE
(COND
((NULL SPAGHETTIFLG)
(DEFLIST
[QUOTE
((PUSHNN (NLAMBDA L
[MAPC L (FUNCTION (LAMBDA (A)
(STORIN (APPEND (QUOTE (PUSH NP ,))
A]
NIL]
(QUOTE AMAC]
(PROG NIL
[COND
((EQ 56Q (CHCON1 EXT))
(* User specified an extension like ".SAV" and the
period will cause GTJFN to die.
Take of the period.)
(SETQ EXT (SUBSTRING EXT 2 -1]
(ASSEMBLE NIL
(CQ (VAG (OR V 0)))
(PUSHNN (1)
(= 377777377777Q)
(= 0)
(= 0)
(= 0)
(XXXMHC)
(XXXMHC)
(= 0))
(CQ (VAG (OR FLAGS 0)))
(NREF (HRLM 1 , -7))
(CQ (SELECTQ
(NTYP EXT)
(30Q EXT)
[14Q (CDR (VAG (IPLUS 2 (LOC EXT]
(MKSTRING EXT)))
(MOVE 2 , XXXMHC)
(PUSHJ CP , SUBROUTINE)
(NREF (MOVEM 2 , -1)) (* First word of table
is FLAGS,,VERSION.)
(CQ (SELECTQ
(NTYP FILE)
(30Q (* STRINGP, nothing to
do.)
FILE)
[14Q (* Atom, get pname)
(CDR (VAG (IPLUS 2 (LOC FILE]
NIL)) (* NOTE WELL THAT XXXMHC
IS REALLY IOFNMP)
(* 'DEFAULT EXTENSION' word of table.
We store there a byte pointer to the part of the
numberstack immediately below this table.)
(CAMN 1 , KNIL)
(JRST OUT)
(NREF (MOVE 2 , -1))
(* This should be zero. I'm using it for a temp, to
hold the 'MAIN STRING POINTER', i.e. the pointer to
the FILE arg.)
(PUSHJ CP , SUBROUTINE)
(NREF (SETZB 2 , 0))
(NREF (EXCH 2 , -1)) (* See, I told you.)
(CQ EXT)
(* Special case: if EXT was NIL, we have actually
given "NIL" for the default extension.
Remedy situation by zeroing the word of the table,
to indicate system default for that field
(in the case of the extension, that's no extension.))
(CAMN 1 , KNIL)
(NREF (SETZM -2))
(NREF (MOVEI 1 , -7))
(JSYS 20Q) (* GTJFN)
(SKIPA 1 , KNIL)
(PUSHJ CP , MKN)
OUT (POPNN 10Q)
(CQ (RETURN (AC)))
SUBROUTINE
(FASTCALL UPATM)
(* UPATM takes a string or pname in ac1, preserves
acs 1 and 2 and returns a byte pointer in ac3 and a
byte count in ac4.)
SUBROUTINE1
(ILDB 1 , 3)
(CAIE 4 , 1)
(CAIE 1 , 33Q)
(SKIPA) (* Convert alt-modes to
control F'S unless last
char)
(HRRZI 1 , 6)
(IDPB 1 , 2)
(SOJG 4 , SUBROUTINE1)
(IDPB 4 , 2) (* Add NULL byte on end
to terminate.)
(RET])
(RLJFN
[LAMBDA (JFN)
(* Releases specified JFN, -1 for all JFN'S which do
not specify open files. Returns T on success, NIL if
error occurred, and TENEX error diagnostic available
by (ERSTR -1))
(ASSEMBLE NIL
(CQ (VAG JFN))
(JSYS 23Q)
(SKIPA 1 , KNIL)
(CQ T])
(FILDIR
[LAMBDA (FILEGROUP FORMATFLG)
(PROG ((JFN (GTJFN FILEGROUP NIL NIL 100100Q))
FILES)
(OR JFN (RETURN))
LP (SETQ FILES (CONS (JFNS (LOGAND JFN 777777Q)
FORMATFLG)
FILES))
(AND (GNJFN JFN)
(GO LP))
(RETURN (DREVERSE FILES])
(GNJFN
[LAMBDA (JFN) (* lmm "11-SEP-78 03:09"
)
(ASSEMBLE NIL
(CQ (VAG JFN))
(JSYS 17Q) (* GNJFN)
(JRST NILRET)
(LSH 1 , -23Q)
(ADDI 1 , ASZ)
(SKIPA)
NILRET
(MOVE 1 , KNIL])
(JFNS
[LAMBDA (JFN AC3 STRPTR) (* lmm " 2-OCT-78 16:02"
)
(* Converts a JFN (Lisp small number) to a filename
(either atom or string) Returns NIL if JFN in any
way illegal. AC3 is normally NIL, otherwise user has
read up on JFNS in JSYS manual)
(ASSEMBLE NIL
(CQ (VAG (FIX JFN)))
(PUSHN)
[CQ (VAG (FIX (OR AC3 211110000001Q]
(* Flag word controls
format of filename.
See JSYS manual)
(PUSHN)
(NREF (HRRZ 1 , -1))
(JSYS 24Q)
(* GETSTS; if B10 is off then the JFN is illegal and
JFNS will trap.)
(TLNE 2 , 200Q)
(JRST OK)
RNIL(CQ NIL)
(JRST RETURN)
OK (CQ MACSCRATCHSTRING)
(PUSHJ CP , UPATM)
(MOVES 0 (3))
(MOVE 4 , 3)
(MOVE 1 , 3)
(* Destination designator in ac1 specifies bytes for
MACSCRATCHSTRING. Is 310Q chars long, hope nobody
breaks it.)
(NREF (MOVE 3 , 0)) (* Formatting bits.)
(NREF (MOVE 2 , -1)) (* JFN)
(JSYS 30Q) (* JFNS.)
(JFCL)
(MOVEI 3 , 0)
(IDPB 3 , 1) (* stick extra NULL at
end, just in case)
[CQ (COND
((STRINGP STRPTR)
(STRCONC1 STRPTR))
(AC3
(* If a3 provided, i.e. request fancy formatting,
return as string because may be > 144Q chars.)
(STRCONC0))
(T (MKATOM (STRCONC1 (CONSTANT (CONCAT]
RETURN
(POPNN 2])
(DELFILE
[LAMBDA (FILE) (* dcl: 22Q Oct 116Q
09:11)
(* SHOULD SOMEDAY TAKE
STARS.)
(* Cleanupflg says delete all but current version if
any. Return list of the ones deleted.)
(PROG (X)
(COND
((OPENP FILE)
(* Error if file open, since user can close it and
try again but cannot very well get it open again to
same place.)
(RETURN))
((NULL (SETQ X (GTJFN FILE NIL -2)))
(* This used to be ERRORX call type 16;
but since we started using ERRORTYPELST to trap such
calls to ERRORX and 'fall back' to <LISP> or
<NEWLISP> or whatever to find the missing file, it
became a non-feature: you would say "DELFILE(MAC)"
and it would reply "=<LISP>MAC" and delete the
system version.)
(RETURN)))
(SETQ FILE (JFNS X))
(RETURN (AND (ASSEMBLE NIL
(CQ (VAG X))
(JSYS 26Q)
(* JSYS DELF. Deletes file just like TENEX DELETE
command, i.e. marks it for 'real deletion' at next
EXPUNGE. Thus file can be undeleted.)
(JRST FAIL)
(HRRZ 1 , KT)
(JRST OUT)
FAIL(CQ (VAG X))
(JSYS 23Q)
(JFCL)
(CQ NIL)
OUT)
FILE])
(RENAMEFILE
[LAMBDA (OLD NEW) (* lmm "18-SEP-78 01:03"
)
(PROG (OLDJFN NEWJFN VAL)
(SETQ OLDJFN (OR (GTJFN OLD)
(RETURN)))
(SETQ NEWJFN (OR (GTJFN (OR NEW (NAMEFIELD OLD T))
NIL -1)
(RETURN)))
(SETQ VAL (OR (JFNS NEWJFN)
(RETURN)))
(ASSEMBLE NIL
(CQ (VAG NEWJFN))
(PUSHN)
(CQ (VAG OLDJFN))
(NREF (HRRZ 2 , 0))
(JSYS 35Q)
(* JSYS RNAMF, renames file identified by JFN in ac1
to be filename identified by JFN in ac2.
If latter is old file, contents irretrievably lost;
should not happen unless NEW contains a version
number, since GTJFN is called with version number of
-1, which means next highest version.
OLDJFN is released by RNAMF, but NEWJFN must be
explicitly released using RLJFN.
We get both JFNS ourself, with GTJFN, but the effect
of renaming a file currently open in lisp for input
or output is uncertain.)
(PUSHJ CP , ERROR)
(POPN)
(JSYS 23Q) (* JSYS RLJFN.)
(PUSHJ CP , ERROR)
(CQ (RETURN VAL))
ERROR
(CQ (SETQ VAL))
(RET])
(PAGEFAULTS
[LAMBDA NIL (* dcl: 6 Apr 115Q
00:07)
(ASSEMBLE NIL
(MOVEI 1 , 400000Q)
(JSYS 172Q) (* GTRPI)
(MOVE 1 , 2)
(FASTCALL MKN])
(LOADAV
[LAMBDA NIL (* First ARG is
(SIXBIT (QUOTE SYSTAT)))
(GETAB -140614133614Q 14Q (QUOTE FLOATING])
(GETAB
[LAMBDA (TABLENAME INDEX FORMATFLG)
(* lmm "31-AUG-81 13:46")
(* Makes the JSYS GETAB available. TABLENAME is a number a string (OR LITATOM) and expected to be one of the system
tables documented in section 3 of the JSYS manual, which GETAB will know about. INDEX is the INDEX, into that table.
FORMATFLG can be 'floating to get answer as floating-point, as in LOADAV, or NIL to get fixed-point.
Perhaps if there is a use FORMATFLG might believe ascii or SIXBIT etc.)
(ASSEMBLE NIL
[CQ (VAG (OR (FIXP TABLENAME)
(SIXBIT TABLENAME]
(JSYS 16Q) (* SYSGT)
(PUSHN 2)
(JUMPE 2 , RETNIL)
(CQ (VAG (OR INDEX 0)))
(NREF (HRLM 1 , 0))
(NREF (MOVE 1 , 0))
(JSYS 10Q) (* GETAB)
(JRST RETNIL)
(VAR (HRRZ 2 , FORMATFLG))
(CAMN 2 , ' FLOATING)
(JRST FLOAT)
(CAMN 2 , KNIL)
(JRST FIX)
(CAMN 2 , ' SIXBIT)
(JRST SIXBIT)
(NREF (MOVEM 1 , 0))
(CQ (VAG (NTYP FORMATFLG)))
(CAIE 1 , FIXT)
(CAIN 1 , FLOATT)
(JRST SMASHN)
FIX (CQ (LOC (AC)))
(JRST OUT)
FLOAT
(FASTCALL MKFN)
(JRST OUT)
SIXBIT
[CQ (SIXBIT (LOC (AC]
(JRST OUT)
(CQ (LOC (AC)))
(JRST OUT)
SMASHN
(CQ FORMATFLG)
(NREF (MOVE 2 , 0))
(MOVEM 2 , 0 (1))
(JRST OUT)
RETNIL
(CQ NIL)
OUT (POPNN 1])
(SIXBIT
[LAMBDA (X) (* lmm "18-SEP-78 03:27"
)
(* Converts a fixed-point number to an string, and
an atom or string to a fixed-point number.
Originally written for GETAB.)
(COND
[(FIXP X)
(ASSEMBLE NIL
(CQ (VAG X))
(PUSHN)
(CQ MACSCRATCHSTRING)
(PUSHJ CP , UPATM)
(MOVES 0 (3))
(POPN 2)
LOOP(MOVEI 1 , 0)
(LSHC 1 , 6)
(ADDI 1 , 40Q)
(IDPB 1 , 3)
(JUMPN 2 , LOOP)
(IDPB 2 , 3) (* Add NULL byte to
terminate.)
(CQ (STRCONC0]
(T (LOC (ASSEMBLE NIL
[CQ (COND
[(LITATOM X)
(CDR (VAG (IPLUS 2 (LOC X]
((STRINGP X)
X)
(T (ERRORX (LIST 33Q X]
(PUSHJ CP , UPATM)
(CAILE 4 , 6)
(HRRZI 4 , 6)
(HRREI 5 , -6 (4))
(SETZ 1 , 0)
LOOP(SOJL 4 , LOOP2)
(ILDB 2 , 3)
(LSH 1 , 6)
(ADDI 1 , -40Q (2))
(JRST LOOP)
LOOP2
(AOJG 5 , OUT)
(LSH 1 , 6)
(JRST LOOP2)
OUT])
(GETER
[LAMBDA NIL (* dcl: 25Q Feb 115Q
00:34)
(* JSYS GETER, returns
most recent system error
number.)
(LOC (ASSEMBLE NIL
(CQ (VAG 400000Q)) (* This fork.)
(JSYS 12Q) (* GETER)
(HRRZI 1 , 0 (2])
(ERSTR
[LAMBDA (ERN) (* lmm "11-SEP-78 03:10"
)
(* Makes the JSYS ERSTR available.
ERN is the error number as returned from GETER, or
NIL or minus one for most recent error.
Returns the TENEX error diagnostic as a string.
Used for assemble code where you call JSYS's and
want to do something reasonable with their error
returns. If ERRFLG is T actually call ERROR;
else just return the string.)
(ASSEMBLE NIL
(CQ ERN)
(CAMN 1 , KNIL)
(SKIPA 1 , MINUS1)
(PUSHJ CP , GUNBOX)
(PUSHN)
(CQ MACSCRATCHSTRING)
(PUSHJ CP , UPATM)
(MOVES 0 (3))
(MOVE 1 , 3) (* Destination
designator in ac1,
points into the dirty
string.)
(POPN 2) (* Error number to RH of
ac2)
(HRLI 2 , 400000Q) (* LH ac2 specifies
fork, 400000Q = this
fork.)
(HRLZI 3 , 0 (4))
(* Maximum number of characters to transfer must be
in ac3 left, UPATM left it in ac4.)
(JSYS 11Q) (* ERSTR)
(JFCL)
(JRST FALSE) (* ERSTR double-skips if
happy.)
(SETZ 3 ,)
(IDPB 3 , 1) (* Null byte supposedly
provided by ERSTR but it
isn't.)
(CQ (STRCONC0))
(JRST END)
MINUS1
(XWD 777777Q 777777Q)
FALSE
(CQ NIL)
END])
(IDATE
[LAMBDA (D) (* lmm "11-SEP-78 03:00"
)
(ASSEMBLE NIL
(CQ D)
(CAMN 1 , KNIL)
(JRST DO-GTAD)
(CQ (RPLSTR0 (AC)))
(CQ MACSCRATCHSTRING)
(PUSHJ CP , UPATM)
(MOVES 0 (3))
(MOVE 1 , 3)
(SETZM 2)
(JSYS 221Q) (* JSYS IDTIM)
(JRST FALSE)
(MOVE 1 , 2)
(JRST BOX)
DO-GTAD
(JSYS 227Q) (* GTAD)
(JRST BOX)
FALSE
(CQ NIL)
(JRST OUT)
BOX (FASTCALL MKN)
OUT])
(HOSTNUMBER
[LAMBDA NIL (* BMW "21-May-81 11:53"
)
(OR (AND (GETAB (QUOTE NETRDY)
0)
(PROG1 (JSYS 273Q 0 NIL NIL 4) (* i.e., JSYS GTHST)
))
-1])
(HOSTNAME
[LAMBDA (HOSTN FLG) (* BMW "21-May-81 13:52"
)
(COND
((EQ (OR HOSTN (SETQ HOSTN (HOSTNUMBER)))
-1)
NIL)
(T (ASSEMBLE NIL
(CQ (VAG HOSTN))
(PUSHN)
(CQ MACSCRATCHSTRING)
(PUSHJ CP , UPATM)
(MOVES 0 (3))
(MOVE 2 , 3)
(POPN 3)
(MOVEI 1 , 2)
(JSYS 273Q) (* i.e., JSYS GTHST)
(JRST RETNIL)
[CQ (COND
((STRINGP FLG)
(STRCONC1 FLG))
(FLG (ATMCONC0))
(T (STRCONC0]
(JRST OUT)
RETNIL
(CQ NIL)
OUT])
(ATMCONC0
[LAMBDA NIL (* dcl: 16Q Dec 116Q
11:47)
(* Utility for my internal use, returns
(MKATOM (SUBSTRING MACSCRATCHSTRING 1
(STRPOS MACSCRATCHSTRING (CHARACTER 0)))))
(ASSEMBLE NIL
(CQ MACSCRATCHSTRING) (* Globalvar.)
(PUSHJ CP , UPATM)
(PUSH CP , 3) (* Ptr to stack so gc
will update it.)
(PUSHJ CP , PACS) (* Init. atom maker)
(SKIPA)
LP (PUSHJ CP , PAC) (* Emit 1 char.)
(ILDB 1 , 0 (CP))
(JUMPN 1 , LP)
(POP CP , 2) (* Flush CP word.)
(PUSHJ CP , MKATM])
(STRCONC0
[LAMBDA NIL
(* Utility for my internal use, returns
(CONCAT (SUBSTRING MACSCRATCHSTRING 1
(STRPOS MACSCRATCHSTRING (CHARACTER 0)))))
(ASSEMBLE NIL
(CQ MACSCRATCHSTRING) (* Globalvar.)
(PUSHJ CP , UPATM)
(PUSH CP , 3) (* Ptr to stack so gc
will update it.)
(PUSHJ CP , MKSTRS) (* Init. Stringmaker)
(SKIPA)
LP (PUSHJ CP , MKSTR1) (* Emit 1 char.)
(ILDB 1 , 0 (CP))
(JUMPN 1 , LP)
(POP CP , 2) (* Flush CP word.)
(MOVE 1 , UNP1)
(PUSHJ CP , MKSP])
(STRCONC1
[LAMBDA (FLG) (* lmm "29-JUL-78 02:15"
) (* (SUBSTRING
MACSCRATCHSTRING 1
(STRPOS MACSCRATCHSTRING
(CHARACTER 0)) FLG))
(ASSEMBLE NIL
(CQ MACSCRATCHSTRING)
(MOVE 2 , 0 (1))
(CQ FLG)
(MOVEM 2 , 0 (1))
(PUSHJ CP , UPATM)
(MOVEI 4 , 0) (* init counter)
LP (ILDB 1 , 3) (* get next char)
(JUMPE 1 , OUT)
(AOJA 4 , LP)
OUT (CQ FLG)
(DPB 4 , = 251601000000Q) (* (POINT 14,@0{1},14))
])
(RPLSTR0
[LAMBDA (STR) (* lmm "11-SEP-78 03:01"
)
(* My internal utility, inverse of STRCONC0: writes
STR onto MACSCRATCHSTRING, starting at front, and
adds a NULL byte after it. Argument must be string
or pname, or it will give error.
Special hack: if ARG ends in alt-mode, altmode is
stripped off and T returned, else returns NIL.
For USERNUMBER.)
(ASSEMBLE NIL
(CQ STR)
(LDTY 2)
(CAIN 2 , 30Q) (* String?)
(JRST OK) (* Yes.)
(CAIE 2 , 14Q) (* Litatom?)
(JRST OHOH) (* Only called
internally.)
(HLRZ 1 , 2 (1)) (* Convert to pname.)
(JRST OK)
OVFLO
(CQ (ERROR (QUOTE "Too big for string buff:")
STR))
OHOH(CQ (ERROR (QUOTE "Arg not string or atom:")
STR))
OK (PUSHJ CP , UPATM)
(PUSH CP , 3)
(PUSHN 4)
(CQ MACSCRATCHSTRING)
(PUSHJ CP , UPATM)
(MOVES 0 (3)) (* MAKE SURE BYTE PG
UNSHARED)
(NREF (CAMG 4 , 0)) (* Scratch > str? must
be greater so str+null
g.e.)
(JRST OVFLO)
(POPN 4)
(POP CP , 2)
(* Assignments: -
1 bytebucket -
2 read ptr to str -
3 write ptr to buf -
4 count)
(JUMPE 4 , OUT)
LOOP(ILDB 1 , 2)
(IDPB 1 , 3)
(SOJG 4 , LOOP)
(CAIN 1 , 33Q) (* Last byte altmode?)
(DPB 4 , 3) (* Clobber with NULL.)
OUT (IDPB 4 , 3) (* Write NULL after.)
(CAIE 1 , 33Q) (* Altmodep again)
(SKIPA 1 , KNIL) (* No.)
(CQ T) (* Yes.)
])
(RAND
[LAMBDA (LOWER UPPER) (* lmm "21-SEP-81 22:22")
(* This function implements the XRAND subroutine described in Stanford memo STAN-CS-77-601, Analysis of Additive
Random Number Generators, by John F. Reiser, on p 28.0 Rather than storing the X values in an array and computing
indexes I and J, however, I have elected to retain state in a circular list of 51 elements. RANDSTATE is
(CONS X (NTH X 31)); each time RAND is called, both CAR and CDR of RANDSTATE are CDR'ed to effectively increment the
index. In addition, the numbers are stored as 35 bit binary fractions (i.e. the decimal point is on the left of the
35-bit quantity))
(ASSEMBLE NIL
(CQ (OR (LISTP RANDSTATE)
(PROGN (RANDSET T)
RANDSTATE)))
(HRRZ 2 , 0 (1)) (* (CQ2 (CAR RANDSTATE)))
(HLRZ 3 , 0 (1)) (* (CQ3 (CDR RANDSTATE)))
(HLRZ 2 , 0 (2)) (* (SETQ 2 (CDR 2)))
(HLRZ 3 , 0 (3)) (* (SETQ 3 (CDR 3)))
(HRLI 2 , 0 (3))
(MOVEM 2 , 0 (1)) (* (FRPLNODE RANDSTATE 2 3))
(HRRZ 2 , 0 (2)) (* (SETQ 2 (CAR 2)))
(HRRZ 3 , 0 (3)) (* (SETQ 3 (CAR 3)))
(MOVE 1 , 0 (2)) (* (SETQ 1 (VAG 2)))
(SUB 1 , 0 (3))
(TLZ 1 , 400000Q) (* clear sign bit -
this effectively computes the number modulo 1)
(* Now store X{i} back into the 1st box)
(MOVEM 1 , 0 (2)))
(COND
((AND (FIXP LOWER)
(FIXP UPPER))
(IPLUS [LOC (ASSEMBLE NIL
[CQ (VAG (ADD1 (IDIFFERENCE UPPER LOWER]
(CQ2 (CAAR RANDSTATE))
(MUL 1 , 0 (2]
LOWER))
(T (FPLUS (FTIMES (FLOC (ASSEMBLE NIL
(CQ (CAAR RANDSTATE))
(MOVE 1 , 0 (1))
(LSH 1 , -10Q)
(FSC 1 , 200Q)))
(FDIFFERENCE UPPER LOWER))
LOWER])
(RANDSET
[LAMBDA (X) (* lmm: "29-JUN-77 16:09"
)
(PROG (RS RS1 RS2)
(COND
((NULL X)
(GO OUT))
((EQ X T) (* initialize with
clock)
(SETQ RS1 (CLOCK))
(SETQ RS2 (IDATE)))
((AND (FIXP (CDR (LISTP X)))
(FIXP (CAR X))) (* user supplies
initialization,
old-style)
(SETQ RS1 (CAR X))
(SETQ RS2 (CDR X)))
((AND (EQ (LENGTH X)
67Q)
(EVERY X (FUNCTION FIXP)))
[SETQ RS (MAPCAR X (FUNCTION (LAMBDA (N Y)
(CLOSER (LOC (SETQ Y
(IPLUS 575360400Q)))
N]
(GO XX))
(T (ERROR (QUOTE "ARG NOT PREVIOUS VALUE OF RANDSET")
X)))
[SETQ RS
(MAPCAR (QUOTE (47447503155Q 326000024101Q 231110260611Q
227761755153Q 232325706615Q
257441134336Q 142066625213Q
220351020462Q 41050065502Q
354112240237Q 347723367427Q
4143151614Q 155441143612Q
322577020366Q 53536334175Q
345317007070Q 246306130377Q
310574310360Q 363024357667Q
214106215653Q 310463172341Q
11247622224Q 357251716512Q
327771474465Q 106336512534Q
62542651720Q 32000042612Q
102726157734Q 212027450455Q
146411472776Q 12167637517Q
163346751512Q 145606523205Q
373036416215Q 123517722614Q
116345213643Q 22266545767Q
272451137321Q 145226166110Q
354607155455Q 43655353345Q
220445470512Q 266640523172Q
233412640056Q 42407046627Q
360344105522Q 320213565147Q
355242324677Q 207411666774Q
277103114257Q 140765617644Q
304415444727Q 142614615772Q
336716353021Q 307146527652Q))
(FUNCTION (LAMBDA (Z)
(LOGAND [IPLUS Z
(SETQ RS2
(PROG1 (IPLUS (ITIMES RS1
2732046635Q)
RS1)
(SETQ RS1 RS2]
377777777777Q]
XX (FRPLACD (LAST RS)
RS)
(SETQ RANDSTATE (CONS RS (FNTH RS 37Q)))
OUT (RETURN (for X in (CAR RANDSTATE) as I from 1 to 67Q
collect (IPLUS X 0])
(CONNECTDIR
[LAMBDA (DIRNAME PASSWORD FLG) (* dcl: 33Q Feb 117Q
11:08)
(PROG ((DNUM (INTERNALDIRNUM DIRNAME 1.419769E32)))
(OR DNUM (RETURN))
(RPLSTR0 PASSWORD)
(AND (SELECTQ (SYSTEMTYPE)
(TENEX (ASSEMBLE NIL
(CQ MACSCRATCHSTRING)
(PUSHJ CP , UPATM)
(CQ DNUM)
(MOVE 1 , 0 (1))
(MOVE 2 , 3)
(JSYS 44Q)
(* CNDIR)
(SKIPA 1 , KNIL)
(CQ T)))
(TOPS20
(ASSEMBLE NIL
(CQ MACSCRATCHSTRING)
(PUSHJ CP , UPATM)
(MOVE 4 , 3)
(CQ DNUM)
(MOVE 3 , 0 (1))
(SETO 5 ,)
(CQ (SELECTQ FLG
((NIL CONNECT)
(VAG -377777777775Q))
((T ACCESS)
(VAG 200000000003Q))
(NOACCESS (VAG
100000000003Q))
(RETURN)))
(MOVEI 2 , 3)
(JSYS 552Q)
(JUMP 16Q , FALSE)
(SKIPA 1 , KT)
FALSE
(CQ NIL)))
NIL)
(RETURN (DIRECTORYNAME DNUM T])
(DIRECTORYNAME
[LAMBDA (DIRNAME STRPTR) (* dcl: 2 Feb 117Q
16:24)
(ASSEMBLE NIL
[CQ (VAG (OR (NUMBERP DIRNAME)
(INTERNALDIRNUM DIRNAME 1.419769E32)
(GO FALSE]
D (PUSHN)
(CQ MACSCRATCHSTRING)
(PUSHJ CP , UPATM)
(MOVES 0 (3))
(MOVE 1 , 3)
(POPN 2)
(JSYS 41Q) (* DIRST)
(JRST FALSE)
[CQ (COND
((STRINGP STRPTR)
(STRCONC1 STRPTR))
(STRPTR (ATMCONC0))
(T (STRCONC0]
(JRST END)
FALSE
(CQ NIL)
END])
(DIRECTORYNAMEP
[LAMBDA (DIRNAME)
(DECLARE (LOCALVARS . T)) (* dcl: 2 Feb 117Q
16:24)
(AND (INTERNALDIRNUM DIRNAME 1.0)
T])
(DIRECTORYNUMBER
[LAMBDA (DIRNAME) (* dcl: 2 Feb 117Q
16:25)
(DECLARE (LOCALVARS . T))
(INTERNALDIRNUM DIRNAME])
(INTERNALDIRNUM
[LAMBDA (A FLG) (* dcl: 15Q Sep 117Q
14:12)
(DECLARE (LOCALVARS . T))
(ASSEMBLE NIL
(JRST START)
OLD-CONNECTED-DIRECTORY
(JSYS 13Q)
(SKIPA 1 , 2)
OLD-LOGIN-DIRECTORY
(JSYS 13Q)
(JRST BOX)
SETUP
(HRLZI 2 , 400000Q)
(CAMN 1 , KNIL)
(SETZ 2 , 0)
(PUSHN 2)
(CQ MACSCRATCHSTRING)
(PUSHJ CP , UPATM)
(MOVES 0 (3))
(MOVE 2 , 3)
(POPN)
(POPJ CP ,)
DOKL20
(SKIPN 1)
(HRLZI 1 , 1)
(JSYS 553Q) (* RCDIR)
(JUMP 16Q , RET) (* ERJMP)
(TLNE 1 , 60000Q)
(JRST RET)
(MOVE 1 , 3)
(AOS 0 (CP))
RET (POPJ CP ,)
START
(MOVE 2 , TOPS20RELEASE)
(AND 2 , KL20FLG)
(CQ A)
(CAMN 1 , KNIL)
(JRST LOGIN-DIRECTORY)
(CAMN 1 , KT)
(JRST CONNECTED-DIRECTORY)
(CQ (RPLSTR0 (AC)))
(PUSHJ CP , SETUP)
(SKIPE KL20FLG)
(JRST KL20)
(JSYS 40Q)
(JFCL)
FALSE
(SKIPA 1 , KNIL)
(SKIPA)
(JRST OUT)
(HRRZ 1 , 1)
(JRST BOX)
KL20(PUSHJ CP , DOKL20)
(SKIPA)
(JRST BOX)
(CQ (RPLSTR1 A))
(PUSHJ CP , SETUP)
(PUSHJ CP , DOKL20)
(JRST FALSE)
(JRST BOX)
CONNECTED-DIRECTORY
(CAIGE 2 , 3)
(JRST OLD-CONNECTED-DIRECTORY)
(SKIPA 3 , = 3)
LOGIN-DIRECTORY
(MOVEI 3 , 17Q)
(CAIGE 2 , 3)
(JRST OLD-LOGIN-DIRECTORY)
(SETO 1 ,)
(HRROI 2 , 4)
(JSYS 507Q)
(JRST FALSE) (* SHOULD HAPPEN?)
(MOVE 1 , 4)
BOX (VAR (HRRZ 2 , FLG))
(CAME 2 , KNIL)
(JRST SMASH)
(PUSHJ CP , MKN)
(JRST OUT)
SMASH
(MOVEM 1 , 0 (2))
(MOVE 1 , 2)
OUT])
(INTERNALUSERNUM
[LAMBDA (A FLG) (* dcl: 37Q Jan 117Q
14:08)
(DECLARE (LOCALVARS . T))
(ASSEMBLE NIL
(CQ A)
(CAMN 1 , KNIL)
(JRST LOGIN-DIRECTORY)
(CQ (RPLSTR0 (AC)))
(HRLZI 2 , 400000Q)
(CAMN 1 , KNIL)
(SETZ 2 , 0)
(PUSHN 2)
(CQ MACSCRATCHSTRING)
(PUSHJ CP , UPATM)
(MOVES 0 (3))
(MOVE 2 , 3)
(POPN)
(SKIPE KL20FLG)
(JRST KL20)
(JSYS 40Q)
(JFCL)
FALSE
(SKIPA 1 , KNIL)
(SKIPA)
(JRST OUT)
(HRRZ 1 , 1)
(JRST BOX)
KL20(SKIPN 1)
(HRLZI 1 , 1)
(JSYS 554Q) (* RCUSR)
(JUMP 16Q , FALSE) (* ERJMP)
(TLNE 1 , 60000Q)
(JRST FALSE)
(MOVE 1 , 3)
(JRST BOX)
LOGIN-DIRECTORY
(JSYS 13Q)
BOX (VAR (HRRZ 2 , FLG))
(CAME 2 , KNIL)
(JRST SMASH)
(PUSHJ CP , MKN)
(JRST OUT)
SMASH
(MOVEM 1 , 0 (2))
(MOVE 1 , 2)
OUT])
(USERNAME
[LAMBDA (USERNAME STRPTR) (* dcl: 2 Feb 117Q
16:25)
(ASSEMBLE NIL
[CQ (VAG (OR (NUMBERP USERNAME)
(INTERNALUSERNUM USERNAME 1.419769E32)
(GO FALSE]
(PUSHN)
(CQ MACSCRATCHSTRING)
(PUSHJ CP , UPATM)
(MOVES 0 (3))
(MOVE 1 , 3)
(POPN 2)
(JSYS 41Q) (* DIRST)
(JRST FALSE)
[CQ (COND
((STRINGP STRPTR)
(STRCONC1 STRPTR))
(STRPTR (ATMCONC0))
(T (STRCONC0]
(JRST END)
FALSE
(CQ NIL)
END])
(USERNUMBER
[LAMBDA (USERNAME) (* dcl: 2 Feb 117Q
16:26)
(DECLARE (LOCALVARS . T))
(INTERNALUSERNUM USERNAME])
(RPLSTR1
[LAMBDA (STR) (* dcl: 2 Feb 117Q
16:46)
(* My internal utility, inverse of STRCONC0: writes
STR onto MACSCRATCHSTRING, starting at front, and
adds a NULL byte after it. Argument must be string
or pname, or it will give error.
Special hack: if ARG ends in alt-mode, altmode is
stripped off and T returned, else returns NIL.
For DIRECTORYNUMBER. Also, puts on the angle
brackets for a directory name.)
(ASSEMBLE NIL
(CQ STR)
(LDTY 2)
(CAIN 2 , 30Q) (* String?)
(JRST OK) (* Yes.)
(CAIE 2 , 14Q) (* Litatom?)
(JRST OHOH) (* Only called
internally.)
(HLRZ 1 , 2 (1)) (* Convert to pname.)
(JRST OK)
OVFLO
(CQ (ERROR (QUOTE "Too big for string buff:")
STR))
OHOH(CQ (ERROR (QUOTE "Arg not string or atom:")
STR))
OK (PUSHJ CP , UPATM)
(PUSH CP , 3)
(PUSHN 4)
(CQ MACSCRATCHSTRING)
(PUSHJ CP , UPATM)
(MOVES 0 (3)) (* MAKE SURE BYTE PG
UNSHARED)
(NREF (CAMG 4 , 0)) (* Scratch > str? must
be greater so str+null
g.e.)
(JRST OVFLO)
(POPN 4)
(POP CP , 2)
(* Assignments: -
1 bytebucket -
2 read ptr to str -
3 write ptr to buf -
4 count)
(JUMPE 4 , OUT)
(MOVEI 1 , 74Q) (* "<")
(IDPB 1 , 3)
LOOP(ILDB 1 , 2)
(IDPB 1 , 3)
(SOJG 4 , LOOP)
(CAIE 1 , 33Q) (* Last byte altmode?)
(JRST BRKET)
(DPB 4 , 3) (* Clobber with NULL.)
(JRST OUT)
BRKET
(MOVEI 2 , 76Q) (* ">")
(IDPB 2 , 3)
OUT (IDPB 4 , 3) (* Write NULL after.)
(CAIE 1 , 33Q) (* Altmodep again)
(SKIPA 1 , KNIL) (* No.)
(CQ T) (* Yes.)
])
(USERNAMEP
[LAMBDA (USERNAME)
(DECLARE (LOCALVARS . T)) (* dcl: 33Q Feb 117Q
14:52)
(AND (INTERNALUSERNUM USERNAME 1.419769E32)
T])
)
(MOVD (QUOTE CHARACTER)
(QUOTE FCHARACTER))
(SETQ FCHARAR (ARRAY 128))
[RPTQ 128 (SETA FCHARAR RPTN (CHARACTER (SUB1 RPTN]
(RPAQQ USERFORKLST NIL)
(RPAQ CFORKTIME (CLOCK 3))
(RPAQ USERFORKS (LIST (HARRAY 25)))
(RPAQQ EXECFORK NIL)
(RPAQQ MACSCRATCHSTRING
"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
)
(RPAQQ SUBSYSSPELLINGS (LISPX EXEC MACRO SRCCOM TECO SNDMSG LISP TELNET FTP NETSTAT READMAIL CALENDAR
HOSTAT RSEXEC FAIL))
(RPAQQ SUBSYSRESCANFLG NIL)
(ADDTOVAR AFTERSYSOUTFORMS (PROGN (CLRHASH USERFORKS)
(SETQ USERFORKLST)))
(RPAQQ MACBLOCKS ((DCHCONBLOCK DUNPACK DCHCON (ENTRIES DUNPACK DCHCON)
(GLOBALVARS DCHCONGV))
(FORKBLOCK SUBSYS TENEX CFORK GCFORKS GPJFN (ENTRIES SUBSYS TENEX CFORK)
(GLOBALVARS USERFORKS USERFORKLST CFORKTIME READBUF EXECFORK SUBSYSSPELLINGS
LASTSUBSYS))
(NIL KFORK KFORK1 RFSTS GEVEC GTJFN RLJFN DELFILE RENAMEFILE PAGEFAULTS LOADAV GETER RAND
RANDSET GETAB RPLSTR0 HOSTNUMBER (LOCALVARS . T)
IDATE USERNUMBER (GLOBALVARS MACSCRATCHSTRING RANDSTATE USERFORKS USERFORKLST)
GDATE)
(MACSTRBLOCK ATMCONC0 STRCONC0 STRCONC1 JFNS SIXBIT ERSTR HOSTNAME
(ENTRIES ATMCONC0 STRCONC0 STRCONC1 JFNS SIXBIT ERSTR HOSTNAME))
(DIRECTORYBLOCK CONNECTDIR DIRECTORYNAME DIRECTORYNAMEP DIRECTORYNUMBER INTERNALDIRNUM
INTERNALUSERNUM USERNAME USERNUMBER RPLSTR1 USERNAMEP
(ENTRIES CONNECTDIR DIRECTORYNAME DIRECTORYNAMEP DIRECTORYNUMBER USERNAME
USERNUMBER USERNAMEP))
(FILDIR FILDIR GNJFN (NOLINKFNS . T))))
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: DCHCONBLOCK DUNPACK DCHCON (ENTRIES DUNPACK DCHCON)
(GLOBALVARS DCHCONGV))
(BLOCK: FORKBLOCK SUBSYS TENEX CFORK GCFORKS GPJFN (ENTRIES SUBSYS TENEX CFORK)
(GLOBALVARS USERFORKS USERFORKLST CFORKTIME READBUF EXECFORK SUBSYSSPELLINGS LASTSUBSYS))
(BLOCK: NIL KFORK KFORK1 RFSTS GEVEC GTJFN RLJFN DELFILE RENAMEFILE PAGEFAULTS LOADAV GETER RAND
RANDSET GETAB RPLSTR0 HOSTNUMBER (LOCALVARS . T)
IDATE USERNUMBER (GLOBALVARS MACSCRATCHSTRING RANDSTATE USERFORKS USERFORKLST)
GDATE)
(BLOCK: MACSTRBLOCK ATMCONC0 STRCONC0 STRCONC1 JFNS SIXBIT ERSTR HOSTNAME
(ENTRIES ATMCONC0 STRCONC0 STRCONC1 JFNS SIXBIT ERSTR HOSTNAME))
(BLOCK: DIRECTORYBLOCK CONNECTDIR DIRECTORYNAME DIRECTORYNAMEP DIRECTORYNUMBER INTERNALDIRNUM
INTERNALUSERNUM USERNAME USERNUMBER RPLSTR1 USERNAMEP
(ENTRIES CONNECTDIR DIRECTORYNAME DIRECTORYNAMEP DIRECTORYNUMBER USERNAME USERNUMBER
USERNAMEP))
(BLOCK: FILDIR FILDIR GNJFN (NOLINKFNS . T))
]
(PUTPROPS MAC COPYRIGHT ("Xerox Corporation" 1983))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1613 47993 (DCHCON 1623 . 4521) (DUNPACK 4523 . 4795) (TENEX 4797 . 6501) (SUBSYS 6503
. 12533) (CFORK 12535 . 13355) (GCFORKS 13357 . 14082) (GDATE 14084 . 15063) (KFORK 15065 . 15849) (
KFORK1 15851 . 16749) (RFSTS 16751 . 17612) (GEVEC 17614 . 17774) (GPJFN 17776 . 18016) (GTJFN 18018
. 20925) (RLJFN 20927 . 21242) (FILDIR 21244 . 21540) (GNJFN 21542 . 21828) (JFNS 21830 . 23392) (
DELFILE 23394 . 24747) (RENAMEFILE 24749 . 25916) (PAGEFAULTS 25918 . 26149) (LOADAV 26151 . 26302) (
GETAB 26304 . 27826) (SIXBIT 27828 . 28990) (GETER 28992 . 29359) (ERSTR 29361 . 30852) (IDATE 30854
. 31419) (HOSTNUMBER 31421 . 31628) (HOSTNAME 31630 . 32284) (ATMCONC0 32286 . 32976) (STRCONC0 32978
. 33622) (STRCONC1 33624 . 34239) (RPLSTR0 34241 . 36067) (RAND 36069 . 38008) (RANDSET 38010 . 40089
) (CONNECTDIR 40091 . 41175) (DIRECTORYNAME 41177 . 41752) (DIRECTORYNAMEP 41754 . 41914) (
DIRECTORYNUMBER 41916 . 42073) (INTERNALDIRNUM 42075 . 43953) (INTERNALUSERNUM 43955 . 45007) (
USERNAME 45009 . 45582) (USERNUMBER 45584 . 45738) (RPLSTR1 45740 . 47821) (USERNAMEP 47823 . 47991)))
))
STOP