;;;  -*- cold-load:t; Mode:COMMON-LISP; Package:TIME; BASE:8; Fonts:cptfont,MEDFNT,HL12B,HL12BI -*-

;1;;                           RESTRICTED RIGHTS LEGEND*

;1;;Use, duplication, or disclosure by the Government is subject to*
;1;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in*
;1;;Technical Data and Computer Software clause at 52.227-7013.*

;1;;                     TEXAS INSTRUMENTS INCORPORATED.*
;1;;                              P.O. BOX 2909*
;1;;                           AUSTIN, TEXAS 78769*
;1;;                                 MS 2151*

;1;; Copyright (c) 1983-1989 Texas Instruments Incorporated  All Rights Reserved. *

;1;; Date and time routines*

;1;; Revision History*

;;; Date      Patcher Rev #   Description
;;; ------------------------------------------------------------------------------
;;; 12-13-88   DAB Added "JST" (Japan)  to *timezones*.
;;; ************* Rel 5.0 OS 12-12-88 DAB
;;; 11/2/88    ab    5-15,16  Fixes to chaparral-set-universal-time, chapparal-get-universal-time
;;;                           and initialize-timebase for the microExplorer.
;;; 01.12.88   MBC     --     MX conditionalize on Resource-Present-P and :RTC.
;1;; 03/09/87  HW  *   --     1Force leading zeroes on date/time formats.*
;;; 01/5/89    clm     --     When we ask the user to enter the time, even if the initial time 
;;;                           is not valid, update the RTC.  CHAPARRAL-SET-UNIVERSAL-TIME has 
;;;                           also been changed to update the ram-month counter.  That counter 
;;;                           is used to determine if the time is valid or not, and before if the time 
;;;                           was not valid, we didn't set the ram.  Gave us a circle where the time is 
;;;                           wrong, but because the time is wrong we can't reset the time.
;;; 02/23/89   clm     --     Changed SET-LOCAL-TIME to pass :USER as the time source for INITIALIZE-TIMEBASE
;;;                           so that we always update RAM-month-counter when user enters time.


;1;; Note: days and months are kept one-based throughout, as much as possible.*
;1;; Days of the week are zero-based on Monday.*

;1;; [Maybe this should have a global variable which causes it to use AM/PM in place*
;1;;  of 24-hour time, in all relevant functions?]*

;1; this should probably have variable which is the initial-year, *
;1; in case we want more precision.*


;1; Documented functions and variables.*

(export '(print-current-time print-time print-universal-time print-brief-universal-time *default-date-print-mode*
			     print-current-date print-date print-universal-date initialize-timebase
			     daylight-savings-time-p daylight-savings-p month-length leap-year-p verify-date
			     day-of-the-week-string month-string timezone-string))

;1; Chaparral Real-time clock chip code.*

;1; Three SIB system constants were changed: Timers-radix was*
;1; changed from timers-base, Rtclock-RAM-100-Microseconds-Counter*
;1; was changed from Rtclock-RAM-100-Nanoseconds-Counter, and*
;1; Rtclock-100-Microseconds-Counter was changed from*
;1; Rtclock-100-Nanoseconds-Counter.  The timers-base was changed*
;1; because it conflicted with the base address for the timers.  The*
;1; name timers-radix seemed more appropriate anyway.  The*
;1; microsecond RAM and clock counter names were changed because*
;1; they were incorrectly documented in the SIB manual as being*
;1; nanosecond RAM and clock counters.  Also note that the ALU*
;1; argument constants have been commented out.  This was done*
;1; because of the uncertainty of the ordering of the bits.*

