mirror of
https://github.com/PDP-10/its.git
synced 2026-02-01 22:42:26 +00:00
Remove old version of LIBDOC; TIME.
This commit is contained in:
Adam Sampson
committed by
Adam Sampson
Adam Sampson
parent
dd878358cf
commit
2e7c9ac33a
@@ -1,692 +0,0 @@
|
||||
;;; -*- 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)))))))
|
||||
Reference in New Issue
Block a user