Artifact 16e9d05d1c2e7c12032e770b472b04763c850f00f2247d79c3ba297fd4805f03:
- File
psl-1983/3-1/util/zboot.lsp
— part of check-in
[eb17ceb7f6]
at
2020-04-21 19:40:01
on branch master
— Add Reduce 3.0 to the historical section of the archive, and some more
files relating to version sof PSL from the early 1980s. Thanks are due to
Paul McJones and Nelson Beebe for these, as well as to all the original
authors.git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 5957) [annotate] [blame] [check-ins using] [more...]
- File
psl-1983/util/zboot.lsp
— part of check-in
[eb17ceb7f6]
at
2020-04-21 19:40:01
on branch master
— Add Reduce 3.0 to the historical section of the archive, and some more
files relating to version sof PSL from the early 1980s. Thanks are due to
Paul McJones and Nelson Beebe for these, as well as to all the original
authors.git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 5957) [annotate] [blame] [check-ins using]
(DM !* (!#X) NIL) (SETQ !*EOLINSTRINGOK T) (!* "Needed for PSL, to avoid error messages while reading strings which contain carriage returns.") (!* "*( X:any ): NIL MACRO ===> NIL For comments--doesn't evaluate anything. Returns NIL. Note: expressions starting with * which are read by the lisp scanner must obey all the normal syntax rules.") (!* " ZBOOT -- Bootstrapping functions and SLISP extensions ONEP (U) EXPR used where? LIST2 (U V) EXPR compiler support fn LIST3 (U V W) EXPR compiler support fn LIST4 (U V W X) EXPR compiler support fn LIST5 (U V W X Y) EXPR compiler support fn MAPOBL (!*PI!*) EXPR UTAH random utility REVERSIP (U) EXPR UTAH support fn WARNING (U) EXPR UTAH support fn IMSSS additions: (complement LOSE mechanism) CDEF (FDSCR TYPE) EXPR conditional function definition CDE (Z) FEXPR conditional expr definition CDF (Z) FEXPR conditional fexpr definition CDM (Z) FEXPR conditional macro definition CLAP( LAPCODE ) FEXPR conditional lap definition C-SETQ (#ARGS) FEXPR conditional setq These are for compatibility with the IBM interpreter: ERASE( #FILE: file descriptor ):NIL EXPR ") (!* "ARE THESE USED ONLY IN COMPILER PACKAGE?") (!* (REMFLAG '(LIST2 LIST3 LIST4 LIST5 REVERSIP) 'LOSE)) (!* (GLOBAL '(OBLIST))) (!* "IMSSS additions: ") (!* "CDEF( FNDSCR: pair, TYPE: {expr,fexpr,macro} ): {id,NIL} EXPR ---- Conditional function definition. #FNDSCR = (NAME ARGS BODY) #TYPE = {EXPR, FEXPR, or MACRO} If the function is already defined, a warning is printed, the function is not redefined, and nil is returned. Otherwise, the function is defined and the name is returned. CDEF is called by CDE, CDM and CDF, analogs to DE, DF and DM.") (!* (DE CDEF (!#FDSCR !#TYPE) (PROG (!#NAME !#NEWARGS !#NEWBODY !#OLDDEF) (COND ((ATOM !#FDSCR) (RETURN (WARNING "Bad arg to CDEF.")))) (SETQ !#NAME (CAR !#FDSCR)) (COND ((NOT (EQUAL (LENGTH !#FDSCR) 3)) (RETURN (WARNING (LIST "Bad args to CDEF for " !#NAME))))) (SETQ !#NEWARGS (CADR !#FDSCR)) (SETQ !#NEWBODY (CADDR !#FDSCR)) (COND ((NULL (SETQ !#OLDDEF (GETD !#NAME))) (RETURN (PUTD !#NAME !#TYPE (LIST 'LAMBDA !#NEWARGS !#NEWBODY)))) ((PAIRP (CDR !#OLDDEF)) (WARNING (LIST !#NAME " already " (LENGTH (CADDR !#OLDDEF)) "-arg " (CAR !#OLDDEF) ", not redefined as " (LENGTH !#NEWARGS) "-arg " !#TYPE))) (T (WARNING (LIST !#NAME " is a compiled " (CAR !#OLDDEF) ", not redefined as " (LENGTH !#NEWARGS) "-arg " !#TYPE)))))) (DF CDE (!#Z) (CDEF !#Z 'EXPR)) (DF CDF (!#Z) (CDEF !#Z 'FEXPR)) (DF CDM (!#Z) (CDEF !#Z 'MACRO)) (!* "CLAP( LAPCODE ): {id,NIL} EXPR ---- Conditional lap definition. If the function already has a compiled definition, warning is given, the function is not redefined, and nil is returned. Otherwise, LAP is called.") (DE CLAP (LAP!#CODE) (PROG (!#ENTRY !#ID OLD!#DEF) (COND ((NULL (SETQ !#ENTRY (ASSOC '!*ENTRY LAP!#CODE))) (RETURN (WARNING "CLAP: No *ENTRY in lap code.")))) (SETQ !#ID (CADR !#ENTRY)) (SETQ OLD!#DEF (GETD !#ID)) (COND ((OR (NULL OLD!#DEF) (PAIRP (CDR OLD!#DEF))) (LAP LAP!#CODE)) (T (WARNING (LIST !#ID " is compiled " (CAR OLD!#DEF) ", not changed to compiled " (CADDR !#ENTRY) ".")))))) ) (DM CDE (!#X) (CONS 'DE (CDR !#X))) (DM CDF (!#X) (CONS 'DF (CDR !#X))) (DM CDM (!#X) (CONS 'DM (CDR !#X))) (!* "C-SETQ( ARGS: (id any)): any FEXPR ------ Conditional SETQ. If the cadr of #ARGS is already defined, it is not reset and its old value is returned. Otherwise, it acts like SETQ. ") (DF C!-SETQ (!#ARGS) (COND ((PAIRP (ERRORSET (CAR !#ARGS) NIL NIL)) (EVAL (CAR !#ARGS))) (T (SET (CAR !#ARGS) (EVAL (CADR !#ARGS)))))) (!* "This CDE is best left here to avoid bootstrapping problems.") (CDE WARNING (!#X!#) (PROG (!#CHAN!#) (SETQ !#CHAN!# (WRS NIL)) (TERPRI) (PRIN2 "*** ") (COND ((ATOM !#X!#) (PRIN2 !#X!#)) (T (MAPC !#X!# (FUNCTION PRIN2)))) (TERPRI) (WRS !#CHAN!#))) (!* (CDE ONEP (U) (OR (EQUAL U 1) (EQUAL U 1.0))) (CDE LIST2 (U V) (CONS U (CONS V NIL))) (CDE LIST3 (U V W) (CONS U (CONS V (CONS W NIL)))) (CDE LIST4 (U V W X) (CONS U (CONS V (CONS W (CONS X NIL))))) (CDE LIST5 (U V W X Y) (CONS U (CONS V (CONS W (CONS X (CONS Y NIL)))))) ) (!* "This definition of MAPOBL doesn't work in PSL, because the oblist has a different structure. MAPOBL is defined in the interpreter though.") (!*(CDE MAPOBL (!*PI!*) (FOREACH X IN OBLIST DO (FOREACH Y IN X DO (APPLY !*PI!* (LIST Y)))))) (!* (CDE REVERSIP (U) (PROG (X Y) (WHILE U (PROGN (SETQ X (CDR U)) (SETQ Y (RPLACD U Y)) (SETQ U X))) (RETURN Y))) ) (!* "ERASE( #FILE: file descriptor ):NIL EXPR ----- This is defined in the IBM interpreter to (irrevocably) delete a file from the file system, which is a highly necessary operation when you are not allowed versions of files. It should be a no-op in the TENEX interpreters until such an operation seems necessary. This assumes the user will delete and expunge old versions from the exec.") (CDE ERASE (!#FILE) NIL)