(FILECREATED "14-AUG-83 17:01:49" {PHYLUM}<LISPCORE>SOURCES>ADIR.;24 24791
changes to: (FNS SAVEVM)
previous date: "22-JUL-83 16:09:03" {PHYLUM}<LISPCORE>SOURCES>ADIR.;23)
(* Copyright (c) 1981, 1982, 1983 by Xerox Corporation)
(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)
(DECLARE: DONTCOPY (MACROS UNPACKFILE1 UNPACKFILE2)))
(COMS (* saving and restoring system state)
(FNS LOGOUT MAKESYS DMAKESYS SYSOUT SAVEVM HERALD \REVALIDATEFILELST
INTERPRET.REM.CM)
(VARS (HERALDSTRING "")
(\USERNAME))
(GLOBALVARS HERALDSTRING USERNAME \USERNAME)
(FNS USERNAME SETUSERNAME)
(* Temporary patch)
(FNS GetBcplString SetBcplString))
(LOCALVARS . T)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA
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) (* bvm: "26-OCT-82 11:26")
(COND
((type? STREAM X)
(fetch FULLFILENAME 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 MACHINE.DEPENDENT.PARAMETERS)
(* bvm: "28-DEC-81 16:39")
(DECLARE (GLOBALVARS \OPENFILES))
(PROG (REC STREAM NAME)
(SELECTQ ACCESS
((INPUT OUTPUT BOTH APPEND))
(\ILLEGAL.ARG ACCESS))
(SETQ REC (SELECTQ RECOG
((OLD NEW OLD/NEW OLDEST)
RECOG)
(NIL (SELECTQ ACCESS
(INPUT (QUOTE OLD))
(OUTPUT (QUOTE NEW))
(QUOTE OLD/NEW)))
(\ILLEGAL.ARG RECOG)))
(SELECTQ BYTESIZE
((NIL 8))
(\ILLEGAL.ARG BYTESIZE))
(* Handle T and NIL separately, cause they can return the terminal OFD's, for which the search isn't necessary and
the \ADDOFD shouldn't be done.)
(RETURN (COND
((EQ FILE T))
((NULL FILE)
(fetch FULLNAME of (\GETOFD NIL ACCESS)))
(T
(* 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 OFD, 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 NAME (fetch FULLNAME of (SETQ STREAM (\OPENFILE FILE ACCESS REC
MACHINE.DEPENDENT.PARAMETERS]
(for ST in \OPENFILES when (EQ NAME (fetch FULLNAME of ST))
do (COND
((\IOMODEP ST ACCESS T)
(COND
((NOT (EQ ST STREAM))
(* Dispose of the newly-obtained OFD.
This might be a noop, but a network device
(LEAF) cares)
(\CLOSEFILE STREAM)))
(RETURN NAME))
(T (LISPERROR "FILE WON'T OPEN" FILE)))
finally (\ADDOFD STREAM)
(RETURN NAME])
(OPENSTREAM
[LAMBDA (FILE ACCESS RECOG BYTESIZE MACHINE.DEPENDENT.PARAMETERS)
(* lmm "20-APR-82 23:35")
(\GETOFD (OPENFILE FILE ACCESS RECOG BYTESIZE MACHINE.DEPENDENT.PARAMETERS)
ACCESS])
(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 (* rmk: " 4-MAY-82 21:15")
(* Note: DEVICE and STRUCTURE are identical but are for
TENEX and TOPS20 respectively.)
(COND
((AND (EQ N 1)
(LISTP (ARG N 1))) (* spread argument list)
(APPLY (FUNCTION PACKFILENAME)
(ARG N 1)))
(T (PROG (HOST DEVICE STRUCTURE DIRECTORY NAME EXTENSION VERSION TEMPORARY PROTECTION ACCOUNT
(I 1)
PACKLIST VAR VAL (BLIP "")
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 (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 [COND
((SETQ TEMP (STRPOS (QUOTE <)
VAL))
(* Host with embedded directory, overrides like BODY)
(OR DIRECTORY (SETQ DIRECTORY (OR (SUBSTRING VAL TEMP)
BLIP)))
(SETQ VAL (SUBSTRING VAL 1 (SUB1 TEMP]
(OR HOST (SETQ HOST (OR VAL BLIP]
[DIRECTORY [COND
((AND (EQ (CHCON1 VAL)
(CHARCODE {))
(SETQ TEMP (LASTCHPOS (CHARCODE })
VAL)))
(* DIRECTORY with embedded HOST, override like BODY)
(OR HOST (SETQ HOST (OR (SUBSTRING VAL 2 (SUB1 TEMP))
BLIP)))
(SETQ VAL (SUBSTRING VAL (ADD1 TEMP)
-1]
(OR DIRECTORY (SETQ DIRECTORY (OR VAL BLIP]
[(DEVICE 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)
(OR HOST DEVICE (PROGN (SETQ HOST (QUOTE CORE))
(SETQ TEMPORARY]
NIL)
[RETURN (PACK (NCONC (AND HOST (NEQ HOST BLIP)
(SELCHARQ [CHCON1 (CAR (SETQ HOST
(CONS HOST
(COND
((NEQ (NTHCHARCODE HOST -1)
(CHARCODE }))
(CONS (QUOTE }]
({ HOST)
(CONS (QUOTE {)
HOST)))
[AND DEVICE (NEQ DEVICE BLIP)
(SELCHARQ (NTHCHARCODE DEVICE -1)
(: (LIST DEVICE))
(LIST DEVICE (QUOTE :]
(AND DIRECTORY (NEQ DIRECTORY BLIP)
(SELCHARQ [CHCON1 (CAR (SETQ DIRECTORY
(CONS DIRECTORY
(COND
((NEQ (NTHCHARCODE
DIRECTORY -1)
(CHARCODE >))
(CONS (QUOTE >]
(< DIRECTORY)
(CONS (QUOTE <)
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]
(RETURN (PACK (NCONC (AND HOST (LIST (QUOTE {)
HOST
(QUOTE })))
[AND (OR DEVICE (SETQ DEVICE STRUCTURE))
(SELECTQ (MKATOM DEVICE)
[(NUL NUL: NIL:)
(CONS (SELECTQ (SYSTEMTYPE)
(TOPS20 (QUOTE NUL:))
(QUOTE NIL:]
(LIST DEVICE (COND
((NEQ (NTHCHARCODE DEVICE -1)
(CHARCODE :))
(QUOTE :))
(T BLIP]
[AND DIRECTORY (COND
((EQ (CHCON1 DIRECTORY)
(CHARCODE <))
(CONS DIRECTORY))
(T (LIST (QUOTE <)
DIRECTORY
(QUOTE >]
(AND NAME (CONS NAME))
(AND (OR EXTENSION VERSION)
(LIST (COND
((AND EXTENSION (EQ (CHCON1 EXTENSION)
(CHARCODE %.)))
BLIP)
(T (QUOTE %.)))
(OR EXTENSION BLIP)))
(AND VERSION (PROGN (OR (FIXP VERSION)
(SELCHARQ (CHCON1 VERSION)
((%. ;)
(SETQ VERSION
(SUBATOM VERSION 2 -1)))
NIL))
(LIST (SELECTQ (SYSTEMTYPE)
(TOPS20 (QUOTE %.))
(QUOTE ;))
VERSION)))
(AND PROTECTION (LIST (SELCHARQ (CHCON1 PROTECTION)
(; BLIP)
(P (QUOTE ;))
(QUOTE ";P"))
PROTECTION))
(AND ACCOUNT (LIST (SELCHARQ (CHCON1 ACCOUNT)
(; BLIP)
(A (QUOTE ;))
(QUOTE ";A"))
ACCOUNT))
(AND TEMPORARY (LIST (QUOTE ;)
(SELECTQ TEMPORARY
((S ;S)
(QUOTE S))
T])
(UNPACKFILENAME
[LAMBDA (FILE ONEFIELDFLG) (* lmm "28-FEB-82 15:33")
(OR (LITATOM FILE)
(STRINGP FILE)
(ERRORX (LIST 27 FILE)))
(PROG (TEM (POS 1)
INEXT INVERS VAL CODE)
(OR FILE (RETURN))
[COND
((AND (EQ (NTHCHARCODE FILE 1)
(CHARCODE {))
(SETQ TEM (LASTCHPOS (CHARCODE })
FILE 2)))
(UNPACKFILE1 (QUOTE HOST)
2
(SUB1 TEM))
(SETQ POS (ADD1 TEM]
[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]
(SELCHARQ (NTHCHARCODE FILE POS)
[(< >)
(COND
((SETQ TEM (LASTCHPOS (CHARCODE >)
FILE POS))
(UNPACKFILE1 (QUOTE DIRECTORY)
(ADD1 POS)
(SUB1 TEM))
(SETQ POS (ADD1 TEM)))
((SETQ TEM (LASTCHPOS (CHARCODE ESC)
FILE POS))
(UNPACKFILE1 (QUOTE DIRECTORY)
(ADD1 POS)
(SETQ POS TEM]
NIL)
(OR (SETQ CODE (NTHCHARCODE FILE (SETQ TEM POS)))
(RETURN (DREVERSE VAL)))
NAMELP
(SELCHARQ CODE
(%. (* delimits end of NAME or EXTENSION)
(UNPACKFILE1 (COND
((NOT INEXT)
(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)))
NIL)
(SETQ CODE (NTHCHARCODE FILE (add TEM 1)))
(GO NAMELP)
OUT (RETURN VAL])
(LASTCHPOS
[LAMBDA (CH STR START) (* lmm " 3-DEC-80 23:48")
(PROG (RESULT NC)
(OR START (SETQ START 1))
(while (SETQ NC (NTHCHARCODE STR START)) do (COND
((EQ CH NC)
(SETQ RESULT START)))
(add START 1))
(RETURN RESULT])
)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS UNPACKFILE1 MACRO [LAMBDA (NAM ST END) (* lmm "22-APR-81 22:21")
(PROG NIL
[COND
(ONEFIELDFLG (COND
((EQMEMB NAM ONEFIELDFLG)
(SETQ VAL (SUBATOM FILE ST END))
(GO OUT))
(T (RETURN]
(SETQ VAL (CONS (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])
)
)
(* saving and restoring system state)
(DEFINEQ
(LOGOUT
[LAMBDA (FAST) (* bvm: "10-NOV-82 14:56")
(DECLARE (GLOBALVARS \OPENFILES))
(FLUSHMAP T)
(\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))
(INTERPRET.REM.CM)
NIL])
(MAKESYS
[LAMBDA (FILE NAME) (* bvm: "24-MAR-82 15:41")
(DECLARE (GLOBALVARS \MISCSTATS))
(\DEVICEEVENT (QUOTE BEFOREMAKESYS)) (* reset totaltime field.)
(replace TOTALTIME of \MISCSTATS with 0)
(COND
((LISTP (\COPYSYS FILE))
(\DEVICEEVENT (QUOTE AFTERMAKESYS))
(\RESETOFDS)))
(PRIN1 HERALDSTRING T)
(INTERPRET.REM.CM)
(RESET])
(DMAKESYS
[LAMBDA (FILE NAME) (* edited: " 2-JUN-83 13:13")
(DECLARE (GLOBALVARS \MISCSTATS))
(SETQ MAKESYSDATE (DATE))
(HERALD (CONCAT "INTERLISP-D " (SUBSTRING (DATE)
1 9)
" ..."))
(SETQ LAST↑TKEYBOARDTIME)
(\DEVICEEVENT (QUOTE BEFOREMAKESYS)) (* reset totaltime field.)
(COND
((LISTP (\COPYSYS FILE))
(\DEVICEEVENT (QUOTE AFTERMAKESYS))
(\RESETOFDS)
(SETQ RESETFORMS (CONS GREETFORM RESETFORMS))
(PRIN1 HERALDSTRING T)
(INTERPRET.REM.CM)
(RESET])
(SYSOUT
[LAMBDA (FILE) (* bvm: "24-MAR-82 15:42")
(DECLARE (GLOBALVARS \MISCSTATS))
(PROG ((TOTALTIMESAVE (fetch TOTALTIME of \MISCSTATS))
NEWFILE)
(\DEVICEEVENT (QUOTE BEFORESYSOUT)) (* 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))
(T (* restarting)
(\DEVICEEVENT (QUOTE AFTERSYSOUT))
(\RESETOFDS)
(INTERPRET.REM.CM])
(SAVEVM
[LAMBDA (RELEASEFLG) (* lmm "14-AUG-83 16:05")
(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)
(\DEVICEEVENT (QUOTE BEFORESYSOUT))
(COND
((\FLUSHVM)
(\RESETKEYBOARD) (* Returns T when starting up fresh)
(\DEVICEEVENT (QUOTE AFTERSYSOUT))
(SETQ \OPENFILES (\REVALIDATEFILELST \OPENFILES))
T])
(HERALD
[LAMBDA (STR) (* wt: " 2-MAY-79 15:38")
(AND STR (SETQ HERALDSTRING STR))
HERALDSTRING])
(\REVALIDATEFILELST
[LAMBDA (OFDLST) (* rrb "22-JUL-83 15:57")
(* OFDLST 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 (OFDS ← OFDLST)
OFD REASON RECLFLG PAGES while OFDS
do (COND
([SETQ REASON (\REVALIDATEFILE (SETQ OFD (CAR OFDS]
(COND
((AND (EQ REASON (QUOTE DELETED))
(EQ OFD \DRIBBLE.OFD)) (* If Dribble file went away, turn it off quick before
we get in trouble)
(SETQ \DRIBBLE.OFD)))
(COND
((NOT RECLFLG) (* Map down the tail of OFDLST and smash the CPPTR to
NIL first)
(for O in OFDS do (replace CPPTR of O with NIL))
(SETQ RECLFLG T)
(RECLAIM)))
(printout T T T "****WARNING: The file " (fetch FULLNAME of OFD))
(SELECTQ REASON
(CHANGED (SETQ PAGES (RESTOREMAP OFD))
(printout T " has been modified since you last accessed it!" T)
(SETQ OFDS (CDR OFDS)))
(DELETED (SETQ PAGES (FORGETPAGES OFD))
(AFTERCLOSE (fetch FULLNAME of OFD))
(replace ACCESS of OFD with NIL)
[COND
((NEQ OFDLST \OPENFILES)
(SETQ \OPENFILES (DREMOVE OFD \OPENFILES]
(COND
((CDR OFDS)
(FRPLNODE2 OFDS (CDR OFDS)))
(T (SETQ OFDLST (DREMOVE OFD OFDLST))
(SETQ OFDS 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 OFDS (CDR OFDS]
OFDLST])
(INTERPRET.REM.CM
[LAMBDA (RETFLG) (* bvm: "26-MAR-82 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 (NLSETQ (OPENFILE (QUOTE {DSK}REM.CM;1)
(QUOTE BOTH]
COM AUXFILE)
[COND
([AND FILE (IGREATERP (GETFILEINFO (SETQ FILE (\GETOFD (CAR FILE)
(QUOTE BOTH)))
(QUOTE LENGTH))
0)
(SELCHARQ (\PEEKBIN FILE)
((%( %")
T)
NIL)
(SETQ COM (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 (OPENFILE (QUOTE {CORE}TEMP.CM)
(QUOTE BOTH)
(QUOTE NEW)))
(COPYBYTES FILE AUXFILE)
(SETFILEPTR FILE 0)
(COPYBYTES AUXFILE FILE 0 (PROG1 (GETFILEPTR AUXFILE)
(SETFILEPTR AUXFILE 0)))
(DELFILE (CLOSEF AUXFILE))
(GETFILEPTR FILE))
(T 0]
(CLOSEF FILE)
(RETURN (COND
(RETFLG COM)
(COM T])
)
(RPAQ HERALDSTRING "")
(RPAQQ \USERNAME NIL)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS HERALDSTRING USERNAME \USERNAME)
)
(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)
)
(PUTPROPS ADIR COPYRIGHT ("Xerox Corporation" 1981 1982 1983))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1238 5513 (DELFILE 1248 . 1396) (FULLNAME 1398 . 1716) (INFILE 1718 . 1884) (INFILEP
1886 . 2025) (IOFILE 2027 . 2185) (OPENFILE 2187 . 4424) (OPENSTREAM 4426 . 4673) (OUTFILE 4675 . 4845
) (OUTFILEP 4847 . 4987) (RENAMEFILE 4989 . 5188) (SIMPLE.FINDFILE 5190 . 5511)) (5570 13763 (
FILENAMEFIELD 5580 . 5857) (PACKFILENAME 5859 . 11617) (UNPACKFILENAME 11619 . 13421) (LASTCHPOS 13423
. 13761)) (14796 22178 (LOGOUT 14806 . 15539) (MAKESYS 15541 . 15997) (DMAKESYS 15999 . 16586) (
SYSOUT 16588 . 17487) (SAVEVM 17489 . 18106) (HERALD 18108 . 18266) (\REVALIDATEFILELST 18268 . 20081)
(INTERPRET.REM.CM 20083 . 22176)) (22325 23479 (USERNAME 22335 . 23001) (SETUSERNAME 23003 . 23477))
(23508 24509 (GetBcplString 23518 . 24161) (SetBcplString 24163 . 24507)))))
STOP