source: trunk/abcl/src/org/armedbear/lisp/time.lisp @ 14840

Last change on this file since 14840 was 14840, checked in by Mark Evenson, 6 years ago

{decode,encode}-universal-time "time of the time" timezone semantics

Scott L. Burson

The implementation of EXT:GET-TIME-ZONE provides the underlying
mechanism.

Both GET-TIME-ZONE and DEFAULT-TIME-ZONE have been elevated to
supported status by virtue of promotion of their respective symbols to
the EXTENSIONS and SYSTEM packages, respectively.

ME: A mechanism for adding symbols to both SYS and EXT packages with
DEFINE-SYMBOL-MACRO didn't work, but left as comment at the end of
'time.lisp' for further work.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 6.5 KB
Line 
1;;; time.lisp
2;;;
3;;; Copyright (C) 2003-2005 Peter Graves
4;;; $Id: time.lisp 14840 2015-11-09 10:59:10Z mevenson $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
19;;;
20;;; As a special exception, the copyright holders of this library give you
21;;; permission to link this library with independent modules to produce an
22;;; executable, regardless of the license terms of these independent
23;;; modules, and to copy and distribute the resulting executable under
24;;; terms of your choice, provided that you also meet, for each linked
25;;; independent module, the terms and conditions of the license of that
26;;; module.  An independent module is a module which is not derived from
27;;; or based on this library.  If you modify this library, you may extend
28;;; this exception to your version of the library, but you are not
29;;; obligated to do so.  If you do not wish to do so, delete this
30;;; exception statement from your version.
31
32;;; Adapted from SBCL.
33
34(in-package #:system)
35
36(defconstant seconds-in-week (* 60 60 24 7))
37(defconstant weeks-offset 2145)
38(defconstant seconds-offset 432000)
39(defconstant minutes-per-day (* 24 60))
40(defconstant quarter-days-per-year (1+ (* 365 4)))
41(defconstant quarter-days-per-century 146097)
42(defconstant november-17-1858 678882)
43(defconstant weekday-november-17-1858 2)
44
45
46
47;;; decode-universal-time universal-time &optional time-zone
48;;; => second minute hour date month year day daylight-p zone
49;;; If time-zone is not supplied, it defaults to the current time zone adjusted
50;;; for daylight saving time. If time-zone is supplied, daylight saving time
51;;; information is ignored. The daylight saving time flag is nil if time-zone
52;;; is supplied.
53(defun decode-universal-time (universal-time &optional time-zone)
54  (let (seconds-west daylight)
55    (if time-zone
56        (setf seconds-west (* time-zone 3600)
57              daylight nil)
58        (multiple-value-bind (time-zone daylight-p) (ext:get-time-zone universal-time)
59          (setf seconds-west (* time-zone 3600)
60                daylight daylight-p)))
61    (multiple-value-bind (weeks secs)
62        (truncate (+ (- universal-time seconds-west) seconds-offset)
63                  seconds-in-week)
64      (let ((weeks (+ weeks weeks-offset)))
65        (multiple-value-bind (t1 second)
66            (truncate secs 60)
67          (let ((tday (truncate t1 minutes-per-day)))
68            (multiple-value-bind (hour minute)
69                (truncate (- t1 (* tday minutes-per-day)) 60)
70              (let* ((t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4)))
71                     (tcent (truncate t2 quarter-days-per-century)))
72                (setq t2 (mod t2 quarter-days-per-century))
73                (setq t2 (+ (- t2 (mod t2 4)) 3))
74                (let* ((year (+ (* tcent 100)
75                                (truncate t2 quarter-days-per-year)))
76                       (days-since-mar0
77                        (1+ (truncate (mod t2 quarter-days-per-year) 4)))
78                       (day (mod (+ tday weekday-november-17-1858) 7))
79                       (t3 (+ (* days-since-mar0 5) 456)))
80                  (cond ((>= t3 1989)
81                         (setq t3 (- t3 1836))
82                         (setq year (1+ year))))
83                  (multiple-value-bind (month t3)
84                      (truncate t3 153)
85                    (let ((date (1+ (truncate t3 5))))
86                      (values second minute hour date month year day
87                              daylight
88                              (if daylight
89                                  (1+ (/ seconds-west 3600))
90                                  (/ seconds-west 3600))))))))))))))
91
92(defun get-decoded-time ()
93  (decode-universal-time (get-universal-time)))
94
95(defun pick-obvious-year (year)
96  (declare (type (mod 100) year))
97  (let* ((current-year (nth-value 5 (get-decoded-time)))
98   (guess (+ year (* (truncate (- current-year 50) 100) 100))))
99    (declare (type (integer 1900 9999) current-year guess))
100    (if (> (- current-year guess) 50)
101  (+ guess 100)
102  guess)))
103
104(defun leap-years-before (year)
105  (let ((years (- year 1901)))
106    (+ (- (truncate years 4)
107    (truncate years 100))
108       (truncate (+ years 300) 400))))
109
110(defvar *days-before-month*
111  #.(let ((reversed-result nil)
112    (sum 0))
113      (push nil reversed-result)
114      (dolist (days-in-month '(31 28 31 30 31 30 31 31 30 31 30 31))
115  (push sum reversed-result)
116  (incf sum days-in-month))
117      (coerce (nreverse reversed-result) 'simple-vector)))
118
119(defun encode-universal-time (second minute hour date month year
120             &optional time-zone)
121  (let* ((year (if (< year 100)
122       (pick-obvious-year year)
123       year))
124   (days (+ (1- date)
125      (aref *days-before-month* month)
126      (if (> month 2)
127          (leap-years-before (1+ year))
128          (leap-years-before year))
129      (* (- year 1900) 365)))
130   (hours (+ hour (* days 24))))
131    (cond (time-zone
132           (let* ((tz-guess (get-time-zone (* hours 3600)))
133      (guess (+ second (* 60 (+ minute (* 60 (+ hours tz-guess))))))
134      (tz (get-time-zone guess)))
135             (+ guess (* 3600 (- tz tz-guess)))))
136          ((> year 2037)
137           (labels ((leap-year-p (year)
138                      (cond ((zerop (mod year 400)) t)
139                            ((zerop (mod year 100)) nil)
140                            ((zerop (mod year 4)) t)
141                            (t nil))))
142             (let* ((fake-year (if (leap-year-p year) 2036 2037))
143                    (fake-time (encode-universal-time second minute hour
144                                                      date month fake-year)))
145               (+ fake-time
146                 (* 86400 (+ (* 365 (- year fake-year))
147                             (- (leap-years-before year)
148                                (leap-years-before fake-year))))))))
149          (t
150           (+ second (* (+ minute (* (+ hours (default-time-zone)) 60)) 60))))))
151
152#|
153(intern "GET-TIME-ZONE" (find-package :ext))
154(define-symbol-macro EXT:GET-TIME-ZONE
155    `(get-time-zone))
156(export (intern "GET-TIME-ZONE" (find-package :ext)))
157#|
Note: See TracBrowser for help on using the repository browser.