(FILECREATED "12-Mar-85 14:40:05" {ERIS}<LISPCORE>SOURCES>ADIR.;15 35067
changes to: (FNS PACKFILENAME PACKFILENAME.STRING)
previous date: "14-Feb-85 23:34:20" {ERIS}<LISPCORE>SOURCES>ADIR.;13)
(* Copyright (c) 1981, 1982, 1983, 1984, 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT ADIRCOMS)
(RPAQQ ADIRCOMS [[COMS (* user-level i/o routines)
(FNS DELFILE FULLNAME INFILE INFILEP IOFILE OPENFILE OPENSTREAM OUTFILE
OUTFILEP RENAMEFILE SIMPLE.FINDFILE)
(P (MOVD? (QUOTE SIMPLE.FINDFILE)
(QUOTE FINDFILE]
(COMS (FNS FILENAMEFIELD PACKFILENAME UNPACKFILENAME LASTCHPOS \UPF.CHPOS)
[VARS \FILENAME.DELIMITERS (* (CHARCODE (%( %) %[ %] { } < > / ! ; :]
(DECLARE: DONTCOPY (MACROS UNPACKFILE1 UNPACKFILE2)))
(COMS (FNS UNPACKFILENAME.STRING PACKFILENAME.STRING)
(DECLARE: DONTCOPY (MACROS UNPACKFILE1.STRING UNPACKFILE2.STRING)))
(COMS (* saving and restoring system state)
(FNS LOGOUT MAKESYS SYSOUT SAVEVM HERALD \REVALIDATEFILELST INTERPRET.REM.CM
\USEREVENT)
(ADDVARS (AROUNDEXITFNS))
(VARS (HERALDSTRING "")
(\USERNAME))
(GLOBALVARS HERALDSTRING USERNAME \USERNAME AROUNDEXITFNS)
(FNS USERNAME SETUSERNAME)
(* Temporary patch)
(FNS GetBcplString SetBcplString))
(LOCALVARS . T)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA PACKFILENAME.STRING PACKFILENAME])
(* user-level i/o routines)
(DEFINEQ
(DELFILE
[LAMBDA (FILE) (* bvm: "27-DEC-81 00:10")
(AND (NEQ FILE T)
(\DELETEFILE FILE])
(FULLNAME
[LAMBDA (X RECOG) (* rmk: "22-AUG-83 13:33")
(COND
((type? STREAM X)
(fetch (STREAM FULLNAME) of X))
(T (SELECTQ RECOG
(NIL (SETQQ RECOG OLD))
((OLD OLD/NEW NEW OLDEST))
(\ILLEGAL.ARG RECOG))
(\GETFILENAME X RECOG])
(INFILE
[LAMBDA (FILE) (* rmk: " 3-OCT-79 14:23")
(INPUT (OPENFILE FILE (QUOTE INPUT)
(QUOTE OLD])
(INFILEP
[LAMBDA (FILE) (* rmk: " 9-OCT-79 22:39")
(\GETFILENAME FILE (QUOTE OLD])
(IOFILE
[LAMBDA (FILE) (* rmk: " 5-SEP-81 13:54")
(OPENFILE FILE (QUOTE BOTH)
(QUOTE OLD])
(OPENFILE
[LAMBDA (FILE ACCESS RECOG BYTESIZE PARAMETERS) (* rmk: "25-OCT-83 19:48")
(fetch FULLNAME of (OPENSTREAM FILE ACCESS RECOG BYTESIZE PARAMETERS])
(OPENSTREAM
[LAMBDA (FILE ACCESS RECOG BYTESIZE PARAMETERS) (* bvm: "17-NOV-83 16:43")
(PROG (REC OLDSTREAM STREAM)
(SELECTQ ACCESS
((INPUT OUTPUT BOTH APPEND))
(\ILLEGAL.ARG ACCESS))
(SETQ REC (SELECTQ RECOG
((EXACT NEW OLD OLD/NEW OLDEST)
RECOG)
(NIL (SELECTQ ACCESS
(INPUT (QUOTE OLD))
(OUTPUT (QUOTE NEW))
(QUOTE OLD/NEW)))
(\ILLEGAL.ARG RECOG)))
[SELECTQ BYTESIZE
(NIL)
[8 (push PARAMETERS (QUOTE (TYPE BINARY]
(COND
((AND (LISTP BYTESIZE)
(NULL PARAMETERS))
(SETQ PARAMETERS BYTESIZE)
(SETQ BYTESIZE NIL))
(T (\ILLEGAL.ARG BYTESIZE]
(COND
((OR (EQ FILE T)
(NULL FILE))
(* Handle T and NIL separately, cause they can return the terminal streams, for which the search isn't necessary
and the \ADDOFD shouldn't be done.)
(SETQ STREAM (\GETSTREAM FILE ACCESS))
(\DO.PARAMS.AT.OPEN STREAM ACCESS PARAMETERS)
(RETURN STREAM)))
(* We open the file before looking to see whether it is already open. This guarantees that we acquire the opening
rights at the time we lookup the name. We then check to see if it is currently open in Lisp.
If it is, we return the previous stream, which has the file's current state. -
There are still potential problems: First, an interrupt can happen while we are doing the search which causes the
file to be deleted or re-opened beneath us, BEFORE it gets added to \OPENFILES. Second, a network device might not
allow multiple openings of the file, even by the same guy with the same mode.)
(SETQ STREAM (\OPENFILE FILE ACCESS REC PARAMETERS))
(COND
[(SETQ OLDSTREAM (\SEARCHOPENFILES (fetch FULLNAME of STREAM)))
(COND
((\IOMODEP OLDSTREAM ACCESS T) (* Dispose of the newly-obtained stream, This might be a
noop, but a network device (LEAF) cares)
(OR (EQ STREAM OLDSTREAM)
(\CLOSEFILE STREAM))
(\DO.PARAMS.AT.OPEN OLDSTREAM ACCESS PARAMETERS)
(* Do parameters on the old stream)
(RETURN OLDSTREAM))
(T (LISPERROR "FILE WON'T OPEN" FILE]
(T (\ADDOFD STREAM) (* Parameters done on new stream by \OPENFILE)
(RETURN STREAM])
(OUTFILE
[LAMBDA (FILE) (* rmk: " 3-OCT-79 14:24")
(OUTPUT (OPENFILE FILE (QUOTE OUTPUT)
(QUOTE NEW])
(OUTFILEP
[LAMBDA (FILE) (* rmk: " 9-OCT-79 22:39")
(\GETFILENAME FILE (QUOTE NEW])
(RENAMEFILE
[LAMBDA (OLDFILE NEWFILE) (* bvm: " 4-JUN-83 22:37")
(AND OLDFILE NEWFILE (NEQ OLDFILE T)
(NEQ NEWFILE T)
(\RENAMEFILE OLDFILE NEWFILE])
(SIMPLE.FINDFILE
[LAMBDA (FILE DUMMY DIRLST) (* bvm: "31-AUG-81 20:59")
(OR (INFILEP FILE)
(for DIR in DIRLST when (SETQ $$VAL (INFILEP (PACKFILENAME (QUOTE DIRECTORY)
DIR
(QUOTE BODY)
FILE)))
do (RETURN $$VAL])
)
(MOVD? (QUOTE SIMPLE.FINDFILE)
(QUOTE FINDFILE))
(DEFINEQ
(FILENAMEFIELD
[LAMBDA (FILE FIELDNAME) (* lmm "22-APR-81 22:00")
(UNPACKFILENAME FILE (SELECTQ FIELDNAME
((VERSION GENERATION)
(QUOTE (VERSION GENERATION)))
((DEVICE STRUCTURE)
(QUOTE (DEVICE STRUCTURE)))
FIELDNAME])
(PACKFILENAME
[LAMBDA N (* lmm "12-Mar-85 14:15")
(if (AND (EQ N 1)
(LISTP (ARG N 1)))
then (* spread argument list)
(APPLY (FUNCTION PACKFILENAME)
(ARG N 1))
else (PROG ((BLIP "")
(I 1)
HOST DEVICE STRUCTURE DIRECTORY NAME EXTENSION VERSION TEMPORARY PROTECTION ACCOUNT
PACKLIST VAR VAL TEMP)
(DECLARE (SPECVARS HOST DEVICE STRUCTURE DIRECTORY NAME EXTENSION VERSION TEMPORARY
PROTECTION ACCOUNT))
LP (COND
((NOT (IGREATERP I N))
(COND
((LISTP (SETQ VAR (ARG N I)))
(SETQ VAL (CDR VAR))
(SETQ VAR (CAR VAR)))
((NOT (IGREATERP (SETQ I (ADD1 I))
N))
(SETQ VAL (ARG N I)))
(T (SETQ VAL)))
(OR (STRINGP VAL)
(ATOM VAL)
(ERRORX (LIST 27 VAL))) (* fields must be atom)
(SELECTQ VAR
(BODY (MAP (UNPACKFILENAME.STRING (COND
((LISTP VAL)
(* PACKFILENAME for error checking of fields)
(PACKFILENAME VAL))
(T VAL)))
[FUNCTION (LAMBDA (X)
(* NIL => not yet seen, BLIP => seen as NIL.)
(OR (EVALV (CAR X))
(SET (CAR X)
(OR (CADR X)
BLIP]
(FUNCTION CDDR)))
[HOST (OR HOST (SETQ HOST
(if VAL
then (SELCHARQ (CHCON1 VAL)
(({ %[ %()
(SUBSTRING VAL 2
(SELCHARQ (NTHCHARCODE
VAL -1)
((} %] %))
-2)
-1)))
VAL)
else BLIP]
[(PATHNAME DIRECTORY) (* DIRECTORY really is treated as
{Host}device:<directory>)
(COND
(VAL (for X on (SETQ VAL (UNPACKFILENAME.STRING VAL NIL T))
by (CDDR X)
do (SELECTQ (CAR X)
[HOST (COND
((NOT HOST)
(SETQ HOST (OR (CADR X)
BLIP]
[DEVICE (COND
((NOT DEVICE)
(SETQ DEVICE (OR (CADR X)
BLIP]
[DIRECTORY (OR DIRECTORY (SETQ DIRECTORY
(OR (CADR X)
BLIP]
(ERROR "Illegal field in DIRECTORY slot" VAL)))
(for X on VAL by (CDDR X)
do (SELECTQ (CAR X)
(HOST (OR DEVICE (SETQ DEVICE BLIP))
(OR DIRECTORY (SETQ DIRECTORY BLIP)))
(DEVICE (OR DIRECTORY (SETQ DIRECTORY BLIP)))
NIL]
[(DEVICE DIRECTORY HOST NAME EXTENSION VERSION TEMPORARY)
(OR (EVALV VAR)
(SET VAR (OR VAL BLIP]
(\ILLEGAL.ARG VAR))
(SETQ I (ADD1 I))
(GO LP)))
(SELECTQ TEMPORARY
[(T S ;S) (* hack for Interlisp-D!)
(OR HOST DEVICE (PROGN (SETQ HOST (QUOTE CORE))
(SETQ TEMPORARY]
NIL)
(RETURN (PACK (NCONC (AND HOST (NEQ HOST BLIP)
(LIST "{" HOST "}"))
[AND DEVICE (NEQ DEVICE BLIP)
(SELCHARQ (NTHCHARCODE DEVICE -1)
(: (LIST DEVICE))
(LIST DEVICE (QUOTE :]
(AND DIRECTORY (NEQ DIRECTORY BLIP)
(LIST "<" DIRECTORY ">"))
(AND NAME (NEQ NAME BLIP)
(LIST NAME))
(AND (OR (AND EXTENSION (NEQ EXTENSION BLIP))
(AND VERSION (NEQ VERSION BLIP)))
(LIST (COND
((AND EXTENSION (EQ (CHCON1 EXTENSION)
(CHARCODE %.)))
BLIP)
(T (QUOTE %.)))
(OR EXTENSION BLIP)))
[AND VERSION (NEQ VERSION BLIP)
(COND
((FIXP VERSION)
(LIST (QUOTE ;)
VERSION))
(T (SELCHARQ (CHCON1 VERSION)
(; (LIST VERSION))
((%. !)
(LIST (QUOTE ;)
(SUBSTRING VERSION 2 -1)))
(LIST (QUOTE ;)
VERSION]
(AND TEMPORARY (NEQ TEMPORARY BLIP)
(LIST (QUOTE ;)
(SELECTQ TEMPORARY
((S ;S)
(QUOTE S))
T])
(UNPACKFILENAME
[LAMBDA (FILE ONEFIELDFLG DIRFLG STRING) (* lmm " 5-Oct-84 18:42")
(OR (LITATOM FILE)
(STRINGP FILE)
(ERRORX (LIST 27 FILE)))
(PROG (TEM (POS 1)
INEXT INVERS VAL CODE)
(OR FILE (RETURN))
[COND
((SELCHARQ (NTHCHARCODE FILE 1)
[{ (* normal use in Interlisp-D)
(SETQ TEM (SUB1 (OR (\UPF.CHPOS (CHARCODE })
FILE 2)
0]
[%[ (* some Xerox and Arpanet systems use "[" for host)
(SETQ TEM (SUB1 (OR (\UPF.CHPOS (CHARCODE "]")
FILE 2)
0]
[%( (* this is the "proposed standard" for Xerox servers)
(SETQ TEM (SUB1 (OR (\UPF.CHPOS (CHARCODE ")")
FILE 2)
0]
NIL)
(UNPACKFILE1 (QUOTE HOST)
2 TEM)
(if (EQ TEM -1)
then (RETURN (DREVERSE VAL)))
(SETQ POS (IPLUS TEM 2]
[COND
((SETQ TEM (LASTCHPOS (CHARCODE :)
FILE POS)) (* all device returned have : on it so that NIL: will
work)
(UNPACKFILE1 (QUOTE DEVICE)
POS TEM)
(SETQ POS (ADD1 TEM]
[COND
(DIRFLG (UNPACKFILE1 (QUOTE DIRECTORY)
(SELCHARQ (NTHCHARCODE FILE POS)
(NIL (RETURN (DREVERSE VAL)))
((/ < >)
(ADD1 POS))
POS)
(SELCHARQ (NTHCHARCODE FILE -1)
((/ < >)
-2)
-1))
(RETURN (DREVERSE VAL)))
((SELCHARQ (NTHCHARCODE FILE POS)
[/ (* unix and the "xerox standard" use / for delimiter)
(SETQ TEM (LASTCHPOS (CHARCODE /)
FILE
(ADD1 POS]
[(< >) (* Interlisp-D and most other Xerox systems, and
Tops-20/Tenex use <>. Jericho uses >>)
(SETQ TEM (LASTCHPOS (CHARCODE >)
FILE
(ADD1 POS]
NIL)
(UNPACKFILE1 (QUOTE DIRECTORY)
(ADD1 POS)
(SUB1 TEM))
(SETQ POS (ADD1 TEM]
(OR (SETQ CODE (NTHCHARCODE FILE (SETQ TEM POS)))
(RETURN (DREVERSE VAL)))
NAMELP
(SELCHARQ CODE
(%. (* delimits end of NAME or EXTENSION)
(UNPACKFILE1 (COND
((NOT INEXT)
(if (AND (SETQ CODE (STRPOS "." FILE (ADD1 TEM)))
(SETQ CODE (NTHCHAR FILE (ADD1 CODE)))
(NOT (FIXP CODE)))
then (GO NEXTCHAR))
(SETQQ INEXT NAME))
(T (SETQQ INVERS EXTENSION)))
POS
(SUB1 TEM))
(SETQ POS (ADD1 TEM)))
((! ;) (* delimits end of NAME EXTENSION VERSION or special
field)
(UNPACKFILE2 POS TEM)
(SETQ POS (ADD1 TEM)))
(NIL (UNPACKFILE2 POS TEM)
(RETURN (DREVERSE VAL)))
(' (add TEM 1))
NIL)
NEXTCHAR
(SETQ CODE (NTHCHARCODE FILE (add TEM 1)))
(GO NAMELP)
OUT (RETURN VAL])
(LASTCHPOS
[LAMBDA (CH STR START) (* lmm " 5-Oct-84 18:41")
(PROG (RESULT NC)
(OR START (SETQ START 1))
(while (SETQ NC (NTHCHARCODE STR START))
do (COND
((EQ NC CH)
(SETQ RESULT START))
((EQ NC (CHARCODE '))
(add START 1)))
(add START 1))
(RETURN RESULT])
(\UPF.CHPOS
[LAMBDA (CHAR STRING POS) (* lmm " 5-Oct-84 18:41")
(bind NCH while (SETQ NCH (NTHCHARCODE STRING POS))
do (if (EQMEMB NCH CHAR)
then (RETURN POS)
elseif (EQ NCH (CHARCODE '))
then (add POS 1))
(add POS 1])
)
(RPAQQ \FILENAME.DELIMITERS (40 41 91 93 123 125 60 62 47 33 59 58))
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS UNPACKFILE1 MACRO [OPENLAMBDA (NAM ST END) (* lmm "22-APR-81 22:21")
(PROG NIL
[COND
(ONEFIELDFLG (COND
((EQMEMB NAM ONEFIELDFLG)
(SETQ VAL
(if STRING
then (OR (SUBSTRING FILE ST
END)
"")
else (SUBATOM FILE ST END)))
(GO OUT))
(T (RETURN]
(SETQ VAL (CONS (if STRING
then (OR (SUBSTRING FILE ST END)
"")
else (SUBATOM FILE ST END))
(CONS NAM VAL])
(PUTPROPS UNPACKFILE2 MACRO [LAMBDA (POS TEM) (* lmm "22-APR-81 21:47")
(UNPACKFILE1 [COND
((NOT INEXT)
(SETQ INVERS (QUOTE ;))
(SETQQ INEXT NAME))
((NOT INVERS)
(SETQQ INVERS ;)
(QUOTE EXTENSION))
(T (SELCHARQ (AND (EQ INVERS (QUOTE ;))
(NTHCHARCODE FILE POS))
(P (QUOTE PROTECTION))
(A (add POS 1)
(QUOTE ACCOUNT))
((T S)
(QUOTE TEMPORARY))
(QUOTE VERSION]
POS
(SUB1 TEM])
)
)
(DEFINEQ
(UNPACKFILENAME.STRING
[LAMBDA (FILE ONEFIELDFLG DIRFLG) (* lmm " 5-Oct-84 14:18")
(UNPACKFILENAME FILE ONEFIELDFLG DIRFLG T])
(PACKFILENAME.STRING
[LAMBDA N (* lmm "12-Mar-85 14:15")
(if (AND (EQ N 1)
(LISTP (ARG N 1)))
then (* spread argument list)
(APPLY (FUNCTION PACKFILENAME.STRING)
(ARG N 1))
else (PROG ((BLIP "")
(I 1)
HOST DEVICE STRUCTURE DIRECTORY NAME EXTENSION VERSION TEMPORARY PROTECTION ACCOUNT
PACKLIST VAR VAL TEMP)
(DECLARE (SPECVARS HOST DEVICE STRUCTURE DIRECTORY NAME EXTENSION VERSION TEMPORARY
PROTECTION ACCOUNT))
LP (COND
((NOT (IGREATERP I N))
(COND
((LISTP (SETQ VAR (ARG N I)))
(SETQ VAL (CDR VAR))
(SETQ VAR (CAR VAR)))
((NOT (IGREATERP (SETQ I (ADD1 I))
N))
(SETQ VAL (ARG N I)))
(T (SETQ VAL)))
(OR (STRINGP VAL)
(ATOM VAL)
(ERRORX (LIST 27 VAL))) (* fields must be atom)
(SELECTQ VAR
(BODY (MAP (UNPACKFILENAME.STRING (COND
((LISTP VAL)
(* PACKFILENAME.STRING for error checking of fields)
(PACKFILENAME.STRING VAL))
(T VAL)))
[FUNCTION (LAMBDA (X)
(* NIL => not yet seen, BLIP => seen as NIL.)
(OR (EVALV (CAR X))
(SET (CAR X)
(OR (CADR X)
BLIP]
(FUNCTION CDDR)))
[HOST (OR HOST (SETQ HOST
(if VAL
then (SELCHARQ (CHCON1 VAL)
(({ %[ %()
(SUBSTRING VAL 2
(SELCHARQ (NTHCHARCODE
VAL -1)
((} %] %))
-2)
-1)))
VAL)
else BLIP]
[(PATHNAME DIRECTORY) (* DIRECTORY really is treated as
{Host}device:<directory>)
(COND
(VAL (for X on (SETQ VAL (UNPACKFILENAME.STRING VAL NIL T))
by (CDDR X)
do (SELECTQ (CAR X)
[HOST (COND
((NOT HOST)
(SETQ HOST (OR (CADR X)
BLIP]
[DEVICE (COND
((NOT DEVICE)
(SETQ DEVICE (OR (CADR X)
BLIP]
[DIRECTORY (OR DIRECTORY (SETQ DIRECTORY
(OR (CADR X)
BLIP]
(ERROR "Illegal field in DIRECTORY slot" VAL)))
(for X on VAL by (CDDR X)
do (SELECTQ (CAR X)
(HOST (OR DEVICE (SETQ DEVICE BLIP))
(OR DIRECTORY (SETQ DIRECTORY BLIP)))
(DEVICE (OR DIRECTORY (SETQ DIRECTORY BLIP)))
NIL]
[(DEVICE DIRECTORY HOST NAME EXTENSION VERSION TEMPORARY)
(OR (EVALV VAR)
(SET VAR (OR VAL BLIP]
(\ILLEGAL.ARG VAR))
(SETQ I (ADD1 I))
(GO LP)))
(SELECTQ TEMPORARY
[(T S ;S) (* hack for Interlisp-D!)
(OR HOST DEVICE (PROGN (SETQ HOST (QUOTE CORE))
(SETQ TEMPORARY]
NIL)
(RETURN (CONCATLIST (NCONC (AND HOST (NEQ HOST BLIP)
(LIST "{" HOST "}"))
[AND DEVICE (NEQ DEVICE BLIP)
(SELCHARQ (NTHCHARCODE DEVICE -1)
(: (LIST DEVICE))
(LIST DEVICE (QUOTE :]
(AND DIRECTORY (NEQ DIRECTORY BLIP)
(LIST "<" DIRECTORY ">"))
(AND NAME (NEQ NAME BLIP)
(LIST NAME))
(AND (OR (AND EXTENSION (NEQ EXTENSION BLIP))
(AND VERSION (NEQ VERSION BLIP)))
(LIST (COND
((AND EXTENSION (EQ (CHCON1 EXTENSION)
(CHARCODE %.)))
BLIP)
(T (QUOTE %.)))
(OR EXTENSION BLIP)))
[AND VERSION (NEQ VERSION BLIP)
(COND
((FIXP VERSION)
(LIST (QUOTE ;)
VERSION))
(T (SELCHARQ (CHCON1 VERSION)
(; (LIST VERSION))
((%. !)
(LIST (QUOTE ;)
(SUBSTRING VERSION 2 -1)))
(LIST (QUOTE ;)
VERSION]
(AND TEMPORARY (NEQ TEMPORARY BLIP)
(LIST (QUOTE ;)
(SELECTQ TEMPORARY
((S ;S)
(QUOTE S))
T])
)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS UNPACKFILE1.STRING MACRO [LAMBDA (NAM ST END) (* lmm "22-APR-81 22:21")
(PROG NIL
[COND
(ONEFIELDFLG (COND
((EQMEMB NAM ONEFIELDFLG)
(SETQ VAL (SUBSTRING FILE ST END))
(GO OUT))
(T (RETURN]
(SETQ VAL (CONS (SUBSTRING FILE ST END)
(CONS NAM VAL])
(PUTPROPS UNPACKFILE2.STRING MACRO [LAMBDA (POS TEM)
(UNPACKFILE1.STRING [COND
((NOT INEXT)
(SETQ INVERS (QUOTE ;))
(SETQQ INEXT NAME))
((NOT INVERS)
(SETQQ INVERS ;)
(QUOTE EXTENSION))
(T (SELCHARQ (AND (EQ INVERS (QUOTE ;))
(NTHCHARCODE FILE POS))
(P (QUOTE PROTECTION))
(A (add POS 1)
(QUOTE ACCOUNT))
((T S)
(QUOTE TEMPORARY))
(QUOTE VERSION]
POS
(SUB1 TEM])
)
)
(* saving and restoring system state)
(DEFINEQ
(LOGOUT
[LAMBDA (FAST) (* bvm: "14-Feb-85 23:24")
(DECLARE (GLOBALVARS \OPENFILES))
(\USEREVENT (QUOTE BEFORELOGOUT))
(COND
((OR (EQ FAST T)
(\FLUSHVMOK? (QUOTE LOGOUT))) (* Check that we have a vmem file before allowing
LOGOUT)
(\PROCESS.BEFORE.LOGOUT)
(\DEVICEEVENT (QUOTE BEFORELOGOUT))
(\SETTOTALTIME) (* update the total time that this sysout has been
running.)
(\LOGOUT0 FAST) (* Must re-establish the state of devices and of
previously open files that might have been modified at
the EXEC.)
(\RESETKEYBOARD)
(\DEVICEEVENT (QUOTE AFTERLOGOUT))
(\OPENLINEBUF)
(SETQ \OPENFILES (\REVALIDATEFILELST \OPENFILES))
(\PROCESS.AFTER.EXIT (QUOTE AFTERLOGOUT))
(\USEREVENT (QUOTE AFTERLOGOUT))
(INTERPRET.REM.CM)
NIL])
(MAKESYS
[LAMBDA (FILE NAME) (* bvm: "14-Feb-85 23:26")
(DECLARE (GLOBALVARS \MISCSTATS)
(SPECVARS FILE NAME)) (* SPECVARS for BEFOREMAKESYSFORMS)
(\FLUSHVMOK? (QUOTE MAKESYS))
(\USEREVENT (QUOTE BEFOREMAKESYS))
(HERALD (CONCAT (OR NAME "INTERLISP-D")
" "
(SUBSTRING (SETQ MAKESYSDATE (DATE))
1 9)
" ..."))
(\DEVICEEVENT (QUOTE BEFOREMAKESYS))
(replace TOTALTIME of \MISCSTATS with 0) (* reset totaltime field.)
(SETQ LAST↑TKEYBOARDTIME)
(PROG ((NEWFILE (\COPYSYS FILE)))
(RETURN (COND
((NLISTP NEWFILE)
(\DEVICEEVENT (QUOTE AFTERDOMAKESYS))
(\USEREVENT (QUOTE AFTERDOMAKESYS))
NEWFILE)
(T (\DEVICEEVENT (QUOTE AFTERMAKESYS))
(\RESETOFDS)
(\PROCESS.AFTER.EXIT (QUOTE AFTERMAKESYS))
(PRIN1 HERALDSTRING T)
(SETQ RESETFORMS (CONS GREETFORM RESETFORMS))
(\USEREVENT (QUOTE AFTERMAKESYS))
(INTERPRET.REM.CM)
(RESET])
(SYSOUT
[LAMBDA (FILE) (* bvm: "14-Feb-85 23:26")
(DECLARE (GLOBALVARS \MISCSTATS)
(SPECVARS FILE)) (* FILE is special so that BEFORESYSOUTFORMS can alter
it)
(\FLUSHVMOK? (QUOTE SYSOUT))
(\USEREVENT (QUOTE BEFORESYSOUT))
(\DEVICEEVENT (QUOTE BEFORESYSOUT))
(PROG ((TOTALTIMESAVE (fetch TOTALTIME of \MISCSTATS))
NEWFILE) (* update the total time field so that the run time in
the sysout will be right.)
(\SETTOTALTIME)
(RETURN (PROG1 (SETQ NEWFILE (\COPYSYS FILE))
(COND
((NLISTP NEWFILE) (* Continuing in same sysout;
reset TOTALTIME in misc stats page to not include the
time before the sysout.)
(replace TOTALTIME of \MISCSTATS with TOTALTIMESAVE)
(\DEVICEEVENT (QUOTE AFTERDOSYSOUT))
(\USEREVENT (QUOTE AFTERDOSYSOUT)))
(T (* restarting)
(\DEVICEEVENT (QUOTE AFTERSYSOUT))
(\PROCESS.AFTER.EXIT (QUOTE AFTERSYSOUT))
(\RESETOFDS)
(INTERPRET.REM.CM)
(\USEREVENT (QUOTE AFTERSYSOUT])
(SAVEVM
[LAMBDA (RELEASEFLG) (* bvm: "14-Feb-85 23:25")
(DECLARE (GLOBALVARS \OPENFILES))
(* Save the virtual memory. This is similar to logging out, then back in, but is much faster, since it doesn't lose
any pages. Conceptually, this is like doing a sysout to Lisp.virtualmem)
(\FLUSHVMOK? (QUOTE SAVEVM))
(\USEREVENT (QUOTE BEFORESAVEVM))
(\DEVICEEVENT (QUOTE BEFORESAVEVM))
(COND
((\FLUSHVM)
(\RESETKEYBOARD) (* Returns T when starting up fresh)
(\DEVICEEVENT (QUOTE AFTERSAVEVM))
(SETQ \OPENFILES (\REVALIDATEFILELST \OPENFILES))
(\PROCESS.AFTER.EXIT (QUOTE AFTERSAVEVM))
(\USEREVENT (QUOTE AFTERSAVEVM))
T)
(T (\DEVICEEVENT (QUOTE AFTERDOSAVEVM))
(\USEREVENT (QUOTE AFTERDOSAVEVM])
(HERALD
[LAMBDA (STR) (* wt: " 2-MAY-79 15:38")
(AND STR (SETQ HERALDSTRING STR))
HERALDSTRING])
(\REVALIDATEFILELST
[LAMBDA (STREAMLST) (* lmm " 6-Sep-84 12:32")
(* STREAMLST is \OPENFILES or a subset of \OPENFILES, in the case when an event (e.g. a host going down) affects
only some files.)
(DECLARE (GLOBALVARS \OPENFILES))
[for (STREAMS ← STREAMLST)
STREAM REASON RECLFLG PAGES while STREAMS
do (COND
([SETQ REASON (\REVALIDATEFILE (SETQ STREAM (CAR STREAMS]
[COND
((AND (EQ REASON (QUOTE DELETED))
(EQ STREAM \DRIBBLE.OFD)) (* If Dribble file went away, turn it off quick before
we get in trouble)
(UNINTERRUPTABLY
(SETQ \DRIBBLE.OFD NIL)
(\REMOVEDRIBBLECHECK (TTYDISPLAYSTREAM)))]
(COND
((NOT RECLFLG) (* Map down the tail of STREAMLST and smash the CPPTR to
NIL first)
(for O in STREAMS do (replace CPPTR of O with NIL))
(SETQ RECLFLG T)
(RECLAIM)))
(printout T T T "****WARNING: The file " (fetch FULLNAME of STREAM))
(SELECTQ REASON
(CHANGED (SETQ PAGES (RESTOREMAP STREAM))
(printout T " has been modified since you last accessed it!" T)
(SETQ STREAMS (CDR STREAMS)))
(DELETED (SETQ PAGES (FORGETPAGES STREAM))
[MAPC (STREAMPROP STREAM (QUOTE AFTERCLOSE))
(FUNCTION (LAMBDA (FN)
(APPLY* FN STREAM]
(replace ACCESS of STREAM with NIL)
[COND
((NEQ STREAMLST \OPENFILES)
(SETQ \OPENFILES (DREMOVE STREAM \OPENFILES]
(COND
((CDR STREAMS)
(FRPLNODE2 STREAMS (CDR STREAMS)))
(T (SETQ STREAMLST (DREMOVE STREAM STREAMLST))
(SETQ STREAMS NIL)))
(printout T " was previously opened but has disappeared!" T))
(SHOULDNT))
(AND PAGES (printout T "You had references to the following pages from that file: "
PAGES T)))
(T (SETQ STREAMS (CDR STREAMS]
STREAMLST])
(INTERPRET.REM.CM
[LAMBDA (RETFLG) (* bvm: "30-Jan-85 11:25")
(DECLARE (GLOBALVARS STARTUPFORM))
(* * Looks at REM.CM and evaluates the form there if the first character of the file is open paren or doublequote.
If it's a string, it will be unread,, else the form will be evaluated at the next prompt. For use in INIT.LISP,
among others. If RETFLG is true, the expression read is simply returned)
(PROG ([FILE (CAR (NLSETQ (OPENSTREAM (QUOTE {DSK}REM.CM;1)
(QUOTE BOTH]
COM AUXFILE)
(OR FILE (RETURN))
[COND
([AND (IGREATERP (GETFILEINFO FILE (QUOTE LENGTH))
0)
(SELECTQ (SKIPSEPRS FILE T)
((%( %")
T)
NIL)
(SETQ COM (PROGN (SETFILEINFO FILE (QUOTE ENDOFSTREAMOP)
(FUNCTION ERROR!))
(CAR (NLSETQ (READ FILE T]
(COND
(RETFLG (* Save it to return))
((LISTP COM) (* make it happen at next prompt)
(SETQ STARTUPFORM (LIST (QUOTE PROGN)
(QUOTE (SETQ PROMPTCHARFORMS (DREMOVE STARTUPFORM
PROMPTCHARFORMS)))
(LIST (QUOTE PRINT)
(LIST (QUOTE LISPXEVAL)
(KWOTE COM))
T T)))
(SETQ PROMPTCHARFORMS (CONS STARTUPFORM PROMPTCHARFORMS)))
(T (* Unread a string)
(BKSYSBUF COM)))
(\SETEOFPTR FILE (COND
((NOT (\EOFP FILE))
(SELCHARQ (\PEEKBIN FILE)
((CR ;) (* Eat up the command terminator)
(\BIN FILE))
NIL) (* Need to rewrite REM.CM with remainder of text)
(SETQ AUXFILE (OPENSTREAM (QUOTE {NODIRCORE})
(QUOTE BOTH)
(QUOTE NEW)))
(COPYBYTES FILE AUXFILE)
(SETFILEPTR FILE 0)
(COPYBYTES AUXFILE FILE 0 (GETFILEPTR AUXFILE))
(CLOSEF AUXFILE)
(GETFILEPTR FILE))
(T 0]
(CLOSEF FILE)
(RETURN (COND
(RETFLG COM)
(COM T])
(\USEREVENT
[LAMBDA (EVENT)
(DECLARE (GLOBALVARS AROUNDEXITFNS)) (* bvm: "16-Dec-83 15:27")
(for FN in (SELECTQ EVENT
((BEFORELOGOUT BEFORESYSOUT BEFORESAVEVM BEFOREMAKESYS)
AROUNDEXITFNS)
(REVERSE AROUNDEXITFNS))
do (APPLY* FN EVENT])
)
(ADDTOVAR AROUNDEXITFNS )
(RPAQ HERALDSTRING "")
(RPAQQ \USERNAME NIL)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS HERALDSTRING USERNAME \USERNAME AROUNDEXITFNS)
)
(DEFINEQ
(USERNAME
[LAMBDA (FLG STRPTR PRESERVECASE)
(* lmm "28-MAR-82 14:10")
(* On 10, USERNAME can take a user number as arg)
(PROG (ADDR NAME)
(SETQ NAME (COND
(FLG NIL)
((NEQ 0 (SETQ ADDR (fetch (IFPAGE UserNameAddr) of \InterfacePage)))
(GetBcplString (\ADDBASE (EMADDRESS 0)
ADDR)
(EQ STRPTR T)))
(T \USERNAME)))
(OR PRESERVECASE (NULL NAME)
(SETQ NAME (U-CASE NAME)))
(RETURN (COND
((NULL NAME)
NIL)
((STRINGP STRPTR)
(SUBSTRING NAME 1 -1 STRPTR))
(T NAME])
(SETUSERNAME
[LAMBDA (NAME) (* lmm "28-MAR-82 14:11")
(* Changed interpretation of UserName0)
(COND
(NAME (PROG ((ADDR (fetch (IFPAGE UserNameAddr) of \InterfacePage)))
(RETURN (COND
((NEQ ADDR 0)
(SetBcplString (\ADDBASE (EMADDRESS 0)
ADDR)
NAME)
(SETQ USERNAME (USERNAME NIL T)))
(T (SETQ \USERNAME (CONCAT NAME])
)
(* Temporary patch)
(DEFINEQ
(GetBcplString
[LAMBDA (BS ATOMFLG) (* bvm: " 1-MAY-81 21:38")
(* Returns as a Lisp string the Bcpl string stored at BS. Format is one byte length, follwed by chars.
If ATOMFLG is true, returns result as an atom)
(PROG (S (L (GETBASEBYTE BS 0)))
(COND
((AND ATOMFLG (ILEQ L \PNAMELIMIT))
(RETURN (\MKATOM BS 1 L)))
(T (SETQ S (ALLOCSTRING L))
(for I to L do (RPLCHARCODE S I (GETBASEBYTE BS I)))
(RETURN (COND
(ATOMFLG (* Let MKATOM handle the error)
(MKATOM S))
(T S])
(SetBcplString
[LAMBDA (BS LS) (* lmm "17-MAY-80 20:21")
(PROG ((L (NCHARS LS)))
(COND
((IGREATERP L 255)
(LISPERROR "ILLEGAL ARG" BS)))
(PUTBASEBYTE BS 0 L)
(for I to L do (PUTBASEBYTE BS I (NTHCHARCODE LS I)))
(RETURN BS])
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA PACKFILENAME.STRING PACKFILENAME)
)
(PUTPROPS ADIR COPYRIGHT ("Xerox Corporation" 1981 1982 1983 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1563 6010 (DELFILE 1573 . 1721) (FULLNAME 1723 . 2046) (INFILE 2048 . 2214) (INFILEP
2216 . 2355) (IOFILE 2357 . 2515) (OPENFILE 2517 . 2709) (OPENSTREAM 2711 . 5170) (OUTFILE 5172 . 5342
) (OUTFILEP 5344 . 5484) (RENAMEFILE 5486 . 5685) (SIMPLE.FINDFILE 5687 . 6008)) (6067 15373 (
FILENAMEFIELD 6077 . 6354) (PACKFILENAME 6356 . 11102) (UNPACKFILENAME 11104 . 14589) (LASTCHPOS 14591
. 15015) (\UPF.CHPOS 15017 . 15371)) (16795 21744 (UNPACKFILENAME.STRING 16805 . 16974) (
PACKFILENAME.STRING 16976 . 21742)) (22884 32388 (LOGOUT 22894 . 23970) (MAKESYS 23972 . 25218) (
SYSOUT 25220 . 26631) (SAVEVM 26633 . 27565) (HERALD 27567 . 27725) (\REVALIDATEFILELST 27727 . 29772)
(INTERPRET.REM.CM 29774 . 32077) (\USEREVENT 32079 . 32386)) (32571 33725 (USERNAME 32581 . 33247) (
SETUSERNAME 33249 . 33723)) (33754 34755 (GetBcplString 33764 . 34407) (SetBcplString 34409 . 34753)))
))
STOP