(FILECREATED "26-Sep-86 14:57:42" {ERIS}<LISPCORE>SOURCES>BOOTSTRAP.;25 49843
changes to: (VARS BOOTSTRAPCOMS)
previous date: "24-Sep-86 12:50:43" {ERIS}<LISPCORE>SOURCES>BOOTSTRAP.;24)
(* "
Copyright (c) 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT BOOTSTRAPCOMS)
(RPAQQ BOOTSTRAPCOMS
[(FNS GETPROP SETATOMVAL RPAQQ RPAQ RPAQ? MOVD MOVD? SELECTQ SELECTQ1 NCONC1 PUTPROP PROPNAMES
ADDPROP REMPROP MEMB CLOSEF?)
(COMS (* ; "Need these in order to load even compiled files SYSLOAD")
(FNS LOAD \LOAD-STREAM FILECREATED FILECREATED1 PRETTYCOMPRINT BOOTSTRAP-NAMEFIELD
PUTPROPS DECLARE: DECLARE:1 ROOTFILENAME DEFINE-FILE-INFO \DO-DEFINE-FILE-INFO))
[INITVARS (EOLCHARCODE (CHCON1 (QUOTE %
)))
(PRETTYHEADER)
(DWIMFLG)
(UPDATEMAPFLG)
(DFNFLG)
(ADDSPELLFLG)
(BUILDMAPFLG)
(FILEPKGFLG)
(SYSFILES)
(NOTCOMPILEDFILES)
(RESETVARSLST)
[LOADPARAMETERS (QUOTE ((SEQUENTIAL T]
(LISPXHIST)
(LISPXPRINTFLG T)
(PRETTYHEADER "File created ")
(LOAD-VERBOSE-STREAM T)
(BELLS (QUOTE ""))
(LOADOPTIONS (QUOTE (SYSLOAD NIL T PROP ALLPROP]
(ADDVARS (LOADEDFILELST))
(GLOBALVARS DWIMFLG UPDATEMAPFLG LOADOPTIONS LOADPARAMETERS FILERDTBL SYSFILES)
(DECLARE: DONTEVAL@LOAD DOCOPY
[P [MAPC (QUOTE ((PUTD . /PUTD)
(PUTPROP . /PUTPROP)
(PUTPROP . PUT)
(PUTPROP . SAVEPUT)
(ADDPROP . /ADDPROP)
(PUT . /PUT)
(PRIN1 . LISPXPRIN1)
(PRIN2 . LISPXPRIN2)
(PRINT . LISPXPRINT)
(TERPRI . LISPXTERPRI)
(SPACES . LISPXSPACES)
(GETPROP . GETP)
(SET . SAVESET)
(NILL . MISSPELLED?)
(SETTOPVAL . /SETTOPVAL)
(BOOTSTRAP-NAMEFIELD . NAMEFIELD)))
(FUNCTION (LAMBDA (X)
(OR (CCODEP (CDR X))
(MOVD (CAR X)
(CDR X)
NIL T]
(AND (CCODEP (QUOTE BOOTSTRAP-NAMEFIELD))
(PUTD (QUOTE BOOTSTRAP-NAMEFIELD)))
(AND (CCODEP (QUOTE BOOTSTRAP-PUTPROPS))
(PUTD (QUOTE BOOTSTRAP-PUTPROPS)))
(MAPC [QUOTE ([STRPOS (LAMBDA (X Y START SKIP ANCHOR TAIL)
[COND [(LITATOM X)
(SETQ X (CDR (VAG (IPLUS (LOC X)
2]
((NULL (STRINGP X))
(SETQ X (MKSTRING X]
[COND ((STRINGP Y))
[(LITATOM Y)
(SETQ Y (CDR (VAG (IPLUS (LOC Y)
2]
(T (SETQ Y (MKSTRING Y]
[COND (SKIP (SETQ SKIP (NTHCHAR SKIP 1]
(COND [START (COND ((MINUSP START)
(SETQ START (IPLUS START
(NCHARS Y)
1]
(T (SETQ START 1)))
(SETQ Y (SUBSTRING Y START))
(PROG ((N START)
W X1 Y1)
L2
(SETQ X1 (SUBSTRING X 1))
(SETQ Y1 (SUBSTRING Y 1))
LP
(COND [(SETQ W (GNC X1))
(COND ((EQ W (GNC Y1))
(GO LP))
((EQ W SKIP)
(GO LP))
(T (GO NX]
(TAIL (RETURN (IPLUS (NCHARS X)
N)))
(T (RETURN N)))
NX
(COND (ANCHOR (RETURN)))
(COND ((GNC Y)
(SETQ N (ADD1 N))
(GO L2))
(T (RETURN]
[PACKFILENAME (LAMBDA (X)
X]
[UNPACKFILENAME (LAMBDA (X)
X]
(RESETRESTORE (LAMBDA (RESETVARSLST0 RESETSTATE)
(PROG (RESETZ)
LP
(COND ((AND RESETVARSLST (NEQ RESETVARSLST
RESETVARSLST0
))
(SETQ RESETZ (CAR RESETVARSLST))
(SETQ RESETVARSLST (CDR
RESETVARSLST
))
[COND ((LISTP (CAR RESETZ))
(APPLY (CAAR RESETZ)
(CDR (CAR RESETZ]
(GO LP]
(FUNCTION (LAMBDA (X)
(OR (GETD (CAR X))
(PUTD (CAR X)
(CADR X]
(P (PRINTLEVEL 1000)
(RADIX 10)))
(DECLARE: DOEVAL@COMPILE DONTCOPY (* ; "eventually imported from FASL")
(CONSTANTS FASL:SIGNATURE))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA DEFINE-FILE-INFO DECLARE: PUTPROPS FILECREATED SELECTQ)
(NLAML RPAQ? RPAQ RPAQQ)
(LAMA])
(DEFINEQ
(GETPROP
[LAMBDA (ATM PROP) (* lmm " 5-SEP-83 22:29")
(* Used to be called GETP)
(AND (LITATOM ATM)
(PROG ((PLIST (GETPROPLIST ATM)))
LOOP
[COND
((OR (NLISTP PLIST)
(NLISTP (CDR PLIST)))
(RETURN NIL))
((EQ (CAR PLIST)
PROP)
(RETURN (CADR PLIST]
(SETQ PLIST (CDDR PLIST))
(GO LOOP])
(SETATOMVAL
[LAMBDA (X Y) (* wt: 27-JAN-76 23 20)
(* dummy defiition so rpaqq will work.)
(COND
((GETD (QUOTE VCTOAC))
(SET X Y))
(T (SETTOPVAL X Y])
(RPAQQ
[NLAMBDA (X Y)
(SETATOMVAL X Y])
(RPAQ
[NLAMBDA (RPAQX RPAQY) (* lmm "23-JUL-83 16:10")
(* RPAQ and RPAQQ are used by
PRETTYDEF to save VARS.)
(SETTOPVAL RPAQX (EVAL RPAQY])
(RPAQ?
[NLAMBDA (RPAQX RPAQY) (* lmm "23-JUL-83 16:12")
(* RPAQ? and RPAQQ are used by
PRETTYDEF to save VARS.)
(OR (NEQ (GETTOPVAL RPAQX)
(QUOTE NOBIND))
(SETTOPVAL RPAQX (EVAL RPAQY])
(MOVD
[LAMBDA (FROM TO COPYFLG DONTCOPY) (* bvm: "10-Jul-85 12:59")
(PROG [(NEWFLG (NULL (GETD TO]
(PUTD TO (COND
(COPYFLG (COPY (VIRGINFN FROM)))
(T (GETD FROM)))
DONTCOPY)
(AND FILEPKGFLG (EXPRP TO)
(MARKASCHANGED TO (QUOTE FNS)
NEWFLG))
(RETURN TO])
(MOVD?
[LAMBDA (FROM TO COPYFLG DONTCOPY) (* bvm: "10-Jul-85 13:00")
(* Like MOVD but only does it if TO is
not defined.)
(COND
((NULL (GETD TO))
(PUTD TO (COND
(COPYFLG (COPY (VIRGINFN FROM)))
(T (GETD FROM)))
DONTCOPY)
(AND FILEPKGFLG (EXPRP TO)
(MARKASCHANGED TO (QUOTE FNS)
T))
TO])
(SELECTQ
[NLAMBDA SELCQ
(APPLY (QUOTE PROGN)
(SELECTQ1 (EVAL (CAR SELCQ)
(QUOTE SELECTQ))
(CDR SELCQ))
(QUOTE SELECTQ])
(SELECTQ1
[LAMBDA (M L)
(PROG (C)
LP (SETQ C L)
[COND
((NULL (SETQ L (CDR L)))
(RETURN C))
([OR (EQ (CAR (SETQ C (CAR C)))
M)
(AND (LISTP (CAR C))
(FMEMB M (CAR C]
(RETURN (CDR C]
(GO LP])
(NCONC1
[LAMBDA (LST X) (* included in wtmisc so can make the
call to nconc be linked.
so that user can then break on nconc.)
(NCONC LST (FRPLACD (CONS X LST])
(PUTPROP
[LAMBDA (ATM PROP VAL) (* Included because it must be defined
before the MOVD's in BOOTSTRAPCOMS
that initialize /PUTPROP are executed.)
[COND
[(NULL ATM)
(ERRORX (LIST 7 (LIST ATM PROP]
((NOT (LITATOM ATM))
(ERRORX (LIST 14 ATM]
(PROG ((X (GETPROPLIST ATM))
X0)
LOOP
(COND
((NLISTP X)
(COND
((AND (NULL X)
X0) (* typical case. property list ran out
on an even parity position.
e.g. (A B C D))
(FRPLACD (CDR X0)
(LIST PROP VAL))
(RETURN VAL)))
(* propety list was initially NIL or a non-list, or else it ended in a non-list
following an even parity position, e.g. (A B . C) fall through and add new
property at beginning)
)
((NLISTP (CDR X))
(* property list runs out on an odd parity, or ends in an odd list following an
odd parity, e.g. (A B C) or (A B C . D) fall through and add at beginning)
)
((EQ (CAR X)
PROP)
(FRPLACA (CDR X)
VAL)
(RETURN VAL))
(T (SETQ X (CDDR (SETQ X0 X)))
(GO LOOP)))
[SETPROPLIST ATM (CONS PROP (CONS VAL (GETPROPLIST ATM]
(RETURN VAL])
(PROPNAMES
[LAMBDA (ATM) (* wt: " 3-AUG-78 01:23")
(MAPLIST (GETPROPLIST ATM)
(FUNCTION CAR)
(FUNCTION CDDR])
(ADDPROP
[LAMBDA (ATM PROP NEW FLG) (* ;
"If FLG is T, NEW is consed onto the front, otherwise NCONCED onto the end.")
(* ; "Value is new PROP value.")
[COND
[(NULL ATM)
(ERRORX (LIST 7 (LIST PROP NEW]
((NOT (LITATOM ATM))
(ERRORX (LIST 14 ATM]
(PROG ((X (GETPROPLIST ATM))
X0)
LOOP
(COND
((NLISTP X)
(COND
((AND (NULL X)
X0) (* ;
"typical case. property list ran out on an even parity position.")
[FRPLACD (CDR X0)
(LIST PROP (SETQ NEW (LIST NEW]
(RETURN NEW))) (* ;; "proprty list was initially NIL or a non-lit, or ele it ended in a non-list following an even parity position, e.g. (A B . C) fall through and add property at beginning of property list.")
)
((NLISTP (CDR X)) (* ;; "property list runs out on an odd parity, or else ends in a non-list following an odd parity, e.g. (A B C) or (A B C . D) fall through and add at beginning")
)
((EQ (CAR X)
PROP) (* ; "PROP found")
[FRPLACA (CDR X)
(SETQ NEW (COND
(FLG (CONS NEW (CADR X)))
(T (NCONC1 (CADR X)
NEW]
(RETURN NEW))
(T (SETQ X (CDDR (SETQ X0 X)))
(GO LOOP))) (* ; "Add to beginning of property list.")
[SETPROPLIST ATM (CONS PROP (CONS (SETQ NEW (LIST NEW))
(GETPROPLIST ATM]
(RETURN NEW])
(REMPROP
[LAMBDA (ATM PROP) (* bvm: "17-Sep-86 17:29")
[COND
((NULL (LITATOM ATM))
(ERRORX (LIST 14 ATM]
(PROG ((X (GETPROPLIST ATM))
X0 VAL)
LP [COND
((OR (NLISTP X)
(NLISTP (CDR X)))
(RETURN VAL))
((EQ (CAR X)
PROP)
(SETQ VAL (OR PROP T)) (* ; "T in case indicator is NIL")
[COND
(X0 (FRPLACD (CDR X0)
(CDDR X)))
(T (SETPROPLIST ATM (CDDR X] (* ; "iterate in case there are more occurrences. Shouldn't happen unless users manually clobber prop list")
(SETQ X (CDDR X)))
(T (SETQ X (CDDR (SETQ X0 X]
(GO LP])
(MEMB
[LAMBDA (X Y)
(PROG NIL
LP (RETURN (COND
((NLISTP Y)
NIL)
((EQ X (CAR Y))
Y)
(T (SETQ Y (CDR Y))
(GO LP])
(CLOSEF?
[LAMBDA (FL) (* wt: 18-MAR-77 12 20)
(* useful for resetsaves, in case
somebody else might close the file.)
(AND FL (OPENP FL)
(CLOSEF FL])
)
(* ; "Need these in order to load even compiled files SYSLOAD")
(DEFINEQ
(LOAD
[LAMBDA (FILE LDFLG PRINTFLG) (* bvm: "22-Sep-86 16:22")
(RESETLST (PROG (STREAM TEM)
TOP (if (FMEMB LDFLG LOADOPTIONS)
elseif (AND DWIMFLG (SETQ TEM (FIXSPELL LDFLG NIL LOADOPTIONS T)))
then (SETQ LDFLG TEM)
else (SETQ LDFLG (ERROR "unrecognized load option" LDFLG))
(GO TOP))
[RESETSAVE NIL (LIST (QUOTE CLOSEF?)
(SETQ STREAM (OPENSTREAM FILE (QUOTE INPUT)
(QUOTE OLD)
NIL LOADPARAMETERS]
(RETURN (\LOAD-STREAM STREAM LDFLG PRINTFLG *OLD-INTERLISP-READ-ENVIRONMENT*
(AND PRETTYHEADER T])
(\LOAD-STREAM
[LAMBDA (STREAM LDFLG PRINTFLG DEFAULTENV LOAD-VERBOSE-STREAM)
(DECLARE (SPECVARS LDFLG PRINTFLG LOAD-VERBOSE-STREAM)) (* bvm: "22-Sep-86 16:32")
(* ;;; "Internal function that loads from an already open stream. DEFAULTENV is the environment in which to read expressions if we haven't figured out how else to. LOAD-VERBOSE-STREAM if non-nil is the stream to which to print %"file created%" messages and such. Similarly, PRINTFLG, if non-nil, is the stream to which to print the value of each expression.")
(PROG ((DFNFLG DFNFLG)
(BUILDMAPFLG BUILDMAPFLG)
(FILEPKGFLG FILEPKGFLG)
(ADDSPELLFLG ADDSPELLFLG)
(LISPXHIST LISPXHIST)
(PRLST (AND FILEPKGFLG (FILEPKGCHANGES)))
(FILECREATEDENV DEFAULTENV)
FILE FILEMAP FNADRLST ROOTNAME TEM FILECREATEDLST LOADA MAYBEWANTFILEMAP FILECREATEDLOC)
(DECLARE (SPECVARS *PACKAGE* *READ-BASE* DFNFLG BUILDMAPFLG FILEPKGFLG ADDSPELLFLG
LISPXHIST FILECREATEDLST FILECREATEDENV FILECREATEDLOC FILE))
(if (NEQ (GETFILEPTR STREAM)
0)
then (* ; "this can come out when MSPF")
(SETFILEPTR STREAM 0))
(RESETSAVE (INPUT STREAM))
(SETQ FILE (FULLNAME STREAM))
(if (AND LOAD-VERBOSE-STREAM FILE (LITATOM FILE))
then (LISPXTERPRI LOAD-VERBOSE-STREAM)
(if (NEQ LOAD-VERBOSE-STREAM T)
then (* ;
"CL:LOAD says to prefix this stuff with comment marker")
(PRIN1 "; " LOAD-VERBOSE-STREAM))
(LISPXPRINT FILE LOAD-VERBOSE-STREAM))
(if (EQ (SETQ DFNFLG LDFLG)
(QUOTE SYSLOAD))
then (SETQ DFNFLG T)
(SETQ ADDSPELLFLG NIL)
(SETQ BUILDMAPFLG NIL)
(SETQ FILEPKGFLG NIL)
(SETQ LISPXHIST NIL))
(if LISPXHIST
then (* ;
"Want UNDOSAVE to keep saving regardless of how many undosaves are involved")
(if (SETQ LOADA (FMEMB (QUOTE SIDE)
LISPXHIST))
then (FRPLACA (CADR LOADA)
-1)
else (LISPXPUT (QUOTE SIDE)
(LIST -1)
NIL LISPXHIST)))
(if (EQ (SETQ TEM (SKIPSEPRCODES STREAM))
FASL:SIGNATURE)
then (* ; "FASL file handled by FASL loader")
(FASL:PROCESS-FILE STREAM PRINTFLG)
(RETURN FILE)
elseif (EQ TEM (CHARCODE ";"))
then (SETQ FILECREATEDENV *COMMON-LISP-READ-ENVIRONMENT*))
(if (AND BUILDMAPFLG (RANDACCESSP STREAM))
then (SETQ MAYBEWANTFILEMAP T))
(WITH-READER-ENVIRONMENT
FILECREATEDENV
(PROG (ADR)
LP (if FILEMAP
then (* ; "need to build map, so read carefully")
(SETQ LOADA (SKIPSEPRCODES STREAM))
(if (OR (SYNTAXP LOADA (QUOTE LEFTPAREN))
(SYNTAXP LOADA (QUOTE LEFTBRACKET)))
then (* ; "See if we have a DEFINEQ")
(SETQ ADR (GETFILEPTR STREAM))
(READCCODE STREAM) (* ; "Eat paren")
(if (EQ (RATOM STREAM)
(QUOTE DEFINEQ))
then (SETQ FNADRLST (TCONC NIL ADR))
(TCONC FNADRLST NIL)
(TCONC FILEMAP (CAR FNADRLST))
(GO DEFQLP)) (* ; "Not a DEFINEQ, so back out")
(SETFILEPTR STREAM ADR)))
(SELECTQ (SETQ LOADA (READ STREAM))
((STOP NIL)
(if (EQ LDFLG (QUOTE SYSLOAD))
then (if (NOT (MEMB (SETQ ROOTNAME (ROOTFILENAME FILE (CDR
FILECREATEDLST
)))
SYSFILES))
then (SETQ SYSFILES (NCONC1 SYSFILES ROOTNAME)))
(SMASHFILECOMS ROOTNAME)
elseif FILEPKGFLG
then (* ;;; "Do not want any items that are added to FILEPKGCHANGES as a result of being mentioned in this file to remain on FILEPKGCHANGES. Also, we want items mentioned earlier to be deleted if they are taken care of by this file. The extra argument to ADDFILE allows it to restore FILEPKGCHANGES to the intersection of its current value and its previous value.")
(ADDFILE FILE T PRLST FILECREATEDLST))
[if FILEMAP
then (PUTFILEMAP FILE (CAR FILEMAP)
FILECREATEDLST FILECREATEDENV NIL FILECREATEDLOC)
(if UPDATEMAPFLG
then (SETFILEPTR STREAM ADR)
(* ;
"address of last expression read. good hint for finding filemap")
(UPDATEFILEMAP STREAM (CAR FILEMAP]
(if (NOT (MEMB FILE LOADEDFILELST))
then (/SETTOPVAL (QUOTE LOADEDFILELST)
(CONS FILE LOADEDFILELST)))
(RETURN))
NIL)
[if (LISTP LOADA)
then (if (AND (EQ (CAR LOADA)
(QUOTE FILECREATED))
MAYBEWANTFILEMAP)
then (* ; "See if we have a valid file map")
(SETQ ADR (GETFILEPTR STREAM))
(if [AND [SETQ TEM (CAR (NLSETQ (SETFILEPTR STREAM (CADDDR LOADA))
(READ STREAM]
(EQ (CAR TEM)
(QUOTE FILEMAP))
(NULL (CAR (SETQ TEM (CADR TEM]
then (* ; "Has ok map")
(PUTFILEMAP FILE TEM NIL FILECREATEDENV)
else (* ; "Need to build a file map as we go")
(SETQ FILEMAP (TCONC NIL NIL)))
(SETFILEPTR STREAM ADR)
(SETQ MAYBEWANTFILEMAP NIL))
(SETQ LOADA (EVAL LOADA))
else (* ; "Atom found. Compiled code definition.")
(if ADDSPELLFLG
then (ADDSPELL LOADA))
(if FILEMAP
then (SETQ ADR (GETFILEPTR STREAM)))
(LAPRD LOADA)
(if FILEMAP
then (TCONC FILEMAP (CONS ADR (CONS (GETFILEPTR STREAM)
LOADA]
LP1 (if PRINTFLG
then (PRINT LOADA PRINTFLG))
(GO LP)
DEFQLP
(SELCHARQ (SKIPSEPRCODES STREAM)
((%) %]) (* ; "Closes DEFINEQ.")
(READCCODE STREAM)
(if FNADRLST
then (RPLACA (CDAR FNADRLST)
(GETFILEPTR STREAM)))
(* ;
"FNADRLST is a TCONC format list, hence want to RPLACA CDAR, not just CDR.")
(SETQ LOADA (DEFINE (DREVERSE LOADA)))
(GO LP1))
((%( %[) (* ; "another function/definition pair")
(SETQ ADR (GETFILEPTR STREAM))
(SETQ LOADA (CONS (READ STREAM)
LOADA))
[if FNADRLST
then (TCONC FNADRLST (CONS (CAAR LOADA)
(CONS ADR (GETFILEPTR STREAM]
(GO DEFQLP))
NIL)
(ERROR "illegal argument in defineq")))
(RETURN FILE])
(FILECREATED
[NLAMBDA X (* bvm: "22-Sep-86 16:18")
(DECLARE (USEDFREE FILECREATEDLST LOAD-VERBOSE-STREAM))
(PROG ((FILEDATE (CAR X))
(FILE (CADR X)))
(SETQ FILECREATEDLST (NCONC1 FILECREATEDLST X))
(COND
(LOAD-VERBOSE-STREAM (* ;; "Presumably if user sets prettyheader to NIL, he doesnt want to see any file created messages, even those frm compiled files.")
(if (NEQ LOAD-VERBOSE-STREAM T)
then (* ;
"CL:LOAD says to prefix this stuff with comment marker")
(PRIN1 "; " LOAD-VERBOSE-STREAM))
(LISPXPRIN1 (FILECREATED1 X)
LOAD-VERBOSE-STREAM)
(LISPXPRIN1 FILEDATE LOAD-VERBOSE-STREAM)
(LISPXTERPRI LOAD-VERBOSE-STREAM)))
(COND
((AND FILE (LITATOM FILE)) (* ;; "This is just temporary, primarily for keeping dates of system files which are loaded with FILEPKGFLG=NIL. The real setting up of file property lists is done when ADDFILE is called.")
(/PUT (ROOTFILENAME FILE)
(QUOTE FILEDATES)
(LIST (CONS FILEDATE FILE])
(FILECREATED1
[LAMBDA (X) (* rmk: "20-FEB-83 21:50")
(* ;; "performs error checking on filecreated expressions. returns the thing to be printed. used by filecreated, and loadfns")
(PROG ((FILE (CADR X)))
(RETURN (COND
((STRINGP FILE) (* ; "old way of doing COMPILED ON")
FILE)
((LISTP FILE) (* ;
"New. also used for printing COMPILED ON message. CDR is a list of files that were compiled.")
(CAR FILE))
(T (* ; "FILE is an atom, the name of the file")
PRETTYHEADER])
(PRETTYCOMPRINT
[NLAMBDA (X) (* bvm: "22-Sep-86 17:02")
(if LOAD-VERBOSE-STREAM
then (if (NEQ LOAD-VERBOSE-STREAM T)
then (* ;
"CL:LOAD says to prefix this stuff with comment marker")
(PRIN1 "; " LOAD-VERBOSE-STREAM))
(LISPXPRINT X LOAD-VERBOSE-STREAM])
(BOOTSTRAP-NAMEFIELD
[LAMBDA (FILE SUFFIXFLG) (* bvm: " 2-Aug-86 14:50")
(* BOOTSTRAP VERSION --
this is replaced by real version from
MACHINEINDEPENDENT)
(PROG ((START 1)
POS END)
(while (SETQ POS (OR (STRPOS (QUOTE })
FILE START)
(STRPOS (QUOTE >)
FILE START)
(STRPOS (QUOTE /)
FILE START))) do (SETQ START (ADD1 POS)))
[COND
((SETQ POS (STRPOS (QUOTE ;)
FILE))
(SETQ END (SUB1 POS))
(COND
((EQ (NTHCHARCODE FILE END)
(CHARCODE ".")) (* eliminates null suffix)
(SETQ END (SUB1 END]
[COND
((SETQ POS (STRPOS (QUOTE %.)
FILE START))
(COND
((NULL SUFFIXFLG)
(SETQ END (SUB1 POS]
(RETURN (SUBATOM FILE START END])
(PUTPROPS
[NLAMBDA X (* bvm: " 8-Sep-86 11:20")
(* Later in the loadup, the PUTPROP is
changed to SAVEPUT)
(MAP (CDR X)
[FUNCTION (LAMBDA (Y)
(PUTPROP (CAR X)
(CAR Y)
(CADR Y]
(FUNCTION CDDR])
(DECLARE:
[NLAMBDA X (* wt: "20-OCT-77 13:00")
(DECLARE:1 X T])
(DECLARE:1
[LAMBDA (X EVALFLG) (* wt: "20-OCT-77 13:09")
(PROG NIL
LP (COND
((NLISTP X)
(RETURN))
[(LISTP (CAR X))
(AND EVALFLG (COND
((EQ (CAAR X)
(QUOTE DECLARE:))
(DECLARE:1 (CDAR X)
T))
(T (EVAL (CAR X]
(T (SELECTQ (CAR X)
((EVAL@LOAD DOEVAL@LOAD)
(SETQ EVALFLG T))
(EVAL@LOADWHEN (SETQ EVALFLG (EVAL (CADR X)))
(SETQ X (CDR X)))
(DONTEVAL@LOAD (SETQ EVALFLG NIL))
NIL)))
(SETQ X (CDR X))
(GO LP])
(ROOTFILENAME
[LAMBDA (NAME COMPFLG) (* rmk: "20-FEB-83 21:35")
(* Returns the root of the filename NAME, the atom that all file package
properties will be associated with. If NAME names a compiled file, then
COMPFLG~=NIL and we assume that the extension is COMPILE.EXT, which is to be
stripped off. We thus have something of an anomaly: We can keep track of 2
symbolic files whose names differ only in extension, but we confuse them when
we deal with their compiled versions.)
(NAMEFIELD NAME (NOT COMPFLG])
(DEFINE-FILE-INFO
[NLAMBDA ARGS (* bvm: "30-Aug-86 16:39")
(DECLARE (USEDFREE FILECREATEDLOC))
(SET-READER-ENVIRONMENT (\DO-DEFINE-FILE-INFO NIL ARGS))
(SETQ FILECREATEDLOC (GETFILEPTR])
(\DO-DEFINE-FILE-INFO
[LAMBDA (STREAM ARGS) (* bvm: "22-Sep-86 15:13")
(* ;;;
"Processes the (DEFINE-FILE-INFO . ARGS) at the front of STREAM")
(LET (PACKAGE READTABLE BASE VALUE)
(for TAIL on ARGS by (CDDR TAIL)
do (SETQ VALUE (CADR TAIL))
(SELECTQ (CAR TAIL)
(:PACKAGE (SETQ PACKAGE (OR (if (LISTP VALUE)
then (\DTEST (EVAL VALUE)
(QUOTE PACKAGE))
else (FIND-PACKAGE VALUE))
(ERROR "Can't find package for reader environment"
VALUE))))
(:READTABLE (SETQ READTABLE (OR (if (LISTP VALUE)
then (\DTEST (EVAL VALUE)
(QUOTE READTABLEP))
else (FIND-READTABLE VALUE))
(ERROR
"Can't find read table for reader environment"
VALUE))))
(:BASE (SETQ BASE (OR (\CHECKRADIX (if (LISTP VALUE)
then (EVAL VALUE)
else VALUE))
(ERROR "Bad read base for reader environment" VALUE))))
NIL))
(create READER-ENVIRONMENT
REPACKAGE ← (OR PACKAGE *INTERLISP-PACKAGE*)
REREADTABLE ← (OR READTABLE FILERDTBL)
REBASE ← (OR BASE 10)
RESPEC ← ARGS])
)
(RPAQ? EOLCHARCODE (CHCON1 (QUOTE %
)))
(RPAQ? PRETTYHEADER )
(RPAQ? DWIMFLG )
(RPAQ? UPDATEMAPFLG )
(RPAQ? DFNFLG )
(RPAQ? ADDSPELLFLG )
(RPAQ? BUILDMAPFLG )
(RPAQ? FILEPKGFLG )
(RPAQ? SYSFILES )
(RPAQ? NOTCOMPILEDFILES )
(RPAQ? RESETVARSLST )
(RPAQ? LOADPARAMETERS (QUOTE ((SEQUENTIAL T))))
(RPAQ? LISPXHIST )
(RPAQ? LISPXPRINTFLG T)
(RPAQ? PRETTYHEADER "File created ")
(RPAQ? LOAD-VERBOSE-STREAM T)
(RPAQ? BELLS (QUOTE ""))
(RPAQ? LOADOPTIONS (QUOTE (SYSLOAD NIL T PROP ALLPROP)))
(ADDTOVAR LOADEDFILELST )
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS DWIMFLG UPDATEMAPFLG LOADOPTIONS LOADPARAMETERS FILERDTBL SYSFILES)
)
(DECLARE: DONTEVAL@LOAD DOCOPY
[MAPC (QUOTE ((PUTD . /PUTD)
(PUTPROP . /PUTPROP)
(PUTPROP . PUT)
(PUTPROP . SAVEPUT)
(ADDPROP . /ADDPROP)
(PUT . /PUT)
(PRIN1 . LISPXPRIN1)
(PRIN2 . LISPXPRIN2)
(PRINT . LISPXPRINT)
(TERPRI . LISPXTERPRI)
(SPACES . LISPXSPACES)
(GETPROP . GETP)
(SET . SAVESET)
(NILL . MISSPELLED?)
(SETTOPVAL . /SETTOPVAL)
(BOOTSTRAP-NAMEFIELD . NAMEFIELD)))
(FUNCTION (LAMBDA (X)
(OR (CCODEP (CDR X))
(MOVD (CAR X)
(CDR X)
NIL T]
(AND (CCODEP (QUOTE BOOTSTRAP-NAMEFIELD))
(PUTD (QUOTE BOOTSTRAP-NAMEFIELD)))
(AND (CCODEP (QUOTE BOOTSTRAP-PUTPROPS))
(PUTD (QUOTE BOOTSTRAP-PUTPROPS)))
[MAPC [QUOTE ([STRPOS (LAMBDA (X Y START SKIP ANCHOR TAIL)
[COND [(LITATOM X)
(SETQ X (CDR (VAG (IPLUS (LOC X)
2]
((NULL (STRINGP X))
(SETQ X (MKSTRING X]
[COND ((STRINGP Y))
[(LITATOM Y)
(SETQ Y (CDR (VAG (IPLUS (LOC Y)
2]
(T (SETQ Y (MKSTRING Y]
[COND (SKIP (SETQ SKIP (NTHCHAR SKIP 1]
(COND [START (COND ((MINUSP START)
(SETQ START (IPLUS START (NCHARS Y)
1]
(T (SETQ START 1)))
(SETQ Y (SUBSTRING Y START))
(PROG ((N START)
W X1 Y1)
L2
(SETQ X1 (SUBSTRING X 1))
(SETQ Y1 (SUBSTRING Y 1))
LP
(COND [(SETQ W (GNC X1))
(COND ((EQ W (GNC Y1))
(GO LP))
((EQ W SKIP)
(GO LP))
(T (GO NX]
(TAIL (RETURN (IPLUS (NCHARS X)
N)))
(T (RETURN N)))
NX
(COND (ANCHOR (RETURN)))
(COND ((GNC Y)
(SETQ N (ADD1 N))
(GO L2))
(T (RETURN]
[PACKFILENAME (LAMBDA (X)
X]
[UNPACKFILENAME (LAMBDA (X)
X]
(RESETRESTORE (LAMBDA (RESETVARSLST0 RESETSTATE)
(PROG (RESETZ)
LP
(COND ((AND RESETVARSLST (NEQ RESETVARSLST RESETVARSLST0))
(SETQ RESETZ (CAR RESETVARSLST))
(SETQ RESETVARSLST (CDR RESETVARSLST))
[COND ((LISTP (CAR RESETZ))
(APPLY (CAAR RESETZ)
(CDR (CAR RESETZ]
(GO LP]
(FUNCTION (LAMBDA (X)
(OR (GETD (CAR X))
(PUTD (CAR X)
(CADR X]
(PRINTLEVEL 1000)
(RADIX 10)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(DECLARE: EVAL@COMPILE
(RPAQQ FASL:SIGNATURE 143)
(CONSTANTS FASL:SIGNATURE)
)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA DEFINE-FILE-INFO DECLARE: PUTPROPS FILECREATED SELECTQ)
(ADDTOVAR NLAML RPAQ? RPAQ RPAQQ)
(ADDTOVAR LAMA )
)
(PRETTYCOMPRINT BOOTSTRAPCOMS)
(RPAQQ BOOTSTRAPCOMS
[(FNS GETPROP SETATOMVAL RPAQQ RPAQ RPAQ? MOVD MOVD? SELECTQ SELECTQ1 NCONC1 PUTPROP PROPNAMES
ADDPROP REMPROP MEMB CLOSEF?)
(COMS (* ; "Need these in order to load even compiled files SYSLOAD")
(FNS LOAD \LOAD-STREAM FILECREATED FILECREATED1 PRETTYCOMPRINT BOOTSTRAP-NAMEFIELD
PUTPROPS DECLARE: DECLARE:1 ROOTFILENAME DEFINE-FILE-INFO \DO-DEFINE-FILE-INFO))
[INITVARS (EOLCHARCODE (CHCON1 (QUOTE %
)))
(PRETTYHEADER)
(DWIMFLG)
(UPDATEMAPFLG)
(DFNFLG)
(ADDSPELLFLG)
(BUILDMAPFLG)
(FILEPKGFLG)
(SYSFILES)
(NOTCOMPILEDFILES)
(RESETVARSLST)
[LOADPARAMETERS (QUOTE ((SEQUENTIAL T]
(LISPXHIST)
(LISPXPRINTFLG T)
(PRETTYHEADER "File created ")
(LOAD-VERBOSE-STREAM T)
(BELLS (QUOTE ""))
(LOADOPTIONS (QUOTE (SYSLOAD NIL T PROP ALLPROP]
(ADDVARS (LOADEDFILELST))
(GLOBALVARS DWIMFLG UPDATEMAPFLG LOADOPTIONS LOADPARAMETERS FILERDTBL SYSFILES)
(DECLARE: DONTEVAL@LOAD DOCOPY
[P [MAPC (QUOTE ((PUTD . /PUTD)
(PUTPROP . /PUTPROP)
(PUTPROP . PUT)
(PUTPROP . SAVEPUT)
(ADDPROP . /ADDPROP)
(PUT . /PUT)
(PRIN1 . LISPXPRIN1)
(PRIN2 . LISPXPRIN2)
(PRINT . LISPXPRINT)
(TERPRI . LISPXTERPRI)
(SPACES . LISPXSPACES)
(GETPROP . GETP)
(SET . SAVESET)
(NILL . MISSPELLED?)
(SETTOPVAL . /SETTOPVAL)
(BOOTSTRAP-NAMEFIELD . NAMEFIELD)))
(FUNCTION (LAMBDA (X)
(OR (CCODEP (CDR X))
(MOVD (CAR X)
(CDR X)
NIL T]
(AND (CCODEP (QUOTE BOOTSTRAP-NAMEFIELD))
(PUTD (QUOTE BOOTSTRAP-NAMEFIELD)))
(AND (CCODEP (QUOTE BOOTSTRAP-PUTPROPS))
(PUTD (QUOTE BOOTSTRAP-PUTPROPS)))
(MAPC [QUOTE ([STRPOS (LAMBDA (X Y START SKIP ANCHOR TAIL)
[COND [(LITATOM X)
(SETQ X (CDR (VAG (IPLUS (LOC X)
2]
((NULL (STRINGP X))
(SETQ X (MKSTRING X]
[COND ((STRINGP Y))
[(LITATOM Y)
(SETQ Y (CDR (VAG (IPLUS (LOC Y)
2]
(T (SETQ Y (MKSTRING Y]
[COND (SKIP (SETQ SKIP (NTHCHAR SKIP 1]
(COND [START (COND ((MINUSP START)
(SETQ START (IPLUS START
(NCHARS Y)
1]
(T (SETQ START 1)))
(SETQ Y (SUBSTRING Y START))
(PROG ((N START)
W X1 Y1)
L2
(SETQ X1 (SUBSTRING X 1))
(SETQ Y1 (SUBSTRING Y 1))
LP
(COND [(SETQ W (GNC X1))
(COND ((EQ W (GNC Y1))
(GO LP))
((EQ W SKIP)
(GO LP))
(T (GO NX]
(TAIL (RETURN (IPLUS (NCHARS X)
N)))
(T (RETURN N)))
NX
(COND (ANCHOR (RETURN)))
(COND ((GNC Y)
(SETQ N (ADD1 N))
(GO L2))
(T (RETURN]
[PACKFILENAME (LAMBDA (X)
X]
[UNPACKFILENAME (LAMBDA (X)
X]
(RESETRESTORE (LAMBDA (RESETVARSLST0 RESETSTATE)
(PROG (RESETZ)
LP
(COND ((AND RESETVARSLST (NEQ RESETVARSLST
RESETVARSLST0
))
(SETQ RESETZ (CAR RESETVARSLST))
(SETQ RESETVARSLST (CDR
RESETVARSLST
))
[COND ((LISTP (CAR RESETZ))
(APPLY (CAAR RESETZ)
(CDR (CAR RESETZ]
(GO LP]
(FUNCTION (LAMBDA (X)
(OR (GETD (CAR X))
(PUTD (CAR X)
(CADR X]
(P (PRINTLEVEL 1000)
(RADIX 10)))
(DECLARE: DOEVAL@COMPILE DONTCOPY (* ; "eventually imported from FASL")
(CONSTANTS FASL:SIGNATURE))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA DEFINE-FILE-INFO DECLARE: PUTPROPS FILECREATED SELECTQ)
(NLAML PRETTYCOMPRINT RPAQ? RPAQ RPAQQ)
(LAMA])
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA DEFINE-FILE-INFO DECLARE: PUTPROPS FILECREATED SELECTQ)
(ADDTOVAR NLAML PRETTYCOMPRINT RPAQ? RPAQ RPAQQ)
(ADDTOVAR LAMA )
)
(PUTPROPS BOOTSTRAP COPYRIGHT ("Xerox Corporation" 1983 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (8046 17100 (GETPROP 8056 . 8645) (SETATOMVAL 8647 . 8942) (RPAQQ 8944 . 8997) (RPAQ
8999 . 9324) (RPAQ? 9326 . 9717) (MOVD 9719 . 10148) (MOVD? 10150 . 10735) (SELECTQ 10737 . 10937) (
SELECTQ1 10939 . 11281) (NCONC1 11283 . 11630) (PUTPROP 11632 . 13414) (PROPNAMES 13416 . 13610) (
ADDPROP 13612 . 15633) (REMPROP 15635 . 16487) (MEMB 16489 . 16748) (CLOSEF? 16750 . 17098)) (17173
36516 (LOAD 17183 . 18094) (\LOAD-STREAM 18096 . 27924) (FILECREATED 27926 . 29338) (FILECREATED1
29340 . 30179) (PRETTYCOMPRINT 30181 . 30661) (BOOTSTRAP-NAMEFIELD 30663 . 32006) (PUTPROPS 32008 .
32496) (DECLARE: 32498 . 32631) (DECLARE:1 32633 . 33498) (ROOTFILENAME 33500 . 34163) (
DEFINE-FILE-INFO 34165 . 34430) (\DO-DEFINE-FILE-INFO 34432 . 36514)))))
STOP