;;; -*- 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)

#+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
	  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.)
	      ;; ejs: commented out as per Alan Sampson. This is an incorrect
	      ;; check.
	      ;; (// 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)))))))