(FILECREATED " 5-Aug-86 11:36:37" {ERIS}<LISPCORE>SOURCES>ADIR.;32 43565
changes to: (FNS OPENSTREAM)
previous date: "26-May-86 13:49:53" {ERIS}<LISPCORE>SOURCES>ADIR.;31)
(* Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT ADIRCOMS)
(RPAQQ ADIRCOMS [(VARS MULTIPLE.STREAMS.PER.FILE.ALLOWED)
(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)
NIL T)))
[COMS (FNS UNPACKFILENAME UNPACKFILENAME.STRING LASTCHPOS \UPF.NEXTPOS FILENAMEFIELD
PACKFILENAME PACKFILENAME.STRING)
(DECLARE: DONTCOPY (MACROS PACKFILENAME.ASSEMBLE UNPACKFILE1))
(VARS \FILENAME.DELIMITERS (* (CHARCODE (%( %) %[ %] { } < > / ! ; :]
(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))
(LOCALVARS . T)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA
PACKFILENAME.STRING
PACKFILENAME
])
(RPAQQ MULTIPLE.STREAMS.PER.FILE.ALLOWED NIL)
(* user-level i/o routines)
(DEFINEQ
(DELFILE
[LAMBDA (FILE) (* bvm: "23-Oct-85 11:20")
(AND FILE (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 PARAMETERS OPTIONAL) (* lmm "30-Mar-85 04:10") (fetch FULLNAME of (
OPENSTREAM FILE ACCESS RECOG PARAMETERS OPTIONAL))))
(OPENSTREAM
[LAMBDA (FILE ACCESS RECOG PARAMETERS OBSOLETE) (* hdj "15-Jul-86 20:29")
(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)))
(if (OR (LISTP OBSOLETE)
(AND PARAMETERS (NLISTP PARAMETERS)))
then (* "used to have OPENFILE/OPENSTREAM with BYTESIZE and PARAMETERS. Now it will take PARAMETERS, and generally ignore the BYTESIZE")
(SETQ PARAMETERS (APPEND (SELECTQ PARAMETERS
(7 (QUOTE ((TYPE TEXT))))
(8 (QUOTE ((TYPE BINARY))))
NIL)
OBSOLETE)))
(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)))
(* * "Explicitly test for PATHNAMEP, as PATHNAMEP will have a NILL def early in the loadup, and the tests in \CONVERT-PATHNAME won't break anything")
(if (PATHNAMEP FILE)
then (SETQ FILE (\CONVERT-PATHNAME FILE)))
(* * "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
[[AND (NOT MULTIPLE.STREAMS.PER.FILE.ALLOWED)
(SETQ OLDSTREAM (\SEARCHOPENFILES (fetch FULLNAME of STREAM]
(* "There is already a stream open on the file. Check that there is no conflict. Eventually all this registration belongs in the device, so that we can have multiple streams open per file")
(COND
((AND (EQ ACCESS (QUOTE INPUT))
(EQ (fetch ACCESS of OLDSTREAM)
(QUOTE INPUT))) (*
"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 (AND (NOT MULTIPLE.STREAMS.PER.FILE.ALLOWED)
(\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: "23-Oct-85 11:22")
(OR (for DIR in DIRLST when (SETQ $$VAL (INFILEP (PACKFILENAME.STRING (QUOTE
DIRECTORY)
DIR
(QUOTE
BODY)
FILE)))
do (RETURN $$VAL))
(AND (NOT (MEMB NIL DIRLST))
(INFILEP FILE])
)
(MOVD? (QUOTE SIMPLE.FINDFILE)
(QUOTE FINDFILE)
NIL T)
(DEFINEQ
(UNPACKFILENAME
[LAMBDA (FILE ONEFIELDFLG) (* bvm: " 5-Jul-85 15:24")
(UNPACKFILENAME.STRING FILE ONEFIELDFLG NIL T])
(UNPACKFILENAME.STRING
[LAMBDA (FILE ONEFIELDFLG DIRFLG PACKFLG) (* jds
" 5-Feb-86 10:33")
(* * Given a string or atom representation of a file name, unpack it into
its component parts)
(PROG ((POS 1)
TEM TEM2 BEYONDNAME BEYONDEXT VAL CODE HOSTP SUBDIREND)
(COND
((NULL FILE)
(RETURN))
((OR (LITATOM FILE)
(STRINGP FILE)
(NUMBERP FILE)))
[(type? STREAM FILE) (* For streams, use
full name. If
anonymous, fake it)
(SETQ FILE (OR (ffetch FULLFILENAME of FILE)
(RETURN (COND
(ONEFIELDFLG (AND (EQ ONEFIELDFLG (QUOTE NAME))
FILE))
(T (LIST (QUOTE NAME)
FILE]
(T (\ILLEGAL.ARG FILE)))
(COND
((SELCHARQ (NTHCHARCODE FILE 1)
({ (* normal use in
Interlisp-D)
(SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE })
FILE 2)
0))))
(%[ (* some Xerox and
Arpanet systems use "["
for host)
(SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE "]")
FILE 2)
0))))
(%( (* this is the
"proposed standard" for
Xerox servers)
(SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE ")")
FILE 2)
0))))
NIL)
(UNPACKFILE1 (QUOTE HOST)
2 TEM)
[COND
((EQ TEM -1)
(RETURN (DREVERSE VAL]
(SETQ POS (IPLUS TEM 2))
(SETQ HOSTP T)))
(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))
(SETQ HOSTP T)))
(COND
((EQ DIRFLG (QUOTE RETURN))
(LET ((TYPE (QUOTE DIRECTORY))
(START (SELCHARQ (NTHCHARCODE FILE POS)
(NIL (RETURN (DREVERSE VAL)))
((/ <)
(ADD1 POS))
POS))
END)
(SETQ END (SELCHARQ (NTHCHARCODE FILE -1)
((/ >)
[COND
((AND (EQ START POS)
(NOT HOSTP)) (* Didn't start with a
directory delimiter,
but it ends with one,
so this must be a
subdirectory)
(SETQ TYPE (QUOTE SUBDIRECTORY]
-2)
(PROGN -1)))
(UNPACKFILE1 TYPE START END))
(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))
(SETQ HOSTP T)))
(OR (SETQ CODE (NTHCHARCODE FILE (SETQ TEM POS)))
(RETURN (DREVERSE VAL)))
NAMELP
(SELCHARQ CODE
((%. ! ; NIL)
(* NAME and
SUBDIRECTORY fields
definitely terminated
by now)
(COND
((AND (EQ CODE (CHARCODE %.))
(NOT BEYONDNAME)
(SETQ TEM2 (STRPOS "." FILE (ADD1 TEM)))
(SETQ TEM2 (NTHCHAR FILE (ADD1 TEM2)))
(NOT (FIXP TEM2))) (* If there's another
dot followed by
something other than a
numeric extension, then
ignore this dot, since
we'll get another
chance)
(GO NEXTCHAR)))
[COND
(SUBDIREND (UNPACKFILE1 (QUOTE SUBDIRECTORY)
POS
(SUB1 SUBDIREND))
(SETQ POS (ADD1 SUBDIREND))
(SETQ SUBDIREND)
(COND
((AND (NULL CODE)
(EQ POS TEM)) (* Nothing follows the
subdirectory;
null name is NOT
implied)
(RETURN (DREVERSE VAL]
(UNPACKFILE1 [COND
((NOT BEYONDNAME)
(COND
((NEQ CODE (CHARCODE %.))
(SETQQ BEYONDEXT ;)))
(SETQQ BEYONDNAME NAME))
((NOT BEYONDEXT)
(SETQ BEYONDEXT (COND
((NEQ CODE (CHARCODE %.))
(QUOTE ;))
(T T)))
(QUOTE EXTENSION))
(T (SELCHARQ (AND (EQ BEYONDEXT (QUOTE ;))
(NTHCHARCODE FILE POS))
(P (QUOTE PROTECTION))
(A (add POS 1)
(QUOTE ACCOUNT))
((T S)
(QUOTE TEMPORARY))
(QUOTE VERSION]
POS
(SUB1 TEM))
[COND
((NULL CODE) (* End of string)
(RETURN (DREVERSE VAL]
(SETQ POS (ADD1 TEM)))
(' (* Quoter)
(add TEM 1))
((/ >)
(* Subdirectory
terminating character)
(COND
((AND (NOT HOSTP)
(NOT BEYONDNAME)
DIRFLG) (* Ok to treat this as
a subdirectory)
(SETQ SUBDIREND TEM))))
NIL)
NEXTCHAR
(SETQ CODE (NTHCHARCODE FILE (add TEM 1)))
(GO NAMELP])
(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.NEXTPOS
[LAMBDA (CHAR STRING POS) (* lmm " 5-Oct-84 18:41")
(bind NCH while (SETQ NCH (NTHCHARCODE STRING POS))
do (COND
((EQMEMB NCH CHAR)
(RETURN POS))
((EQ NCH (CHARCODE '))
(add POS 1)))
(add POS 1])
(FILENAMEFIELD
[LAMBDA (FILE FIELDNAME) (* bvm: " 6-Jul-85 17:57")
(UNPACKFILENAME.STRING FILE (SELECTQ FIELDNAME
((VERSION GENERATION)
(QUOTE (VERSION GENERATION)))
((DEVICE STRUCTURE)
(QUOTE (DEVICE STRUCTURE)))
FIELDNAME)
(QUOTE OK)
T])
(PACKFILENAME
[LAMBDA N (* bvm: " 5-Jul-85 15:40")
(COND
((AND (EQ N 1)
(LISTP (ARG N 1))) (* spread argument list)
(APPLY (FUNCTION PACKFILENAME)
(ARG N 1)))
(T (PACK (PACKFILENAME.ASSEMBLE])
(PACKFILENAME.STRING
[LAMBDA N (* bvm: " 5-Jul-85 15:41")
(COND
((AND (EQ N 1)
(LISTP (ARG N 1))) (* spread argument list)
(APPLY (FUNCTION PACKFILENAME.STRING)
(ARG N 1)))
(T (CONCATLIST (PACKFILENAME.ASSEMBLE])
)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
[PUTPROPS PACKFILENAME.ASSEMBLE MACRO
(NIL (* Common part of PACKFILENAME and PACKFILENAME.STRING -- maps down nospread arg N and
assembles list to be packed or concated)
(PROG ((BLIP "")
(I 1)
HOST DEVICE STRUCTURE DIRECTORY SUBDIRECTORY NAME EXTENSION VERSION TEMPORARY
PROTECTION ACCOUNT PACKLIST VAR VAL TEMP)
(DECLARE (SPECVARS HOST DEVICE STRUCTURE DIRECTORY SUBDIRECTORY 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)
(EQ VAR (QUOTE BODY))
(\ILLEGAL.ARG VAL))
(* non-BODY fields must be stringlike)
(SELECTQ VAR (BODY (MAP (UNPACKFILENAME.STRING (COND ((LISTP VAL)
(* PACKFILENAME for
error checking of
fields)
(PACKFILENAME.STRING
VAL))
(T VAL))
NIL
(QUOTE OK))
[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
(COND
(VAL (SELCHARQ (CHCON1 VAL)
(({ %[ %()
(SUBSTRING VAL 2
(SELCHARQ (NTHCHARCODE
VAL -1)
((} %] %))
-2)
-1)))
VAL))
(T BLIP]
[(PATHNAME DIRECTORY)
(* DIRECTORY really is treated as {Host}device:<directory>)
(COND (VAL (for X on (SETQ VAL (UNPACKFILENAME.STRING VAL NIL
(QUOTE RETURN)))
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]
[SUBDIRECTORY (OR SUBDIRECTORY
(SETQ SUBDIRECTORY
(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)))
(T (OR DIRECTORY (SETQ DIRECTORY BLIP]
[(DEVICE DIRECTORY SUBDIRECTORY 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)
(COND ((EQ HOST BLIP)
(SETQ HOST NIL)))
(COND ((EQ DEVICE BLIP)
(SETQ DEVICE NIL)))
(COND ((EQ DIRECTORY BLIP)
(SETQ DIRECTORY NIL)))
[COND ((EQ SUBDIRECTORY BLIP)
(SETQ SUBDIRECTORY NIL))
(SUBDIRECTORY (COND ((AND (NULL DIRECTORY)
(OR HOST DEVICE))
(* no DIRECTORY specified, but the resulting name can't
just have a subdirectory, so make it a full directory
)
(SETQ DIRECTORY SUBDIRECTORY)
(SETQ SUBDIRECTORY NIL]
(RETURN (NCONC (AND HOST (LIST "{" HOST "}"))
[AND DEVICE (SELCHARQ (NTHCHARCODE DEVICE -1)
(: (LIST DEVICE))
(LIST DEVICE (QUOTE :]
(AND DIRECTORY (LIST "<" DIRECTORY ">"))
(AND SUBDIRECTORY (LIST SUBDIRECTORY ">"))
(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]
[PUTPROPS UNPACKFILE1 MACRO (OPENLAMBDA (NAM ST END)
(* lmm "22-APR-81 22:21")
(COND [(NOT ONEFIELDFLG)
(SETQ VAL (CONS (COND (PACKFLG (SUBATOM FILE ST END))
(T (OR (SUBSTRING FILE ST END)
"")))
(CONS NAM VAL]
((EQMEMB NAM ONEFIELDFLG)
(RETURN (COND (PACKFLG (SUBATOM FILE ST END))
(T (OR (SUBSTRING FILE ST END)
""]
)
)
(RPAQQ \FILENAME.DELIMITERS (40 41 91 93 123 125 60 62 47 33 59 58))
(* saving and restoring system state)
(DEFINEQ
(LOGOUT
[LAMBDA (FAST) (* hdj "23-May-86 16:20")
(\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)
(\PROCESS.AFTER.EXIT (QUOTE AFTERLOGOUT))
(\USEREVENT (QUOTE AFTERLOGOUT))
(INTERPRET.REM.CM)
NIL])
(MAKESYS
[LAMBDA (FILE NAME)
(DECLARE (GLOBALVARS \MISCSTATS)
(SPECVARS FILE NAME)) (* lmm "17-Jan-86 18:12")
(\FLUSHVMOK? (QUOTE MAKESYS))
(\USEREVENT (QUOTE BEFOREMAKESYS))
(HERALD (CONCAT (OR NAME "Xerox Lisp")
" "
(SUBSTRING (SETQ MAKESYSDATE (DATE))
1 9)
" ..."))
(\DEVICEEVENT (QUOTE BEFOREMAKESYS))
(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) (* hdj "23-May-86 16:20")
(* 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))
(\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) (* hdj "26-May-86 13:47")
(* 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)))]
(printout T T T "****WARNING: The file " (fetch (STREAM 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])
)
(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 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2260 8304 (DELFILE 2270 . 2437) (FULLNAME 2439 . 2762) (INFILE 2764 . 2930) (INFILEP
2932 . 3071) (IOFILE 3073 . 3231) (OPENFILE 3233 . 3394) (OPENSTREAM 3396 . 7361) (OUTFILE 7363 . 7533
) (OUTFILEP 7535 . 7675) (RENAMEFILE 7677 . 7876) (SIMPLE.FINDFILE 7878 . 8302)) (8374 20951 (
UNPACKFILENAME 8384 . 8551) (UNPACKFILENAME.STRING 8553 . 19102) (LASTCHPOS 19104 . 19528) (
\UPF.NEXTPOS 19530 . 19868) (FILENAMEFIELD 19870 . 20223) (PACKFILENAME 20225 . 20576) (
PACKFILENAME.STRING 20578 . 20949)) (32001 41911 (LOGOUT 32011 . 33260) (MAKESYS 33262 . 34289) (
SYSOUT 34291 . 35702) (SAVEVM 35704 . 36545) (HERALD 36547 . 36705) (\REVALIDATEFILELST 36707 . 39295)
(INTERPRET.REM.CM 39297 . 41600) (\USEREVENT 41602 . 41909)) (42094 43248 (USERNAME 42104 . 42770) (
SETUSERNAME 42772 . 43246)))))
STOP