;1; The following two functions need to be present until the microcode versions*
;1; are written.  They perform the same thing, so one only needs to remove*
;1; them when the microcode versions come into being.*
(si:define-when :RTC

(DEFUN 4%NUBUS-READ-BYTE* (SLOT-NUMBER ADDRESS)
  "2Read in a byte from the NUBUS using the word read function.*"
  (LDB (DPB ADDRESS (BYTE 2 11) #o0010)
       (LOGAND #x+FFFFFFFF (si:%NUBUS-READ SLOT-NUMBER ADDRESS)))) 

(DEFUN 4%NUBUS-WRITE-BYTE* (SLOT-NUMBER ADDRESS VALUE)
  "2Write in a byte into the NUBUS using the word write function.*"
  (si:%NUBUS-WRITE SLOT-NUMBER ADDRESS
		(DPB VALUE (DPB ADDRESS (BYTE 2 11) #o0010)
		     (LOGAND #x+FFFFFFFF (si:%NUBUS-READ SLOT-NUMBER ADDRESS)))))

(defvar 4RT-clock-interrupted* nil
    "2T when the RTC interrupts, nil otherwise.  Only used for RAM compares.*")

(Defmacro 4DefAlternate* (symbol alternation-list)
  (DO ((list alternation-list (cddr list))
       (alternates (car alternation-list) (cons (car list) alternates))
       (*forms* nil))
      ((null list)
       `(Progn 'compile
	       (DefParameter ,symbol ',(reverse alternates))
	       ,@*forms*))
    (Push `(DefParameter ,(car list) ,(cadr list)) *forms*)))

;1; The following are system constants for the Serial Interface Board*
;1; (SIB) for the Chaparral system.  Included are base addresses,*
;1; device offsets and register field formats.*
;1;*
;1; For reference purposes only, the page number of a reference in the*
;1; SIB specification is located in the comment field.*


;1; Base addresses for the devices:*
(DefAlternate 4Sib-Base-Addresses*
  (Graphics-And-Bit-Map-Control-Base 	   #xE00000	;1 4-4*
   Event-Generator-Base              	   #xF00000	;1 4-4*
   Printer-Port-Base	          	   #xF10000	;1 4-4*
   Mouse-Registers-Base              	   #xF20000	;1 4-4*
   Real-Time-Clock-Base              	   #xF80000	;1 4-4*
   Timers-Base                       	   #xF90000	;1 4-4*
   Non-Volatile-Ram-Base             	   #xFA0000	;1 4-4*
   RS232C-Port-Base                  	   #xFB0000	;1 4-4*
   Keyboard-Base                     	   #xFC0000	;1 4-4*
   Configuration-Rom-Base            	   #xFE0000)	;1 4-4*
  )


;1; The offsets from the Graphics-And-Bit-Map-Control-Base follow.*
(DefAlternate 4Graphics-Offsets*
  (Graphics-Char-Per-Horiz-period	         0.	;1 4-44*
   Graphics-Char-Per-Data-Row		         4.	;1 4-44*
   Graphics-Horiz-Delay			         8.	;1 4-44*
   Graphics-Horiz-Sync-Width		        12.	;1 4-44*
   Graphics-Vertical-Sync-Width		        16.	;1 4-44*
   Graphics-Vertical-Delay		        20.	;1 4-44*
   Graphics-Skew			        24.	;1 4-44*
   Graphics-Visible-Data-Rows-Per-Frame	        28.	;1 4-44*
   Graphics-Scan-Lines			        32.	;1 4-44*
   Graphics-Scan-Lines-Per-Frame-LS	        36.	;1 4-44*
   Graphics-Dma-Control			        40.	;1 4-44*
   Graphics-Operation-Control		        44.	;1 4-44*
   Graphics-Table-Start-Register-LS	        48.	;1 4-44*
   Graphics-Table-Start-Register-MS	        52.	;1 4-44*
   Graphics-Aux-Address-Register-1-LS	        56.	;1 4-44*
   Graphics-Aux-Address-Register-1-MS	        60.	;1 4-44*
   Graphics-Seq-Break-Register-1	        64.	;1 4-44*
   Graphics-Data-Row-Start		        68.	;1 4-44*
   Graphics-Data-Row-End		        72.	;1 4-44*
   Graphics-Aux-Address-Register-2-LS	        76.	;1 4-44*
   Graphics-Aux-Address-Register-2-MS	        80.	;1 4-44*
   Graphics-Start-Command		        84.	;1 4-44*
   Graphics-Reset-Command		        88.	;1 4-44*
   Graphics-Offset			        92.	;1 4-44*
   Graphics-Cursor-Row			        96.	;1 4-44*
   Graphics-Cursor-Column		       100.	;1 4-44*
   Graphics-Status-Register		       104.	;1 4-44*
   Graphics-Interrupt-Enable		       104.	;1 4-44*
   Graphics-Light-Pen-Row		       108.	;1 4-44*
   Graphics-Light-Pen-Column		       112.	;1 4-44*
   Graphics-Char-Per-Horiz-Period	       124.	;1 4-44*
   Graphics-Attribute-Register 		       128.	;1 4-38*
   Graphics-Mask-Register 		       132.	;1 4-34*
   Graphics-Alu-Register 		       136.	;1 4-35*
   Graphics-Video-Test-Register 	       152.)	;1 4-37*
  )

;1; The settings for the video attribute register follow.*
;1; These settings correspond with the*
;1; Graphics-Attribute-Register offset.*
(DefAlternate 4Video-Attribute-Fields*			4;1 4-38**
  (Video-Blanking			     #o0001 
   Video-Blanking-On				  1 
   Video-Polarity			     #o0101 
   Video-Polarity-One-Is-White			  1)
  )


(comment ******<><><><><> Temporary comment <><><><><>******
;1; The register values for ALU operations follow.*
;1; These settings correspond with the*
;1; Graphics-Alu-Register offset.*
(DefAlternate 4TV:Graphics-ALU-Operations*		4;1 4-35**
  (TV:ALU-Setz				     #b0000 	;1 CLEAR*
   TV:ALU-Nor				     #b0001 	;1 M  NOR  W*
   TV:ALU-Ca-And			     #b0010 	;1 M- AND  W*
   ;1;TV:ALU-*				1     #b0011 *	1; M-*

   TV:ALU-Andca				     #b0100 	;1 M  AND  W-*
   ;1;TV:ALU-*				1     #b0101 *	1; W-*
   TV:ALU-Xor				     #b0110 	;1 M  XOR  W*
   TV:ALU-Nand				     #b0111 	;1 M  NAND W*

   TV:ALU-And				     #b1000 	;1 M  AND  W*
   TV:ALU-Xnor				     #b1001 	;1 M  XNOR W*
   TV:ALU-Seta				     #b1010 	;1 W*
   TV:ALU-Ca-Or				     #b1011 	;1 M- OR   W*

   ;1;TV:ALU-*				1     #b1100 *	1; M*
   TV:ALU-Or-Ca				     #b1101 	;1 M  OR   W-*
   TV:ALU-Ior				     #b1110 	;1 M  OR   W*
   TV:ALU-Set				     #b1111) 	;1 SET*
  )
)

;1; Bit offsets for the video test register.*
;1; These settings correspond with the *
;1; Graphics-Video-Test-Register offset.*
(DefAlternate 4Graphics-Video-Test-Fields*		4;1 4-37**
  (Graphics-Test-Even-Negative		     #o0301 
   Graphics-Test-Odd-Negative		     #o0201 
   Graphics-Test-Even-Positive		     #o0101 
   Graphics-Test-Odd-Positive		     #o0001)
  )




;1; The offsets from the Event-Generator-Base follow.*
(DefAlternate 4Event-Offsets*
  (Event-Real-Time-Clock		       	 0.	;1 4-14*
   Event-Short-Interval-Timer		 	 1. 	;1 4-14*
   Event-Long-Interval-Timer		 	 2. 	;1 4-14*
   Event-RS232C-Port			 	 3. 	;1 4-14*
   Event-Printer-Port			 	 4. 	;1 4-14*
   Event-Graphics-Controller		 	 5. 	;1 4-14*
   Event-Keyboard			 	 6. 	;1 4-14*
   Event-Power-Supply			 	 7. 	;1 4-14*
   Event-Keyboard-Special-Chord-Reset	 	 8. 	;1 4-14*
   Event-Mouse-Motion			 	 9. 	;1 4-14*
   Event-Mouse-Keyswitch			10. 	;1 4-14*
   Event-Voice-Data				11. 	;1 4-14*
   Event-Sound-Data				12. 	;1 4-14*
   Event-Power-Failure				13.)	;1 4-14*
  )




;1; The offsets from the Printer-Port-Base follow.*
(DefAlternate 4Printer-Port-Offsets*
  (Printer-Data-Register			 0.	;1 4-130*
   Printer-Status-Register			 0.)	;1 4-130, 4-131*
  )

;1; The register values for printer status follow.*
;1; These settings correspond with reading at the*
;1; Printer-Status-Register offset.*
(DefAlternate 4Printer-Status-Fields*
  (Printer-Status-Fault			     #o0301 
   Printer-Status-Online		     #o0201 
   Printer-Status-Paper-Out		     #o0101 
   Printer-Status-Busy			     #o0001)
  )

;1; The register values for printer status follow.*
;1; These settings correspond with writing to the*
;1; Printer-Status-Register offset.*
(DefAlternate 4Printer-Control-Fields*
  (Printer-Interrupt-Enable		     #o0301 
   Printer-Initialize			     #o0201 
   Printer-Data-Strobe			     #o0101 
   Printer-Auto-Feed			     #o0001)
  )


;1; The offsets from the Mouse-Registers-Base follow.*
(DefAlternate 4Mouse-Register-Offsets*
  (Mouse-Y-Position-Register			 0. 	;1 4-48, 4-52*
   Mouse-X-Position-Register			 1. 	;1 4-48, 4-52*
   Mouse-Motion-And-Keyswitch-Register		 2. 	;1 4-48, 4-49*
   Mouse-Control-Register		 	 3. 	;1 4-48, 4-57*
   Mouse-Diagnostic-Data-Register		 4. 	;1 4-48*
   Mouse-Sound-Control-Register			 5. 	;1 4-48, 4-58*
   Mouse-Speech-Register		 	 6. 	;1 4-48, 4-59*
   Mouse-Voice-Register			 	 7.)    ;1 4-48, 4-60*
  )

;1; The register values for mouse motion/keyswitch data follow.*
;1; These settings correspond with the*
;1; Mouse-Motion-And-Keyswitch-Register offset.*
(DefAlternate 4Mouse-Motion-And-Keyswitch-Fields*
  (Mouse-Keyboard-Data			     #o0701 
   Mouse-Left-Button			     #o0601 
   Mouse-Middle-Button			     #o0501 
   Mouse-Right-Button			     #o0401 
   Mouse-Raw-Mouse-Motion		     #o0304)
  )

;1; The register values for monitor control follow.*
;1; These settings correspond with the*
;1; Mouse-Control-Register offset.*
(DefAlternate 4Mouse-Control-Fields*
  (Mouse-Control-Sound-Enable		       #o1001 
   Mouse-Control-Sound-Error-Enable	       #o0701 
   Mouse-Control-Mouse-Motion-Interrupt-Enable #o0601 
   Mouse-Control-Mouse-Button-Enable	       #o0501 
   Mouse-Control-Voice-Interrupt-Enable	       #o0401 

   Mouse-Control-Diagnostic-Control	       #o0304 	;1 4-75*
   Mouse-Control-Diagnostic-External-Loopback  #b1000 
   Mouse-Control-Diagnostic-Internal-Loopback  #b0100 
   Mouse-Control-Diagnostic-Mouse-Select       #b0010 
   Mouse-Control-Diagnostic-Voice-Select       #b0001)
  )

;1; The register values for monitor diagnostic data follow.*
;1; These settings correspond with the*
;1; Mouse-Diagnostic-Data-Register offset.*
(DefAlternate 4Mouse-Diagnostic-Data-Fields*
  (Mouse-Diagnostic-Parity		     #o1001
   Mouse-Diagnostic-Data		     #o0710)
  )

;1; The register values for sound control follow.*
;1; These settings correspond with the*
;1; Mouse-Sound-Control-Register offset.*
(DefAlternate 4Mouse-Sound-Control-Fields*
  (Mouse-Sound-Control-Parity		     #o1001
   Mouse-Sound-Control-Data		     #o0710)
  )

;1; The register values for speech follow.*
;1; These settings correspond with the*
;1; Mouse-Speech-Register offset.*
(DefAlternate 4Mouse-Speech-Fields*
  (Mouse-Speech-Parity			     #o1001
   Mouse-Speech-Data			     #o0710)
  )

;1; The register values for voice follow.*
;1; These settings correspond with the*
;1; Mouse-Voice-Register offset.*
(DefAlternate 4Mouse-Speech-Fields*
  (Mouse-Voice-Data-Present		     #o1001
   Mouse-Voice-Data			     #o0710)
  )


;1; The byte offsets from the Real-Time-Clock-Base follow.*
(DefAlternate 4Real-Time-Clock-Offsets*
  (Rtclock-100-Microseconds-Counter		 0. 	;1 4-18*
   Rtclock-10-And-100-Millisecond-Counter	 4. 	;1 4-18*
   Rtclock-Seconds-Counter			 8. 	;1 4-18*
   Rtclock-Minutes-Counter			12. 	;1 4-18*
   Rtclock-Hours-Counter			16. 	;1 4-18*
   Rtclock-Day-Of-Week-Counter			20. 	;1 4-18*
   Rtclock-Day-Of-Month-Counter			24. 	;1 4-18*
   Rtclock-Month-Counter			28. 	;1 4-18*
   Rtclock-RAM-100-Microseconds-Counter		32. 	;1 4-18*
   Rtclock-RAM-10-And-100-Millisecond-Counter	36. 	;1 4-18*
   Rtclock-RAM-Seconds-Counter			40. 	;1 4-18*
   Rtclock-RAM-Minutes-Counter			44. 	;1 4-18*
   Rtclock-RAM-Hours-Counter			48. 	;1 4-18*
   Rtclock-RAM-Day-Of-Week-Counter		52. 	;1 4-18*
   Rtclock-RAM-Day-Of-Month-Counter		56. 	;1 4-18*
   Rtclock-RAM-Month-Counter			60. 	;1 4-18*
   Rtclock-Interrupt-Status-Register		64. 	;1 4-18, 4-20*
   Rtclock-Interrupt-Control-Register		68. 	;1 4-18 --> 4-20*
   Rtclock-Counters-Reset			72. 	;1 4-18, 4-20*
   Rtclock-Ram-Reset				76. 	;1 4-18, 4-20*
   Rtclock-Read-Status-Bit			80. 	;1 4-18, 4-20*
   Rtclock-Go-Command				84. 	;1 4-18, 4-20*
   Rtclock-Standby-Interrupt			88. 	;1 4-18*
   Rtclock-Test-Mode				92.)	;1 4-18*
  )


;1; The offsets from the Timers-Base follow.*
(DefAlternate 4Timer-Offsets*
  (Timers-Load-Counter-0			 0. 	;1 4-27*
   Timers-Load-Counter-1			 1. 	;1 4-27*
   Timers-Load-Counter-2			 2. 	;1 4-27*
   Timers-Write-Mode-Control			 3. 	;1 4-25, 4-27*
   Timers-Read-Counter-0			 0. 	;1 4-24, 4-27*
   Timers-Read-Counter-1			 1. 	;1 4-24, 4-27*
   Timers-Read-Counter-2			 2.)	;1 4-24, 4-27*
  )

;1; The bit assignments for the timer control byte follow:*
(DefAlternate 4Timers-Control-Fields*			4;1 4-25**
  ;1; Counter selection field:*
  (Timers-Counter-Select		     #o0702 
   Timers-Select-Counter-0			 0. 
   Timers-Select-Counter-1			 1. 
   Timers-Select-Counter-2			 2. 

  ;1;Byte ordering field:*
   Timers-Byte-Ordering		   	     #o0502 
   Timers-Ordering-Counter-Latching	         0. 
   Timers-Ordering-LSB				 1. 
   Timers-Ordering-MSB				 2. 
   Timers-Ordering-LSB-Then-MSB			 3. 

  ;1; Timer mode field:*
   Timers-Mode			   	     #o0303 
   Timers-Mode-Interrupt-On-Last-Count		 0. 
   Timers-Mode-Square-Wave			 3. 
  
   Timers-radix 		   	     #o0001 
   Timers-Base-Binary				 0. 
   Timers-Base-BCD				 1.)
  )


;1; The offsets from the Non-Volatile-Ram-Base are not present.  Page*
;1; 4-17 of the SIB specification describes the layout of this ROM.*



;1; The offsets from the RS232C-Port-Base follow.*
(DefAlternate 4RS232C-Port-Offsets*
  (RS232C-Channel-B-Status			 0. 	;1 4-109*
   RS232C-Channel-B-Pointer			 0. 	;1 4-109*
   RS232C-Channel-A-Status			 8. 	;1 4-109*
   RS232C-Channel-A-Pointer			 8. 	;1 4-109*
   RS232C-Channel-A-Receive-Buffer		12. 	;1 4-109*
   RS232C-Channel-A-Transmit-Buffer		12. 	;1 4-109*
   RS232C-Interrupt-Acknowledge-Address		16.)	;1 4-109*
  )

;1; The divisors for the baud rate generator follow.*
(DefAlternate 4RS232C-Baud-Rate-Divisors*			4;1 4-111**
  (RS232C-Baud-Rate-50			    #x2FFE
   RS232C-Baud-Rate-75			    #x1FFE
   RS232C-Baud-Rate-110			    #x11E7
   RS232C-Baud-Rate-134.5		    #x11D6
   RS232C-Baud-Rate-150			    #x0FFE
   RS232C-Baud-Rate-200			    #x0BFE
   RS232C-Baud-Rate-300			    #x07FE
   RS232C-Baud-Rate-600			    #x03FE
   RS232C-Baud-Rate-1200		    #x01FE
   RS232C-Baud-Rate-1800		    #x0153
   RS232C-Baud-Rate-2400		    #x00FE
   RS232C-Baud-Rate-3600		    #x00A9
   RS232C-Baud-Rate-4800		    #x007E
   RS232C-Baud-Rate-7200		    #x0053
   RS232C-Baud-Rate-9600		    #x003E
   RS232C-Baud-Rate-19200		    #x001E)
  )


;1; The offsets from the Keyboard-Base follow.*
(DefAlternate 4Keyboard-Offsets*
  (Keyboard-Status-And-Control-Register		 0.	;1 4-69*
   Keyboard-Transmit-And-Recieve-Data		 1.)	;1 4-69*
  )

;1; The register values for the keyboard mode byte follows.*
;1; These settings correspond with the*
;1; Keyboard-Status-And-Control-Register offset.*
(DefAlternate 4Keyboard-Mode-Fields*			4;1 4-70**
  (Keyboard-Mode-Stop-Bit		     #o0702 
   Keyboard-Mode-1-Stop-Bit			 1. 
   Keyboard-Mode-1-And-A-Half-Stop-Bits		 2. 
   Keyboard-Mode-2-Stop-Bits			 3. 

   Keyboard-Mode-Parity-Select		     #o0501 
   Keyboard-Mode-Odd-Parity-Select		 0. 
   Keyboard-Mode-Even-Parity-Select		 1. 

   Keyboard-Mode-Parity-Enable		     #o0401

   Keyboard-Mode-Character-Length	     #o0302 
   Keyboard-Mode-5-Bit-Characters		 0. 
   Keyboard-Mode-6-Bit-Characters		 1. 
   Keyboard-Mode-7-Bit-Characters		 2. 
   Keyboard-Mode-8-Bit-Characters		 3. 

   Keyboard-Mode-Baud-Rate-Select	     #o0102 
   Keyboard-Mode-Syncr-Baud-Rate		 0. 
   Keyboard-Mode-No-Division-Baud-Rate		 1. 
   Keyboard-Mode-Clock-By-16-Baud-Rate		 2. 
   Keyboard-Mode-Clock-By-64-Baud-Rate		 3.)
  )

;1; The register values for the keyboard command byte follows.*
;1; These settings correspond with the*
;1; Keyboard-Status-And-Control-Register offset.*
(DefAlternate 4Keyboard-Command-Fields*			4;1 4-72**
  (Keyboard-Command-Internal-Reset	     #o0601 
   Keyboard-Command-Request-To-Send	     #o0501 
   Keyboard-Command-Error-Status-Reset	     #o0401 
   Keyboard-Command-Send-Break-Character     #o0301 
   Keyboard-Command-Receive-Enable	     #o0201 
   Keyboard-Command-Data-Terminal-Ready	     #o0101 
   Keyboard-Command-Transmit-Enable	     #o0001)
  )

;1; The register values for the keyboard status byte follows.*
;1; These settings correspond with the*
;1; Keyboard-Status-And-Control-Register offset.*
(DefAlternate 4Keyboard-Status-Fields*			4;1 4-73**
  (Keyboard-Status-Data-Set-Ready	     #o0701 
   Keyboard-Status-Break-And-Sync-Detect     #o0601 
   Keyboard-Status-Framing-Error	     #o0501 
   Keyboard-Status-Overrun-Error	     #o0401 
   Keyboard-Status-Parity-Error		     #o0301 
   Keyboard-Status-Transmit-Buffer-Empty     #o0201 
   Keyboard-Status-Receive-Ready	     #o0101 
   Keyboard-Status-Transmit-Ready	     #o0001)
  )


;1; The offsets from the Configuration-Rom-Base are not present.  Page*
;1; 4-11 of the SIB specification describes the layout of this ROM.*

;1; Bit field assignments for the configuration register:*
(DefAlternate 4Configuration-Fields*			4;1 4-12**
  (Configuration-Over-Temperature	     #o1201 
   Configuration-Chassis-Test 		     #o1101 
   Configuration-Monitor-Test		     #o1001 
   Configuration-Nubus-Test		     #o0301 
   Configuration-Sib-Test-LED		     #o0201 
   Configuration-Master-Enable		     #o0101 
   Configuration-Reset			     #o0001)
  )

;; End of DEFINE-WHEN
)


;1; This is code to read and initialize the Chaparral's battery*
;1; backup clock.*

;1; Note that this clock has all of the necessary clock information*
;1; except for the year.  This means that the year information needs to*
;1; be kept somewhere else.  The best place for it seems to be the*
;1; RAM registers located within the clock chip.  This information is*
;1; encoded with a flag which indicates whether or not today is*
;1; February 29th.  See the function READ-CHAPARRAL-YEAR for more details*
;1; on the encoding.  The updating of the year is done when the clock*
;1; triggers on the last second of the year.  Overflow from the year*
;1; number to the century number is checked at that time.*

(defvar 4rt-clock-counter-registers*
        `(,Rtclock-Seconds-Counter
          ,Rtclock-Minutes-Counter
          ,Rtclock-Hours-Counter
          ,Rtclock-Day-Of-Month-Counter
          ,Rtclock-Month-Counter)
      "2The numbers of the active counter registers in the real-time clock.*")

(defvar 4sleeping-time-pending* nil
    "2List of time/function pairs which are pending.  The first
     pair is the current one.  This is used by the
     EXECUTE-FUNCTION-ON function to allow for several times at
     which a function could be executed.*")

(defvar 4sleeping-time-process* nil
  "2Process which is waiting for its time to execute.  Used by
    the EXECUTE-FUNCTION-ON function.*")

(defvar 4scheduler-process* nil
  "2Process which handles the scheduling of RTC interrupts.*")

(DEFPARAMETER 4MAXIMUM-YEAR*  2399. "2Maximum year that is being supported.*")

(si:define-when :RTC
(defun 4last-second-of-year* ()
  "2Universal time value for the last second of the year.*"
  (time:encode-universal-time 59. 59. 23. 31. 12. (read-chaparral-year))
  )

(defun 4first-second-of-year* ()
  "2Universal time value for the first second of the year.*"
  (time:encode-universal-time 0 0 0 1 1 (read-chaparral-year))
  )

(defun 4last-second-of-february-28* (&optional (year-increment 0))
  "2Just before end of February 28th.  This is needed to handle leap years.*"
  (time:encode-universal-time 59. 59. 23. 28. 2.
                              (+ (read-chaparral-year) year-increment))
  )

)

(defun 4bcd-to-fixnum* (bcd-number)
  "2Converts a 2 digit BCD number to a fixnum.*"
  (+ (* (truncate bcd-number #x10) 10.) (mod bcd-number #x10)))

(defun 4fixnum-to-bcd* (fixnum)
  "2Converts a 2 digit fixnum to a BCD number.*"
  (+ (* (truncate fixnum 10.) #x10) (mod fixnum 10.)))

(si:define-when :RTC
(defun 4read-chaparral-RTC-chip* (offset)
  "2Reads a single value from the Chaparral real time clock chip.*"
  (declare (special tv:sib-slot-number))
  (%nubus-read-byte tv:sib-slot-number  (+ real-time-clock-base offset)))

(defun 4write-chaparral-RTC-chip* (offset value)
  "2Writes a single value into the Chaparral real time clock chip.*"
  (declare (special tv:sib-slot-number))
  (%nubus-write-byte tv:sib-slot-number (+ real-time-clock-base offset) value))

(defun 4chaparral-RTC-read-status-ok-p* ()
  "2Returns T if the read status on the RTC is OK, nil otherwise.*"
  (evenp (read-chaparral-RTC-chip rtclock-read-status-bit)))

(defun 4read-chaparral-RTC* (&aux clock-values (try-again t))
  "2Reads all current clock data from the clock.*"
  (loop WHILE try-again
        DO
        (progn
          (without-interrupts
            (setq clock-values 
                  (loop FOR register IN rt-clock-counter-registers 
                        ALWAYS (chaparral-RTC-read-status-ok-p)
                        FINALLY (return (progn (setq try-again nil) clock-collector))
                        COLLECT (bcd-to-fixnum (read-chaparral-RTC-chip register))
                        INTO clock-collector)))))
  clock-values)

(defun 4write-chaparral-RTC* 
    (seconds minutes hours date month
     &aux clock-values 
     (try-again t))
  "2Writes all the specified clock data into the clock.*"
  (setq clock-values 
	`(,seconds ,minutes ,hours ,date ,month))
  (loop while try-again
        DO (without-interrupts
	     (loop FOR time-index FROM 0 BY 1
		   FOR register IN rt-clock-counter-registers 
		   ALWAYS (chaparral-RTC-read-status-ok-p)
		   FINALLY (setq try-again nil)
		   DO
		   (write-chaparral-RTC-chip
		     register
		     (fixnum-to-bcd (nth time-index clock-values)))))))

)

;;(DEFVAR *time-is-daylight-savings* nil)		;ab 11/1/88

;;ab 11/2/88.
;; Use this fn to determine whether or not to adjust the time we
;; get from the MAC because time:*last-time-daylight-savings-p* can be 
;; inconsistent early in boot.  ab 11/2/88
(DEFUN ut-daylight-savings-p (ut)
  (MULTIPLE-VALUE-BIND (ignore ignore ignore ignore ignore ignore ignore day-sav-p)
      (DECODE-UNIVERSAL-TIME ut)
    day-sav-p))
  
(DEFUN (:cond (NOT (si:resource-present-p :RTC)) chaparral-set-universal-time)
       (universal-time)				;&AUX february-29)
  "Store the time into the Chaparral hardware."
  (let ((acb (add:get-acb 4))			; length in bytes
	(ch  (add:find-channel si:%Chan-Type-Misc)))
    (unwind-protect
	(progn
	  (add:init-acb acb si:%MC-tvcalls si:%TC-Set-Time)
	  (add:load-parms-32b acb (- universal-time
				     (encode-universal-time 0 0 0 1 1 1904.)
				     (if (ut-daylight-savings-p universal-time)  -3600. 0)))	;ab 11/2/88
	  (add:transmit-packet-and-wait acb ch)
	  (add:check-error acb))
      (setf (add:requestor-complete acb) t)
      (add:return-acb acb))))

(DEFUN (:cond (NOT (si:resource-present-p :RTC)) chaparral-get-universal-time) ()
  "Read the time and date using the Chaparral hardware."
  ;; Special note: when February 29th comes around, we have
  ;; backed up the clock to February 28th and set a flag
  ;; that indicates that today is really February 29th.
  
  (let ((acb (add:get-acb 4))			; length in bytes
	(ch  (add:find-channel si:%Chan-Type-Misc))
	universal-time)
    (unwind-protect
	(progn
	  (add:init-acb acb si:%MC-tvcalls si:%TC-Get-Time)
	  (add:transmit-packet-and-wait acb ch)
	  (add:check-error acb)
	  
	  ;return time + ut of 1/1/1904
	  (SETF universal-time 
		(+ (add:parm-32b acb 0)
		   (encode-universal-time 0 0 0 1 1 1904.)))
	  (+ universal-time
	     (if (ut-daylight-savings-p universal-time) -3600. 0)))	;ab 11/2/88
      (setf (add:requestor-complete acb) t)
      (add:return-acb acb))))

;;01/06/89 clm - changed to always write out the month to the ram-month-counter; this
;;fixes a problem that occurred when networked machines were powered down over a year flip -
;;they would come up and ask the date/time because the time in the counter was invalid,
;;and because of earlier changes if the time was invalid, we would update ram counter.
(DEFUN (:cond (si:resource-present-p :RTC) chaparral-set-universal-time)
       (universal-time &AUX february-29)
  "Store the time into the Chaparral hardware."
  (multiple-value-bind (seconds minutes hours day-of-month month year)
      (time:decode-universal-time universal-time)
    (setq february-29 (and (= day-of-month 29.) (= month 2)))
    (write-chaparral-RTC
      seconds minutes hours
      (if february-29
	  (1- day-of-month) day-of-month)
      month)
    (write-day-is-february-29 february-29)
    (write-chaparral-year year)
    (write-chaparral-RTC-chip Rtclock-RAM-Month-Counter month))
  )

(DEFUN (:cond (si:resource-present-p :RTC) 4chaparral-get-universal-time*) (&AUX clock-value)
  "2Read the time and date using the Chaparral hardware.*"
  ;1; Special note: when February 29th comes around, we have*
  ;1; backed up the clock to February 28th and set a flag*
  ;1; that indicates that today is really February 29th.*
  (setq clock-value (read-chaparral-RTC))
  (time:encode-universal-time
      (nth 0 clock-value)    		;1 Seconds*
      (nth 1 clock-value)    		;1 Minutes*
      (nth 2 clock-value)    		;1 Hours*
      (+ (nth 3 clock-value)    	;1 Day of month*
	 (if (day-is-february-29-p) 1 0))
      (nth 4 clock-value)    		;1 Month*
      (read-chaparral-year))
  )

(si:define-when :RTC
(DEFUN CHAPARRAL-INITIAL-DATE-VALID-P (&AUX YEAR CLOCK-VALUE MONTH)
  "Check out the first date value coming from the RTC clock."
  ;;  4/21/88 CLM - If a year flip has occurred, return NIL.  This will
  ;;                require standalones to enter the current date/time
  ;;                info, but it prevents the wrong date from being
  ;;                displayed. [spr 1286]
  (SETQ YEAR (READ-CHAPARRAL-YEAR))
  (IF (OR (< YEAR 1984.) (> YEAR MAXIMUM-YEAR))
    ()
    ;;ELSE
    (PROGN
      (SETQ CLOCK-VALUE (READ-CHAPARRAL-RTC))
      (IF (OR (> (NTH 0 CLOCK-VALUE) 59.)       ; Seconds
	      (> (NTH 1 CLOCK-VALUE) 59.)	; Minutes
	      (> (NTH 2 CLOCK-VALUE) 23.))	; Hours
	()
	;;ELSE
	(PROGN
	  (SETQ MONTH (NTH 4 CLOCK-VALUE))
	  (IF (OR (> MONTH 12.)
		  (> (NTH 3 CLOCK-VALUE) (MONTH-LENGTH MONTH YEAR))    ; Day of month
		  (> (read-chaparral-month) month))
	    ()
	    T))))))
)

(defun 4leap-year-setup* ())

  
(defun 4check-leap-year* ())


(defun 4done-with-february-29* ()
  "2Called only after February 29th is over.*"
  (write-day-is-february-29 nil))

(si:define-when :RTC
(defun read-chaparral-month ()
  "Read the month from the RAM part of the clock."
  ;;  4/21/88 CLM - This is used to check if a year flip has occurred.  If
  ;;                the value in the ram counter is greater than the value
  ;;                in the RTC, then a flip has occurred.
  (bcd-to-fixnum (read-chaparral-rtc-chip Rtclock-RAM-Month-Counter)))
)

(si:define-when :RTC
(DEFUN 4READ-CHAPARRAL-YEAR* ()
  "2Get the year from the low order part of the clock.*"
  ;1; Did I hear someone say HACK?*
  ;1; The clock chip doesn't have a year counter so we will store that*
  ;1; information into the RAM part of the clock which we will not be*
  ;1; using.  The low order 3 decimal digits of the time will contain*
  ;1; the year data in the following format:*
  ;1;   10 and 100 millisecond counters - year within century*
  ;1;   100 microsecond counter         - formula*
  ;1;*
  ;1; where the formula is calculated as follows:*
  ;1;   (century - 19) * 2 + day-is-february-29*
  ;1; Note that the 100 microsecond counter only has the 10's digits*
  ;1; being valid.  The units digits are all zeros.*
  ;1;      7 6 5 4 3 2 1 0  bit position*
  ;1;      D D D D 0 0 0 0  data present or 0*
  ;1;      x x x            century*
  ;1;            x          day-is-february-29*
  ;1;*
  ;1; This will get us up to the year 2399, which should be enough.  Note*
  ;1; that the D D D D part goes from 0 --> 9, making the x x x part go*
  ;1; from 0 --> 4.  (Actually, an earlier version of the RTC chip allowed*
  ;1; the D D D D value to go    from 0 --> 15, making the maximum year*
  ;1; value 2699.)*
  ;1;*
  ;1; day-is-february-29 is 0 on every day which is not February 29 and*
  ;1;   is  1 on that day.*
  (+ (BCD-TO-FIXNUM (READ-CHAPARRAL-RTC-CHIP RTCLOCK-RAM-10-AND-100-MILLISECOND-COUNTER))
     (* 100. (+ 19. (LDB (BYTE 3 5)
			 (READ-CHAPARRAL-RTC-CHIP
			   RTCLOCK-RAM-100-MICROSECONDS-COUNTER))))))

(DEFUN 4WRITE-CHAPARRAL-YEAR* (YEAR)
  "2Store the year back into the clock chip.*"
  ;1; Read about the format of the year information in the*
  ;1; READ-CHAPARRAL-YEAR function.*
  (MULTIPLE-VALUE-BIND (CENTURY YEAR-WITHIN-CENTURY)
    (TRUNCATE YEAR 100.)
    (WRITE-CHAPARRAL-RTC-CHIP
      RTCLOCK-RAM-10-AND-100-MILLISECOND-COUNTER
      (FIXNUM-TO-BCD YEAR-WITHIN-CENTURY))
    ;1; Write in the century information, being careful not to*
    ;1; touch the day-is-february-29 bit (bit 4)*
    (WRITE-CHAPARRAL-RTC-CHIP
      RTCLOCK-RAM-100-MICROSECONDS-COUNTER
      (DPB (- CENTURY 19.) (BYTE 3 5)
	   (READ-CHAPARRAL-RTC-CHIP
	     RTCLOCK-RAM-100-MICROSECONDS-COUNTER)))))


)

(DEFUN 4DAY-IS-FEBRUARY-29-P* ()
  "2Read the flag which indicates that today is February 29.*"
  ;1; Read all about this in the comments for the*
  ;1; READ-CHAPARRAL-YEAR function.*
  (= 1 (LDB (BYTE 1 4) (READ-CHAPARRAL-RTC-CHIP
			 RTCLOCK-RAM-100-MICROSECONDS-COUNTER))))

(si:define-when :RTC

(DEFUN 4WRITE-DAY-IS-FEBRUARY-29* (DAY-INDICATOR)
  "2Write the flag which indicates that today is February 29.*"
  ;1; Read all about this in the comments for the*
  ;1; READ-CHAPARRAL-YEAR function.*
  (IF (NOT (NUMBERP DAY-INDICATOR))
    (SETQ DAY-INDICATOR (IF DAY-INDICATOR 1 0)))
  (WRITE-CHAPARRAL-RTC-CHIP
    RTCLOCK-RAM-100-MICROSECONDS-COUNTER
    (DPB DAY-INDICATOR (BYTE 1 4)
	 (READ-CHAPARRAL-RTC-CHIP
	   RTCLOCK-RAM-100-MICROSECONDS-COUNTER))))  


(defun 4update-year* ()
  "2Increment the year*"
  ;1; This is only called just before the end of the year.*
  (write-chaparral-year (1+ (read-chaparral-year)))
;1  (execute-function-on (first-second-of-year) #'setup-update-year)*
  )
)


(defun 4setup-update-year* ()
  "2Used only to startup the UPDATE-YEAR function.*"
  ;1; This is done in two steps because when we are updating the year,*
  ;1; we are still on the last second of the year.  This way we wait*
  ;1; until the first second of the year (one second later) and then*
  ;1; schedule the update for another year.*
;1  (execute-function-on (last-second-of-year) #'update-year)*
  )


;1;; Conversion routines, universal time is seconds since 1-jan-00 00:00-GMT*

(defvar 4*TIMEZONE** 6) ;1; Give it a default value for builds.*
(add-initialization "Initialize *timezone*" '(setq *timezone* (si:get-site-option :timezone)) '(:site-option :normal))
;1(DEFINE-SITE-VARIABLE *TIMEZONE* :TIMEZONE)*
(defvar 4*signal-timezone-parse-error** nil)

(defun 4parse-timezone-string* (timezone)
  "2Return the timezone number that corresponds to timezone. Timezone can be:
       -12 <= a number <= 12
       The string name of a timezone as found on the variable *timezones*
       A single character corresponding to a military timezone.
       Returns nil if timezone is invalid.*"
  
  (let* ((timezone-string (typecase timezone
			    (number (format nil "~d" timezone))
			    (t (string timezone))))
	 
	 (timezone-element (unless (null timezone)
			     (or (find timezone-string *timezones* :test #'string-equal :key #'second)
				 (find timezone-string *timezones* :test #'string-equal :key #'third)
				 (find (parse-number timezone-string 0 nil 10. t) *timezones* :test #'eql :key #'first)
				 (and (eql (length timezone-string) 1)
				      (find (char-int (char timezone-string 0)) *timezones* :test #'eql :key #'fourth))))))
    (first timezone-element)
    
    ))

(net:define-site-option-parser (:timezone)
			       (cond ((parse-timezone-string option))
				     
				     ((and (integerp *timezone*)
					   (<= -12 *timezone* 12)
					   (not *signal-timezone-parse-error*))
				      
				      (format t "~&The site-option database for site ~s contained an invalid value ~
                                                   for timezone (~s)~
                                                 ~%Returning the old value of *timezone* (~s)"
					      si:site-name option *timezone*)
				      *timezone*)
				     
				     (t
				      (setf (get-site-option :timezone) (net:site-option-error option :timezone *timezone*))
				      (get-site-option :timezone))))

;1;; One-based array of cumulative days per month.*

(DEFVAR 4*CUMULATIVE-MONTH-DAYS-TABLE** (MAKE-ARRAY 13. :element-type '(unsigned-byte 16))
  "2One-based array of cumulative days per month.*")

(si:FILL-ARRAY-from-sequences *CUMULATIVE-MONTH-DAYS-TABLE*
	   '(0 0 31. 59. 90. 120. 151. 181. 212. 243. 273. 304. 334.) 0 0)

;1; Takes Univeral Time (seconds since 1/1/1900) as a 32-bit number*
;1; Algorithm from KLH's TIMRTS.*
(DEFUN 4DECODE-UNIVERSAL-TIME* (UNIVERSAL-TIME &OPTIONAL TIMEZONE
			      &AUX SECS MINUTES HOURS DAY MONTH
			      YEAR DAY-OF-THE-WEEK DST-P)
  "2Given a UNIVERSAL-TIME, decode it into year, month number, day of month, etc.
TIMEZONE is hours before GMT (5, for EST).
DAY and MONTH are origin-1.  DAY-OF-THE-WEEK = 0 for Monday.*"
  (DECLARE (VALUES SECS MINUTES HOURS DAY MONTH YEAR
			DAY-OF-THE-WEEK DAYLIGHT-SAVINGS-P TIMEZONE))
  (IF TIMEZONE					;1explicit timezone means no-dst*
    (MULTIPLE-VALUE-SETQ (SECS MINUTES HOURS DAY MONTH YEAR DAY-OF-THE-WEEK)
      (DECODE-UNIVERSAL-TIME-WITHOUT-DST UNIVERSAL-TIME TIMEZONE))
    ;1;Otherwise, decode the time and THEN daylight-adjust it.*
    (PROGN
      (MULTIPLE-VALUE-SETQ (SECS MINUTES HOURS DAY MONTH YEAR DAY-OF-THE-WEEK)
	(DECODE-UNIVERSAL-TIME-WITHOUT-DST UNIVERSAL-TIME *TIMEZONE*))
      (AND (SETQ DST-P (DAYLIGHT-SAVINGS-TIME-P HOURS DAY MONTH YEAR))
	   ;1; See if it's daylight savings time, time-zone number gets smaller if so.*
	 (MULTIPLE-VALUE-SETQ (SECS MINUTES HOURS DAY MONTH YEAR DAY-OF-THE-WEEK)
	   (DECODE-UNIVERSAL-TIME-WITHOUT-DST UNIVERSAL-TIME (1- *TIMEZONE*))))))
  (VALUES SECS MINUTES HOURS DAY MONTH YEAR DAY-OF-THE-WEEK DST-P
	  (OR TIMEZONE *TIMEZONE*)))

(defconstant 4ord-year-cum-days* #(0. 31. 59. 90. 120. 151. 181. 212. 243. 273. 304. 334. 365.))


(defconstant 4leap-year-cum-days* #(0. 31. 60. 91. 121. 152. 182. 213. 244. 274. 305. 335. 366.))

;1;PHD 2/27 New version *
(defun 4decode-universal-time-without-dst* (universal-time &optional (timezone *timezone*))
  (multiple-value-bind (minute second)
      (floor universal-time 60.)
    (multiple-value-bind (hour minute)
	(floor minute 60.)
      (decf hour timezone)
      (multiple-value-bind
	(days hour)
	  (floor hour 24.)
	(let ((year (floor (ash days 2.) 1461.)) date)
	  (loop (setq date (- days (* 365. year)
			      (floor(1- year) 4.)
			      (- (floor (1- year) 100.))
			      (floor (+ year 299.) 400.)
			      ))
		(cond ((minusp date)
		       (decf year))
		      ((or (> date 365.)
			   (and (= date 365.)
				(or (/= (mod YEAR 4) 0)
				     (and (ZEROP (mod YEAR 100.))
					  (/= (mod (- YEAR 100.) 400.) 0)))))
		       (incf year))
		      (t (incf year 1900.) (return))))
	  (let ((month (floor  date 31.))
		(cum-days (if (leap-year-p year)
			      leap-year-cum-days
			      ord-year-cum-days)))
	    (when (>= date (aref cum-days (1+ month)))
	      (incf month))
	    (when (< date (aref cum-days month))
	      (decf month))
	    (decf date (aref cum-days month))
	    (incf date)
	    (incf month)
	    (values second minute hour date month year (mod days 7.) timezone)))))))




;;PHD changed this function because of the new (1987) rule for daylight saving time.
(DEFUN 4DAYLIGHT-SAVINGS-TIME-P* (HOURS DAY MONTH YEAR)
  "2T if daylight savings time would be in effect at specified time in North America.*"
  (COND
    ((OR (< MONTH 4)				;1Standard time if before 2 am last Sunday in April*
	(AND (= MONTH 4)
	   (LET ((LSA (if (>= year 1987. )
			  (first-sunday-in-april year)
			  (LAST-SUNDAY-IN-APRIL YEAR))))
	     (OR (< DAY LSA) (AND (= DAY LSA) (< HOURS 2))))))
     NIL)
    ((OR (> MONTH 10.)				;1Standard time if after 1 am last Sunday in October*
	(AND (= MONTH 10.)
	   (LET ((LSO (LAST-SUNDAY-IN-OCTOBER YEAR)))
	     (OR (> DAY LSO) (AND (= DAY LSO) (>= HOURS 1))))))
     NIL)
    (T T))) 

;1;; Domain-dependent knowledge*
(DEFUN 4LAST-SUNDAY-IN-OCTOBER* (YEAR)
  (LET ((LSA (LAST-SUNDAY-IN-APRIL YEAR)))
    ;1; Days between April and October = 31+30+31+31+30 = 153  6 mod 7*
    ;1; Therefore the last Sunday in October is one less than the last Sunday in April*
    ;1; unless that gives 24. or 23. in which case it is six greater.*
    (IF (<= LSA 25.) (+ LSA 6) (1- LSA))))

;1;PHD 2/11/87 fix leap-year-p argument*

(DEFUN 3FIRST-SUNDAY-IN-APRIL* (YEAR)
  (IF (> YEAR  100.)
    (SETQ YEAR (- YEAR  1900.)))
  ;1; This copied from GDWOBY routine in ITS*
  (LET ((DOW-BEG-YEAR
	 (LET ((B (REM (+ YEAR  1899.)  400.)))
	   (REM (- (+ (1+ B) (SETQ B (FLOOR B 4))) (FLOOR B  25.)) 7)))
	(FEB29 (IF (LEAP-YEAR-P (+ 1900. YEAR))
		 1
		 0)))
    (LET ((DOW-APRIL-30 (REM (+ DOW-BEG-YEAR  96. FEB29) 7)))
      (- 7. DOW-APRIL-30))))

(DEFUN last4-SUNDAY-IN-APRIL* (YEAR)
  (IF (> YEAR  100.)
    (SETQ YEAR (- YEAR  1900.)))
  ;1; This copied from GDWOBY routine in ITS*
  (LET ((DOW-BEG-YEAR
	 (LET ((B (REM (+ YEAR  1899.)  400.)))
	   (REM (- (+ (1+ B) (SETQ B (FLOOR B 4))) (FLOOR B  25.)) 7)))
	(FEB29 (IF (LEAP-YEAR-P (+ 1900. YEAR))
		 1
		 0)))
    (LET ((DOW-APRIL-30 (REM (+ DOW-BEG-YEAR  119. FEB29) 7)))
      (- 30. DOW-APRIL-30))))

;;PHD 4/8/87 Fixed it so it is right for new daylight saving time rules
;1;PDH 2/11/87 Fix it so it is correct for leap years.*
(DEFUN 4ENCODE-UNIVERSAL-TIME* (SECONDS MINUTES HOURS DAY MONTH YEAR
				 &OPTIONAL TIMEZONE &AUX TEM)
  "2Given a time, return a universal-time encoding of it.
A universal-time is the number of seconds since 1900 00:00-GMT (a bignum).*"
  (IF (< YEAR  100.)
      (MULTIPLE-VALUE-BIND (NIL NIL NIL NIL NIL CURRENT-YEAR)
	  (GET-DECODED-TIME)
	;1; In case called during startup or during DISK-SAVE.*
	(UNLESS CURRENT-YEAR
	  (SETQ CURRENT-YEAR  2000.))
	(SETQ YEAR (+ CURRENT-YEAR
		      (- (MOD (+ 50. (- YEAR (REM CURRENT-YEAR 100.))) 100.) 50.)))))
  (OR TIMEZONE
      (SETQ TIMEZONE
	    (IF (DAYLIGHT-SAVINGS-TIME-P HOURS DAY MONTH YEAR)
		(1- *TIMEZONE*)
		*TIMEZONE*)))
  (SETQ YEAR (- YEAR 1900.))
  (SETQ TEM	;1Number of days since 1/1/1900.*
	(+ (1- DAY) (AREF *CUMULATIVE-MONTH-DAYS-TABLE* MONTH)
	   (+(floor(1- year) 4.)
	     (- (floor (1- year) 100.))
	     (floor (+ year 299.) 400.))
	   (* YEAR 365.)))
  (AND (> MONTH 2) (LEAP-YEAR-P (+ 1900. YEAR))
       (SETQ TEM (1+ TEM)))			;1After 29-Feb in a leap year.*
  (+ SECONDS (* 60. MINUTES) (* 3600. HOURS) (* TEM  86400.) (* TIMEZONE 3600.)))


;1;; Maintenance functions*

(DEFCONSTANT 4INTERNAL-TIME-UNITS-PER-SECOND* 60.)  ;160 60th of a sec in a second*

(DEFVAR 4HIGH-TIME-BITS* 0)
;1; T if  (TIME) was TIME-LESSP than LAST-BOOT-TIME  when last checked.*
;1; Each time this changes from T to NIL, (TIME) has wrapped around once.*
(DEFVAR 4WAS-NEGATIVE* NIL)
(DEFVAR 4LAST-BOOT-TIME* 0 "2Value of (TIME) when machine was booted.*")

(DEFVAR 4*SAVED-MICROSECOND-OVERFLOW**    0)
(DEFVAR 4*PREVIOUS-TOP-9-TIME-BITS**    NIL)
(DEFVAR 4*PREVIOUS-BOTTOM-23-TIME-BITS**  0)
(DEFVAR 4*LAST-TIME-SECONDS** 0)
(DEFVAR 4*LAST-TIME-MINUTES** 0)
(DEFVAR 4*LAST-TIME-HOURS** 0)
(DEFVAR 4*LAST-TIME-DAY** 0)
(DEFVAR 4*LAST-TIME-MONTH** 0)
(DEFVAR 4*LAST-TIME-YEAR** 0)
(DEFVAR 4*LAST-TIME-DAY-OF-THE-WEEK** 0)
(DEFVAR 4*LAST-TIME-DAYLIGHT-SAVINGS-P** nil)
(DEFVAR 4*LAST-TIME-UPDATE-TIME** nil)
(DEFVAR 4*NETWORK-TIME-FUNCTION** NIL)
(DEFVAR 4*UT-AT-BOOT-TIME** NIL "2Used for UPTIME protocol, do not random SETQ.*")

(PROCLAIM '(inline Obsolete-fixnum-microsecond-time))
;1; This is an ancient version of FIXNUM-MICROSECOND-TIME that returns*
;1; the current value of the microsecond clock as two fixnums.*
(DEFUN 4Obsolete-fixNUM-MICROSECOND-TIME* ()
  (DECLARE (VALUES LOW-23-BITS TOP-9-BITS))
  (LET ((TIME (COMPILER:%MICROSECOND-TIME)))
    (VALUES (LDB #o0027 TIME) (LDB #o2711 TIME))))

;;AB 8/5/87. Broke out from INITIALIZE-TIMEBASE.
(DEFUN get-time-from-network (&aux ut)
  (AND (NOT (GET-SITE-OPTION :STANDALONE))
       *NETWORK-TIME-FUNCTION*
       (SETQ ut (FUNCALL *NETWORK-TIME-FUNCTION*)))
  (WHEN (NUMBERP ut) ut))

;;AB 8/5/87. Broke out from INITIALIZE-TIMEBASE.
(DEFUN get-time-from-rtc ()
  (COND ((si:resource-present-p :rtc)
	 (AND (CHAPARRAL-INITIAL-DATE-VALID-P)
	      (CHAPARRAL-GET-UNIVERSAL-TIME)))
	(t
	 (CHAPARRAL-GET-UNIVERSAL-TIME))))

;;AB 8/5/87.  Broke out from INITIALIZE-TIMEBASE.  Fixed problem that year would
;;            be in the wrong century. [SPR 5724]
(DEFUN get-time-from-user (&aux ut)
  "Query user for time, parsing and retrying as necessary.  Returns parsed
universal time or NIL if user gives up."
  (tagbody
   STRING
      (FORMAT *QUERY-IO* "~&Please type the date and time: ")
      (SETQ UT (zlc:READLINE *QUERY-IO*))
      (WHEN (STRING-EQUAL UT "")
	(IF (Y-OR-N-P "Do you want to specify the time or not? ")
	    (GO STRING)
	    (PROGN
	      (SETQ *LAST-TIME-UPDATE-TIME* ())
	      (RETURN-FROM get-time-from-user nil))))
      (CONDITION-CASE (ERROR)
	  (SETQ UT (PARSE-UNIVERSAL-TIME UT 0 () T #.(GET-UNIVERSAL-TIME)))
	(ERROR (SEND ERROR :REPORT *QUERY-IO*)
	       (GO STRING)))
   GIVE-IT-A-SHOT
      (COND ((NOT (Y-OR-N-P (FORMAT () "Time is ~A, OK? "
				    (PRINT-UNIVERSAL-DATE UT ()))))
	     (GO STRING))))
  ut)

;;AB 8/5/87.  New
(DEFUN forget-time ()
  "Turn off timekeeping."
  (SETQ *last-time-update-time* nil
	*ut-at-boot-time* nil))

;;AB 8/5/87.  Fixed century problem with parsing time from user (see above). [SPR 5724]
;;            Re-wrote so time source can be specified.   This way it can be called
;;            early in the inits (before net initialized) to get the local (RTC) time.
;;            [SPRs 4997, 4637]
;;DNG 8/17/87. Fixed misplaced right-paren in order to work for non-nil UT argument.
;;clm 1/06/89 - changed so that if user is entering the time, always set the time.
(DEFUN INITIALIZE-TIMEBASE (&OPTIONAL UT source)
  "Set the clock.  UT, if specified, is the universal time.  
SOURCE describes where to get the time.  NIL means try all sources.  
Other possible values of SOURCE include :NET (the network), :LOCAL (the
local clock), and :USER (ask the user)."
  (WHEN (NULL ut)
    (SETQ ut
	  (SELECT source
	    (:net (get-time-from-network))
	    (:local (get-time-from-rtc))
	    (:user (get-time-from-user))
	    (:otherwise
	     (OR (get-time-from-network)
		 (get-time-from-rtc)
		 (progn (setq source :user) (get-time-from-user)))))) )
  (WHEN ut
    (WITHOUT-INTERRUPTS
      (IF (NOT (NULL *UT-AT-BOOT-TIME*))
	  ;;if we are randomly changing the time while up, mung uptime
	  (SETQ *UT-AT-BOOT-TIME*
		(+ *UT-AT-BOOT-TIME* (- UT (GET-UNIVERSAL-TIME))))
	;;no real surprise: changing at boot time
	(SETQ *UT-AT-BOOT-TIME* UT))
      (SETF (VALUES *LAST-TIME-UPDATE-TIME* *PREVIOUS-TOP-9-TIME-BITS*)
	    (obsolete-FIXNUM-MICROSECOND-TIME))
      (MULTIPLE-VALUE-SETQ
	(*LAST-TIME-SECONDS* *LAST-TIME-MINUTES* *LAST-TIME-HOURS*
	 *LAST-TIME-DAY* *LAST-TIME-MONTH* *LAST-TIME-YEAR*
	 *LAST-TIME-DAY-OF-THE-WEEK* *LAST-TIME-DAYLIGHT-SAVINGS-P*)
	(DECODE-UNIVERSAL-TIME UT))
      ;; Don't touch the MAC clock if on microExplorer.  ab 11/1/88.
      (WHEN (AND (SI:RESOURCE-PRESENT-P :RTC)	
		 (or (CHAPARRAL-INITIAL-DATE-VALID-P)
		     (equalp source :user)))             ;; clm 1/6/89
	(CHAPARRAL-SET-UNIVERSAL-TIME UT))
      (LEAP-YEAR-SETUP)
      ;; Make sure that the leap year times are OK.  See
      ;; leap-year-setup for more details.
      
      T)))

(DEFUN 4SET-LOCAL-TIME* (&OPTIONAL NEW-TIME)
  "2 Set the time on this machine to NEW-TIME. NEW-TIME should be a string 
 which is a reasonable representation of date and time. Examples might be:
 \"11:30\" \"11:30 pm\" \"11:59 4/30/85\" or anything acceptable to 
 time:parse-universal-time*"
  (AND (STRINGP NEW-TIME)
       (SETQ NEW-TIME (PARSE-UNIVERSAL-TIME NEW-TIME)))
  (LET ((*NETWORK-TIME-FUNCTION* NIL))
    (INITIALIZE-TIMEBASE NEW-TIME :USER))) ;; clm 02/23/89

(DEFF 4GET-INTERNAL-REAL-TIME* 'GET-INTERNAL-RUN-TIME)

(DEFUN 4GET-INTERNAL-RUN-TIME* ()
  "2Returns time in 60'ths since last boot.  Can be a bignum.*"
  (LET ((TIME-DIFF (si:%POINTER-DIFFERENCE (TIME) LAST-BOOT-TIME)))
    (WHEN (AND (PROG1 WAS-NEGATIVE
		      (SETQ WAS-NEGATIVE (LDB-TEST (BYTE 1 22.) TIME-DIFF)))
	       (NOT WAS-NEGATIVE))
      (INCF HIGH-TIME-BITS))
    (DPB HIGH-TIME-BITS (BYTE 23. 23.) (LDB (BYTE 23. 0) TIME-DIFF))))

;1; This is so freshly booted machines don't give out an incorrect time or uptime until*
;1; they've found out for themselves what the time *really* is.*
(ADD-INITIALIZATION "Forget time" '(SETQ TIME:*LAST-TIME-UPDATE-TIME* NIL) '(BEFORE-COLD))
(ADD-INITIALIZATION "Forget uptime" '(SETQ TIME:*UT-AT-BOOT-TIME* NIL) '(BEFORE-COLD))

;1This must not process-wait, since it can be called inside the scheduler via the who-line*
(DEFUN UPDATE-TIMEBASE (&AUX BOTTOM-23-TIME-BITS TOP-9-TIME-BITS
			INCREMENTAL-BOTTOM-23-TIME-BITS INCREMENTAL-TOP-9-TIME-BITS
			(OLD-HOUR *LAST-TIME-HOURS*)
			RESIDUE TICK (old-day *last-time-day*))
  "Update our information on the current time."
  ;; 04/07/88 CLM - Fix for two known time problems for standalone machines (which can't
  ;;                get the correct time across the network): 1) if you reboot the machine
  ;;                in January, the year was being set back to the previous year.
  ;;                2) if you reboot the machine on the 29th of a leap year,
  ;;                the date is set to March 1.  Both problems are solved by saving off the
  ;;                time to the rtc when the day changes. [spr 7384]
  ;; 04/21/88 CLM - Fix for problem related to the above.  If you shutdown the machine in
  ;;                December and start it again in January, the old year is displayed.  This
  ;;                is fixed be saving off the month in the ram-month-counter and doing a
  ;;                comparison CHAPARRAL-INITIAL-DATE-VALID-P.  If the month saved in ram
  ;;                is greater than the month saved in the rtc, a year flip has occurred,
  ;;                and the user will be prompted to enter the time. [spr 1286]
  ;; 07/13/88 CLM - Fix yet another stand-alone problem.  The problem occurs if the booted
  ;;                band was created around midnight.  This time is saved in the band's
  ;;                time variables and will cause UPDATE-TIMEBASE to call INITIALIZE-TIMEBASE
  ;;                when it believes a day change has occurred.  This is inappropriate and
  ;;                produces the wrong time if the clock and ram holding the time were zeroed
  ;;                out by the extended diagnostic tests before booting the load band.  The
  ;;                result is your local time comes up the same as the time when the band
  ;;                was created.  The fix is to prevent initializing the clock if the time
  ;;                contained there is not valid.  The user will have to enter date and time
  ;;                when he boots, but this is the appropriate thing to do in this case.
  ;; 08/09/88 clm - Fixed problem occurring on mac, had a call to an RTC function which doesn't
  ;;                exist on the mac side.
  (COND ((NOT (NULL *PREVIOUS-BOTTOM-23-TIME-BITS*))
	 (WITHOUT-INTERRUPTS
       
              ;; Read the microsecond clock (getting time back in two parts)
	   (SETF (VALUES BOTTOM-23-TIME-BITS TOP-9-TIME-BITS)
		 (obsolete-FIXNUM-MICROSECOND-TIME))
      
	      ;; Don't lose when installing this code, set the previous
	      ;; read times to the current.
	   (WHEN (NOT *PREVIOUS-TOP-9-TIME-BITS*)
	     (SETQ *PREVIOUS-TOP-9-TIME-BITS* TOP-9-TIME-BITS)
	     (SETQ *PREVIOUS-BOTTOM-23-TIME-BITS* BOTTOM-23-TIME-BITS))
	   
	      ;; Find out how many times the top 9 bits have changed
	      ;; (handle wrap of 32 bit microsecond counter)
	   (SETQ INCREMENTAL-TOP-9-TIME-BITS
		 (IF (<= *PREVIOUS-TOP-9-TIME-BITS* TOP-9-TIME-BITS)
		     (- TOP-9-TIME-BITS *PREVIOUS-TOP-9-TIME-BITS*)
		     (- (+ TOP-9-TIME-BITS (EXPT 2 11)) *PREVIOUS-TOP-9-TIME-BITS*)))
	   
	      ;; Find out by how much the bottom 23 bits have changed, if
	      ;; the current if less than previous than we have wrapped
              ;; so remove one count from top 9 bits and handle wrap of bottom.
	   (SETQ INCREMENTAL-BOTTOM-23-TIME-BITS
		 (IF (<= *PREVIOUS-BOTTOM-23-TIME-BITS* BOTTOM-23-TIME-BITS)
		     (- BOTTOM-23-TIME-BITS *PREVIOUS-BOTTOM-23-TIME-BITS*)
		     ;; else
		     (PROGN
		       (DECF INCREMENTAL-TOP-9-TIME-BITS)
		       (- (+ BOTTOM-23-TIME-BITS (EXPT 2 27)) *PREVIOUS-BOTTOM-23-TIME-BITS*))))
         ;; Save current times for next time this function is called.
      (SETQ *PREVIOUS-BOTTOM-23-TIME-BITS* BOTTOM-23-TIME-BITS)
      (SETQ *PREVIOUS-TOP-9-TIME-BITS* TOP-9-TIME-BITS)

      (DO (EXIT-THIS-TIME
	   )
	  (NIL)
	(IF (<= INCREMENTAL-TOP-9-TIME-BITS 0)
	  (PROGN
	    (SETQ INCREMENTAL-BOTTOM-23-TIME-BITS
		  (+ *SAVED-MICROSECOND-OVERFLOW*
		     INCREMENTAL-BOTTOM-23-TIME-BITS))
	    (MULTIPLE-VALUE-SETQ (TICK *SAVED-MICROSECOND-OVERFLOW*)
				 (FLOOR INCREMENTAL-BOTTOM-23-TIME-BITS  1000000.))
	    (SETQ EXIT-THIS-TIME T))
	  (PROGN
	    (MULTIPLE-VALUE-SETQ (TICK RESIDUE) (FLOOR (EXPT 2 23.)  1000000.))
	    (SETQ *SAVED-MICROSECOND-OVERFLOW* (+ *SAVED-MICROSECOND-OVERFLOW* RESIDUE))))
	
	(OR (ZEROP TICK) (< (SETQ *LAST-TIME-SECONDS* (+ *LAST-TIME-SECONDS* TICK)) 60.)
	   (<
	    (PROG1
	      (SETQ *LAST-TIME-MINUTES* (+ *LAST-TIME-MINUTES* (FLOOR *LAST-TIME-SECONDS* 60.)))
	      (SETQ *LAST-TIME-SECONDS* (REM *LAST-TIME-SECONDS* 60.)))
	    60.)
	   (<
	    (PROG1
	      (SETQ *LAST-TIME-HOURS* (+ *LAST-TIME-HOURS* (FLOOR *LAST-TIME-MINUTES* 60.)))
	      (SETQ *LAST-TIME-MINUTES* (REM *LAST-TIME-MINUTES* 60.)))
	    24.)
	   (<=
	    (PROG1
	      (SETQ *LAST-TIME-DAY* (1+ *LAST-TIME-DAY*))
	      (SETQ *LAST-TIME-DAY-OF-THE-WEEK*
		    (REM (1+ *LAST-TIME-DAY-OF-THE-WEEK*) 7))
	      (SETQ *LAST-TIME-HOURS* 0)
	      )
	    (MONTH-LENGTH *LAST-TIME-MONTH* *LAST-TIME-YEAR*))
	   (<= (SETQ *LAST-TIME-DAY* 1
		     *LAST-TIME-MONTH* (1+ *LAST-TIME-MONTH*)) 12.)
	   (SETQ *LAST-TIME-MONTH* 1
		 *LAST-TIME-YEAR* (1+ *LAST-TIME-YEAR*)))
	(IF EXIT-THIS-TIME
	  (RETURN ())
	  (DECF INCREMENTAL-TOP-9-TIME-BITS)))
      (WHEN (/= OLD-HOUR *LAST-TIME-HOURS*)
       ;; If hour has incremented, turn decoded time into a UT
       ;; using the timezone we were using up to now,
       ;; use that to decide if we have turned DST on or off,
       ;; and then re-decode the time.
	(LET ((NEWT (ENCODE-UNIVERSAL-TIME
		      *LAST-TIME-SECONDS* *LAST-TIME-MINUTES* *LAST-TIME-HOURS*
		      *LAST-TIME-DAY* *LAST-TIME-MONTH* *LAST-TIME-YEAR*
		      (IF *LAST-TIME-DAYLIGHT-SAVINGS-P*
			  (1- *TIMEZONE*) *TIMEZONE*))))
	  (MULTIPLE-VALUE-SETQ
	    (*LAST-TIME-SECONDS* *LAST-TIME-MINUTES* *LAST-TIME-HOURS*
	     *LAST-TIME-DAY* *LAST-TIME-MONTH* *LAST-TIME-YEAR*
	     *LAST-TIME-DAY-OF-THE-WEEK* *LAST-TIME-DAYLIGHT-SAVINGS-P*)
	    (DECODE-UNIVERSAL-TIME NEWT))
	  (WHEN (AND (/= OLD-DAY *LAST-TIME-DAY*)
		     (SI:RESOURCE-PRESENT-P :RTC)
		     (CHAPARRAL-INITIAL-DATE-VALID-P)
		     *UT-AT-BOOT-TIME*) 
	    ;;update ram-month-counter so we can check for year flips on stand-alone systems
	    (write-chaparral-RTC-chip Rtclock-RAM-Month-Counter *LAST-TIME-MONTH*))
	  ;; update things for get-internal-run-time at least once an hour.
	  (GET-INTERNAL-RUN-TIME)))
      T))
    ;This used to call INITIALIZE-TIMEBASE.  However, since that gets called by
    ;an initialization it seems best not to get processes into it at the same time.
    (T NIL)))

;;AB 8/5/87.  Changed this to allow time initialization source to be specified.  [SPRs 4997, 4637]
(defun 4init-the-clock* (&optional source)
  (setq last-boot-time (time)
	Was-Negative nil
        High-time-bits 0)
  (initialize-timebase nil source))

;;AB 8/5/87.  Init the clock very early from the RTC.  Later, try all sources.  [SPRs 4997, 4637]
(add-initialization "Initialize the Clock" '(Init-the-Clock :local) :system)
(add-initialization "Initialize the Clock" '(progn (Init-the-Clock)
						   (setf name:*uncertain-clock* nil)) nil 'net:*network-warm-initialization-list*)

;1;; One-based lengths of months*
(DEFVAR 4*MONTH-LENGTHS** '(0 31. 28. 31. 30. 31. 30. 31. 31. 30. 31. 30. 31.)
  "2One-based list of lengths of months.*")

(DEFUN 4MONTH-LENGTH* (MONTH YEAR)
  "2Return the number of days in month MONTH in year YEAR.
Knows about leap years.  January is month 1.*"
  (IF (= MONTH 2)
      (IF (LEAP-YEAR-P YEAR) 29. 28.)
      (NTH MONTH *MONTH-LENGTHS*)))

(DEFUN 4LEAP-YEAR-P* (YEAR)           ;1;2000 is a leap year.  2100 is not.*
  "2T if YEAR is a leap year.*"
  (IF (< YEAR 100.)
    (SETQ YEAR (+ 1900. YEAR)))
  (AND (ZEROP (REM YEAR 4))
     (OR (NOT (ZEROP (REM YEAR 100.)))
	 (ZEROP (REM YEAR 400.)))))

(DEFUN 4DAYLIGHT-SAVINGS-P* ()
  "2T if we are now in daylight savings time.*"
  (UPDATE-TIMEBASE)
  *LAST-TIME-DAYLIGHT-SAVINGS-P*)

(DEFUN 4DEFAULT-YEAR* ()
  "2Return the current year, minus 1900.*"
  (UPDATE-TIMEBASE)
  *LAST-TIME-YEAR*)

;1;; These are the functions the user should call*
;1;; If they can't find out what time it is, they return NIL*
(DEFF 4GET-DECODED-TIME* 'GET-TIME)

;;PHD 3/12/87 prevent get-time from giving the time before the timebase is 
;;initialized.
(DEFUN 4GET-TIME* ()
  "2Return the current time, decoded into second, hour, day, etc.
Returns NIL if the time is not known (during startup or DISK-SAVE).*"
  (DECLARE (VALUES SECONDS MINUTES HOURS DAY MONTH YEAR DAY-OF-THE-WEEK
			DAYLIGHT-SAVINGS-P TIMEZONE))
  (AND  TIME:*LAST-TIME-UPDATE-TIME*
	(UPDATE-TIMEBASE)
       (VALUES *LAST-TIME-SECONDS* *LAST-TIME-MINUTES* *LAST-TIME-HOURS*
	       *LAST-TIME-DAY* *LAST-TIME-MONTH*
	       *LAST-TIME-YEAR*
	       *LAST-TIME-DAY-OF-THE-WEEK* *LAST-TIME-DAYLIGHT-SAVINGS-P*
	       *TIMEZONE*)))

(DEFUN 4GET-UNIVERSAL-TIME* ()
  "2Return the current time as a universal-time.
A universal-time is the number of seconds since 1/1/00 00:00-GMT (a bignum).*"
  (UPDATE-TIMEBASE)
  (ENCODE-UNIVERSAL-TIME *LAST-TIME-SECONDS* *LAST-TIME-MINUTES* *LAST-TIME-HOURS*
			 *LAST-TIME-DAY* *LAST-TIME-MONTH* *LAST-TIME-YEAR*
			 (IF *LAST-TIME-DAYLIGHT-SAVINGS-P*
			     (1- *TIMEZONE*) *TIMEZONE*)))

(DEFVAR 4DEFAULT-DATE-PRINT-MODE* :MM/DD/YY;1site variable???????*
   "2How to output the year, month, day part of times.
Possible values include:
:MM/DD/YY :DD/MM/YY :DD-MM-YY :DD-MMM-YY :|DD MMM YY| :DDMMMYY :YYMMDD :YYMMMDD*")

(defvar 4*default-date-print-mode** :unbound
  "2Defines the default way to print the date. Possible values include:
:DD/MM/YY :MM/DD/YY :DD-MM-YY :DD-MMM-YY :|DD MMM YY| :DDMMMYY :YYMMDD :YYMMMDD*")

(forward-value-cell '*default-date-print-mode* 'default-date-print-mode)

;1;args to format: DAY MONTH MONTH-STRING DONT-PRINT-YEAR-P YEAR*
;1;*		1  0   1     2            3                 4*
(DEFPROP 4:MM/DD/YY* "~*~32,'0*D/~0@*~2,'0D~2*~:[/~2,'0D~]" DATE-FORMAT) 	;110/27{/66}*
(DEFPROP 4:DD/MM/YY* "~32,'0*D/~2,'0D~*~:[/~2,'0D~]" DATE-FORMAT)		;127/10{/66}*
(DEFPROP 4:DD-MM-YY* "~32,'0*D-~2,'0D~*~:[-~2,'0D~]" DATE-FORMAT)		;127-10{-66}*
;;PHD 4/9/87 added quote before 0D.
(DEFPROP 4:DD-MMM-YY* "~32,*'30*D-~*~A~:[-~2,'0D~]" DATE-FORMAT)	        ;127-Oct{-66*
(DEFPROP 4:|DD* MMM YY| "2~2,'0D ~*~A~:[ ~2,'0D~]*" DATE-FORMAT)		;127 Oct{-66}*
;;PHD 3/10/87 Added next symbol.
(DEFPROP 4:|*dd mmm yy| "2~2,'0D ~*~A~:[ ~2,'0D~]*" DATE-FORMAT)		;127 Oct{-66}*
(DEFPROP 4:DDMMMYY* "3~2,'0*D~*~A~:[~2,'0D~]" DATE-FORMAT)		;127Oct{66}*
(DEFPROP 4:YYMMDD* "~4*~2,'0D~1@*~2,'0D~0@*~2,'0D" DATE-FORMAT)		;1661027*
(DEFPROP 4:YYMMMDD* "~3*~:[~2,'0D~]~2@*~A~0@*~2,'0D" DATE-FORMAT)	;1{66}Oct27*

;;(DEFUN 4PRINT-CURRENT-TIME* (&OPTIONAL (STREAM *STANDARD-OUTPUT*)
;;				     (DATE-PRINT-MODE DEFAULT-DATE-PRINT-MODE))
;;  "2Print the current time on STREAM.*"
;;  (AND (UPDATE-TIMEBASE)
;;       (MULTIPLE-VALUE-BIND (SECONDS MINUTES HOURS DAY MONTH YEAR)
;;	   (GET-TIME)
;;         (PRINT-TIME SECONDS MINUTES HOURS DAY MONTH YEAR STREAM DATE-PRINT-MODE))))

;;AB 8/5/87.  Fixed always to print some time.  [SPRs 4997, 4637]
(DEFUN 4PRINT-CURRENT-TIME* (&OPTIONAL (STREAM *STANDARD-OUTPUT*)
			        (DATE-PRINT-MODE DEFAULT-DATE-PRINT-MODE))
  "2Print the current time on STREAM.*"
  (update-timebase)
  (MULTIPLE-VALUE-BIND (SECONDS MINUTES HOURS DAY MONTH YEAR)
      (GET-TIME)
    (IF seconds
	(PRINT-TIME SECONDS MINUTES HOURS DAY MONTH YEAR STREAM DATE-PRINT-MODE)
	(print-universal-time 0 stream 0 date-print-mode))))

(DEFUN 4PRINT-UNIVERSAL-TIME* (UT
			     &OPTIONAL (STREAM *STANDARD-OUTPUT*)
			     TIMEZONE
			     (DATE-PRINT-MODE DEFAULT-DATE-PRINT-MODE))
  "2Print the universal-time UT on STREAM, interpreting for time zone TIMEZONE.
TIMEZONE is the number of hours earlier than GMT.*"
  ;1;Let DECODE-UNIVERSAL-TIME default the timezone if wanted, as that fcn*
  ;1;must know to suppress DST iff TIMEZONE is supplied.*
  (MULTIPLE-VALUE-BIND (SECONDS MINUTES HOURS DAY MONTH YEAR)
      (DECODE-UNIVERSAL-TIME UT TIMEZONE)
    (PRINT-TIME SECONDS MINUTES HOURS DAY MONTH YEAR STREAM DATE-PRINT-MODE)))

(DEFUN 4PRINT-TIME* (SECONDS MINUTES HOURS DAY MONTH YEAR
		   &OPTIONAL (STREAM *STANDARD-OUTPUT*)
		   (DATE-PRINT-MODE *DEFAULT-DATE-PRINT-MODE*))
  "2Print time specified on STREAM using date format DATE-PRINT-MODE.
If STREAM is NIL, construct and return a string.*"
  (WITH-STACK-LIST (DATE-MODE-ARGS DAY MONTH (MONTH-STRING MONTH :SHORT)
				   NIL (MOD YEAR 144))
     (FORMAT STREAM "~? ~2,'0D:~2,'0D:~2,'0D"
	     (OR (GET DATE-PRINT-MODE 'DATE-FORMAT)
		(FERROR () "Bad value of DATE-PRINT-MODE: ~s" DATE-PRINT-MODE))
	     DATE-MODE-ARGS
	     HOURS MINUTES SECONDS)))

(DEFUN 4PRINT-CURRENT-DATE* (&OPTIONAL (STREAM *STANDARD-OUTPUT*))
  "2Print the current date in a verbose form on STREAM.
If STREAM is NIL, construct and return a string.*"
  (AND (UPDATE-TIMEBASE)
       (MULTIPLE-VALUE-BIND (SECONDS MINUTES HOURS DAY MONTH YEAR DAY-OF-THE-WEEK)
	   (GET-TIME)
         (PRINT-DATE SECONDS MINUTES HOURS DAY MONTH YEAR DAY-OF-THE-WEEK STREAM))))

(DEFUN 4PRINT-UNIVERSAL-DATE* (UT &OPTIONAL (STREAM *STANDARD-OUTPUT*) TIMEZONE)
  "2Print the universal-time UT in verbose form on STREAM, decoding for TIMEZONE.
If STREAM is NIL, construct and return a string.*"
  (MULTIPLE-VALUE-BIND (SECONDS MINUTES HOURS DAY MONTH YEAR DAY-OF-THE-WEEK)
      (DECODE-UNIVERSAL-TIME UT TIMEZONE)
    (PRINT-DATE SECONDS MINUTES HOURS DAY MONTH YEAR DAY-OF-THE-WEEK STREAM)))

(DEFUN 4PRINT-DATE* (SECONDS MINUTES HOURS DAY MONTH YEAR DAY-OF-THE-WEEK
		   &OPTIONAL (STREAM *STANDARD-OUTPUT*))
  "2Print the date and time in verbose form on STREAM.
If STREAM is NIL, construct and return a string.*"
  (SETQ MONTH (MONTH-STRING MONTH)
	DAY-OF-THE-WEEK (DAY-OF-THE-WEEK-STRING DAY-OF-THE-WEEK))
  (FORMAT STREAM
	  "~A the ~:R of ~A, ~D; ~D:~2,'0D:~2,'0D ~A"
	  DAY-OF-THE-WEEK DAY MONTH YEAR (1+ (REM (+ HOURS 11.) 12.)) MINUTES SECONDS
	  (COND ((AND (ZEROP SECONDS)
		      (ZEROP MINUTES)
		      (MEMBER HOURS '(0 12.) :TEST #'EQ))
		 (IF (= HOURS 0) "midnight" "noon"))
		((>= HOURS 12.) "pm")
		(T "am"))))

(DEFUN 4PRINT-BRIEF-UNIVERSAL-TIME* (UT &OPTIONAL (STREAM *STANDARD-OUTPUT*)
				   (REF-UT (GET-UNIVERSAL-TIME))
				   (DATE-PRINT-MODE *DEFAULT-DATE-PRINT-MODE*))
  "2Prints only those aspects of the time, UT, that differ from the current time.
Also never prints seconds.  Used by notifications, for example.
If STREAM is NIL, construct and return a string.*"
  (MULTIPLE-VALUE-BIND (IGNORE MINUTES HOURS DAY MONTH YEAR)
    (DECODE-UNIVERSAL-TIME UT)
    (MULTIPLE-VALUE-BIND (IGNORE IGNORE IGNORE REF-DAY REF-MONTH REF-YEAR)
      (DECODE-UNIVERSAL-TIME REF-UT)
      ;1; If not same day, print month and day numerically*
      (IF (OR (/= DAY REF-DAY) (/= MONTH REF-MONTH) (/= YEAR REF-YEAR))
	(WITH-STACK-LIST (DATE-MODE-ARGS DAY MONTH (MONTH-STRING MONTH :SHORT)
					 (= YEAR REF-YEAR) (MOD YEAR 100.))
	 (FORMAT STREAM "~? ~2,'0D:~2,'0D"
		 (OR (GET DATE-PRINT-MODE 'DATE-FORMAT)
		     (FERROR () "Bad date-print-mode: ~s" DATE-PRINT-MODE))
		 DATE-MODE-ARGS
		 HOURS MINUTES))
	;1; Always print hours colon minutes, even if same as now*
	(FORMAT STREAM "~2,'0D:~2,'0D" HOURS MINUTES)))))


;1;; Some useful strings and accessing functions.*

;1;; Days of the week.  Elements must be (in order):*
;1;; (1) Three-letter form.*
;1;; (2) Full spelling.*
;1;; (3) Middle-length form if any, else NIL.*
;1;; (4) Francais.*
;1;; (5) Deutsch.*
;1;; (6) Italian.  ; How do you say that in Italian ?*

(DEFVAR 4*DAYS-OF-THE-WEEK** '(("Mon" "Monday" NIL "Lundi" "Montag" "Lunedi")
			     ("Tue" "Tuesday" "Tues" "Mardi" "Dienstag" "Martedi")
			     ("Wed" "Wednesday" NIL "Mercredi" "Mittwoch" "Mercoledi")
			     ("Thu" "Thursday" "Thurs" "Jeudi" "Donnerstag" "Giovedi")
			     ("Fri" "Friday" NIL "Vendredi" "Freitag" "Venerdi")
			     ("Sat" "Saturday" NIL "Samedi" "Samstag" "Sabato")
			     ("Sun" "Sunday" NIL "Dimanche" "Sonntag" "Domenica")))

(DEFUN 4DAY-OF-THE-WEEK-STRING* (DAY-OF-THE-WEEK &OPTIONAL (MODE :LONG) &AUX STRINGS)
  (SETQ STRINGS (NTH DAY-OF-THE-WEEK *DAYS-OF-THE-WEEK*))
  (CASE MODE
    (:SHORT (FIRST STRINGS))
    (:LONG(SECOND STRINGS))
    (:MEDIUM (OR (THIRD STRINGS) (FIRST STRINGS)))
    (:FRENCH (FOURTH STRINGS))
    (:GERMAN (FIFTH STRINGS))
    (:ITALIAN (SIXTH STRINGS))    ;1; After this, perhaps NDOWSS ?*
    (OTHERWISE (FERROR () "~S is not a known day-of-the-week mode" MODE))))  


;1;; Months of the year:  Elements must be (in order):*
;1;; (1) Three-letter form.*
;1;; (2) Full spelling.*
;1;; (3) Middle-length form if any, else NIL.*
;1;; (4) Francais.*
;1;; (5) Roman numerals (used in Europe).*
;1;; (6) Deutsch.*
;1;; (7) Italian.*

(DEFVAR 4*MONTHS** '(("Jan" "January" NIL "Janvier" "I" "Januar" "Genniao")
		   ("Feb" "February" NIL "Fevrier" "II" "Februar" "Febbraio")
		   ("Mar" "March" NIL "Mars" "III" "Maerz" "Marzo")
		   ("Apr" "April" NIL "Avril" "IV" "April" "Aprile")
		   ("May" "May" NIL "Mai" "V" "Mai" "Maggio")
		   ("Jun" "June" NIL "Juin" "VI" "Juni" "Giugno")
		   ("Jul" "July" NIL "Juillet" "VII" "Juli" "Luglio")
		   ("Aug" "August" NIL "Aout" "VIII" "August" "Agosto")
		   ("Sep" "September" "Sept" "Septembre" "IX" "September" "Settembre")
		   ("Oct" "October" NIL "Octobre" "X" "Oktober" "Ottobre")
		   ("Nov" "November" "Novem" "Novembre" "XI" "November" "Novembre")
		   ("Dec" "December" "Decem" "Decembre" "XII" "Dezember" "Dicembre")))

(DEFUN 4MONTH-STRING* (MONTH &OPTIONAL (MODE :LONG) &AUX STRINGS)
  (SETQ STRINGS (NTH (1- MONTH) *MONTHS*))
  (CASE MODE
    (:SHORT (FIRST STRINGS))
    (:LONG (SECOND STRINGS))
    (:MEDIUM (OR (THIRD STRINGS) (FIRST STRINGS)))
    (:FRENCH (FOURTH STRINGS))
    (:ROMAN (FIFTH STRINGS))
    (:GERMAN (SIXTH STRINGS))
    (:ITALIAN (SEVENTH STRINGS))
    (OTHERWISE (FERROR () "~S is not a known month mode" MODE)))) 

;1;; minutes offset from gmt, normal name, daylight name, miltary character*
(DEFVAR *TIMEZONES* '((0 "GMT" NIL #.(char-int #\Z))			;Greenwich
		      (0 "UT" NIL #.(char-int #\Z))
		      (1 NIL NIL #.(char-int #\A))
		      (2 NIL NIL #.(char-int #\B))
		      (3 NIL "ADT" #.(char-int #\C))
		      (4 "AST" "EDT" #.(char-int #\D))		;Atlantic
		      (5 "EST" "CDT" #.(char-int #\E))		;Eastern
		      (6 "CST" "MDT" #.(char-int #\F))		;Central
		      (7 "MST" "PDT" #.(char-int #\G))		;Mountain
		      (8. "PST" "YDT" #.(char-int #\H))		;Pacific
		      (9. "YST" "HDT" #.(char-int #\I))		;Yukon
		      (10. "HST" "BDT" #.(char-int #\K))		;Hawaiian
		      (11. "BST" NIL #.(char-int #\L))		;Bering
		      (12. NIL NIL #.(char-int #\M))
		      (-1 NIL NIL #.(char-int #\N))
		      (-2 NIL NIL #.(char-int #\O))
		      (-3 NIL NIL #.(char-int #\P))
		      (-4 NIL NIL #.(char-int #\Q))
		      (-5 NIL NIL #.(char-int #\R))
		      (-6 NIL NIL #.(char-int #\S))
		      (-7 NIL NIL #.(char-int #\T))
		      (-8. NIL NIL #.(char-int #\U))
		      (-9. "JST" nil #.(char-int #\V))  ;JAPAN 12-05-88 DAB
		      (-10. NIL NIL #.(char-int #\W))
		      (-11. NIL NIL #.(char-int #\X))
		      (-12. NIL NIL #.(char-int #\Y))
		      (3.5 "NST" NIL -1))		;Newfoundland
		      
  "List of timezones: offset from gmt, name, daylight-savings-name, military character.")

(DEFUN 4TIMEZONE-STRING* (&OPTIONAL (TIMEZONE *TIMEZONE*) (DAYLIGHT-SAVINGS-P (DAYLIGHT-SAVINGS-P)))
  "2Return a string describing timezone TIMEZONE, optionally for daylight savings time.
Defaults are our own timezone, and DST if it is now in effect.*"
  (IF DAYLIGHT-SAVINGS-P
    (THIRD (ASSOC (1- TIMEZONE) *TIMEZONES* :TEST #'EQUAL))
    (SECOND (ASSOC TIMEZONE *TIMEZONES* :TEST #'EQUAL))))   

;1;; Date and time parsing*

(DEFMACRO 4BAD-DATE-OR-TIME* (REASON . ARGS)
  `(*THROW 'BAD-DATE-OR-TIME ,(IF (NULL ARGS)
				REASON
				`(GLOBAL:FORMAT () ,REASON ,@ARGS))))  

;;AB 8/5/87.  Fix to work as documented regarding YEAR.  [SPR 5382]
;1;; Check that a date is ok: day is within month; and day-of-week, if specified, is valid*
(DEFUN 4VERIFY-DATE* (DAY MONTH YEAR DAY-OF-THE-WEEK)
  "2If the day of the week of the date specified by DATE, MONTH, and YEAR
is the same as DAY-OF-THE-WEEK, return NIL; otherwise, return a string that
contains a suitable error message. If YEAR is less than 100, it is shifted
by centuries until it is within 50 years of the present.*"
  (COND
    ((> DAY (MONTH-LENGTH MONTH YEAR))
     (FORMAT () "~A only has ~D day~:P" (MONTH-STRING MONTH) (MONTH-LENGTH MONTH YEAR)))
    (DAY-OF-THE-WEEK
     (LET ((UT (ENCODE-UNIVERSAL-TIME 0 0 0 DAY MONTH YEAR)))
       (MULTIPLE-VALUE-BIND (NIL NIL NIL NIL NIL year CORRECT-DAY-OF-THE-WEEK)
	 (DECODE-UNIVERSAL-TIME UT)
	 (AND (/= DAY-OF-THE-WEEK CORRECT-DAY-OF-THE-WEEK)
	    (FORMAT () "The ~:R of ~A, ~D is a ~A, not a ~A" DAY (MONTH-STRING MONTH) YEAR
		    (DAY-OF-THE-WEEK-STRING CORRECT-DAY-OF-THE-WEEK)
		    (DAY-OF-THE-WEEK-STRING DAY-OF-THE-WEEK))))))
    (T NIL)))  

;;;CLM 10/09/87 - Moved this init form from file PROCESSES.  It was causing
;;;a problem (unbound variable *CUMULATIVE-MONTH-DAYS-TABLE* in function
;;;ENCODE-UNIVERSAL-TIME) during boot of a cold band.  
(ADD-INITIALIZATION "Reset Global Process stats" '(si:reset-time-stats) '(:cold))