diff --git a/build/build.tcl b/build/build.tcl index 67bceccf..96b078f6 100644 --- a/build/build.tcl +++ b/build/build.tcl @@ -1452,6 +1452,18 @@ respond "*" ":midas sys3;ts balanc_alan;balanc\r" expect ":KILL" respond "*" ":link sys3;ts movdir,sys3;ts balanc\r" +# Additional LSPLIB packages +respond "*" "complr\013" +respond "_" "liblsp;iota_libdoc;iota kmp1\r" +respond "_" "liblsp;time_libdoc;time kmp8\r" +respond "_" "liblsp;letfex_libdoc;letfex gjc2\r" +respond "_" "liblsp;lusets fasl_libdoc;lusets\r" +respond "_" "liblsp;break fasl_libdoc;break\r" +respond "_" "liblsp;smurf_libdoc;smurf rwk1\r" +respond "_" "liblsp;fasdmp fasl_rlb%;fasdmp\r" +respond "_" "\032" +type ":kill\r" + bootable_tapes # make output.tape diff --git a/src/libdoc/break.gjc1 b/src/libdoc/break.gjc1 new file mode 100755 index 00000000..34f97c6b --- /dev/null +++ b/src/libdoc/break.gjc1 @@ -0,0 +1,79 @@ +;;;-*-LISP-*- + + +(HERALD BREAKLEVEL) + +;;; You must do (SSTATUS BREAKLEVEL '(BREAKLEVEL)) + +;;; Break level with extra features, sufficiently general for +;;; binding TTY echoing on, binding readtables, creating new read buffers, +;;; and handling other environment and re-entrancy considerations. +;;; 9:15pm Friday, 20 February 1981 -GJC + +(DEFVAR BREAK-VARS '(TTYON - + *) + "Variables to bind inside the breaklevel") + +(DEFVAR BREAK-VALS '(NIL NIL * * *) + "Cooresponding values for above variables, this should be a + list of functions to call to get the the values, however, + the UNWIND-PROTECTed BREAK-PROCS provide the full functionality + of that and more.") + +(DEFVAR BREAK-PROCS '(TTYON) + "List of procedures called with argument T for ENTER, NIL for EXIT. + Do not RPLAC* this list.") + + +(defun BREAKLEVEL () + (PROGV BREAK-VARS BREAK-VALS + (LET ((HOWFAR 0) + (P BREAK-PROCS)) + (UNWIND-PROTECT + (DO ((L P (CDR L))) + ((NULL L) + (do ()(NIL) + (SETQ + -) + (SETQ - (*-read-eval-print)) + (COND ((EQ - 'P) + (*THROW 'BREAK NIL)) + ((AND (NOT (ATOM -)) + (EQ (CAR -) 'RETURN)) + (*THROW 'BREAK (EVAL (CADR -)))) + (T + (setq * (read-*-eval-print -)) + (read-eval-*-print *) + (read-eval-print-*))))) + (FUNCALL (CAR L) T) + (SETQ HOWFAR (1+ HOWFAR))) + (DO ((L P (CDR L))) + ((OR (NULL L) + (ZEROP HOWFAR))) + (SETQ HOWFAR (1- HOWFAR)) + (FUNCALL (CAR L) NIL)))))) + + +(DEFVAR TTYON NIL) + +(DEFUN TTYON (ENTERP) + (COND (ENTERP + (COND ((STATUS FEATURE ITS) + (SETQ TTYON (SYSCALL 3. 'TTYGET TYI)) + (SYSCALL 0 'TTYSET TYI + (LOGIOR (CAR TTYON) #o202020202020) + (LOGIOR (CADR TTYON) #o202020200020))) + ((STATUS FEATURE TOPS-20) + (SETQ TTYON (STATUS TTY)) + (SSTATUS TTY + (CAR TTYON) + (CADR TTYON) + (DPB 0. #o1301 (CADDR TTYON)))))) + (T + (COND ((STATUS FEATURE ITS) + (SYSCALL 0. 'TTYSET TYI + (CAR TTYON) + (CADR TTYON))) + ((STATUS FEATURE TOPS-20) + (SSTATUS TTY + (CAR TTYON) + (CADR TTYON) + (CADDR TTYON))))))) \ No newline at end of file diff --git a/src/libdoc/iota.kmp1 b/src/libdoc/iota.kmp1 new file mode 100644 index 00000000..4312bb6f --- /dev/null +++ b/src/libdoc/iota.kmp1 @@ -0,0 +1,282 @@ +;;; -*- LISP -*- +;;; IOTA: Macros for doing I/O correctly. +;;; Bugs/suggestions/complaints to KMP@MC + +;;; Functions defined in this package are: +;;; +;;; IOTA - Macro for binding I/O streams +;;; PHI - A different flavor of IOTA that works more like LAMBDA + + +;;; IOTA +;;; +;;; Mnemonic Basis: A form of Lambda for doing I/O binding. +;;; +;;; This is a LAMBDA binding macro that will open a lisp file object +;;; in such a way that it is automatically closed when the lambda binding +;;; range is exited. +;;; +;;; Syntax: +;;; +;;; (IOTA (( ) +;;; ( ) ...) +;;; ) +;;; +;;; +;;; Description: +;;; +;;; [1] ... are, in essence, bound to +;;; (OPEN ) +;;; for K = 1 thru N. +;;; +;;; [2] 's and 's are evaluated before entering +;;; the context in which the 's are bound. (constant names +;;; must be quoted.) +;;; +;;; [2] Body is of the same form as a lambda-body (ie, an implicit PROGN). +;;; +;;; [3] All files are closed upon any exit from the LAMBDA (including +;;; normal exit, ^G Quit, or an error). +;;; +;;; +;;; Expands into: +;;; +;;; ((LAMBDA ( ... ) +;;; (UNWIND-PROTECT +;;; (PROGN (WITHOUT-INTERRUPTS +;;; (SETQ (APPLY 'OPEN (POP ))) +;;; (SETQ (APPLY 'OPEN (POP ))) +;;; ...) +;;; ) +;;; (AND (OR (SFAP ) (FILEP )) (CLOSE )) +;;; (AND (OR (SFAP ) (FILEP )) (CLOSE )) +;;; ...)) +;;; (LIST (LIST ) (LIST ) ...) +;;; () () ... ()) +;;; +;;; On LISPM, uses pseudo-FILEP operation omits the SFAP operation. +;;; +;;; Example: +;;; +;;; (DEFUN FILECOPY (FROM TO) +;;; (IOTA ((FOO FROM 'IN) +;;; (BAR TO 'OUT)) +;;; (DO ((C (TYI FOO -1) (TYI FOO -1))) +;;; ((MINUSP C)) +;;; (TYO C BAR)))) +;;; +;;; Note: +;;; This function should never be called on TYO, TYI, or T +;;; since it will close them upon its return, leaving the +;;; Lisp in a hung state. +;;; + +(DEFUN (IOTA MACRO) (X) + (LET* ((STREAMS (CADR X)) + (BODY (CDDR X)) + (VARS (MAPCAR 'CAR STREAMS)) + (VALS (MAPCAR #'(LAMBDA (X) `(LIST ,@(CDR X))) STREAMS)) + (TEMP (GENSYM 'F))) + `((LAMBDA (,TEMP ,@VARS) + (UNWIND-PROTECT + (PROGN + (WITHOUT-INTERRUPTS + ,@(MAPCAR #'(LAMBDA (X) + `(SETQ ,X (APPLY 'OPEN (POP ,TEMP)))) + VARS)) + ,@BODY) + ,@ (MAPCAR #'(LAMBDA (VAR) + #+LISPM + `(AND + (CLOSUREP ,VAR) + (MEMQ ':CLOSE + (FUNCALL ,VAR ':WHICH-OPERATIONS)) + (CLOSE ,VAR)) + #-LISPM + `(AND (OR (FILEP ,VAR) + (AND (STATUS FEATURE SFA) + (SFAP ,VAR))) + (CLOSE ,VAR))) + VARS))) + (LIST . ,VALS) + ,@(MAPCAR #'(LAMBDA (THING) THING ()) ; Create a list of NILs + VARS)))) + + +;;; PHI +;;; +;;; Mnemonic basis: PHI is a special LAMBDA for PHIle object binding. +;;; +;;; This is a LAMBDA binding macro that will accept an open lisp file object +;;; or SFA and guarantee that the object will be closed when the binding is +;;; exited. +;;; +;;; Syntax: +;;; +;;; (PHI (( ) +;;; ( ) ...) +;;; ) +;;; +;;; Description: +;;; +;;; [1] ... are, in essence, bound to +;;; the EVAL'd form of . +;;; for K = 1 thru N. +;;; +;;; [2] ... are evaluated outside of the scope of +;;; ... according to traditional +;;; LET-semantics. They should return file objects +;;; or SFA's. +;;; +;;; [3] is of the same form as a lambda-body (ie, an implicit PROGN). +;;; +;;; [4] All variables of the PHI bound variable list which contain files +;;; or SFA's at time of return from the PHI (by normal return, ^G quit, +;;; or error) will be properly closed. +;;; +;;; Expands into: +;;; +;;; +;;; ((LAMBDA ( ) +;;; (UNWIND-PROTECT +;;; (PROGN +;;; (WITHOUT-INTERRUPTS +;;; (SETQ ) +;;; (SETQ (CONS )) +;;; ... +;;; (SETQ ) +;;; (SETQ (CONS )) +;;; (SETQ ) +;;; (SETQ (CONS )) +;;; (SETQ ()) +;;; (SETQ (REVERSE ))) +;;; ((LAMBDA ( ... ) +;;; (UNWIND-PROTECT (PROGN (SETQ (CAR )) +;;; (POP ) +;;; (SETQ (CAR )) +;;; (POP ) +;;; ... +;;; (SETQ (CAR )) +;;; (POP ) +;;; ) +;;; (AND (OR (FILEP ) (SFAP )) +;;; (CLOSE )) +;;; (AND (OR (FILEP ) (SFAP )) +;;; (CLOSE )) +;;; ... +;;; (AND (OR (FILEP ) (SFAP )) +;;; (CLOSE )))) +;;; () () () ... ())) +;;; (COND ((OR (FILEP ) (SFAP )) +;;; (CLOSE ))) +;;; (DO ((X (CDR X))) +;;; ((NULL X)) +;;; (COND ((OR (FILEP (CAR X)) (SFAP (CAR X))) +;;; (CLOSE (CAR X))))))) +;;; NIL NIL) +;;; +;;; +;;; Example: +;;; +;;; (DEFUN DUMP-DATA (FROM TO) +;;; (PHI ((FOO (MY-SFA-MAKER FROM 'INPUT)) +;;; (BAR (MY-SFA-MAKER TO 'OUTPUT))) +;;; (DO ((C (TYI FOO -1) (TYI FOO -1))) +;;; ((MINUSP C)) +;;; (TYO C BAR)))) +;;; +;;; Notes: +;;; +;;; (1) MY-SFA-MAKER is of course not a Lisp builtin function. +;;; Presumably it returns an SFA object of the proper type. +;;; +;;; (2) This function should never be called on TYO, TYI, or T +;;; since it will close them upon its return, leaving the +;;; Lisp in a hung state. +;;; + +(DEFUN (PHI MACRO) (FORM) + (LET ((TEMP1 (GENSYM)) + (TEMP2 (GENSYM)) + (FORMS (CADR FORM)) + (BODY (CDDR FORM)) + (VARLIST ()) + (FORMLIST ())) + (DO ((FORMS FORMS (CDR FORMS))) + ((NULL FORMS) + (SETQ VARLIST (NREVERSE VARLIST)) + (SETQ FORMLIST (NREVERSE FORMLIST))) + (PUSH (CAAR FORMS) VARLIST) + (PUSH (CADAR FORMS) FORMLIST)) + `((LAMBDA (,TEMP1 ,TEMP2) + (UNWIND-PROTECT + (PROGN + (WITHOUT-INTERRUPTS + ,@(NREVERSE + (MAPCAN #'(LAMBDA (X) + `((SETQ ,TEMP1 + (CONS ,TEMP2 + ,TEMP1)) + (SETQ ,TEMP2 ,X))) + (REVERSE FORMLIST))) + (SETQ ,TEMP2 ()) + (SETQ ,TEMP1 (REVERSE ,TEMP1))) + ((LAMBDA ,VARLIST + (UNWIND-PROTECT + (PROGN + ,@(MAPCAN #'(LAMBDA (X) + `((SETQ ,X (CAR ,TEMP1)) + (SETQ ,TEMP1 (CDR ,TEMP1)))) + VARLIST) + ,@BODY) + ,@ (MAPCAR #'(LAMBDA (VAR) + #+LISPM + `(AND + (CLOSUREP ,VAR) + (MEMQ ':CLOSE + (FUNCALL ,VAR + ':WHICH-OPERATIONS)) + (CLOSE ,VAR)) + #-LISPM + `(AND (OR (FILEP ,VAR) + (AND (STATUS FEATURE SFA) + (SFAP ,VAR))) + (CLOSE ,VAR))) + VARLIST))) + ,@(MAPCAR #'(LAMBDA (THING) THING ()) ; List of NILs + VARLIST))) + (COND ((OR (FILEP ,TEMP2) (AND (STATUS FEATURE SFA) + (SFAP ,TEMP2))) + (CLOSE ,TEMP2))) + (DO ((X ,TEMP1 (CDR X))) + ((NULL X)) + (COND (#-LISPM (OR (FILEP (CAR X)) + (AND (STATUS FEATURE SFA) + (SFAP (CAR X)))) + #+LISPM (AND (CLOSUREP (CAR X)) + (MEMQ ':CLOSE (FUNCALL (CAR X) ':WHICH-OPERATIONS))) + (CLOSE (CAR X))))))) + () ()))) + + +;;; Mnemonic basis: PI is a special form for binding Program Interrupts +;;; +;;; PI has been replaced by the Maclisp system function WITHOUT-INTERRUPTS + +(DEFUN (PI MACRO) (X) + (LET ((Y `(WITHOUT-INTERRUPTS ,(cdr x)))) + #-LISPM (SETQ Y (OR (MACROFETCH X) (MACROMEMO X Y 'PI))) + Y)) + + +;;; Note that the package has loaded. + +(SSTATUS FEATURE #+LISPM : IOTA) + +#+LISPM (GLOBALIZE 'IOTA) +#+LISPM (GLOBALIZE 'PHI) + +;;; Version Number Support + +#-LISPM (HERALD IOTA /40) + diff --git a/src/libdoc/letfex.gjc2 b/src/libdoc/letfex.gjc2 new file mode 100755 index 00000000..fd1a3035 --- /dev/null +++ b/src/libdoc/letfex.gjc2 @@ -0,0 +1,156 @@ +;;-*-LISP-*- +;; A special-form LET for the maclisp interpreter. +;; 1:07am Friday, 18 September 1981 -George Carrette. +;; This takes up less space than, and is generally easier to deal +;; with than a hairy macro implementation in the interpreter. + +;; grossly hacked for BIL to run on Lispm. + +#+MACLISP +(HERALD LETFEX) + +#+MACLISP +(PROGN (DEFPROP LET LETFEX FEXPR) + (DEFPROP LET* LET*FEX FEXPR) + (DEFPROP PROGN EVALN FEXPR) + (DEFPROP DESETQ DESETQFEX FEXPR)) + +#+LISPM +(PROGN 'COMPILE +(DEFUN LET ("E &REST L) (LETFEX L)) +(DEFUN LET* ("E &REST L) (LET*FEX L)) +(DEFUN DESETQ ("E &REST L) (DESETQFEX L)) +) + +(DEFUN LETFEX-WTA (F M A &REST L) + (LEXPR-FUNCALL F (ERROR M A 'WRNG-TYPE-ARG) L)) + +(DEFUN EVALN (L) + (DO ((VALUE)) + ((ATOM L) + (IF (NULL L) VALUE + (LETFEX-WTA #'EVALN "is a bad tail of a list for a PROGN" L))) + (SETQ VALUE (EVAL (POP L))))) + +(DEFVAR LETFEX-VARS) +(DEFVAR LETFEX-VALS) + +(DEFUN LETFEX-RECLAIM () + (#+MACLISP RECLAIM #+LISPM PROGN + (PROG1 LETFEX-VARS (SETQ LETFEX-VARS NIL)) NIL) + (#+MACLISP RECLAIM #+LISPM PROGN + (PROG1 LETFEX-VALS (SETQ LETFEX-VALS NIL)) NIL)) + +(DEFUN LETFEX (L) + (IF (ATOM L) + (LETFEX-WTA #'LETFEX "bad form to LET" L) + (LET ((LETFEX-VARS ()) + (LETFEX-VALS ())) + (UNWIND-PROTECT + (PROGN (LETFEX-BINDING-FORM (CAR L)) + (PROGV LETFEX-VARS LETFEX-VALS + (EVALN (CDR L)))) + (LETFEX-RECLAIM))))) + +(DEFUN LET*FEX (L) + (IF (ATOM L) + (LETFEX-WTA #'LET*FEX "bad form to LET*" L) + (LET*FEX1 (CAR L) (CDR L)))) + +(DEFUN LET*FEX1 (B L) + (COND ((ATOM B) + (IF (NULL B) (EVALN L) + (LETFEX-WTA #'LET*FEX1 "bad form to LET*" B L))) + ('ELSE + (LET ((LETFEX-VARS ()) + (LETFEX-VALS ())) + (UNWIND-PROTECT + (PROGN (LETFEX-BINDING-FORM1 (CAR B)) + (PROGV LETFEX-VARS LETFEX-VALS + (LET*FEX1 (CDR B) L))) + (LETFEX-RECLAIM)))))) + +(DEFUN DESETQ-ERR (M A) + (ERROR (LIST M "in DESETQ") A 'FAIL-ACT)) + +(DEFUN DESETQFEX (L) + (DO ((ANY NIL T) + (VALUE) + (LETFEX-VARS NIL NIL) + (LETFEX-VALS NIL NIL) + (L L (CDDR L))) + ((ATOM L) + (IF (AND (NULL L) ANY) + VALUE + (LETFEX-WTA #'DESETQFEX "bad DESETQ form" L))) + (COND ((CDR L) + (IF (NULL (CAR L)) + (DESETQ-ERR "bad variable" (CAR L))) + (SETQ VALUE (EVAL (CADR L))) + (UNWIND-PROTECT + (PROGN (LETFEX-BINDING-PATTERN (CAR L) VALUE) + (MAPC 'SET LETFEX-VARS LETFEX-VALS)) + (LETFEX-RECLAIM))) + ('ELSE + (DESETQ-ERR "odd number of args" L))))) + +(DEFUN LETFEX-BINDING-FORM (B) + (IF (AND (ATOM B) (NOT (NULL B))) + (LETFEX-WTA #'LETFEX-BINDING-FORM + "bad binding form in LET" B) + (MAPC #'LETFEX-BINDING-FORM1 B))) + +(DEFUN LETFEX-BINDING-FORM1-WTA (FORM) + (LETFEX-WTA #'LETFEX-BINDING-FORM1 + "bad single binding form in LET" FORM)) + +(DEFUN LETFEX-BINDING-FORM1 (PAR) + (COND ((ATOM PAR) + (COND ((AND PAR (SYMBOLP PAR) (NOT (EQ PAR T))) + (PUSH PAR LETFEX-VARS) + (PUSH NIL LETFEX-VALS)) + ('ELSE + (LETFEX-BINDING-FORM1-WTA PAR)))) + ((EQ (TYPEP PAR) 'LIST) + (COND ((NULL (CDR PAR)) + (LETFEX-BINDING-PATTERN (CAR PAR) NIL)) + ((NULL (CDDR PAR)) + (LETFEX-BINDING-PATTERN (CAR PAR) (EVAL (CADR PAR)))) + ('ELSE + (LETFEX-BINDING-FORM1-WTA PAR)))) + ('ELSE + (LETFEX-BINDING-FORM1-WTA PAR)))) + +(DEFUN LETFEX-BINDING-PATTERN-WTA1 (PATTERN FORM) + (LETFEX-BINDING-PATTERN + (ERROR "bad destructuring pattern" pattern 'wrng-type-arg) + FORM)) + +(DEFUN LETFEX-BINDING-PATTERN-WTA2 (PATTERN FORM) + (LETFEX-BINDING-PATTERN + PATTERN + (ERROR (LIST "form doesn't destructure against" PATTERN) + FORM 'WRNG-TYPE-ARG))) + +(DEFVAR LETFEX-BINDING-PATTERN-HUNK ()) + +(DEFUN LETFEX-BINDING-PATTERN (PATTERN FORM) + (COND ((ATOM PATTERN) + (COND ((NULL PATTERN)) + ((AND (SYMBOLP PATTERN) (NOT (EQ PATTERN T))) + (PUSH PATTERN LETFEX-VARS) + (PUSH FORM LETFEX-VALS)) + ('ELSE + (LETFEX-BINDING-PATTERN-WTA1 PATTERN FORM)))) + ((EQ (TYPEP PATTERN) 'LIST) + (COND ((OR (EQ (TYPEP FORM) 'LIST) + (NULL FORM)) + (LETFEX-BINDING-PATTERN (CAR PATTERN) (CAR FORM)) + (LETFEX-BINDING-PATTERN (CDR PATTERN) (CDR FORM))) + ('ELSE + (LETFEX-BINDING-PATTERN-WTA2 PATTERN FORM)))) + ('ELSE + (IF LETFEX-BINDING-PATTERN-HUNK + (FUNCALL LETFEX-BINDING-PATTERN-HUNK PATTERN FORM) + (LETFEX-BINDING-PATTERN-WTA1 PATTERN FORM))))) + diff --git a/src/libdoc/lusets.alan b/src/libdoc/lusets.alan new file mode 100755 index 00000000..d46fb624 --- /dev/null +++ b/src/libdoc/lusets.alan @@ -0,0 +1,91 @@ +; this is a support file for LISPT and LDDT, normally only used at compile time +; It may also be useful for other applications where the HUMBLE package is used +; in hacking jobs inferior to LISP. + +(DEFUN (*USET MACRO) (X) + ((LAMBDA (NAME) + ((LAMBDA (VAL) + (OR VAL (ERROR '|INVALID *USET VARIABLE| X 'WRNG-TYPE-ARG)) + (COND ((CDDR X) + (LIST 'JOB-USET-WRITE VAL (CADDR X))) + (T (LIST 'JOB-USET-READ VAL)))) + (GET NAME (COND ((CDDR X) 'USET-WRITE) + (T 'USET-READ))))) + ((LAMBDA (EXP) + (AND (CDDDR (CDDDR EXP)) + (RPLACD (CDDR (CDDDR EXP)) NIL)) + (IMPLODE EXP)) + (EXPLODEC (CADR X))))) + +; DEFINE USET SYMBOLS + + +(DEFPROP *RUPC 0 USET-READ) (DEFPROP *SUPC 400000 USET-WRITE) +(DEFPROP *RVAL 1 USET-READ) (DEFPROP *SVAL 400001 USET-WRITE) +(DEFPROP *RTTY 2 USET-READ) (DEFPROP *STTY 400002 USET-WRITE) +(DEFPROP *RFLS 3 USET-READ) (DEFPROP *SFLS 400003 USET-WRITE) +(DEFPROP *RUNAM 4 USET-READ) (DEFPROP *SUNAM 400004 USET-WRITE) +(DEFPROP *RJNAM 5 USET-READ) (DEFPROP *SJNAM 400005 USET-WRITE) +(DEFPROP *RMASK 6 USET-READ) (DEFPROP *SMASK 400006 USET-WRITE) +(DEFPROP *RUSTP 7 USET-READ) (DEFPROP *SUSTP 400007 USET-WRITE) +(DEFPROP *RPIRQ 10 USET-READ) (DEFPROP *SPIRQ 400010 USET-WRITE) +(DEFPROP *RINTB 11 USET-READ) (DEFPROP *SINTB 400011 USET-WRITE) +(DEFPROP *RMEMT 12 USET-READ) (DEFPROP *SMEMT 400012 USET-WRITE) +(DEFPROP *RSV40 13 USET-READ) (DEFPROP *SSV40 400013 USET-WRITE) +(DEFPROP *RIPIR 14 USET-READ) (DEFPROP *SIPIR 400014 USET-WRITE) +(DEFPROP *RAPIR 15 USET-READ) (DEFPROP *SAPIR 400015 USET-WRITE) +(DEFPROP *RSNAM 16 USET-READ) (DEFPROP *SSNAM 400016 USET-WRITE) +(DEFPROP *RPICL 17 USET-READ) (DEFPROP *SPICL 400017 USET-WRITE) +(DEFPROP *RMARA 20 USET-READ) (DEFPROP *SMARA 400020 USET-WRITE) +(DEFPROP *RMARP 21 USET-READ) (DEFPROP *SMARP 400021 USET-WRITE) +(DEFPROP *RUUOH 22 USET-READ) (DEFPROP *SUUOH 400022 USET-WRITE) +(DEFPROP *RUIND 23 USET-READ) (DEFPROP *SUIND 400023 USET-WRITE) +(DEFPROP *RRUNT 24 USET-READ) (DEFPROP *SRUNT 400024 USET-WRITE) +(DEFPROP *RMSK2 25 USET-READ) (DEFPROP *SMSK2 400025 USET-WRITE) +(DEFPROP *RIFPI 26 USET-READ) (DEFPROP *SIFPI 400026 USET-WRITE) +(DEFPROP *RAPRC 27 USET-READ) (DEFPROP *SAPRC 400027 USET-WRITE) +(DEFPROP *RSV60 30 USET-READ) (DEFPROP *SSV60 400030 USET-WRITE) +(DEFPROP *RUTRP 31 USET-READ) (DEFPROP *SUTRP 400031 USET-WRITE) +(DEFPROP *RIIFP 32 USET-READ) (DEFPROP *SIIFP 400032 USET-WRITE) +(DEFPROP *RAIFP 33 USET-READ) (DEFPROP *SAIFP 400033 USET-WRITE) +(DEFPROP *RIMAS 34 USET-READ) (DEFPROP *SIMAS 400034 USET-WRITE) +(DEFPROP *RAMAS 35 USET-READ) (DEFPROP *SAMAS 400035 USET-WRITE) +(DEFPROP *RIMSK 36 USET-READ) (DEFPROP *SIMSK 400036 USET-WRITE) +(DEFPROP *RAMSK 37 USET-READ) (DEFPROP *SAMSK 400037 USET-WRITE) +(DEFPROP *RJPC 40 USET-READ) (DEFPROP *SJPC 400040 USET-WRITE) +(DEFPROP *ROPC 41 USET-READ) (DEFPROP *SOPC 400041 USET-WRITE) +(DEFPROP *RRTMR 42 USET-READ) (DEFPROP *SRTMR 400042 USET-WRITE) +(DEFPROP *RHSNA 43 USET-READ) (DEFPROP *SHSNA 400043 USET-WRITE) +;;What is this for?!? (-Alan) +(DEFPROP *R60H 43 USET-READ) (DEFPROP *S60H 400043 USET-WRITE) +(DEFPROP *RBCHN 44 USET-READ) (DEFPROP *SBCHN 400044 USET-WRITE) +(DEFPROP *RMPVA 45 USET-READ) (DEFPROP *SMPVA 400045 USET-WRITE) +(DEFPROP *RIDF1 46 USET-READ) (DEFPROP *SIDF1 400046 USET-WRITE) +(DEFPROP *RADF1 47 USET-READ) (DEFPROP *SADF1 400047 USET-WRITE) +(DEFPROP *RIDF2 50 USET-READ) (DEFPROP *SIDF2 400050 USET-WRITE) +(DEFPROP *RADF2 51 USET-READ) (DEFPROP *SADF2 400051 USET-WRITE) +(DEFPROP *RDF1 52 USET-READ) (DEFPROP *SDF1 400052 USET-WRITE) +(DEFPROP *RDF2 53 USET-READ) (DEFPROP *SDF2 400053 USET-WRITE) +(DEFPROP *ROPTI 54 USET-READ) (DEFPROP *SOPTI 400054 USET-WRITE) +(DEFPROP *R40AD 55 USET-READ) (DEFPROP *S40AD 400055 USET-WRITE) +(DEFPROP *RTVCR 56 USET-READ) (DEFPROP *STVCR 400056 USET-WRITE) +(DEFPROP *RTTST 57 USET-READ) (DEFPROP *STTST 400057 USET-WRITE) +(DEFPROP *RTTS1 60 USET-READ) (DEFPROP *STTS1 400060 USET-WRITE) +(DEFPROP *RTTS2 61 USET-READ) (DEFPROP *STTS2 400061 USET-WRITE) +(DEFPROP *RWHO1 62 USET-READ) (DEFPROP *SWHO1 400062 USET-WRITE) +(DEFPROP *RWHO2 63 USET-READ) (DEFPROP *SWHO2 400063 USET-WRITE) +(DEFPROP *RWHO3 64 USET-READ) (DEFPROP *SWHO3 400064 USET-WRITE) +(DEFPROP *RSUPP 65 USET-READ) (DEFPROP *SSUPP 400065 USET-WRITE) +(DEFPROP *RTR1I 66 USET-READ) (DEFPROP *STR1I 400066 USET-WRITE) +(DEFPROP *RTR2I 67 USET-READ) (DEFPROP *STR2I 400067 USET-WRITE) +(DEFPROP *RMBOX 70 USET-READ) (DEFPROP *SMBOX 400070 USET-WRITE) +(DEFPROP *RMBO1 71 USET-READ) (DEFPROP *SMBO1 400071 USET-WRITE) +(DEFPROP *REBOX 72 USET-READ) (DEFPROP *SEBOX 400072 USET-WRITE) +(DEFPROP *REBO1 73 USET-READ) (DEFPROP *SEBO1 400073 USET-WRITE) +(DEFPROP *RXUNA 74 USET-READ) (DEFPROP *SXUNA 400074 USET-WRITE) +(DEFPROP *RXJNA 75 USET-READ) (DEFPROP *SXJNA 400075 USET-WRITE) +(DEFPROP *RFTL1 76 USET-READ) (DEFPROP *SFTL1 400076 USET-WRITE) +(DEFPROP *RFTL2 77 USET-READ) (DEFPROP *SFTL2 400077 USET-WRITE) +(DEFPROP *RIOC 100 USET-READ) (DEFPROP *SIOC 400100 USET-WRITE) +(DEFPROP *RIOS 120 USET-READ) (DEFPROP *SIOS 400120 USET-WRITE) +(DEFPROP *RPMAP 200 USET-READ) (DEFPROP *SPMAP 400200 USET-WRITE) diff --git a/src/libdoc/smurf.rwk1 b/src/libdoc/smurf.rwk1 new file mode 100755 index 00000000..98782632 --- /dev/null +++ b/src/libdoc/smurf.rwk1 @@ -0,0 +1,36 @@ +;; (SMURF) prints 300 characters around the current position in INFILE. +;; It's useful when you get a dot-context error or other error while +;; loading a file. Just do (SMURF) and it'll print out the vicinity +;; of the error. 2/3 of the printing will be before the error, 1/3 +;; after. If you want to see more context, just call it on the number +;; of characters you'd like to see instead of 300. +;; This function is my version of a long-existing function who's origin +;; is lost in the murky depths of history. You'll have to play historian +;; if you want to know why it's named SMURF! --RWK + +(HERALD SMURF) + +(defun smurf (&optional (chars-wanted 300)) + (cond ((and (filep infile) (memq 'filepos (status filemode infile))) + (terpri tyo) + (let ((old-filepos (filepos infile)) + (pre-chars (// (* 2 chars-wanted) 3))) + (let ((new-filepos (max 0 (- old-filepos pre-chars))) + (post-chars (- chars-wanted pre-chars))) + (filepos infile new-filepos) + (smurf-em (min old-filepos pre-chars)) + (filepos infile old-filepos) + (princ '|===>>> Error Occured Here <<<===| tyo) + (smurf-em post-chars)))) + (T (terpri tyo) + (princ '|Can't FILEPOS with INFILE = | tyo) + (prin1 infile tyo) + (terpri tyo)))) + +(defun smurf-em (chars-wanted) + (DO ((num chars-wanted (1- num)) + (char (tyi infile nil) + (tyi infile nil))) + ((or (= num 0) + (null char))) + (tyo char tyo))) diff --git a/src/libdoc/time.kmp8 b/src/libdoc/time.kmp8 new file mode 100644 index 00000000..45ccc270 --- /dev/null +++ b/src/libdoc/time.kmp8 @@ -0,0 +1,692 @@ +;;; -*- Package:TIME; Mode:Lisp; -*- +;;; +;;; This package created by KMP@MC, 24 May 81. +;;; +;;; TIME:DAYS - Bound to an alist of (daynum . dayname) +;;; TIME:MONTHS - Bound to an alist of (monthnum . monthname) +;;; +;;; STANDARD-OUTPUT - If undefined when this package loads, this variable +;;; will be set to the current value of TYO +;;; +;;; (TIME:GET-TIME-LIST) +;;; Returns (sec mins hours date month year dayofweek). This returns +;;; information similar to that returned by the LispM TIME:GET-TIME +;;; routine, but the information is returned as a list. +;;; Unlike the LispM, however, dayofweek is returned as a string (not +;;; a fixnum) and daylightsavings information is not returned at all. +;;; +;;; (TIME:PARSE-LIST string) +;;; Returns (sec mins hours date month year dayofweek). This returns +;;; information similar to that returned by the LispM TIME:PARSE +;;; routine, but the information is returned as a list. +;;; Unlike the LispM, however, dayofweek is returned as a string (not +;;; a fixnum). Daylightsavings information and relative information +;;; is not returned at all. +;;; +;;; The following several functions are used the same as in LispM lisp. +;;; The optional argument, stream, in the following functions defaults to +;;; the value of the symbol STANDARD-OUTPUT. A stream argument of () means +;;; to return the string rather than printing it. +;;; Year arguments less than one hundred are assumed to be offset from +;;; 1900. +;;; Day of week arguments to the dateprinting functions may be either +;;; strings or fixnums (0=Monday). +;;; +;;; (TIME:PRINT-CURRENT-TIME &optional stream) +;;; Calls TIME:PRINT-TIME using the current time. +;;; +;;; (TIME:PRINT-TIME sec min hrs date month year &optional stream) +;;; Displays the given time in format yr/mo/dy hr:min:sec +;;; +;;; (TIME:PRINT-CURRENT-DATE &optional stream) +;;; Calls TIME:PRINT-DATE using the current date. +;;; +;;; (TIME:PRINT-DATE sec min hrs date month year dayofweek &optional stream) +;;; Displays the given time in full English format. eg, +;;; Sunday the twenty-fourth of May; 3:02:17 pm +;;; +;;; (TIME:MONTH-STRING n &optional ignore) +;;; Returns the name of the nth month (1=January). +;;; Mode is not supported but is provided for calling compatibility +;;; with the LispM. +;;; +;;; (TIME:DAY-OF-THE-WEEK-STRING n &optional ignore) +;;; Returns the name of the nth day of the week (0=Monday). +;;; Mode is not supported but is provided for calling compatibility +;;; with the LispM. +;;; +;;; (TIME:VERIFY-DATE date month year dayofweek) +;;; Returns () if day,month,year fell on dayofweek. Else returns a string +;;; containing a suitable error message. +;;; +;;; This last function is not in the LispM lisp time package, but seemed +;;; a useful function to have, so is provided at no extra cost. +;;; +;;; (TIME:ON-WHAT-DAY-OF-THE-WEEK? day month year) +;;; Returns the day of the week that a given day fell on. +;;; + +#+Maclisp +(HERALD TIME /4) + +#+Maclisp +(DEFVAR STANDARD-OUTPUT TYO) + +#+Maclisp +(EVAL-WHEN (COMPILE) (SETQ DEFMACRO-FOR-COMPILING ())) + +#+Maclisp +(DEFMACRO CHAR-UPCASE (X) + (IF (NOT (ATOM X)) + `(LET ((X ,X)) (CHAR-UPCASE X)) + `(IF (AND (>= ,X #/a) (<= ,X #/z)) + (- ,X #.(- #/a #/A)) + ,X))) + +#+Maclisp +(DEFMACRO CHAR-DOWNCASE (X) + (IF (NOT (ATOM X)) + `(LET ((X ,X)) (CHAR-DOWNCASE X)) + `(IF (AND (>= ,X #/A) (<= ,X #/Z)) + (- ,X #.(- #/A #/a)) + ,X))) + +(DEFMACRO STANDARDIZE-YEAR (YEAR) + (IF (NOT (ATOM YEAR)) + `(LET ((YEAR ,YEAR)) (STANDARDIZE-YEAR YEAR)) + `(IF (< ,YEAR 100.) (+ ,YEAR 1900.) ,YEAR))) + +(DEFMACRO STRING-UPPERCASE-INITIAL (FORM) + `(LET ((EXPL (EXPLODEN ,FORM))) + (IMPLODE (CONS (CHAR-UPCASE (CAR EXPL)) + (DO ((L (CDR EXPL) (CDR L)) + (LL () (CONS (CHAR-DOWNCASE (CAR L)) LL))) + ((NULL L) (NREVERSE LL))))))) + +(DEFMACRO DAY (X) `(CDR (ASSQ ,X TIME:DAYS))) + +(DEFVAR TIME:DAYS + '((0. . "Monday" ) + (1. . "Tuesday" ) + (2. . "Wednesday") + (3. . "Thursday" ) + (4. . "Friday" ) + (5. . "Saturday" ) + (6. . "Sunday" ))) + +(DEFMACRO MONTH (X) `(CDR (ASSQ ,X TIME:MONTHS))) + +(DEFVAR TIME:MONTHS + '((1. . "January" ) + (2. . "February" ) + (3. . "March" ) + (4. . "April" ) + (5. . "May" ) + (6. . "June" ) + (7. . "July" ) + (8. . "August" ) + (9. . "September") + (10. . "October" ) + (11. . "November" ) + (12. . "December" ))) + +(DEFUN TIME:GET-TIME-LIST () + (LET ((FULL-DATE (STATUS DATE)) + (FULL-TIME (STATUS DAYTIME)) + (DAY-OF-WEEK (STATUS DOW))) + (IF (NOT (EQUAL FULL-DATE (STATUS DATE))) + (TIME:GET-TIME-LIST) + (LET (((HOURS MINUTES SECONDS) FULL-TIME) + ((YEAR MONTH DATE ) FULL-DATE) + (DOW (STRING-UPPERCASE-INITIAL DAY-OF-WEEK))) + (LIST SECONDS MINUTES HOURS DATE MONTH YEAR DOW))))) + +(DEFUN TIME:PRINT-CURRENT-TIME (&OPTIONAL (STREAM STANDARD-OUTPUT)) + (LEXPR-FUNCALL #'TIME:PRINT-TIME + (NREVERSE + (CONS STREAM (CDR (REVERSE (TIME:GET-TIME-LIST))))))) + +(DEFUN TIME:PRINT-TIME (SECONDS MINUTES HOURS DATE MONTH YEAR + &OPTIONAL (STREAM STANDARD-OUTPUT)) + (SETQ YEAR (STANDARDIZE-YEAR YEAR)) + (FORMAT STREAM "~D//~D//~D ~D:~2,'0D:~2,'0D" + MONTH + DATE + (- YEAR 1900.) + HOURS + MINUTES + SECONDS)) + +(DEFUN TIME:PRINT-CURRENT-DATE (&OPTIONAL (STREAM STANDARD-OUTPUT)) + (LEXPR-FUNCALL #'TIME:PRINT-DATE + (APPEND (TIME:GET-TIME-LIST) (NCONS STREAM)))) + +(DEFUN TIME:PRINT-DATE (SECONDS MINUTES HOURS DATE MONTH YEAR DAY-OF-WEEK + &OPTIONAL (STREAM STANDARD-OUTPUT)) + (SETQ YEAR (STANDARDIZE-YEAR YEAR)) +;; (LET ((MSG (TIME:VERIFY-DATE DATE MONTH YEAR DAY-OF-WEEK))) +;; (IF MSG (FERROR NIL MSG))) + (FORMAT STREAM "~A the ~:R of ~A, ~D; ~D:~2,'0D:~2,'0D ~A" + (IF (FIXP DAY-OF-WEEK) + (DAY DAY-OF-WEEK) + (STRING-UPPERCASE-INITIAL DAY-OF-WEEK)) + DATE + (MONTH MONTH) + YEAR + (LET ((HR (\ HOURS 12.))) (IF (ZEROP HR) 12. HR)) + MINUTES + SECONDS + (IF (ZEROP (// HOURS 12.)) "am" "pm"))) + +(DEFUN TIME:MONTH-STRING (MONTHNUM &OPTIONAL MODE) MODE ;ignored + (MONTH MONTHNUM)) + +(DEFUN TIME:DAY-OF-THE-WEEK-STRING (DAYNUM &OPTIONAL MODE) MODE ;ignored + (DAY DAYNUM)) + +(DEFUN TIME:VERIFY-DATE (DATE MONTH YEAR DAY-OF-THE-WEEK) + (SETQ YEAR (STANDARDIZE-YEAR YEAR)) + (LET ((TRUE-DOW (TIME:DAY-OF-THE-WEEK-STRING + (TIME:ON-WHAT-DAY-OF-THE-WEEK? DATE MONTH YEAR)))) + (IF (FIXP DAY-OF-THE-WEEK) + (SETQ DAY-OF-THE-WEEK (TIME:DAY-OF-THE-WEEK-STRING DAY-OF-THE-WEEK))) + (SETQ DAY-OF-THE-WEEK (STRING-UPPERCASE-INITIAL DAY-OF-THE-WEEK)) + (IF (NOT (SAMEPNAMEP DAY-OF-THE-WEEK TRUE-DOW)) + (LET (((TODAY-DATE TODAY-MONTH TODAY-YEAR) + (CDDDR (TIME:GET-TIME-LIST)))) + (SETQ TODAY-YEAR (STANDARDIZE-YEAR TODAY-YEAR)) + (FORMAT () + (COND ((OR (> TODAY-YEAR YEAR) + (AND (= TODAY-YEAR YEAR) + (OR (> TODAY-MONTH MONTH) + (AND (= TODAY-MONTH MONTH) + (> TODAY-DATE DATE))))) + "The ~:R of ~A, ~D fell on a ~A, not a ~A.") + ((AND (= TODAY-YEAR YEAR) + (= TODAY-MONTH MONTH) + (= TODAY-DATE DATE)) + "Today is a ~3G~A, not a ~A.") + (T + "The ~:R of ~A, ~D will fall on a ~A, not a ~A.")) + DATE + (MONTH MONTH) + YEAR + TRUE-DOW + DAY-OF-THE-WEEK))))) + + +;;; This code adapted from JONL's package MC:LIBDOC;DOW > + +;;; The following function, when given the date as three numbers, +;;; will produce a number of the day-of-week for that date (0=Monday). +;;; eg, +;;; (TIME:DAY-OF-THE-WEEK-STRING +;;; (TIME:ON-WHAT-DAY-OF-THE-WEEK? 22. 11. 1963.)) +;;; => "Friday" +;;; which happened to be the day President John F. Kennedy was assasinated. + +(DEFUN TIME:ON-WHAT-DAY-OF-THE-WEEK? (DAY MONTH YEAR) + (IF (NOT (AND (FIXP YEAR) (FIXP MONTH) (FIXP DAY))) + (ERROR "Args to TIME:DAY-OF-WEEK must be fixnums" (LIST YEAR MONTH DAY)) + (SETQ YEAR (STANDARDIZE-YEAR YEAR)) + (LET ((A (+ YEAR (// (+ MONTH -14.) 12.)))) + (DECLARE (FIXNUM A)) + (\ (+ (// (1- (* 13. (+ MONTH 10. (* (// (+ MONTH 10.) -13.) 12.)))) + 5.) + DAY + 76. + (// (* 5. (- A (* (// A 100.) 100.))) 4.) + (// A -2000.) + (// A 400.) + (* (// A -100.) 2.)) + 7.)))) + + +;;; The following sequence is translated from the Teco code in +;;; KMP's TPARSE library. + +(EVAL-WHEN (EVAL COMPILE) + (COND ((NOT (GET 'UMLMAC 'VERSION)) + (LOAD '((LISP) UMLMAC))))) + +(DEFPROP GMT -4 TIMEZONE-OFFSET) + +(DEFPROP EDT 0 TIMEZONE-OFFSET) +(DEFPROP EST 0 TIMEZONE-OFFSET) + +(DEFPROP CDT 1 TIMEZONE-OFFSET) +(DEFPROP CST 1 TIMEZONE-OFFSET) + +(DEFPROP MDT 2 TIMEZONE-OFFSET) +(DEFPROP MST 2 TIMEZONE-OFFSET) + +(DEFPROP PDT 3 TIMEZONE-OFFSET) +(DEFPROP PST 3 TIMEZONE-OFFSET) + +(DEFPROP MONDAY MONDAY DAY-VALUE) +(DEFPROP MON MONDAY DAY-VALUE) + +(DEFPROP TUESDAY TUESDAY DAY-VALUE) +(DEFPROP TUESDAY TUE DAY-VALUE) + +(DEFPROP WEDNESDAY WEDNESDAY DAY-VALUE) +(DEFPROP WEDNESDAY WED DAY-VALUE) + +(DEFPROP THURSDAY THURSDAY DAY-VALUE) +(DEFPROP THURSDAY THU DAY-VALUE) + +(DEFPROP FRIDAY FRIDAY DAY-VALUE) +(DEFPROP FRIDAY FRI DAY-VALUE) + +(DEFPROP SATURDAY SATURDAY DAY-VALUE) +(DEFPROP SATURDAY SAT DAY-VALUE) + +(DEFPROP SUNDAY SUNDAY DAY-VALUE) +(DEFPROP SUNDAY SUN DAY-VALUE) + +(DEFPROP JANUARY 1 MONTH-VALUE) +(DEFPROP JAN 1 MONTH-VALUE) + +(DEFPROP FEBRUARY 2 MONTH-VALUE) +(DEFPROP FEB 2 MONTH-VALUE) + +(DEFPROP MARCH 3 MONTH-VALUE) +(DEFPROP MAR 3 MONTH-VALUE) + +(DEFPROP APRIL 4 MONTH-VALUE) +(DEFPROP APR 4 MONTH-VALUE) + +(DEFPROP MAY 5 MONTH-VALUE) + +(DEFPROP JUNE 6 MONTH-VALUE) +(DEFPROP JUN 6 MONTH-VALUE) + +(DEFPROP JULY 7 MONTH-VALUE) +(DEFPROP JUL 7 MONTH-VALUE) + +(DEFPROP AUGUST 8 MONTH-VALUE) +(DEFPROP AUG 8 MONTH-VALUE) + +(DEFPROP SEPTEMBER 9 MONTH-VALUE) +(DEFPROP SEP 9 MONTH-VALUE) +(DEFPROP SEPT 9 MONTH-VALUE) + +(DEFPROP OCTOBER 10. MONTH-VALUE) +(DEFPROP OCT 10. MONTH-VALUE) + +(DEFPROP NOVEMBER 11. MONTH-VALUE) +(DEFPROP NOV 11. MONTH-VALUE) + +(DEFPROP DECEMBER 12. MONTH-VALUE) +(DEFPROP DEC 12. MONTH-VALUE) + +(DEFUN TIME:PARSE-WORD-INTERNAL () + (DECLARE (SPECIAL CHARS)) + (DO ((L NIL (CONS C L)) + (C (CAR CHARS) (CAR CHARS))) + ((AND (OR (< C #/A) (> C #/Z)) + (OR (< C #/a) (> C #/z))) + (IMPLODE (NREVERSE L))) + (SETQ C (IF (AND (NOT (< C #/a)) + (NOT (> C #/z))) + (- C #.(- #/a #/A)) + C)) + (POP CHARS))) + +(DEFUN TIME:PARSE-NUMBER-INTERNAL () + (DECLARE (SPECIAL CHARS)) + (DO ((FLAG NIL T) + (NUM 0 (+ (- (POP CHARS) #/0) (* NUM 10.)))) + ((NOT (MEMQ (CAR CHARS) + '(#/0 #/1 #/2 #/3 #/4 #/5 #/6 #/7 #/8 #/9))) + (AND FLAG NUM)))) + +(DEFUN GOTO MACRO (X) + #+DEBUG `(PROGN (FORMAT T "~&TO ~A N=~D. ~D//~D//~D ~D:~D:~D" + ',(CADR X) N O D Y H M S) + (GO ,(CADR X))) + #-DEBUG `(GO ,(CADR X))) + +(DEFUN TIME:PARSE-LIST (STRING) + (LET ((CHARS (EXPLODEN STRING)) + /0 /1 + (S -1) (M -1) (H -1) + (D -1) (O -1) (Y -1) + (Q 0.) (W NIL) (N -1) (X 0.) (R 0.)) + (DECLARE (SPECIAL CHARS S M H D O Y)) + (PROG () + MAIN + (DO () ((OR (NULL CHARS) + (NOT (MEMBER (CAR CHARS) + '(#/( #/) #/- #\TAB #\SPACE #\LF #\CR))))) + (POP CHARS)) + (IF (NULL CHARS) (GOTO RET)) + (WHEN (= (CAR CHARS) #/,) ;Watch for MONTH DAY, YR + (POP CHARS) + (WHEN (NOT (MINUSP O)) + (WHEN (NOT (MINUSP N)) + (WHEN (MINUSP D) + (SETQ D N) + (SETQ N -1)))) + (GOTO MAIN)) + (LET ((NUM (TIME:PARSE-NUMBER-INTERNAL))) + (WHEN NUM + (IF (NOT (MINUSP N)) (GOTO SYN)) + (SETQ N NUM) + (GOTO NUM))) + (SETQ /0 (TIME:PARSE-WORD-INTERNAL)) + (WHEN (SETQ /1 (GET /0 'MONTH-VALUE)) + (WHEN (NOT (MINUSP N)) + (SETQ D N) + (SETQ N -1)) + (SETQ X (LOGIOR X 2.)) + (SETQ O /1) + (GOTO MAIN)) + (WHEN (SETQ /1 (GET /0 'DAY-VALUE)) + (SETQ W /1) + (GOTO MAIN)) + (IF (EQ /0 'PM) (GOTO EVE)) + (GOTO NOT-EVE) + EVE + (COND ((MINUSP H) + (IF (OR (MINUSP N) (PLUSP (- N 12.))) (GOTO SYN)) + (SETQ H N) + (SETQ N -1.)) + ((NOT (MINUSP N)) (GOTO SYN))) + (IF (= H 12.) (SETQ H 0.)) + (SETQ H (+ H 12.)) + (GOTO MAIN) + NOT-EVE + (IF (EQ /0 'AM) (GOTO MORN)) + (GOTO NOT-MORN) + MORN + (COND ((MINUSP H) + (IF (OR (MINUSP N) (PLUSP (- N 12.))) (GOTO SYN)) + (SETQ H N) + (SETQ N -1.)) + ((NOT (MINUSP N)) (GOTO SYN))) + (IF (= H 12.) (SETQ H 0.)) + (GOTO MAIN) + NOT-MORN + (IF (EQ /0 'THE) (GOTO MAIN)) + (WHEN (SETQ /1 (GET /0 'TIMEZONE-OFFSET)) + (SETQ Q (+ Q /1)) + (GOTO MAIN)) + (IF (MEMQ /0 '(AT IN ON)) (GOTO MAIN)) + (IF (MEMQ /0 '(ST ND RD TH)) (GOTO DATE-END)) + (WHEN (AND (EQ /0 'O) + (NOT (MINUSP N))) + (UNLESS (AND (= (POP CHARS) #/') + (EQ (TIME:PARSE-WORD-INTERNAL) 'CLOCK)) + (GOTO SYN)) + (SETQ H N) + (SETQ X (LOGIOR X 1.)) + (SETQ N -1.) + (GOTO MAIN)) + (IF (EQ /0 'A) (GOTO MAIN)) + (WHEN (EQ /0 'NOON) + (IF (PLUSP (LOGAND X 1.)) (GOTO SYN)) + (SETQ H 12.) + (SETQ M 0.) + (SETQ S 0.) + (SETQ X (LOGIOR X 1.)) + (GOTO MAIN)) + (WHEN (EQ /0 'NOW) + (SETQ X (LOGIOR X 1.)) + (GOTO MAIN)) + (WHEN (EQ /0 'TODAY) + (GOTO MAIN)) + (WHEN (EQ /0 'TOMORROW) + (SETQ Q (+ Q 24.)) + (GOTO MAIN)) + (WHEN (EQ /0 'YESTERDAY) + (SETQ Q (- Q 24.)) + (GOTO MAIN)) + (WHEN (EQ /0 'HENCE) + (SETQ X (LOGIOR X 1.)) + (SETQ /0 'AFTER)) + (WHEN (MEMQ /0 '(AFTER FROM)) + (IF (NOT (MINUSP N)) (GOTO SYN)) + (SETQ Q (+ Q R)) + (SETQ R 0.) + (GOTO MAIN)) + (WHEN (MEMQ /0 '(AGO BEFORE)) + (IF (NOT (MINUSP N)) (GOTO SYN)) + (SETQ Q (- Q R)) + (SETQ R 0.) + (GOTO MAIN)) + (WHEN (EQ /0 'OF) + (IF (NOT (PLUSP R)) (GOTO MAIN)) + (IF (NOT (ZEROP (\ R 24.))) (GOTO SYN)) + (SETQ Q (+ Q (- R 24.))) + (SETQ R 0.) + (GOTO MAIN)) + (WHEN (MEMQ /0 '(WK WKS WEEK WEEKS)) + (SETQ R (+ R (* (IF (MINUSP N) 1 N) 168.))) + (SETQ N -1.) + (GOTO MAIN)) + (WHEN (MEMQ /0 '(DY DYS DAY DAYS)) + (SETQ R (+ R (* (IF (MINUSP N) 1 N) 24.))) + (SETQ N -1.) + (GOTO MAIN)) + (WHEN (MEMQ /0 '(HR HRS HOUR HOURS)) + (SETQ R (+ R (IF (MINUSP N) 1 N))) + (SETQ N -1.) + (GOTO MAIN)) + (WHEN (MEMQ /0 '(AFTERNOON EVENING NIGHT LATE)) (GOTO EVE)) + (WHEN (MEMQ /0 '(MORNING EARLY)) (GOTO MORN)) + (WHEN (MINUSP N) + (PROG () + (WHEN (MEMQ /0 '(FIFTY FIFTIETH )) (SETQ N 50.) (GOTO CK-UNITS)) + (WHEN (MEMQ /0 '(FORTY FORTIETH )) (SETQ N 40.) (GOTO CK-UNITS)) + (WHEN (MEMQ /0 '(THIRTY THIRTIETH)) (SETQ N 30.) (GOTO CK-UNITS)) + (WHEN (MEMQ /0 '(TWENTY TWENTIETH)) (SETQ N 20.) (GOTO CK-UNITS)) + (GOTO NOTENS) + CK-UNITS + (WHEN (= (CAR CHARS) #/-) + (POP CHARS) + (SETQ /0 (TIME:PARSE-WORD-INTERNAL)) + (GOTO UNITS)) + (RETURN T) + NOTENS + (WHEN (MEMQ /0 '(NINETEEN NINETEENTH )) (SETQ N 19.) (RETURN T)) + (WHEN (MEMQ /0 '(EIGHTEEN EIGHTEENTH )) (SETQ N 18.) (RETURN T)) + (WHEN (MEMQ /0 '(SEVENTEEN SEVENTEENTH)) (SETQ N 17.) (RETURN T)) + (WHEN (MEMQ /0 '(SIXTEEN SIXTEENTH )) (SETQ N 16.) (RETURN T)) + (WHEN (MEMQ /0 '(FIFTEEN FIFTEENTH )) (SETQ N 15.) (RETURN T)) + (WHEN (MEMQ /0 '(FOURTEEN FOURTEENTH )) (SETQ N 14.) (RETURN T)) + (WHEN (MEMQ /0 '(THIRTEEN THIRTEENTH )) (SETQ N 13.) (RETURN T)) + (WHEN (MEMQ /0 '(TWELVE TWELFTH )) (SETQ N 12.) (RETURN T)) + (WHEN (MEMQ /0 '(ELEVEN ELEVENTH )) (SETQ N 11.) (RETURN T)) + (WHEN (MEMQ /0 '(TEN TENTH )) (SETQ N 10.) (RETURN T)) + UNITS + (WHEN (MEMQ /0 '(NINE NINTH)) + (IF (MINUSP N) (SETQ N 0.)) + (SETQ N (+ N 9.)) + (RETURN T)) + (WHEN (MEMQ /0 '(EIGHT EIGHTH)) + (IF (MINUSP N) (SETQ N 0.)) + (SETQ N (+ N 8.)) + (RETURN T)) + (WHEN (MEMQ /0 '(SEVEN SEVENTH)) + (IF (MINUSP N) (SETQ N 0.)) + (SETQ N (+ N 7.)) + (RETURN T)) + (WHEN (MEMQ /0 '(SIX SIXTH)) + (IF (MINUSP N) (SETQ N 0.)) + (SETQ N (+ N 6.)) + (RETURN T)) + (WHEN (MEMQ /0 '(FIVE FIFTH)) + (IF (MINUSP N) (SETQ N 0.)) + (SETQ N (+ N 5.)) + (RETURN T)) + (WHEN (MEMQ /0 '(FOUR FOURTH)) + (IF (MINUSP N) (SETQ N 0.)) + (SETQ N (+ N 4.)) + (RETURN T)) + (WHEN (MEMQ /0 '(THREE THIRD)) + (IF (MINUSP N) (SETQ N 0.)) + (SETQ N (+ N 3.)) + (RETURN T)) + (WHEN (MEMQ /0 '(TWO SECOND)) + (IF (MINUSP N) (SETQ N 0.)) + (SETQ N (+ N 2.)) + (RETURN T)) + (WHEN (MEMQ /0 '(ONE FIRST A AN)) + (IF (MINUSP N) (SETQ N 0.)) + (SETQ N (+ N 1.)) + (RETURN T)))) + (IF (NOT (MINUSP N)) (GOTO NUM)) + SYN + (ERROR "Syntax error in time spec" STRING) + DATE-END + (WHEN (AND (PLUSP N) + (MINUSP (- N 32.))) + (SETQ D N) + (SETQ N -1.) + (SETQ X (LOGIOR X 2.)) + (GOTO MAIN)) + (GOTO SYN) + NUM ;By now, N must have a positive number in it + (WHEN (AND (PLUSP (- N 1899.)) + (MINUSP Y)) + (SETQ Y (- N 1900.)) + (SETQ N -1.) + (SETQ X (LOGIOR X 2.)) + (GOTO MAIN)) + (WHEN (< N 100.) + (COND ((= (CAR CHARS) #/:) + (IF (NOT (ZEROP (LOGAND X 1.))) (GOTO SYN)) + (SETQ X (LOGIOR X 1.)) + (IF (PLUSP (- N 24.)) (GOTO SYN)) + (SETQ H N) + (SETQ N -1.) + (POP CHARS) + (SETQ M (TIME:PARSE-NUMBER-INTERNAL)) + (IF (NOT M) (GOTO SYN)) + (SETQ S (IF (NOT (= (CAR CHARS) #/:)) 0 + (POP CHARS) + (TIME:PARSE-NUMBER-INTERNAL))) + (IF (NOT S) (GOTO SYN)) + (GOTO SYN)) + ((MEMBER (CAR CHARS) '(#/- #//)) + (IF (NOT (ZEROP (LOGAND X 2.))) (GOTO SYN)) + (SETQ X (LOGIOR X 2.)) + (POP CHARS) + (SETQ /0 (TIME:PARSE-NUMBER-INTERNAL)) + (IF (NOT /0) (GOTO NOTDATE)) + (IF (PLUSP (- N 12.)) (GOTO SYN)) + (SETQ O N) + (SETQ N -1.) + (SETQ D /0) + (SETQ Y (IF (NOT (MEMBER (CAR CHARS) '(#// #/-))) 0 + (TIME:PARSE-NUMBER-INTERNAL))) + (IF (NOT Y) (GOTO SYN)) + (GOTO MAIN)))) + NOTDATE + (WHEN (AND (NOT (MINUSP D)) + (NOT (MINUSP O)) + (MINUSP Y) + (> N 24.)) + (SETQ Y N) + (SETQ X (LOGIOR X 2.)) + (SETQ N -1.) + (GOTO MAIN)) + (WHEN (AND (NOT (MINUSP Y)) + (NOT (MINUSP O)) + (NOT (MINUSP D))) + (WHEN (ZEROP (LOGAND X 1.)) + (IF (< N 25.) (GOTO MAIN)) + (SETQ H (// N 100.)) + (SETQ M (- N (* H 100.))) + (SETQ S 0.) + (SETQ X (LOGIOR X 2.)) + (SETQ N -1.) + (GOTO MAIN))) + (WHEN (AND (NOT (MINUSP O)) + (MINUSP D) + (OR (ZEROP (LOGAND X 1.)) + (AND (NOT (MINUSP H)) + (NOT (MINUSP M)) + (NOT (MINUSP S))))) + (SETQ D N) + (SETQ X (LOGIOR X 2.)) + (SETQ N -1.) + (GOTO MAIN)) + (GOTO MAIN) + RET + (WHEN (NOT (MINUSP N)) + (WHEN (MINUSP D) + (SETQ D N) (SETQ N -1.) (SETQ X (LOGIOR X 2.)) (GOTO DEFAULTS)) + (WHEN (MINUSP Y) + (WHEN (> N 24.) + (SETQ Y N) (SETQ N -1.) (SETQ X (LOGIOR X 2.)) (GOTO DEFAULTS))) + (WHEN (MINUSP H) + (SETQ H N) (SETQ N -1.) (SETQ X (LOGIOR X 1.)) (GOTO DEFAULTS)) + (GOTO SYN)) + DEFAULTS + (LET ((DATE (STATUS DATE)) + (DOW (STATUS DOW)) + (TIME (STATUS DAYTIME))) + (WHEN (NOT (EQUAL (STATUS DATE) DATE)) ;just after midnite? + (SETQ DATE (STATUS DATE)) + (SETQ DOW (STATUS DOW)) + (SETQ TIME (STATUS DAYTIME))) + (PROG () + (WHEN (AND (NOT (ZEROP (LOGAND X 1.))) + (MINUSP H) + (MINUSP M) + (MINUSP S)) + (SETQ H (CAR TIME) M (CADR TIME) S (CADDR TIME))) + (IF (MINUSP H) (SETQ H 0.)) + (IF (MINUSP M) (SETQ M 0.)) + (IF (MINUSP S) (SETQ S 0.)) + (WHEN (AND (NOT (ZEROP (LOGAND X 2.))) + (MINUSP Y) + (MINUSP O) + (MINUSP D)) + (GOTO TODAY)) + (IF (NOT (ZEROP (LOGAND X 2.))) (GOTO NOT-TODAY)) + TODAY + (SETQ Y (CAR DATE)) + (SETQ O (CADR DATE)) + (SETQ D (CADDR DATE)) + NOT-TODAY + (IF (MINUSP Y) (SETQ Y (CAR DATE))) + (IF (MINUSP O) (SETQ O (IF (MINUSP D) 1 (CADR DATE)))) + (IF (MINUSP D) (SETQ D 1.))) + (WHEN (NOT (ZEROP Q)) + (SETQ /0 (+ 1 (* 2 (IF (PLUSP Q) -1 0)))) + (SETQ H (+ H Q)) + (PROG () + TOP + (TIME:NORMALIZE-DATE-INTERNAL) + (IF (AND (NOT (MINUSP H)) (< H 24.)) + (RETURN T)) + (SETQ W NIL) + (SETQ H (+ H (* 24. /0))) + (SETQ D (- D /0)) + (GO TOP))) + ;W holds specified date or NIL. We ignore that for now... + (RETURN + (LIST S M H D O Y + (TIME:DAY-OF-THE-WEEK-STRING + (TIME:ON-WHAT-DAY-OF-THE-WEEK? D O Y)))))))) + +(DEFUN TIME:NORMALIZE-DATE-INTERNAL () + (DECLARE (SPECIAL Y O D H M S)) + (PROG (TT X) + (IF (AND (PLUSP D) (MINUSP (- D 29.))) (RETURN T)) + (SETQ TT (TIME:ON-WHAT-DAY-OF-THE-WEEK? D O Y)) + (COND ((NOT (PLUSP D)) + (SETQ O (1- O)) + (SETQ D 28.) + (WHEN (ZEROP O) (SETQ O 12.) (SETQ Y (1- Y))) + (SETQ X (TIME:ON-WHAT-DAY-OF-THE-WEEK? D O Y)) + (IF (MINUSP (- TT X)) (SETQ TT (+ TT 7))) + (SETQ D (+ D TT (- X)))) + (T + (LET ((YY Y) (OO (1+ O)) (DD 1)) + (WHEN (> O 12.) (SETQ O 1) (SETQ Y (1+ Y))) + (SETQ X (TIME:ON-WHAT-DAY-OF-THE-WEEK? DD OO YY)) + (IF (ZEROP (- X TT)) (SETQ Y YY O OO D DD))))))) diff --git a/src/rlb%/fasdmp.124 b/src/rlb%/fasdmp.124 new file mode 100755 index 00000000..975aeebb --- /dev/null +++ b/src/rlb%/fasdmp.124 @@ -0,0 +1,367 @@ + +(DECLARE (SPECIAL LFASDHASH ATOMINDEX DSK) + (FIXNUM LFASDHASH ATOMINDEX (EQHASH) (ATOMINDEX)) + (ARRAY* (NOTYPE FASDHASH1 1 FASDHASH2 1)) + (EVAL (READ))) +(SETQ IBASE 8. BASE 8. *NOPOINT NIL) + +(PROG2 NIL 'FASDUMP-SETUP + (SETQ LFASDHASH 377) + (ARRAY FASDHASH1 T (1+ LFASDHASH)) + (ARRAY FASDHASH2 T (1+ LFASDHASH))) + + +(DEFUN FASDUMP (TARGETFILE NONEQFORMS EQFORMS FASDUMPALIST) + (PROG (F) + (SETQ TARGETFILE (MERGEF TARGETFILE '(* FASL))) + (SETQ F (OPEN (MERGEF '(|.FASD.| OUTPUT) TARGETFILE) + '(OUT FIXNUM DSK BLOCK))) + (*FASDUMP F NONEQFORMS EQFORMS FASDUMPALIST) + (SETQ TARGETFILE (TRUENAME (RENAMEF F TARGETFILE))) + (CLOSE F) + (RETURN TARGETFILE))) + +(DEFUN *FASDUMP (DSK NONEQFORMS EQFORMS FASDUMPALIST) + (PROG (ATOMINDEX) + (DECLARE (FIXNUM I)) + (FILLARRAY 'FASDHASH1 '(NIL)) + (FILLARRAY 'FASDHASH2 '(NIL)) + (COND (EQFORMS + (DO ALIST FASDUMPALIST (CDR ALIST) (NULL ALIST) + (SINTERN1 (CAAR ALIST) 'PUT) ;CAUSE THE ALIST FORMS + (SINTERN2 (CAAR ALIST) 'PUT) ; TO BE KNOWN + (INTERNATOMS (CDAR ALIST))) ;AND THE ATOMS, TOO. + (MAPC (FUNCTION COLLECTEQFORMS) EQFORMS))) + (MAPC (FUNCTION INTERNATOMS) NONEQFORMS) + (DO I 0 (1+ I) (> I LFASDHASH) + (RPLACA-LIST-WITH-NIL (FASDHASH1 I) (FASDHASH2 I))) + (OUT DSK (CAR (PNGET '*FASL* 6))) + (OUT DSK 0) ;LISP VERSION NO., IMMATERIAL + (INITBUFFERBIN) + (SETQ ATOMINDEX 0) + (ZAPATOMS) ;GROVEL OVER THE "OBARRAYS" TO ZAP ATOMS + (COND (EQFORMS + (MAPC (FUNCTION ZAPALIST) FASDUMPALIST);ALIST FORMS + (DO I 0 (1+ I) (> I LFASDHASH) ;ZAP THE DUP FORMS + (MAPC (FUNCTION ZAPEQFORM) (FASDHASH2 I))) + (MAPC (FUNCTION ZAPFORM) EQFORMS)));AND THE FORMS + (MAPC (FUNCTION ZAPFORM) NONEQFORMS) + (BUFFERBIN 17 NIL) ;FINALLY CLOSE UP THE FASL OUTPUT FILE + (FILLARRAY 'FASDHASH1 '(NIL)) + (FILLARRAY 'FASDHASH2 '(NIL)) + (RETURN DSK))) + +(DEFUN INTERNATOMS (FORM) + (DO ((FORM FORM (CDR FORM))) + ((ATOM FORM) + (COND (FORM (SINTERN1 FORM 'PUT) + (SINTERN2 FORM 'PUT)))) + (INTERNATOMS (CAR FORM)))) + +(DEFUN COLLECTEQFORMS (FORM) + (DO ((FORM FORM (CDR FORM))) + ((ATOM FORM) ;ALWAYS "INTERN" ATOMS, BUT NEVER NIL + (COND (FORM (SINTERN1 FORM 'PUT) + (SINTERN2 FORM 'PUT)))) + (COND ((SINTERN1 FORM 'PUT) ;MIGHT AS WELL STOP, WE'VE + (SINTERN2 FORM 'PUT) ;BEEN HERE BEFORE. + (RETURN T))) + (COLLECTEQFORMS (CAR FORM)))) + + +(DEFUN SINTERN MACRO (FORM) + ((LAMBDA (NUFORM) + (RPLACA FORM (CAR NUFORM)) + (RPLACD FORM (CDR NUFORM)) + FORM) + (SUBLIS + (LIST (CONS 'ARY (CADR FORM))) + '(LET ((EQH (EQHASH OBJ)) TEM) + (SETQ TEM (ARY EQH)) + (COND ((EQ FLAG '?) (AND (MEMQ OBJ TEM) T)) + ((EQ FLAG 'PUT) + (COND ((MEMQ OBJ TEM) T) + (T (STORE (ARY EQH) (CONS OBJ TEM)) + NIL))) + ((EQ FLAG 'REM) + (STORE (ARY EQH) (DELQ OBJ TEM 1)))))))) + +(DEFUN SINTERN1 (OBJ FLAG) (SINTERN FASDHASH1)) +(DEFUN SINTERN2 (OBJ FLAG) (SINTERN FASDHASH2)) + +(DEFUN ZAPATOMS NIL ; OUTPUT ALL THE ATOMS (INCL NOS.) + (DECLARE (FIXNUM I)) + (DO I 0 (1+ I) (> I LFASDHASH) ;GROVEL BUCKET TO BUCKET + (DO ((FORMS (FASDHASH2 I) (CDR FORMS)) ;OVER EACH BUCKET + (PLACES (FASDHASH1 I) (CDR PLACES))) + ((NULL FORMS)) + (COND ((AND (ATOM (CAR FORMS)) (NULL (CAR PLACES))) + (RPLACA PLACES (SETQ ATOMINDEX (1+ ATOMINDEX))) + (BUFFERBIN 12 (CAR FORMS))))))) + +;ZAP OUT AN ATOMTABLE ENTRY FOR THE EVAL MUNGEABLE WHICH IS THE +;CDR OF EACH ALIST MEMBER. ENTRY 16 TO BUFFERBIN HAS BEEN +;HACKED TO CAUSE RESULT OF MUNGING TO BE ENTERED INTO ATOMTB, +;RATHER THAN THROWN AWAY. (I.E. CALL WITH CODE 36). +(DEFUN ZAPALIST (ALIST-MEMBER) + (LET ((EQH (EQHASH (CAR ALIST-MEMBER)))) + (DO ((FORMS (FASDHASH2 EQH) (CDR FORMS)) + (PLACES (FASDHASH1 EQH) (CDR PLACES))) + ((EQ (CAR ALIST-MEMBER) (CAR FORMS)) + (RPLACA PLACES (SETQ ATOMINDEX (1+ ATOMINDEX))) + (BUFFERBIN 36 (CDR ALIST-MEMBER)))))) + +(DEFUN EQHASH (X) (/\ (MAKNUM X) LFASDHASH)) + +;RETURNS RPLACA-ABLE SUBLIST WITH : +;(CAR ) = INDEX OF ATOMTABLE ENTRY IF ONE IS THERE +;ELSE (CAR ) = NIL IF ENTRY IS THERE BUT ITS INDEX IS STILL +; UNKNOWN +;ELSE = NIL (=> NO ENTRY) + +(DEFUN ATOMINDEX1 (FORM) + (COND ((NULL FORM) '(0)) + (T (LET ((EQH (EQHASH FORM))) + (DO ((FORMS (FASDHASH2 EQH) (CDR FORMS)) + (PLACES (FASDHASH1 EQH) (CDR PLACES))) + ((NULL FORMS) NIL) + (COND ((EQ FORM (CAR FORMS)) + (RETURN PLACES)))))))) + +(DEFUN ATOMINDEX (FORM) + (COND ((NULL FORM) 0) + (T (LET ((ATX (ATOMINDEX1 FORM))) + (COND ((OR (NULL ATX) (NULL (CAR ATX))) + (ERROR '|No atomindex found| FORM 'WRNG-TYPE-ARG)) + (T (CAR ATX))))))) + +(DEFUN ZAPEQFORM (FORM) + (PROG (ATX) +;DON'T HAVE TO ZAP IF ATOM OR IF ALREADY ZAPPED + (COND ((OR (ATOM FORM) + (AND (SETQ ATX (ATOMINDEX1 FORM)) + (CAR ATX)))) + ((NULL ATX) ;NOT AN "EQ FORM" + (ZAPEQFORM (CAR FORM)) + (ZAPEQFORM (CDR FORM))) + (T + (ZAPEQFORM (CAR FORM)) + (ZAPEQFORM (CDR FORM)) + (RPLACA ATX (SETQ ATOMINDEX (1+ ATOMINDEX))) + ;;It's OK to inc ATOMINDEX before BUFFERBIN because + ;;ATOMINDEX is inc'ed only by ZAPATOMS, ZAPALIST, and ZAPEQFORM + ;;all of which have run by the time we get here. + (BUFFERBIN 25 FORM))))) + +;ZAP FOR EVAL, THROW AWAY. NOTE THAT LISTOUT AND ATOMINDEX +;(CALLED BY BUFFERBIN) HAVE BEEN HACKED CONSIDERABLY. +(DEFUN ZAPFORM (FORM) (BUFFERBIN 16 FORM)) + +(DEFUN RPLACA-LIST-WITH-NIL (A B) + (COND (A (COND (B (DO ((A (RPLACA A NIL) (RPLACA (CDR A) NIL)) + (B (CDR B) (CDR B))) + ((NULL B) (AND A (RPLACD A NIL))))) + (T (RPLACA A NIL) (RPLACD A NIL)))))) + +(DECLARE (SPECIAL BINCT) + (FIXNUM (UNBYTES FIXNUM) (ATOMINDEX) (ARGSPROPEVAL) + TYPN BINCT) + (ARRAY* (FIXNUM BINTYPARRAY 1) + (NOTYPE BINFORMARRAY 1 BINDISPATCHARRAY 1)) + (SETQ INTERPRETED NIL) + (READ)) +(SETQ INTERPRETED T) + +(DEFUN CONDINTERPRETED MACRO (FORM) + ((LAMBDA (NUFORM) (RPLACA FORM (CAR NUFORM)) + (RPLACD FORM (CDR NUFORM)) + FORM) + (COND (INTERPRETED (COND ((= 1 (LENGTH (CADR FORM))) + (CAADR FORM)) + (T (CONS 'PROGN (CADR FORM))))) + (T (COND ((= 1 (LENGTH (CADDR FORM))) + (CAADDR FORM)) + (T (CONS 'PROGN (CADDR FORM)))))))) + +(DEFUN CALL MACRO (FORM) + (LET ((TYPLIST '(T NIL FIXNUM FLONUM)) NUFORM) + (SETQ NUFORM + (COND (INTERPRETED + (CONS 'FUNCALL + (COND ((MEMQ (CADR FORM) TYPLIST) + (CDDR FORM)) + (T (CDR FORM))))) + (T (CONS 'SUBRCALL + (COND ((MEMQ (CADR FORM) TYPLIST) + (CDR FORM)) + (T (CONS NIL (CDR FORM)))))))) + (RPLACA FORM (CAR NUFORM)) + (RPLACD FORM (CDR NUFORM)) + FORM)) + +(DEFUN INITBUFFERBIN NIL + (DECLARE (FIXNUM I)) + (SETQ BINCT 0) + (ARRAY BINTYPARRAY FIXNUM 9.) + (ARRAY BINFORMARRAY T 9.) + (CONDINTERPRETED ((ARRAY BINDISPATCHARRAY T 20)) + ((ARRAY BINDISPATCHARRAY NIL 20))) + (DO ((I 0 (1+ I)) (L '(OUT2 OUT2 OUT2 OUT2 + OUT2 BUFQTL OUT2 BUFGET + OUT2 BUFFERBINBARF BUFATX BUFENT + BUFFERBINBARF BUFPUT BUFMNG BUFEND) + (CDR L))) + ((NULL L)) + (CONDINTERPRETED ((STORE (BINDISPATCHARRAY I) (CAR L))) + ((STORE (BINDISPATCHARRAY I) + (GET (CAR L) 'SUBR)))))) + + +(DEFUN BUFFERBIN (BINTYP BINFORM) + (DECLARE (FIXNUM BINTYP)) + (STORE (BINTYPARRAY BINCT) BINTYP) + (STORE (BINFORMARRAY BINCT) BINFORM) + (SETQ BINTYP (BOOLE 1 17 BINTYP)) + (COND ((= BINTYP 17) + (OUT DSK (UNBYTES BINCT)) + (DO I 0 (1+ I) (> I BINCT) + (CALL (BINDISPATCHARRAY + (BOOLE 1 17 (BINTYPARRAY I))) + (BINTYPARRAY I) + (BINFORMARRAY I)))) + ((> (SETQ BINCT (1+ BINCT)) 8.) + (OUT DSK (UNBYTES 8.)) + (DO I 0 (1+ I) (> I 8.) + (CALL (BINDISPATCHARRAY + (BOOLE 1 17 (BINTYPARRAY I))) + (BINTYPARRAY I) + (BINFORMARRAY I))) + (SETQ BINCT 0)))) + + +;;; GOBBLES 4-BIT BYTES FROM CT ELEMENTS OF BINTYPARRAY +;;; AND COMBINES THEM INTO ONE FIXNUM +(DEFUN UNBYTES (CT) + (DECLARE (FIXNUM CT I N)) + (DO ((I 1 (1+ I)) (N (BOOLE 1 17 (BINTYPARRAY 0)))) + ((< CT I) (LSH N (- 32. (* 4 CT)))) + (SETQ N (BOOLE 7 (LSH N 4) + (BOOLE 1 17 (BINTYPARRAY I)))))) + +(DEFUN OUT2 (AS DUMMY) (OUT DSK AS)) + +;;; QUOTED LIST +;;; TYPE 5: ( . ) +;;; TERMINATE LIST WITH -1,, +;;; TYPE 25: TERMINATE LIST WITH -2,,0 [ENTER INTO ATOM TABLE] + +(DEFUN BUFQTL (TYPN FORM) + (COND ((ZEROP (BOOLE 1 20 TYPN)) + (LISTOUT (CDR FORM) NIL) + (OUT DSK (BOOLE 7 -1_18. (LSH (CAR FORM) -18.))) + (OUT DSK (SXHASH (CDR FORM)))) + (T (LISTOUT FORM 1) + (OUT DSK -2_18.) + (OUT DSK (SXHASH FORM))))) + +;;; GETDDTSYM, TYPE 7 ( . ) + +(DEFUN BUFGET (TYPN FORM) + (OUT DSK(CAR FORM)) + (AND (CDR FORM) (OUT DSK (CDR FORM)))) + +;;; ATOMINDEX INFO, TYPE 12 + +(DEFUN BUFATX (TYPN FORM) + (LET ((TYPE (TYPEP FORM))) + (COND ((EQ TYPE 'SYMBOL) + (SETQ FORM (PNGET FORM 7)) + (OUT DSK(LENGTH FORM)) + (MAPC (FUNCTION (LAMBDA (X) (OUT DSK X))) FORM)) + ((EQ TYPE 'FIXNUM) (OUT DSK 1_33.) (OUT DSK FORM)) + ((EQ TYPE 'FLONUM) (OUT DSK 2_33.) (OUT DSK (ROT FORM 0))) + ((EQ TYPE 'BIGNUM) + (OUT DSK (BOOLE 7 3_33. + (COND ((MINUSP FORM) 7_18.) (T 0)) + (LENGTH (CDR FORM)))) + (BUFBNCDR (CDR FORM))) + (T (BUFATX + TYPN (ERROR '|Ill-formed expression - BUFATX| + FORM 'WRNG-TYPE-ARG)))))) + +;;; RECURSIVELY ITERATES ON CDR OF A BIGNUM TO OUTPUT COMPONENTS +;;; IN REVERSE ORDER +(DEFUN BUFBNCDR (N) + (AND (CDR N) (BUFBNCDR (CDR N))) + (OUT DSK (CAR N))) + +;;; ENTRY INFO, TYPE 13 +;;; ((( . ) . ) . ) +;;; WHERE IS NIL OR ( . ) +(DEFUN BUFENT (TYPN FORM) + (OUT DSK(BOOLE 7 (LSH (ATOMINDEX (CAAAR FORM)) 18.) + (ATOMINDEX (CDAAR FORM)))) + (OUT DSK + (COND ((NULL (CDR FORM)) 0) + (T (BOOLE 7 (LSH (ARGSPROPEVAL (CADR FORM)) 27.) + (LSH (ARGSPROPEVAL (CDDR FORM)) 18.)))))) + +(DEFUN ARGSPROPEVAL (X) + (COND ((NULL X) 0) ((< X 777) (1- X)) (T 777))) + +;;; PUTDDTSYM, TYPE 15 + +(DEFUN BUFPUT (TYPN FORM) (OUT DSK (SQOZ/| (NCONS FORM)))) + +;;; EVAL MUNGEABLE +;;; TYPE 16, TERMINATE WITH -1,,0 [THROW AWAY VALUE] +;;; TYPE 36, TERMINATE WITH -2,,0 [ENTER VALUE IN ATOMTABLE] + +(DEFUN BUFMNG (TYPN FORM) + (COND ((ZEROP (BOOLE 1 20 TYPN)) + (LISTOUT FORM T) (OUT DSK -1_18.)) + (T (LISTOUT FORM NIL) (OUT DSK -2_18.)))) + + +;;; END OF BINARY, TYPE 17, FORM IS IGNORED +(DEFUN BUFEND (TYPN FORM) (OUT DSK (CAR (PNGET '*FASL* 6)))) + + +;;; LISTOUT OUTPUTS AN S-EXPRESSION AS A SEQUENCE OF LIST-SPECS. +;;; LISTOUT IS USED BY BUFFERBIN FOR VARIOUS TYPES. +;;; EACH LIST-SPEC MAY BE AS FOLLOWS: +;;; 0,,N THE ATOM WHOSE ATOMINDEX IS N +;;; 100000,,N LISTIFY THE LAST N ITEMS, TO CREATE A NEW ITEM +;;; 200000,,N MAKE A DOTTED LIST OUT OF THE LAST N+1 ITEMS +;;; A SEQUENCE OF LIST-SPECS IS TERMINATED BY A WORD WHOSE LEFT +;;; HALF IS -1. (LISTOUT DOES NOT GENERATE THIS WORD, BUFFERBIN +;;; DOES.) +;;; FLAG TELLS LISTOUT WHETHER OR NOT TO TRY TO PRESERVE +;;; EQ-NESS, I.E. WHETHER OR NOT TO TERMINATE LIST DO WITH CHECK +;;; FOR ATOM OR FOR ATOMINDEX. +(DEFUN LISTOUT (X FLAG) + (DECLARE (FIXNUM I N)) + (LET ((TYPE (TYPEP X))) + (COND ((EQ TYPE 'RANDOM) + (SETQ X (ERROR '|Randomness in LISTOUT| X 'WRNG-TYPE-ARG)) + (LISTOUT X FLAG)) + ((NOT (EQ TYPE 'LIST)) (OUT DSK (ATOMINDEX X))) + ((DO ((I 0 (1+ I)) (Y X (CDR Y)) (FL)) + ((COND ((NULL Y) (OUT DSK (BOOLE 7 1_41 I))) + ((ATOM Y) + (OUT DSK (ATOMINDEX Y)) + (OUT DSK (BOOLE 7 2_41 I))) + ((AND (EQ FLAG T) (SETQ FL (ATOMINDEX1 Y))) + (COND ((NULL (CAR FL)) + (SETQ FL (NCONS + (ERROR '|No atomindex| + Y 'WRNG-TYPE-ARG))))) + (OUT DSK (CAR FL)) + (OUT DSK (BOOLE 7 2_41 I))) + (FLAG (SETQ FLAG T) NIL))) + (LISTOUT (CAR Y) FLAG)))))) + +;; Local Modes: +;; Mode:LISP +;; Comment Column:40 +;; END: