Artifact 16649324f379e333ad4cc71e00df64637d3268558ff8587e36dca56efcb96410:
- File
psl-1983/3-1/util/zsys.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: 11294) [annotate] [blame] [check-ins using] [more...]
- File
psl-1983/util/zsys.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: 11294) [annotate] [blame] [check-ins using]
(!* "ZSYS -- the system dependent file. Currently, the only code in it is MAKE-OPEN-FILE-NAME, which uses a semi machine-independant file description to create a filename suitable for OPEN in the resident system. N.B.: TO SET THIS CODE UP FOR A PARTICULAR INTEPRETER, REMOVE THE * FROM BEFORE THE APPROPRIATE SETQ BELOW. THAT SHOULD BE ALL YOU NEED TO DO. ") (COMPILETIME (GLOBAL '(G!:SYSTEM)) (IF!_SYSTEM TOPS20 (SETQ G!:SYSTEM 'PSL!-TOPS20)) (IF!_SYSTEM UNIX (SETQ G!:SYSTEM 'PSL!-UNIX)) (!* SETQ G!:SYSTEM 'IMSSS!-TENEX) (!* SETQ G!:SYSTEM 'UTAH!-TOPS10) (!* SETQ G!:SYSTEM 'UTAH!-TENEX) (!* SETQ G!:SYSTEM 'CMS) (!* SETQ G!:SYSTEM 'ORVYL) (PROGN (TERPRI) (PRIN2 "Filenames will be made for ") (PRIN2 G!:SYSTEM) (PRIN2 " system.") (TERPRI)) ) (FLUID '(F!:FILE!:ID F!:OLD!:FILE)) (COMPILETIME (!* "This macro (and those following) are separated only for readability. The appropriate MAKE-xxx-NAME will provide the body of the definition for MAKE-OPEN-FILE-NAME. Note: (a) #DSCR can be mentioned free in the macros since it is the lambda variable for MAKE-OPEN-FILE-NAME. (b) ORVYL and CMS differ only in the delimiter they use. (c) When compiling, all these macros are REMOB'ed to clear up otherwise extraneous code.") (DM MAKE!-SYS!-FILE!-NAME (!#X) (SELECTQ G!:SYSTEM (PSL!-TOPS20 '(MAKE!-PSL!-TOPS20!-NAME)) (PSL!-UNIX '(MAKE!-PSL!-UNIX!-NAME)) (UTAH!-TENEX '(MAKE!-UTAH!-TENEX!-NAME)) (UTAH!-TOPS10 '(MAKE!-UTAH!-TOPS10!-NAME)) (IMSSS!-TENEX '(MAKE!-IMSSS!-TENEX!-NAME)) (ORVYL '(MAKE!-IBM!-NAME !.)) (CMS '(MAKE!-IBM!-NAME ! )) (ERROR 0 (LIST "Don't know how to make file names for system " G!:SYSTEM)))) (DM MAKE!-UTAH!-TENEX!-NAME (!#X) '(PROG (!#DIR !#NAM !#EXT) (RETURN (SETQ F!:OLD!:FILE (COND ((NULL (PAIRP !#DSCR)) (ERROR 0 (LIST "BAD FILE DSCR: " !#DSCR))) ((NULL (CDR !#DSCR)) (LIST (CONS (SETQ F!:FILE!:ID (CAR !#DSCR)) 'LSP))) ((EQ (CDR !#DSCR) '!;) (LIST (SETQ F!:FILE!:ID (CAR !#DSCR)))) ((IDP (CDR !#DSCR)) (PROGN (SETQ F!:FILE!:ID (CAR !#DSCR)) (LIST !#DSCR))) (T (PROGN (SETQ !#DIR (CAR !#DSCR)) (SETQ F!:FILE!:ID (SETQ !#NAM (CADR !#DSCR))) (SETQ !#EXT (COND ((NULL (CDDR !#DSCR)) 'LSP) ((IDP (CDDR !#DSCR)) (CDDR !#DSCR)) (T (CADDR !#DSCR)))) (LIST 'DIR!: !#DIR (CONS !#NAM !#EXT))))))))) (!* "Use decimal equivalent of PPNs for tops 10. Maybe the ROCT switch in the interpreter will allow octal PPNS??") (DM MAKE!-UTAH!-TOPS10!-NAME (!#X) '(PROG (!#DIR !#NAM !#EXT) (RETURN (SETQ F!:OLD!:FILE (COND ((NULL (PAIRP !#DSCR)) (ERROR 0 (LIST "BAD FILE DSCR: " !#DSCR))) ((NULL (CDR !#DSCR)) (LIST (CONS (SETQ F!:FILE!:ID (CAR !#DSCR)) 'LSP))) ((EQ (CDR !#DSCR) '!;) (LIST (SETQ F!:FILE!:ID (CAR !#DSCR)))) ((IDP (CDR !#DSCR)) (PROGN (SETQ F!:FILE!:ID (CAR !#DSCR)) (LIST !#DSCR))) (T (PROGN (SETQ !#DIR (CAR !#DSCR)) (COND ((NOT (AND (PAIRP !#DIR) (NUMBERP (CAR !#DIR)) (NUMBERP (CADR !#DIR)))) (BUG!-STOP "Bad PPN: USE (<n> <n>) w/ decimal equiv of octal PPN.") )) (SETQ F!:FILE!:ID (SETQ !#NAM (CADR !#DSCR))) (SETQ !#EXT (COND ((NULL (CDDR !#DSCR)) 'LSP) ((IDP (CDDR !#DSCR)) (CDDR !#DSCR)) (T (CADDR !#DSCR)))) (LIST !#DIR (CONS !#NAM !#EXT))))))))) (DM MAKE!-IMSSS!-TENEX!-NAME (!#X) '(PROG (DIR!#NAM !#EXT) (!* "#DSCR is a list") (RETURN (SETQ F!:OLD!:FILE (LIST (COND ((NULL (PAIRP !#DSCR)) (ERROR 0 (LIST "BAD FILE DSCR: " !#DSCR))) ((NULL (CDR !#DSCR)) (CONS (SETQ F!:FILE!:ID (CAR !#DSCR)) 'LSP)) ((EQ (CDR !#DSCR) '!;) (SETQ F!:FILE!:ID (CAR !#DSCR))) ((IDP (CDR !#DSCR)) (PROGN (SETQ F!:FILE!:ID (CAR !#DSCR)) !#DSCR)) (T (PROGN (SETQ DIR!#NAM (COMPRESS (NCONCL (LIST '!! '!<) (EXPLODE (CAR !#DSCR)) (LIST '!! '!>) (EXPLODE (CADR !#DSCR))))) (SETQ F!:FILE!:ID (CADR !#DSCR)) (SETQ !#EXT (COND ((NULL (CDDR !#DSCR)) 'LSP) ((IDP (CDDR !#DSCR)) (CDDR !#DSCR)) (T (CADDR !#DSCR)))) (CONS DIR!#NAM !#EXT))))))))) (DM MAKE!-PSL!-TOPS20!-NAME (!#X) '(PROG (DIR!#NAM !#EXT) (!* "#DSCR is a list") (COND ((STRINGP !#DSCR) (MAKE !#DSCR NCONS))) (RETURN (SETQ F!:OLD!:FILE (COND ((NULL (PAIRP !#DSCR)) (ERROR 0 (LIST "BAD FILE DSCR: " !#DSCR))) ((NULL (CDR !#DSCR)) (COND ((STRINGP (CAR !#DSCR)) (PROGN (SETQ F!:FILE!:ID (EXTRACT!-FILE!-ID (CAR !#DSCR))) (CAR !#DSCR))) (T (ID!-LIST!-TO!-STRING (LIST (SETQ F!:FILE!:ID (CAR !#DSCR)) '!. 'LSP))))) ((EQ (CDR !#DSCR) '!;) (ID2STRING (SETQ F!:FILE!:ID (CAR !#DSCR)))) ((IDP (CDR !#DSCR)) (ID!-LIST!-TO!-STRING (LIST (SETQ F!:FILE!:ID (CAR !#DSCR)) '!. (CDR !#DSCR))) ) (T (PROGN (SETQ DIR!#NAM (COMPRESS (NCONCL (LIST '!! '!<) (EXPLODE (CAR !#DSCR)) (LIST '!! '!>) (EXPLODE (CADR !#DSCR))))) (SETQ F!:FILE!:ID (CADR !#DSCR)) (SETQ !#EXT (COND ((NULL (CDDR !#DSCR)) 'LSP) ((IDP (CDDR !#DSCR)) (CDDR !#DSCR)) (T (CADDR !#DSCR)))) (ID!-LIST!-TO!-STRING (LIST DIR!#NAM '!. !#EXT))))))))) (DM MAKE!-PSL!-UNIX!-NAME (!#X) '(PROG (DIR!#NAM !#EXT) (!* "#DSCR is a list") (COND ((STRINGP !#DSCR) (MAKE !#DSCR NCONS))) (RETURN (SETQ F!:OLD!:FILE (COND ((NULL (PAIRP !#DSCR)) (ERROR 0 (LIST "BAD FILE DSCR: " !#DSCR))) ((NULL (CDR !#DSCR)) (COND ((STRINGP (CAR !#DSCR)) (PROGN (SETQ F!:FILE!:ID (EXTRACT!-FILE!-ID (CAR !#DSCR))) (CAR !#DSCR))) (T (ID!-LIST!-TO!-STRING (LIST (SETQ F!:FILE!:ID (CAR !#DSCR)) '!. 'LSP))))) ((EQ (CDR !#DSCR) '!;) (ID2STRING (SETQ F!:FILE!:ID (CAR !#DSCR)))) ((IDP (CDR !#DSCR)) (ID!-LIST!-TO!-STRING (LIST (SETQ F!:FILE!:ID (CAR !#DSCR)) '!. (CDR !#DSCR)))) (T (PROGN (SETQ DIR!#NAM (COMPRESS (NCONCL (EXPLODE (CAR !#DSCR)) (LIST '!! '!/) (EXPLODE (CADR !#DSCR))))) (SETQ F!:FILE!:ID (CADR !#DSCR)) (SETQ !#EXT (COND ((NULL (CDDR !#DSCR)) 'LSP) ((IDP (CDDR !#DSCR)) (CDDR !#DSCR)) (T (CADDR !#DSCR)))) (ID!-LIST!-TO!-STRING (LIST DIR!#NAM '!. !#EXT)))))))))) (IF!_SYSTEM TOPS20 (PROGN (DE EXTRACT!-FILE!-ID (!#X) (PROG (!#Y) (!* "Take a TOPS-20 filename string and try to find a root file name in it") (SETQ !#Y (DREVERSE (EXPLODE2 !#X))) (SETQ !#X !#Y) LOOP1(COND ((OR (NULL !#X) (MEMQ (CAR !#X) '(!: !>))) (GO LOOP1END)) ((EQ (CAR !#X) '!.) (PROGN (SETQ !#Y (CDR !#X)) (GO LOOP1END)))) (SETQ !#X (CDR !#X)) (GO LOOP1) LOOP1END (SETQ !#X !#Y) LOOP2(COND ((OR (NULL !#X) (NULL (CDR !#X))) (GO LOOP2END)) ((MEMQ (CADR !#X) '(!> !:)) (PROGN (RPLACD !#X NIL) (GO LOOP2END)))) (SETQ !#X (CDR !#X)) (GO LOOP2) LOOP2END (RETURN (ICOMPRESS (DREVERSE !#Y))))) (DE ID!-LIST!-TO!-STRING (!#X) (PROG (!#S) (SETQ !#S "") LOOP (COND ((NULL !#X) (RETURN !#S))) (SETQ !#S (CONCAT !#S (ID2STRING (CAR !#X)))) (SETQ !#X (CDR !#X)) (GO LOOP))))) (IF!_SYSTEM UNIX (PROGN (DE EXTRACT!-FILE!-ID (!#X) (PROG (!#Y) (!* "Take a UNIX filename string and try to find a root file name in it") (SETQ !#Y (DREVERSE (EXPLODE2 !#X))) (SETQ !#X !#Y) LOOP1(COND ((OR (NULL !#X) (MEMQ (CAR !#X) '(!: !>))) (GO LOOP1END)) ((EQ (CAR !#X) '!.) (PROGN (SETQ !#Y (CDR !#X)) (GO LOOP1END)))) (SETQ !#X (CDR !#X)) (GO LOOP1) LOOP1END (SETQ !#X !#Y) LOOP2(COND ((OR (NULL !#X) (NULL (CDR !#X))) (GO LOOP2END)) ((MEMQ (CADR !#X) '(!> !:)) (PROGN (RPLACD !#X NIL) (GO LOOP2END)))) (SETQ !#X (CDR !#X)) (GO LOOP2) LOOP2END (RETURN (ICOMPRESS (DREVERSE !#Y))))) (FLUID '(!*LOWER)) (!* "*LOWER when T all output (including EXPLODE) is in lowercase") (DE ID!-LIST!-TO!-STRING (!#X) (PROG (!#S !*LOWER) (SETQ !*LOWER T) (SETQ !#S "") LOOP (COND ((NULL !#X) (RETURN !#S))) (SETQ !#S (CONCAT !#S (LIST2STRING (EXPLODE2 (CAR !#X))))) (SETQ !#X (CDR !#X)) (GO LOOP))))) (!* "IBM code got lost") (DE MAKE!-OPEN!-FILE!-NAME (!#DSCR) (MAKE!-SYS!-FILE!-NAME)) (!* "Remove excess baggage once macros have been used.") (!* COND ((CODEP (CDR (GETD 'MAKE!-OPEN!-FILE!-NAME))) (PROGN (REMOB 'MAKE!-SYS!-FILE!-NAME) (REMOB 'MAKE!-UTAH!-TENEX!-NAME) (REMOB 'MAKE!-UTAH!-TOPS10!-NAME) (REMOB 'MAKE!-IMSSS!-TENEX!-NAME) (REMOB 'MAKE!-IBM!-NAME))))