(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "27-Sep-2021 10:25:31"  {DSK}kaplan>Local>medley3.5>git-medley>sources>BOOTSTRAP.;60 47698 changes to%: (FNS PRINT-READER-ENVIRONMENT READ-READER-ENVIRONMENT) previous date%: "17-Aug-2021 00:08:39" {DSK}kaplan>Local>medley3.5>git-medley>sources>BOOTSTRAP.;58) (* ; " Copyright (c) 1983-1990, 1992, 2021 by Venue & Xerox Corporation. ") (PRETTYCOMPRINT BOOTSTRAPCOMS) (RPAQQ BOOTSTRAPCOMS [(COMS (* ; "Some basic fns. Note that several are redefined later. E.g., RPAQQ et al real definitions are on UNDO") (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)) [COMS (* ; "For DEFINE-FILE-INFO") (FNS DEFINE-FILE-INFO \DO-DEFINE-FILE-INFO PRINT-READER-ENVIRONMENT READ-READER-ENVIRONMENT MAKE-DEFINE-FILE-INFO-ENV) (INITVARS (*DEFINE-FILE-INFO-ENV* (MAKE-DEFINE-FILE-INFO-ENV] (INITVARS (EOLCHARCODE (CHCON1 " ")) (PRETTYHEADER) (DWIMFLG) (UPDATEMAPFLG) (DFNFLG) (ADDSPELLFLG) (BUILDMAPFLG) (FILEPKGFLG) (SYSFILES) (NOTCOMPILEDFILES) (RESETVARSLST) [LOADPARAMETERS '((SEQUENTIAL T] (LISPXHIST) (LISPXPRINTFLG T) (PRETTYHEADER "File created ") (LOAD-VERBOSE-STREAM T) (BELLS '"") (LOADOPTIONS '(SYSLOAD NIL T PROP ALLPROP)) (PRETTYDEFMACROS NIL) (PRETTYTYPELST NIL) (FILEPKGTYPES NIL)) (ADDVARS (LOADEDFILELST)) (GLOBALVARS DWIMFLG UPDATEMAPFLG LOADOPTIONS LOADPARAMETERS FILERDTBL SYSFILES) (DECLARE%: DONTEVAL@LOAD DOCOPY [P [MAPC '((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) (SET . /SET) (NILL . MISSPELLED?) (SETTOPVAL . /SETTOPVAL) (BOOTSTRAP-NAMEFIELD . NAMEFIELD) (NILL . RESETRESTORE)) (FUNCTION (LAMBDA (X) (OR (CCODEP (CDR X)) (MOVD (CAR X) (CDR X) NIL T] (AND (CCODEP 'BOOTSTRAP-NAMEFIELD) (PUTD 'BOOTSTRAP-NAMEFIELD] (P (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]) (* ; "Some basic fns. Note that several are redefined later. E.g., RPAQQ et al real definitions are on UNDO" ) (DEFINEQ (GETPROP [LAMBDA (ATM PROP) (* lmm " 5-SEP-83 22:29") (* ; "Used to be called GETP") (AND (LITATOM ATM) (PROG ((PLIST (GETPROPLIST ATM))) LP [COND ((OR (NLISTP PLIST) (NLISTP (CDR PLIST))) (RETURN NIL)) ((EQ (CAR PLIST) PROP) (RETURN (CADR PLIST] (SETQ PLIST (CDDR PLIST)) (GO LP]) (SETATOMVAL [LAMBDA (X Y) (* bvm%: "29-Sep-86 16:14") (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) 'NOBIND) (SETTOPVAL RPAQX (EVAL RPAQY]) (MOVD [LAMBDA (FROM TO COPYFLG DONTCOPY) (* ;  "Edited 2-Nov-92 03:50 by sybalsky:mv:envos") (COND ((AND DONTCOPY (NULL COPYFLG)) (* ;; "He really wants NO copy made, not a renamed version.") (* ;;  "This is like MOVD, but absolutely no consing is done, frame names are not changed, etc.") (LET ((FROMCELL (fetch (LITATOM DEFINITIONCELL) of FROM)) (TOCELL (fetch (LITATOM DEFINITIONCELL) of TO))) (UNINTERRUPTABLY (replace (DEFINITIONCELL DEFPOINTER) of TOCELL with (fetch (DEFINITIONCELL DEFPOINTER) of FROMCELL)) (replace (DEFINITIONCELL DEFCELLFLAGS) of TOCELL with (fetch (DEFINITIONCELL DEFCELLFLAGS) of FROMCELL)) (replace (DEFINITIONCELL AUXDEFCELLFLAGS) of TOCELL with (fetch (DEFINITIONCELL AUXDEFCELLFLAGS) of FROMCELL)) TO))) (T (LET [(NEWFLG (NULL (GETD TO] (PUTD TO (COND (COPYFLG (COPY (VIRGINFN FROM))) (T (GETD FROM))) DONTCOPY) (AND FILEPKGFLG (EXPRP TO) (MARKASCHANGED TO 'FNS NEWFLG)) 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 'FNS T)) TO]) (SELECTQ [NLAMBDA SELCQ (APPLY 'PROGN (SELECTQ1 (EVAL (CAR SELCQ) 'SELECTQ) (CDR SELCQ)) '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) (* ; "Edited 28-May-87 09:16 by jop") (* ;; "Included because it must be defined before the MOVD's in BOOTSTRAPCOMS that initialize /PUTPROP are executed.") [COND ((NOT (LITATOM ATM)) (ERRORX (LIST 14 ATM] (PROG ((X (GETPROPLIST ATM)) X0) LP (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 LP))) [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) LP (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 LP))) (* ;  "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 PACKAGE) (* ; "Edited 9-Apr-87 18:44 by bvm:") (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)) [if (AND PACKAGE (NOT (CL:PACKAGEP PACKAGE))) then (* ;  "Make sure package arg is ok, too") (SETQ PACKAGE (OR (CL:FIND-PACKAGE PACKAGE) (\DTEST PACKAGE 'PACKAGE] [RESETSAVE NIL (LIST 'CLOSEF? (SETQ STREAM (OPENSTREAM FILE 'INPUT 'OLD LOADPARAMETERS] (RETURN (\LOAD-STREAM STREAM LDFLG PRINTFLG (AND PRETTYHEADER T) PACKAGE]) (\LOAD-STREAM [LAMBDA (STREAM LDFLG PRINTFLG LOAD-VERBOSE-STREAM PACKAGE) (DECLARE (SPECVARS LDFLG PRINTFLG LOAD-VERBOSE-STREAM)) (* ; "Edited 17-Jul-2021 21:58 by rmk:") (* ;;; "Internal function that loads from an already open stream. 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 ((*STANDARD-INPUT* STREAM) (FILE (FULLNAME STREAM)) (*PACKAGE* *PACKAGE*) (*READTABLE* (PROG1 FILERDTBL (* ; "This initial value important for SKIPSEPRCODES below, but *READTABLE* gets reset appropriately before anything else is read") )) (DFNFLG DFNFLG) (BUILDMAPFLG BUILDMAPFLG) (FILEPKGFLG FILEPKGFLG) (ADDSPELLFLG ADDSPELLFLG) (LISPXHIST LISPXHIST) (PRLST (AND FILEPKGFLG (FILEPKGCHANGES))) (DEFINEDENV) FILEMAP FNADRLST ROOTNAME TEM FILECREATEDLST LOADA MAYBEWANTFILEMAP INTERLISP-P FILECREATEDLOC) (DECLARE (SPECVARS DFNFLG BUILDMAPFLG FILEPKGFLG ADDSPELLFLG LISPXHIST FILECREATEDLST DEFINEDENV FILECREATEDLOC FILE)) (if (AND LOAD-VERBOSE-STREAM FILE) then (LISPXTERPRI LOAD-VERBOSE-STREAM) (if (NEQ LOAD-VERBOSE-STREAM T) then (* ;  "CL:LOAD says to prefix this stuff with comment marker") (PRIN1 "; Loading " LOAD-VERBOSE-STREAM)) (* ;  "Might use EXEC-FORMAT here except that it isn't defined early in loadup") (LISPXPRIN1 FILE LOAD-VERBOSE-STREAM) (LISPXTERPRI LOAD-VERBOSE-STREAM)) (if (EQ (SETQ DFNFLG LDFLG) '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 'SIDE LISPXHIST)) then (FRPLACA (CADR LOADA) -1) else (LISPXPUT 'SIDE (LIST -1) NIL LISPXHIST))) (if (EQ (SETQ TEM (SKIPSEPRCODES STREAM)) FASL:SIGNATURE) then (* ;  "FASL file handled by FASL loader") (FASL:PROCESS-FILE STREAM) [LET [(MANAGED-FILE-P (GET (SETQ ROOTNAME (ROOTFILENAME FILE T)) 'FILEDATES] (if (NOT (MEMB FILE LOADEDFILELST)) then (* ;  "Keep track of every file loaded.") (SETQ LOADEDFILELST (CONS FILE LOADEDFILELST))) (if MANAGED-FILE-P then (if (EQ LDFLG 'SYSLOAD) then (* ;;  "Don't notice DFASL's when you are coming from CL:LOAD, and the user didn't specify a load flag") (if (NOT (MEMB ROOTNAME SYSFILES)) then (SETQ SYSFILES (NCONC1 SYSFILES ROOTNAME))) (SMASHFILECOMS ROOTNAME) elseif FILEPKGFLG then (ADDFILE ROOTNAME 'Compiled] (RETURN FILE) elseif (NEQ TEM (CHARCODE "(")) then (RETURN (\CML-LOAD STREAM PRINTFLG LOAD-VERBOSE-STREAM PACKAGE))) (if (AND BUILDMAPFLG (RANDACCESSP STREAM)) then (SETQ MAYBEWANTFILEMAP T)) (* ;; "Get the environment from the DEFINE-FILE-INFO expression. This is read in the DEFINE-FILE-INFO-ENVIRONMENT.") (SETQ DEFINEDENV (READ-READER-ENVIRONMENT STREAM *OLD-INTERLISP-READ-ENVIRONMENT*)) (CL:WHEN PACKAGE (* ;; "Caller better really mean it--overrides what's on file! But we don't want to smash what the reader returned, couldbe the old-interlisp-file-env.") [SETQ DEFINEDENV (CREATE READER-ENVIRONMENT USING DEFINEDENV REPACKAGE _ (SETQ *PACKAGE* (\DTEST PACKAGE 'PACKAGE]) (* ;; "At this point we have the environment for the file, the external format is set. We now read/interpret all the other forms.") (WITH-READER-ENVIRONMENT DEFINEDENV (PROG (ADR) LP (if FILEMAP then (* ;  "need to build map, so read carefully") (SETQ LOADA (SKIPSEPRCODES STREAM)) (if (OR (SYNTAXP LOADA 'LEFTPAREN) (SYNTAXP LOADA 'LEFTBRACKET)) then (* ; "See if we have a DEFINEQ") (SETQ ADR (GETFILEPTR STREAM)) (READCCODE STREAM) (* ; "Eat paren") (if (EQ (RATOM STREAM) '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 '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 DEFINEDENV 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 'LOADEDFILELST (CONS FILE LOADEDFILELST))) (RETURN)) NIL) [if (LISTP LOADA) then (SELECTQ (CAR LOADA) (FILECREATED (if MAYBEWANTFILEMAP then (* ; "See if we have a valid file map") (SETQ ADR (GETFILEPTR STREAM)) (if [AND (FIXP (SETQ TEM (CADDDR LOADA))) [SETQ TEM (CAR (NLSETQ (SETFILEPTR STREAM TEM) (READ STREAM] (EQ (CAR TEM) 'FILEMAP) (NULL (CAR (SETQ TEM (CADR TEM] then (* ; "Has ok map") (PUTFILEMAP FILE TEM NIL DEFINEDENV) 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))) (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 (* ; "Edited 12-Jan-88 10:44 by bvm") (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 (NLISTP 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) 'FILEDATES (LIST (CONS FILEDATE FILE]) (FILECREATED1 [LAMBDA (X) (* ; "Edited 12-Jan-88 10:44 by bvm") (* ;; "performs error checking on filecreated expressions. returns the thing to be printed. used by filecreated, and loadfns.") (* ;; "FILECREATED expression for source file is of form (FILECREATED date filename mapaddress . historyinfo). For compiled file, is of form (FILECREATED date (%"compiled on%" sourceFile)). ") (LET ((FILE (CADR X))) (COND ((AND NIL (STRINGP FILE)) (* ;  "old way of doing COMPILED ON -- we no longer have such files, and the file name can be a string.") 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 atomic, 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 '} FILE START) (STRPOS '> FILE START) (STRPOS '/ FILE START))) do (SETQ START (ADD1 POS))) [COND ((SETQ POS (STRPOS '; FILE)) (SETQ END (SUB1 POS)) (COND ((EQ (NTHCHARCODE FILE END) (CHARCODE ".")) (* ; "eliminates null suffix") (SETQ END (SUB1 END] [COND ((SETQ POS (STRPOS '%. 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) '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) (* ; "Edited 22-May-92 11:59 by jds") (* ;; "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.") (* ;; "The name is always returned in upper case, so that file-system case dependencies don't carry over into Medley, where source file names are NOT case dependent. JDS, fixing AR 11518 5/21/92") (U-CASE (NAMEFIELD (COND ((TYPEP NAME 'STREAM) (FULLNAME NAME)) (T NAME)) (NOT COMPFLG]) ) (* ; "For DEFINE-FILE-INFO") (DEFINEQ (DEFINE-FILE-INFO [NLAMBDA ARGS (* bvm%: "13-Oct-86 17:24") (* ;; "Evaluated when it appears at top of file. Caller (e.g., LOAD) binds reader environment, so we just set it. Also return the env in case someone wants it.") (DECLARE (USEDFREE FILECREATEDLOC)) (SETQ FILECREATEDLOC (GETFILEPTR)) (SET-READER-ENVIRONMENT (\DO-DEFINE-FILE-INFO NIL ARGS]) (\DO-DEFINE-FILE-INFO [LAMBDA (STREAM ARGS) (* ; "Edited 17-Aug-2021 00:05 by rmk:") (* ;;; "Processes the (DEFINE-FILE-INFO . ARGS) at the front of STREAM. This converts the ARGS list to a READER-ENVIRONMENT, and also imposes the external format on STREAM, if non-NIL.") (* ;; "Include the :PACKAGE... for bootstrapping before in sysouts without an updated version of \LOAD-STREAM") (* ;;; "") (* ;;; "The LISTP forms for package and readtable are to allow for those to be created if they don't already exist. If they do exist, the forms should not make any incompatiblel changes--those should be in a file command somewhere.") (* ;;; "It doesn't make sense to produce an a new number base by evaluation in a particular runtime environment. I'm leaving this in for reading, for backward compatibility. Presumably future writing will instantiate to the particular number.") (LET (PACKAGE READTABLE BASE FORMAT VALUE PACKAGEFORM READTABLEFORM) [for TAIL on ARGS by (CDDR TAIL) do (SETQ VALUE (CADR TAIL)) (SELECTQ (CAR TAIL) ((:PACKAGE %:PACKAGE) (SETQ PACKAGE (if (LISTP VALUE) then (SETQ PACKAGEFORM VALUE) (EVAL VALUE) ELSE VALUE)) (IF (TYPEP PACKAGE 'PACKAGE) ELSEIF (SETQ PACKAGE (CL:FIND-PACKAGE PACKAGE)) ELSE (* ;; "Better message than just \DTEST") (ERROR "Can't find package for DEFINE-FILE-INFO reader environment" VALUE))) ((:READTABLE %:READTABLE) (SETQ READTABLE (if (LISTP VALUE) then (SETQ READTABLEFORM VALUE) (EVAL VALUE) ELSE VALUE)) (IF (TYPEP READTABLE 'READTABLEP) ELSEIF (SETQ READTABLE (FIND-READTABLE READTABLE)) ELSE (* ;; "Better message than just \DTEST") (ERROR "Can't find read table for DEFINE-FILE-INFO reader environment" VALUE))) ((:BASE %:BASE) (* ;  "RMK: An EVAL form here makes no sense. ") (SETQ BASE (OR (\CHECKRADIX (if (LISTP VALUE) then (EVAL VALUE) else VALUE)) (ERROR "Bad read base for DEFINE-FILE-INFO reader environment" VALUE)))) ((:FORMAT FORMAT %:FORMAT) (SETQ FORMAT (FETCH (EXTERNALFORMAT NAME) OF (FIND-FORMAT VALUE)))) (ERROR "Unrecognized file info key" (CAR TAIL] (* ;; "Set the defaults. Is this essentially ignoring the *DEFAULT-MAKEFILE-ENVIRONMENT*? Maybe the defaults should be take from there?") (CL:UNLESS FORMAT (SETQ FORMAT :XCCS)) (CL:WHEN STREAM (\EXTERNALFORMAT STREAM FORMAT)) (create READER-ENVIRONMENT REPACKAGE _ (OR PACKAGE *INTERLISP-PACKAGE*) REREADTABLE _ (OR READTABLE FILERDTBL) REBASE _ (OR BASE 10) REFORMAT _ FORMAT REPACKAGEFORM _ PACKAGEFORM REREADTABLEFORM _ READTABLEFORM]) (PRINT-READER-ENVIRONMENT [LAMBDA (ENV STREAM) (* ; "Edited 27-Sep-2021 10:24 by rmk:") (* ;;; "If ENV is not the old default interlisp reader environment, writes a DEFINE-FILE-INFO expression on STREAM that will produce this environment when the file is loaded.") (CL:UNLESS (EQUAL-READER-ENVIRONMENT ENV *OLD-INTERLISP-READ-ENVIRONMENT*) (LET ((*PACKAGE* *INTERLISP-PACKAGE*) (*PRINT-BASE* 10) PKG RDTBL) [SETQ PKG (IF (FETCH REPACKAGEFORM OF ENV) ELSEIF (fetch REPACKAGE of ENV) THEN (CL:PACKAGE-NAME (fetch REPACKAGE of ENV] [SETQ RDTBL (IF (FETCH REREADTABLEFORM OF ENV) ELSEIF (fetch REREADTABLE of ENV) THEN (READTABLEPROP (fetch REREADTABLE of ENV) 'NAME] (PRINT [CONS 'DEFINE-FILE-INFO `(,@[AND PKG `(:PACKAGE ,PKG] ,@[AND RDTBL `(:READTABLE ,RDTBL] :BASE ,(fetch REBASE of ENV) ,@(CL:UNLESS (EQ :XCCS (FETCH REFORMAT OF ENV)) `(:FORMAT ,(FETCH REFORMAT OF ENV)))] STREAM (FETCH (READER-ENVIRONMENT REREADTABLE) OF *DEFINE-FILE-INFO-ENV*)) (TERPRI STREAM)))]) (READ-READER-ENVIRONMENT [LAMBDA (STREAM DEFAULTENV RETURNFORM) (* ; "Edited 26-Sep-2021 23:31 by rmk:") (* ;; "Starting environment is the old interlisp file, just for the seprchar scans.") (* ;; "RETURNFORM=T means return the DEFINE-FILE-INFO as a second value, for READFILE") (CL:UNLESS DEFAULTENV (SETQ DEFAULTENV *OLD-INTERLISP-READ-ENVIRONMENT*)) (LET ((START (GETFILEPTR STREAM)) ARGS (ENV DEFAULTENV) (*READTABLE* (FETCH (READER-ENVIRONMENT REREADTABLE) OF *OLD-INTERLISP-READ-ENVIRONMENT* ))) (DECLARE (SPECVARS *READTABLE*)) (SELCHARQ (SKIPSEPRCODES STREAM) (";" (* ; "Assume it's a common lisp file") (\EXTERNALFORMAT STREAM (FETCH (READER-ENVIRONMENT REFORMAT) OF *COMMON-LISP-READ-ENVIRONMENT* )) *COMMON-LISP-READ-ENVIRONMENT*) ("(" (\EXTERNALFORMAT STREAM (FETCH (READER-ENVIRONMENT REFORMAT) OF *DEFINE-FILE-INFO-ENV* )) (* ;  "Should we reset the format if we fail?") (READCCODE STREAM) (WITH-READER-ENVIRONMENT *DEFINE-FILE-INFO-ENV* (IF (STREQUAL "DEFINE-FILE-INFO" (RSTRING STREAM)) THEN (* ;;  "After the \DO-DEFINE-FILE-INFO, we have the new environment and we have set the new format.") [SETQ ENV (\DO-DEFINE-FILE-INFO STREAM (SETQ ARGS (CL:READ-DELIMITED-LIST (CHARCODE ")") STREAM] ELSE (* ; "Hope we are RANDACCESSP") (SETFILEPTR STREAM START)) (* ;;  "If we didn't see ARGS, then we didn't see a DEFINE-FILE-INFO, no form to return.") (CL:IF (AND RETURNFORM ARGS) (CL:VALUES ENV (CONS 'DEFINE-FILE-INFO ARGS)) ENV))) DEFAULTENV]) (MAKE-DEFINE-FILE-INFO-ENV [LAMBDA NIL (* ; "Edited 29-Jul-2021 20:29 by rmk:") (* ;; "Makes the reader environment and read table used for printing and reading the DEFINE-FILE-INFO expression. Like the OLD-INTERLISP-FILE, but : is the preferred package delim") (LET [(RTBL (COPYREADTABLE (FETCH REREADTABLE OF *OLD-INTERLISP-READ-ENVIRONMENT*] (* ;;  "But this is all rather silly: Why not just have ordinary Interlisp atoms for the key words. ") (* (READTABLEPROP RTBL  (QUOTE PACKAGECHAR)  (CHARCODE %:))) (SETSYNTAX (CHARCODE %:) 'PACKAGEDELIM RTBL) (* ;  "In transition: read : but don't yet put it out") (* ;; "The INTERLISP package doesn't exist in bootstrap, the REPACKAGE field is filled in in PACKAGE-ENABLE in PACKAGE-STARTUP") (CREATE READER-ENVIRONMENT USING *OLD-INTERLISP-READ-ENVIRONMENT* REREADTABLE _ RTBL ]) ) (RPAQ? *DEFINE-FILE-INFO-ENV* (MAKE-DEFINE-FILE-INFO-ENV)) (RPAQ? EOLCHARCODE (CHCON1 " ")) (RPAQ? PRETTYHEADER ) (RPAQ? DWIMFLG ) (RPAQ? UPDATEMAPFLG ) (RPAQ? DFNFLG ) (RPAQ? ADDSPELLFLG ) (RPAQ? BUILDMAPFLG ) (RPAQ? FILEPKGFLG ) (RPAQ? SYSFILES ) (RPAQ? NOTCOMPILEDFILES ) (RPAQ? RESETVARSLST ) (RPAQ? LOADPARAMETERS '((SEQUENTIAL T))) (RPAQ? LISPXHIST ) (RPAQ? LISPXPRINTFLG T) (RPAQ? PRETTYHEADER "File created ") (RPAQ? LOAD-VERBOSE-STREAM T) (RPAQ? BELLS '"") (RPAQ? LOADOPTIONS '(SYSLOAD NIL T PROP ALLPROP)) (RPAQ? PRETTYDEFMACROS NIL) (RPAQ? PRETTYTYPELST NIL) (RPAQ? FILEPKGTYPES NIL) (ADDTOVAR LOADEDFILELST ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DWIMFLG UPDATEMAPFLG LOADOPTIONS LOADPARAMETERS FILERDTBL SYSFILES) ) (DECLARE%: DONTEVAL@LOAD DOCOPY [MAPC '((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) (SET . /SET) (NILL . MISSPELLED?) (SETTOPVAL . /SETTOPVAL) (BOOTSTRAP-NAMEFIELD . NAMEFIELD) (NILL . RESETRESTORE)) (FUNCTION (LAMBDA (X) (OR (CCODEP (CDR X)) (MOVD (CAR X) (CDR X) NIL T] (AND (CCODEP 'BOOTSTRAP-NAMEFIELD) (PUTD 'BOOTSTRAP-NAMEFIELD)) (RADIX 10) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ FASL:SIGNATURE 145) (CONSTANTS FASL:SIGNATURE) ) ) (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 ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 1992 2021)) (DECLARE%: DONTCOPY (FILEMAP (NIL (4751 14423 (GETPROP 4761 . 5333) (SETATOMVAL 5335 . 5464) (RPAQQ 5466 . 5519) (RPAQ 5521 . 5833) (RPAQ? 5835 . 6205) (MOVD 6207 . 8071) (MOVD? 8073 . 8503) (SELECTQ 8505 . 8692) ( SELECTQ1 8694 . 9036) (NCONC1 9038 . 9234) (PUTPROP 9236 . 10720) (PROPNAMES 10722 . 10913) (ADDPROP 10915 . 12978) (REMPROP 12980 . 13834) (MEMB 13836 . 14095) (CLOSEF? 14097 . 14421)) (14496 35060 ( LOAD 14506 . 15675) (\LOAD-STREAM 15677 . 28751) (FILECREATED 28753 . 30171) (FILECREATED1 30173 . 31281) (PRETTYCOMPRINT 31283 . 31768) (BOOTSTRAP-NAMEFIELD 31770 . 32730) (PUTPROPS 32732 . 33100) ( DECLARE%: 33102 . 33234) (DECLARE%:1 33236 . 34108) (ROOTFILENAME 34110 . 35058)) (35098 45530 ( DEFINE-FILE-INFO 35108 . 35543) (\DO-DEFINE-FILE-INFO 35545 . 39891) (PRINT-READER-ENVIRONMENT 39893 . 41475) (READ-READER-ENVIRONMENT 41477 . 44252) (MAKE-DEFINE-FILE-INFO-ENV 44254 . 45528))))) STOP