/[cmucl]/src/code/time.lisp
ViewVC logotype

Diff of /src/code/time.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.14 by ram, Wed Aug 25 01:15:27 1993 UTC revision 1.15 by wlott, Sat Nov 13 00:59:48 1993 UTC
# Line 30  Line 30 
30    (/ 1000000 internal-time-units-per-second))    (/ 1000000 internal-time-units-per-second))
31    
32    
 (defmacro not-leap-year (year)  
   (let ((sym (gensym)))  
     `(let ((,sym ,year))  
        (cond ((eq (mod ,sym 4) 0)  
               (and (eq (mod ,sym 100) 0)  
                    (not (eq (mod ,sym 400) 0))))  
              (T T)))))  
33    
34    
35  ;;; The base number of seconds for our internal "epoch".  We initialize this to  ;;; The base number of seconds for our internal "epoch".  We initialize this to
# Line 88  Line 81 
81                     micro-seconds-per-internal-time-unit)))))                     micro-seconds-per-internal-time-unit)))))
82    
83    
84    ;;;; Encode and Decode universal times.
85    
86    ;;; CURRENT-TIMEZONE -- internal.
87    ;;;
88    ;;; Returns two values:
89    ;;;  - the minuteswest of GMT.
90    ;;;  - T if daylight savings is in effect, NIL if not.
91    ;;;
92    (alien:def-alien-routine get-timezone c-call:void
93      (when c-call:long :in)
94      (minutes-west c-call:int :out)
95      (daylight-savings-p alien:boolean :out))
96    
97    
98  ;;; Subtract from the returned Internal_Time to get the universal time.  ;;; Subtract from the returned Internal_Time to get the universal time.
99  ;;; The offset between our time base and the Perq one is 2145 weeks and  ;;; The offset between our time base and the Perq one is 2145 weeks and
100  ;;; five days.  ;;; five days.
# Line 102  Line 109 
109  (defconstant weekday-november-17-1858 2)  (defconstant weekday-november-17-1858 2)
110  (defconstant unix-to-universal-time 2208988800)  (defconstant unix-to-universal-time 2208988800)
111    
 ;;; Make-Universal-Time  --  Internal  
 ;;;  
 ;;;    Convert a Unix Internal_Time into a universal time.  
 ;;;  
 (defun make-universal-time (weeks msec)  
   (+ (* (- weeks weeks-offset) seconds-in-week)  
      (- (truncate msec 1000) seconds-offset)))  
   
112    
113  ;;; Get-Universal-Time  --  Public  ;;; Get-Universal-Time  --  Public
114  ;;;  ;;;
# Line 127  Line 126 
126     (daylight savings times) or NIL (standard time), and timezone."     (daylight savings times) or NIL (standard time), and timezone."
127    (decode-universal-time (get-universal-time)))    (decode-universal-time (get-universal-time)))
128    
129    
130  (defun decode-universal-time (universal-time &optional time-zone)  (defun decode-universal-time (universal-time &optional time-zone)
131    "Converts a universal-time to decoded time format returning the following    "Converts a universal-time to decoded time format returning the following
132    nine values: second, minute, hour, date, month, year, day of week (0 =     nine values: second, minute, hour, date, month, year, day of week (0 =
133    Monday), T (daylight savings time) or NIL (standard time), and timezone.     Monday), T (daylight savings time) or NIL (standard time), and timezone.
134    Completely ignores daylight-savings-time when time-zone is supplied."     Completely ignores daylight-savings-time when time-zone is supplied."
   (declare (type (or fixnum null) time-zone))  
135    (multiple-value-bind (weeks secs)    (multiple-value-bind (weeks secs)
136                         (truncate (+ universal-time seconds-offset)                         (truncate (+ universal-time seconds-offset)
137                                   seconds-in-week)                                   seconds-in-week)
138      (let ((weeks (+ weeks weeks-offset))      (let* ((weeks (+ weeks weeks-offset))
139            (second NIL)             (second NIL)
140            (minute NIL)             (minute NIL)
141            (hour NIL)             (hour NIL)
142            (date NIL)             (date NIL)
143            (month NIL)             (month NIL)
144            (year NIL)             (year NIL)
145            (day NIL)             (day NIL)
146            (daylight NIL)             (daylight NIL)
147            (timezone (if (null time-zone)             (timezone (if (null time-zone)
148                          (multiple-value-bind (res s us tz)                           (multiple-value-bind
149                                               (unix:unix-gettimeofday)                               (ignore minwest dst)
150                            (declare (ignore s us))                               (get-timezone (- universal-time
151                            (if res tz 0))                                                unix-to-universal-time))
152                          (* time-zone 60))))                             (declare (ignore ignore))
153                               (setf daylight dst)
154                               minwest)
155                             (* time-zone 60))))
156        (declare (fixnum timezone))        (declare (fixnum timezone))
157        (multiple-value-bind (t1 seconds) (truncate secs 60)        (multiple-value-bind (t1 seconds) (truncate secs 60)
158          (setq second seconds)          (setq second seconds)
# Line 168  Line 170 
170              (let ((days-since-mar0 (1+ (truncate (mod t2 quarter-days-per-year)              (let ((days-since-mar0 (1+ (truncate (mod t2 quarter-days-per-year)
171                                                   4))))                                                   4))))
172                (setq day (mod (+ tday weekday-november-17-1858) 7))                (setq day (mod (+ tday weekday-november-17-1858) 7))
               (unless time-zone  
                 (if (setq daylight (dst-check days-since-mar0 hour day))  
                     (cond ((eq hour 23)  
                            (setq hour 0)  
                            (setq day (mod (1+ day) 7))  
                            (setq days-since-mar0 (1+ days-since-mar0))  
                            (if (>= days-since-mar0 366)  
                                (if (or (> days-since-mar0 366)  
                                        (not-leap-year (1+ year)))  
                                    (setq days-since-mar0 368))))  
                           (T (setq hour (1+ hour))))))  
173                (let ((t3 (+ (* days-since-mar0 5) 456)))                (let ((t3 (+ (* days-since-mar0 5) 456)))
174                  (cond ((>= t3 1989)                  (cond ((>= t3 1989)
175                         (setq t3 (- t3 1836))                         (setq t3 (- t3 1836))
# Line 186  Line 177 
177                  (multiple-value-setq (month t3) (truncate t3 153))                  (multiple-value-setq (month t3) (truncate t3 153))
178                  (setq date (1+ (truncate t3 5))))))))                  (setq date (1+ (truncate t3 5))))))))
179        (values second minute hour date month year day        (values second minute hour date month year day
180                daylight (truncate timezone 60)))))                daylight
181                  (if daylight
182                      (1+ (/ timezone 60))
183                      (/ timezone 60))))))
184    
185    
186    (defun pick-obvious-year (year)
187      (declare (type (mod 100) year))
188      (let* ((current-year (nth-value 5 (get-decoded-time)))
189             (guess (+ year (* (truncate (- current-year 50) 100) 100))))
190        (declare (type (integer 1900 9999) current-year guess))
191        (if (> (- current-year guess) 50)
192            (+ guess 100)
193            guess)))
194    
195    (defun leap-years-before (year)
196      (let ((years (- year 1901)))
197        (+ (- (truncate years 4)
198              (truncate years 100))
199           (truncate years 400))))
200    
201    (defvar *days-before-month*
202      (collect ((results))
203        (results nil)
204        (let ((sum 0))
205          (dolist (days-per-month '(31 28 31 30 31 30 31 31 30 31 30 31))
206            (results sum)
207            (incf sum days-per-month)))
208        (coerce (results) 'vector)))
209    
210  ;;; Encode-Universal-Time  --  Public  ;;; Encode-Universal-Time  --  Public
211  ;;;  ;;;
 ;;;    Just do a TimeUser:T_UserToInt.  If the year is between 0 and 99 we  
 ;;; have to figure out which the "obvious" year is.  
 ;;;  
   
212  (defun encode-universal-time (second minute hour date month year  (defun encode-universal-time (second minute hour date month year
213                                       &optional time-zone)                                       &optional time-zone)
214    "The time values specified in decoded format are converted to    "The time values specified in decoded format are converted to
215     universal time, which is returned."     universal time, which is returned."
216      (declare (type (mod 60) second)
217               (type (mod 60) minute)
218               (type (mod 24) hour)
219               (type (integer 1 31) date)
220               (type (integer 1 12) month)
221               (type (or (integer 0 99) (integer 1900)) year)
222               (type (or null rational) time-zone))
223    (let* ((year (if (< year 100)    (let* ((year (if (< year 100)
224                     (multiple-value-bind (sec min hour day month now-year)                     (pick-obvious-year year)
                                         (get-decoded-time)  
                      (declare (ignore sec min hour day month))  
                      (do ((y (+ year (* 100 (1- (truncate now-year 100))))  
                              (+ y 100)))  
                          ((<= (abs (- y now-year)) 50) y)))  
225                     year))                     year))
226           (zone (if time-zone (* time-zone 60)           (days (+ (1- date)
227                     (multiple-value-bind (res s us tz) (unix:unix-gettimeofday)                    (aref *days-before-month* month)
228                       (declare (ignore s us))                    (if (> month 2)
229                       (if res tz))))                        (leap-years-before (1+ year))
230           (tmonth (- month 3)))                        (leap-years-before year))
231      (cond ((< tmonth 0)                    (* (- year 1900) 365)))
232             (setq tmonth (+ tmonth 12))           (hours (+ hour (* days 24))))
233             (setq year (1- year))))      (if time-zone
234      (let ((days-since-mar0 (+ (truncate (+ (* tmonth 153) 2) 5) date)))          (+ second (* (+ minute (* (+ hours time-zone) 60)) 60))
235        (multiple-value-bind (tcent tyear) (truncate year 100)          (let* ((minwest-guess
236          (let* ((tday (- (+ (truncate (* tcent quarter-days-per-century) 4)                  (nth-value 1
237                             (truncate (* tyear quarter-days-per-year) 4)                             (get-timezone (- (* hours 60 60)
238                             days-since-mar0)                                              unix-to-universal-time))))
239                          november-17-1858))                 (guess (+ minute (* hours 60) minwest-guess))
240                 (daylight (dst-check days-since-mar0 (1- hour)                 (minwest
241                                      (mod (+ tday weekday-november-17-1858) 7)))                  (nth-value 1
242                 (tminutes (+ (* hour 60) minute zone)))                             (get-timezone (- (* guess 60)
243            (if daylight (setq tminutes (- tminutes 60)))                                              unix-to-universal-time)))))
244            (do ((i tminutes (+ i minutes-per-day)))            (+ second (* (+ guess (- minwest minwest-guess)) 60))))))
245                ((>= i 0) (setq tminutes i))  
             (declare (fixnum i))  
             (decf tday 1))  
           (do ((i tminutes (- i minutes-per-day)))  
               ((< i minutes-per-day) (setq tminutes i))  
             (declare (fixnum i))  
             (incf tday 1))  
           (multiple-value-bind (weeks dpart) (truncate tday 7)  
             (make-universal-time weeks (* (+ (* (+ (* dpart minutes-per-day)  
                                                    tminutes) 60)  
                                              second) 1000))))))))  
   
 ;;; Dst-check -- Internal  
 (defconstant april-1 (+ (truncate (+ (* (- 4 3) 153) 2) 5) 1))  
 (defconstant october-31 (+ (truncate (+ (* (- 10 3) 153) 2) 5) 31))  
   
 (eval-when (compile eval)  
   
   (defmacro dst-check-start-of-month-ge (day hour weekday daybound)  
     (let ((d (gensym))  
           (h (gensym))  
           (w (gensym))  
           (db (gensym)))  
       `(let ((,d ,day)  
              (,h ,hour)  
              (,w ,weekday)  
              (,db ,daybound))  
          (declare (fixnum ,d ,h ,w ,db))  
          (cond ((< ,d ,db) NIL)  
                ((> (the fixnum (- ,d ,w)) ,db) T)  
                ((and (eq ,w 6) (> ,h 0)) T)  
                (T NIL)))))  
   
   (defmacro dst-check-end-of-month-ge (day hour weekday daybound)  
     (let ((d (gensym))  
           (h (gensym))  
           (w (gensym))  
           (db (gensym)))  
       `(let ((,d ,day)  
              (,h ,hour)  
              (,w ,weekday)  
              (,db ,daybound))  
          (declare (fixnum ,d ,h ,w ,db))  
          (cond ((< (the fixnum (+ ,d 6)) ,db) NIL)  
                ((> (the fixnum  (- (the fixnum (+ ,d 6)) ,w)) ,db) T)  
                ((and (eq ,w 6) (> ,h 0)) T)  
                (T NIL)))))  
   )  
   
 (defun dst-check (day hour weekday)  
   (and (dst-check-start-of-month-ge day hour weekday april-1)  
        (not (dst-check-end-of-month-ge day hour weekday october-31))))  
246    
247  ;;;; Time:  ;;;; Time:
248    

Legend:
Removed from v.1.14  
changed lines
  Added in v.1.15

  ViewVC Help
Powered by ViewVC 1.1.5