source: trunk/ccl/lib/time.lisp @ 6919

Last change on this file since 6919 was 6919, checked in by gb, 13 years ago

GET-TIMEZONE: conditionalize on target word size, not ppc32/ppc64.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 7.5 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(in-package "CCL")
18
19(eval-when (:compile-toplevel :execute)
20  (defconstant seconds-in-week (* 60 60 24 7))
21  (defconstant weeks-offset 2145)
22  (defconstant seconds-offset 432000)
23  (defconstant minutes-per-day (* 24 60))
24  (defconstant quarter-days-per-year (1+ (* 365 4)))
25  (defconstant quarter-days-per-century 146097)
26  (defconstant november-17-1858 678882)
27  (defconstant weekday-november-17-1858 2)
28)
29
30(defun gctime ()
31  (let* ((timeval-size (record-length :timeval)))
32    (%stack-block ((copy (* timeval-size 5)))
33      (#_memmove copy *total-gc-microseconds* (* timeval-size 5))
34      (values
35       (timeval->milliseconds copy)
36       (timeval->milliseconds (%incf-ptr copy timeval-size))
37       (timeval->milliseconds (%incf-ptr copy timeval-size))
38       (timeval->milliseconds (%incf-ptr copy timeval-size))
39       (timeval->milliseconds (%incf-ptr copy timeval-size))))))
40
41(defun get-universal-time ()
42  "Return a single integer for the current time of
43   day in universal time format."
44  (rlet ((tv :timeval))
45    (#_gettimeofday tv (%null-ptr))
46    (+ (pref tv :timeval.tv_sec) unix-to-universal-time)))
47
48;;; This should stop using #_localtime_r: not all times can be represented
49;;; as a signed natural offset from the start of Unix time.
50;;; For now, if the time won't fit in a :time_t, use an arbitrary time
51;;; value to get the time zone and assume that DST was -not- in effect.
52(defun get-timezone (time)
53  (let* ((toobig (not (typep time '(unsigned-byte
54                                    #+32-bit-target 32
55                                    #+64-bit-target 64)))))
56    (when toobig
57      (setq time 0))
58    (rlet ((when :time_t)
59           (tm :tm))
60      (setf (pref when :time_t) time)
61      (with-macptrs ((ltm (#_localtime_r when tm)))
62        (if (%null-ptr-p ltm)
63          (values 0 nil)
64          (progn
65            (values (floor (pref tm :tm.tm_gmtoff) -60)
66                    (unless toobig (not (zerop (pref tm :tm.tm_isdst)))))))))))
67
68
69
70(defun decode-universal-time (universal-time &optional time-zone)
71  "Converts a universal-time to decoded time format returning the following
72   nine values: second, minute, hour, date, month, year, day of week (0 =
73   Monday), T (daylight savings time) or NIL (standard time), and timezone.
74   Completely ignores daylight-savings-time when time-zone is supplied."
75  (multiple-value-bind (weeks secs)
76                       (truncate (+ universal-time seconds-offset)
77                                 seconds-in-week)
78    (let* ((weeks (+ weeks weeks-offset))
79           (second NIL)
80           (minute NIL)
81           (hour NIL)
82           (date NIL)
83           (month NIL)
84           (year NIL)
85           (day NIL)
86           (daylight NIL)
87           (timezone (if (null time-zone)
88                         (multiple-value-bind
89                             (minwest dst)
90                             (get-timezone (- universal-time
91                                              unix-to-universal-time))
92                           (setf daylight dst)
93                           minwest)
94                         (* time-zone 60))))
95      (declare (fixnum timezone))
96      (multiple-value-bind (t1 seconds) (truncate secs 60)
97        (setq second seconds)
98        (setq t1 (- t1 timezone))
99        (let* ((tday (if (< t1 0)
100                         (1- (truncate (1+ t1) minutes-per-day))
101                         (truncate t1 minutes-per-day))))
102          (multiple-value-setq (hour minute)
103            (truncate (- t1 (* tday minutes-per-day)) 60))
104          (let* ((t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4)))
105                 (tcent (truncate t2 quarter-days-per-century)))
106            (setq t2 (mod t2 quarter-days-per-century))
107            (setq t2 (+ (- t2 (mod t2 4)) 3))
108            (setq year (+ (* tcent 100) (truncate t2 quarter-days-per-year)))
109            (let ((days-since-mar0 (1+ (truncate (mod t2 quarter-days-per-year)
110                                                 4))))
111              (setq day (mod (+ tday weekday-november-17-1858) 7))
112              (let ((t3 (+ (* days-since-mar0 5) 456)))
113                (cond ((>= t3 1989)
114                       (setq t3 (- t3 1836))
115                       (setq year (1+ year))))
116                (multiple-value-setq (month t3) (truncate t3 153))
117                (setq date (1+ (truncate t3 5))))))))
118      (values second minute hour date month year day
119              daylight
120              (if daylight
121                  (1+ (/ timezone 60))
122                  (/ timezone 60))))))
123
124(defun get-decoded-time ()
125  "Return nine values specifying the current time as follows:
126   second, minute, hour, date, month, year, day of week (0 = Monday), T
127   (daylight savings times) or NIL (standard time), and timezone."
128  (decode-universal-time (get-universal-time)))
129
130(defun current-year ()
131  (nth-value 5 (get-decoded-time)))
132
133(defun leap-years-before (year)
134  (let ((years (- year 1901)))
135    (+ (- (truncate years 4)
136          (truncate years 100))
137       (truncate (+ years 300) 400))))
138
139(defvar *days-before-month*
140  (let* ((results (list nil)))
141    (let ((sum 0))
142      (dolist (days-per-month '(31 28 31 30 31 30 31 31 30 31 30 31))
143        (push sum results)
144        (incf sum days-per-month)))
145    (coerce (nreverse results) 'vector)))
146
147(defun encode-universal-time (second minute hour date month year
148                                     &optional time-zone)
149  "The time values specified in decoded format are converted to
150   universal time, which is returned."
151  (declare (type (mod 60) second)
152           (type (mod 60) minute)
153           (type (mod 24) hour)
154           (type (integer 1 31) date)
155           (type (integer 1 12) month)
156           (type unsigned-byte year)
157           (type (or null rational) time-zone))
158  (when (< year 100)
159    (let* ((this (current-year))
160           (past (- this 50))
161           (future (+ this 49))
162           (maybe-past (+ (- past (mod past 100)) year))
163           (maybe-future (+ (- future (mod future 100)) year)))
164      (if (>= maybe-past past)
165        (setq year maybe-past)
166        (setq year maybe-future))))
167           
168  (let* ((days (+ (1- date)
169                  (aref *days-before-month* month)
170                  (if (> month 2)
171                    (leap-years-before (1+ year))
172                    (leap-years-before year))
173                  (* (- year 1900) 365)))
174         (hours (+ hour (* days 24))))
175    (if time-zone
176      (+ second (* (+ minute (* (+ hours time-zone) 60)) 60))
177      (let* ((minwest-guess
178              (get-timezone (- (* hours 60 60)
179                               unix-to-universal-time)))
180             (guess (+ minute (* hours 60) minwest-guess))
181             (minwest
182              (get-timezone (- (* guess 60)
183                               unix-to-universal-time))))
184        (+ second (* (+ guess (- minwest minwest-guess)) 60))))))
185
186
187
188(defun sleep (seconds)
189  "This function causes execution to be suspended for N seconds. N may
190  be any non-negative, non-complex number."
191  (when (minusp seconds) (report-bad-arg seconds '(real 0 *)))
192  (multiple-value-bind (secs nanos)
193      (nanoseconds seconds)
194    (%nanosleep secs nanos)))
195
196(defun get-internal-run-time ()
197  "Return the run time in the internal time format. (See
198  INTERNAL-TIME-UNITS-PER-SECOND.) This is useful for finding CPU usage."
199  (rlet ((usage :rusage))
200    (%%rusage usage)
201    (let* ((user-seconds (pref usage :rusage.ru_utime.tv_sec))
202           (system-seconds (pref usage :rusage.ru_stime.tv_sec))
203           (user-micros (pref usage :rusage.ru_utime.tv_usec))
204           (system-micros (pref usage :rusage.ru_stime.tv_usec)))
205      (+ (* (+ user-seconds system-seconds) internal-time-units-per-second)
206         (round (+ user-micros system-micros) (floor 1000000 internal-time-units-per-second))))))
207
208
209
210
211
212     
Note: See TracBrowser for help on using the repository browser.