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

Last change on this file was 14997, checked in by Mark Evenson, 4 years ago

Move SYS:GET-TIME-ZONE to EXT:GET-TIME-ZONE

Refactor Time.java to Java primitive linkage conventions.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 6.3 KB
Line 
1;;; time.lisp
2;;;
3;;; Copyright (C) 2003-2005 Peter Graves
4;;; $Id: time.lisp 14997 2017-04-17 13:47:31Z 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;;; decode-universal-time universal-time &optional time-zone
46;;; => second minute hour date month year day daylight-p zone
47;;; If time-zone is not supplied, it defaults to the current time zone adjusted
48;;; for daylight saving time. If time-zone is supplied, daylight saving time
49;;; information is ignored. The daylight saving time flag is nil if time-zone
50;;; is supplied.
51(defun decode-universal-time (universal-time &optional time-zone)
52  (let (seconds-west daylight)
53    (if time-zone
54        (setf seconds-west (* time-zone 3600)
55              daylight nil)
56        (multiple-value-bind (time-zone daylight-p) (ext:get-time-zone universal-time)
57          (setf seconds-west (* time-zone 3600)
58                daylight daylight-p)))
59    (multiple-value-bind (weeks secs)
60        (truncate (+ (- universal-time seconds-west) seconds-offset)
61                  seconds-in-week)
62      (let ((weeks (+ weeks weeks-offset)))
63        (multiple-value-bind (t1 second)
64            (truncate secs 60)
65          (let ((tday (truncate t1 minutes-per-day)))
66            (multiple-value-bind (hour minute)
67                (truncate (- t1 (* tday minutes-per-day)) 60)
68              (let* ((t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4)))
69                     (tcent (truncate t2 quarter-days-per-century)))
70                (setq t2 (mod t2 quarter-days-per-century))
71                (setq t2 (+ (- t2 (mod t2 4)) 3))
72                (let* ((year (+ (* tcent 100)
73                                (truncate t2 quarter-days-per-year)))
74                       (days-since-mar0
75                        (1+ (truncate (mod t2 quarter-days-per-year) 4)))
76                       (day (mod (+ tday weekday-november-17-1858) 7))
77                       (t3 (+ (* days-since-mar0 5) 456)))
78                  (cond ((>= t3 1989)
79                         (setq t3 (- t3 1836))
80                         (setq year (1+ year))))
81                  (multiple-value-bind (month t3)
82                      (truncate t3 153)
83                    (let ((date (1+ (truncate t3 5))))
84                      (values second minute hour date month year day
85                              daylight
86                              (if daylight
87                                  (1+ (/ seconds-west 3600))
88                                  (/ seconds-west 3600))))))))))))))
89
90(defun get-decoded-time ()
91  (decode-universal-time (get-universal-time)))
92
93(defun pick-obvious-year (year)
94  (declare (type (mod 100) year))
95  (let* ((current-year (nth-value 5 (get-decoded-time)))
96   (guess (+ year (* (truncate (- current-year 50) 100) 100))))
97    (declare (type (integer 1900 9999) current-year guess))
98    (if (> (- current-year guess) 50)
99  (+ guess 100)
100  guess)))
101
102(defun leap-years-before (year)
103  (let ((years (- year 1901)))
104    (+ (- (truncate years 4)
105    (truncate years 100))
106       (truncate (+ years 300) 400))))
107
108(defvar *days-before-month*
109  #.(let ((reversed-result nil)
110    (sum 0))
111      (push nil reversed-result)
112      (dolist (days-in-month '(31 28 31 30 31 30 31 31 30 31 30 31))
113  (push sum reversed-result)
114  (incf sum days-in-month))
115      (coerce (nreverse reversed-result) 'simple-vector)))
116
117(defun encode-universal-time (second minute hour date month year
118             &optional time-zone)
119  (let* ((year (if (< year 100)
120       (pick-obvious-year year)
121       year))
122   (days (+ (1- date)
123      (aref *days-before-month* month)
124      (if (> month 2)
125          (leap-years-before (1+ year))
126          (leap-years-before year))
127      (* (- year 1900) 365)))
128   (hours (+ hour (* days 24))))
129    (cond (time-zone
130           (+ second (* (+ minute (* (+ hours time-zone) 60)) 60)))
131          ((> year 2037)
132           (labels ((leap-year-p (year)
133                      (cond ((zerop (mod year 400)) t)
134                            ((zerop (mod year 100)) nil)
135                            ((zerop (mod year 4)) t)
136                            (t nil))))
137             (let* ((fake-year (if (leap-year-p year) 2036 2037))
138                    (fake-time (encode-universal-time second minute hour
139                                                      date month fake-year)))
140               (+ fake-time
141                 (* 86400 (+ (* 365 (- year fake-year))
142                             (- (leap-years-before year)
143                                (leap-years-before fake-year))))))))
144          (t
145           (let* ((tz-guess (ext:get-time-zone (* hours 3600)))
146      (guess (+ second (* 60 (+ minute (* 60 (+ hours tz-guess))))))
147      (tz (get-time-zone guess)))
148       (+ guess (* 3600 (- tz tz-guess))))))))
Note: See TracBrowser for help on using the repository browser.