(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "12-Oct-93 15:20:15" "{Pele:mv:envos}Sources>CLTL2>BOOTSTRAP.;1" 41500 changes to%: (VARS BOOTSTRAPCOMS) (FNS \LOAD-STREAM) previous date%: " 2-Nov-92 04:15:40" "{Pele:mv:envos}Sources>BOOTSTRAP.;4") (* ; " Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1992, 1993 by Venue & Xerox Corporation. All rights reserved. ") (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 DEFINE-FILE-INFO \DO-DEFINE-FILE-INFO)) (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) (BOOTSTRAP-NAMEFIELD . COMSNAME) (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 29-Jan-88 19:02 by jop") (* ;;; "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))) (FILECREATEDENV *OLD-INTERLISP-READ-ENVIRONMENT*) FILEMAP FNADRLST ROOTNAME TEM FILECREATEDLST LOADA MAYBEWANTFILEMAP INTERLISP-P FILECREATEDLOC) (DECLARE (SPECVARS DFNFLG BUILDMAPFLG FILEPKGFLG ADDSPELLFLG LISPXHIST FILECREATEDLST FILECREATEDENV 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 (CL::DEFAULT-IO-PACKAGE PACKAGE] (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 '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 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 'LOADEDFILELST (CONS FILE LOADEDFILELST))) (RETURN)) NIL) [if (LISTP LOADA) then (SELECTQ (CAR LOADA) (DEFINE-FILE-INFO (* ;  "Handle this specially, since we want to remember the environment") (SETQ FILECREATEDLOC (GETFILEPTR STREAM)) [SET-READER-ENVIRONMENT (SETQ LOADA (SETQ FILECREATEDENV (\DO-DEFINE-FILE-INFO NIL (CDR LOADA] (if PACKAGE then (* ;  "Caller better really mean it--overrides what's on file!") (replace REPACKAGE of FILECREATEDENV with (SETQ *PACKAGE* (OR (CL:FIND-PACKAGE *PACKAGE* ) (CL:CERROR "Use current *PACKAGE*" "~s does not name a package" *PACKAGE*) *PACKAGE*))) (LISTPUT (fetch RESPEC of FILECREATEDENV ) :PACKAGE (CL:PACKAGE-NAME *PACKAGE*)))) (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 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))) (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]) (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) (* bvm%: "14-Oct-86 00:28") (* ;;; "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 (LET ((P (EVAL VALUE))) (if (TYPEP P 'PACKAGE) then P else (CL:FIND-PACKAGE P))) else (CL:FIND-PACKAGE VALUE)) (ERROR "Can't find package for reader environment" VALUE)))) (:READTABLE (SETQ READTABLE (OR (if (LISTP VALUE) then (\DTEST (EVAL VALUE) '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)))) (ERROR "Unrecognized file info key" (CAR TAIL] (create READER-ENVIRONMENT REPACKAGE _ (OR PACKAGE *INTERLISP-PACKAGE*) REREADTABLE _ (OR READTABLE FILERDTBL) REBASE _ (OR BASE 10) RESPEC _ ARGS]) ) (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) (BOOTSTRAP-NAMEFIELD . COMSNAME) (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 1993)) (DECLARE%: DONTCOPY (FILEMAP (NIL (4584 14256 (GETPROP 4594 . 5166) (SETATOMVAL 5168 . 5297) (RPAQQ 5299 . 5352) (RPAQ 5354 . 5666) (RPAQ? 5668 . 6038) (MOVD 6040 . 7904) (MOVD? 7906 . 8336) (SELECTQ 8338 . 8525) ( SELECTQ1 8527 . 8869) (NCONC1 8871 . 9067) (PUTPROP 9069 . 10553) (PROPNAMES 10555 . 10746) (ADDPROP 10748 . 12811) (REMPROP 12813 . 13667) (MEMB 13669 . 13928) (CLOSEF? 13930 . 14254)) (14329 39341 ( LOAD 14339 . 15508) (\LOAD-STREAM 15510 . 30380) (FILECREATED 30382 . 31800) (FILECREATED1 31802 . 32910) (PRETTYCOMPRINT 32912 . 33397) (BOOTSTRAP-NAMEFIELD 33399 . 34359) (PUTPROPS 34361 . 34729) ( DECLARE%: 34731 . 34863) (DECLARE%:1 34865 . 35737) (ROOTFILENAME 35739 . 36687) (DEFINE-FILE-INFO 36689 . 37124) (\DO-DEFINE-FILE-INFO 37126 . 39339))))) STOP