github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-01-26 12:12:12 +00:00
Code Issues Releases Wiki Activity

Added sources and build instructions for Lisp library packages

Browse Source 
required by Macsyma. Resolves #706.
This commit is contained in:
Eric Swenson
2018-03-06 16:08:48 -08:00
committed by Lars Brinkhoff
parent 1bb26d9206
commit aefb232db9
8 changed files with 1715 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

79
src/libdoc/break.gjc1 Executable file
View File

@@ -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)))))))

282
src/libdoc/iota.kmp1 Normal file
View File

@@ -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 ((<var1> <filename1> <filemodes1>)
;;; (<var2> <filename2> <filemodes2>) ...)
;;; <body>)
;;;
;;;
;;; Description:
;;;
;;; [1] <var1> ... <varN> are, in essence, bound to
;;; (OPEN <filenameK> <filemodeK>)
;;; for K = 1 thru N.
;;;
;;; [2] <filename>'s and <filemode>'s are evaluated before entering
;;; the context in which the <var>'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 (<temp> <var1> <var2> ... <varN>)
;;; (UNWIND-PROTECT
;;; (PROGN (WITHOUT-INTERRUPTS
;;; (SETQ <var1> (APPLY 'OPEN (POP <temp>)))
;;; (SETQ <var2> (APPLY 'OPEN (POP <temp>)))
;;; ...)
;;; <body>)
;;; (AND (OR (SFAP <var1>) (FILEP <var1>)) (CLOSE <var1>))
;;; (AND (OR (SFAP <var2>) (FILEP <var2>)) (CLOSE <var2>))
;;; ...))
;;; (LIST (LIST <filename1> <filemodes1>) (LIST <filename2> <filemodes2>) ...)
;;; () () ... ())
;;;
;;; 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 ((<var1> <form1>)
;;; (<var2> <form2>) ...)
;;; <body>)
;;;
;;; Description:
;;;
;;; [1] <var1> ... <varN> are, in essence, bound to
;;; the EVAL'd form of <formK>.
;;; for K = 1 thru N.
;;;
;;; [2] <form1> ... <formN> are evaluated outside of the scope of
;;; <var1> ... <varN> according to traditional
;;; LET-semantics. They should return file objects
;;; or SFA's.
;;;
;;; [3] <body> 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 (<temp> <temp'>)
;;; (UNWIND-PROTECT
;;; (PROGN
;;; (WITHOUT-INTERRUPTS
;;; (SETQ <temp'> <form1>)
;;; (SETQ <temp> (CONS <temp'> <temp>))
;;; ...
;;; (SETQ <temp'> <form2>)
;;; (SETQ <temp> (CONS <temp'> <temp>))
;;; (SETQ <temp'> <form2>)
;;; (SETQ <temp> (CONS <temp'> <temp>))
;;; (SETQ <temp'> ())
;;; (SETQ <temp> (REVERSE <temp>)))
;;; ((LAMBDA (<var1> <var2> <var3> ... <varN>)
;;; (UNWIND-PROTECT (PROGN (SETQ <var1> (CAR <temp>))
;;; (POP <temp>)
;;; (SETQ <var2> (CAR <temp>))
;;; (POP <temp>)
;;; ...
;;; (SETQ <varN> (CAR <temp>))
;;; (POP <temp>)
;;; <body>)
;;; (AND (OR (FILEP <var1>) (SFAP <var1>))
;;; (CLOSE <var1>))
;;; (AND (OR (FILEP <var2>) (SFAP <var2>))
;;; (CLOSE <var2>))
;;; ...
;;; (AND (OR (FILEP <varN>) (SFAP <varN>))
;;; (CLOSE <varN>))))
;;; () () () ... ()))
;;; (COND ((OR (FILEP <temp'>) (SFAP <temp'>))
;;; (CLOSE <temp'>)))
;;; (DO ((X <temp> (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)

156
src/libdoc/letfex.gjc2 Executable file
View File

@@ -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 (&QUOTE &REST L) (LETFEX L))
(DEFUN LET* (&QUOTE &REST L) (LET*FEX L))
(DEFUN DESETQ (&QUOTE &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)))))

91
src/libdoc/lusets.alan Executable file
View File

@@ -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)

36
src/libdoc/smurf.rwk1 Executable file
View File

@@ -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)))

692
src/libdoc/time.kmp8 Normal file
View File

@@ -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)))))))