source: trunk/j/src/org/armedbear/lisp/time.lisp @ 4135

Last change on this file since 4135 was 4135, checked in by piso, 19 years ago

Initial checkin.

File size: 4.4 KB
Line 
1;;; time.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: time.lisp,v 1.1 2003-09-29 17:59:26 piso Exp $
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;;; Adapted from SBCL.
21
22(in-package "SYSTEM")
23
24(defconstant seconds-in-week (* 60 60 24 7))
25(defconstant weeks-offset 2145)
26(defconstant seconds-offset 432000)
27(defconstant minutes-per-day (* 24 60))
28(defconstant quarter-days-per-year (1+ (* 365 4)))
29(defconstant quarter-days-per-century 146097)
30(defconstant november-17-1858 678882)
31(defconstant weekday-november-17-1858 2)
32
33;;; decode-universal-time universal-time &optional time-zone
34;;; => second minute hour date month year day daylight-p zone
35;;; If time-zone is not supplied, it defaults to the current time zone adjusted
36;;; for daylight saving time. If time-zone is supplied, daylight saving time
37;;; information is ignored. The daylight saving time flag is nil if time-zone
38;;; is supplied.
39(defun decode-universal-time (universal-time &optional time-zone)
40  (unless time-zone
41    (setf time-zone (default-time-zone)))
42  (multiple-value-bind (weeks secs)
43    (truncate (+ universal-time seconds-offset)
44              seconds-in-week)
45    (let* ((weeks (+ weeks weeks-offset))
46     (second NIL)
47     (minute NIL)
48     (hour NIL)
49     (date NIL)
50     (month NIL)
51     (year NIL)
52     (day NIL)
53     (daylight NIL)
54     (timezone (* time-zone 60)))
55      (multiple-value-bind (t1 seconds) (truncate secs 60)
56  (setq second seconds)
57  (setq t1 (- t1 timezone))
58  (let* ((tday (if (< t1 0)
59       (1- (truncate (1+ t1) minutes-per-day))
60       (truncate t1 minutes-per-day))))
61    (multiple-value-setq (hour minute)
62                               (truncate (- t1 (* tday minutes-per-day)) 60))
63    (let* ((t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4)))
64     (tcent (truncate t2 quarter-days-per-century)))
65      (setq t2 (mod t2 quarter-days-per-century))
66      (setq t2 (+ (- t2 (mod t2 4)) 3))
67      (setq year (+ (* tcent 100) (truncate t2 quarter-days-per-year)))
68      (let ((days-since-mar0 (1+ (truncate (mod t2 quarter-days-per-year)
69             4))))
70        (setq day (mod (+ tday weekday-november-17-1858) 7))
71        (let ((t3 (+ (* days-since-mar0 5) 456)))
72    (cond ((>= t3 1989)
73           (setq t3 (- t3 1836))
74           (setq year (1+ year))))
75    (multiple-value-setq (month t3) (truncate t3 153))
76    (setq date (1+ (truncate t3 5))))))))
77      (values second minute hour date month year day
78        daylight
79        (if daylight
80      (1+ (/ timezone 60))
81      (/ timezone 60))))))
82
83(defun get-decoded-time ()
84  (decode-universal-time (get-universal-time)))
85
86(defun pick-obvious-year (year)
87  (declare (type (mod 100) year))
88  (let* ((current-year (nth-value 5 (get-decoded-time)))
89   (guess (+ year (* (truncate (- current-year 50) 100) 100))))
90    (declare (type (integer 1900 9999) current-year guess))
91    (if (> (- current-year guess) 50)
92  (+ guess 100)
93  guess)))
94
95(defun leap-years-before (year)
96  (let ((years (- year 1901)))
97    (+ (- (truncate years 4)
98    (truncate years 100))
99       (truncate (+ years 300) 400))))
100
101(defvar *days-before-month*
102  #.(let ((reversed-result nil)
103    (sum 0))
104      (push nil reversed-result)
105      (dolist (days-in-month '(31 28 31 30 31 30 31 31 30 31 30 31))
106  (push sum reversed-result)
107  (incf sum days-in-month))
108      (coerce (nreverse reversed-result) 'simple-vector)))
109
110(defun encode-universal-time (second minute hour date month year
111             &optional time-zone)
112  (let* ((year (if (< year 100)
113       (pick-obvious-year year)
114       year))
115   (days (+ (1- date)
116      (aref *days-before-month* month)
117      (if (> month 2)
118          (leap-years-before (1+ year))
119          (leap-years-before year))
120      (* (- year 1900) 365)))
121   (hours (+ hour (* days 24))))
122    (unless time-zone
123      (setf time-zone (default-time-zone)))
124    (+ second (* (+ minute (* (+ hours time-zone) 60)) 60))))
Note: See TracBrowser for help on using the repository browser.