1 |
|
;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa |
2 |
|
|
3 |
|
;; This file is part of GNU Common Lisp, herein referred to as GCL |
4 |
|
;; |
5 |
|
;; GCL is free software; you can redistribute it and/or modify it under |
6 |
|
;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by |
7 |
|
;; the Free Software Foundation; either version 2, or (at your option) |
8 |
|
;; any later version. |
9 |
|
;; |
10 |
|
;; GCL is distributed in the hope that it will be useful, but WITHOUT |
11 |
|
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
12 |
|
;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public |
13 |
|
;; License for more details. |
14 |
|
;; |
15 |
|
;; You should have received a copy of the GNU Library General Public License |
16 |
|
;; along with GCL; see the file COPYING. If not, write to the Free Software |
17 |
|
;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |
18 |
|
|
19 |
|
|
20 |
|
;;;; This file is IMPLEMENTATION-DEPENDENT. |
21 |
|
|
22 |
|
|
23 |
|
(in-package 'lisp) |
24 |
|
|
25 |
|
|
26 |
|
(export 'time) |
27 |
|
(export 'nth-value) |
28 |
|
(export '(decode-universal-time encode-universal-time compile-file-pathname complement constantly)) |
29 |
|
|
30 |
|
|
31 |
|
(in-package 'system) |
32 |
|
|
33 |
|
|
34 |
|
(proclaim '(optimize (safety 2) (space 3))) |
35 |
|
|
36 |
|
|
37 |
|
(defmacro time (form) |
38 |
|
`(let (real-start real-end run-start run-end x) |
39 |
|
(setq real-start (get-internal-real-time)) |
40 |
|
(setq run-start (get-internal-run-time)) |
41 |
|
(setq x (multiple-value-list ,form)) |
42 |
|
(setq run-end (get-internal-run-time)) |
43 |
|
(setq real-end (get-internal-real-time)) |
44 |
|
(fresh-line *trace-output*) |
45 |
|
(format *trace-output* |
46 |
|
"real time : ~,3F secs~%~ |
47 |
|
run time : ~,3F secs~%" |
48 |
|
(/ (- real-end real-start) internal-time-units-per-second) |
49 |
|
(/ (- run-end run-start) internal-time-units-per-second)) |
50 |
|
(values-list x))) |
51 |
|
|
52 |
|
|
53 |
|
(defconstant month-days-list '(31 28 31 30 31 30 31 31 30 31 30 31)) |
54 |
|
(defconstant seconds-per-day #.(* 24 3600)) |
55 |
|
|
56 |
|
(defun leap-year-p (y) |
57 |
|
(and (zerop (mod y 4)) |
58 |
|
(or (not (zerop (mod y 100))) (zerop (mod y 400))))) |
59 |
|
|
60 |
|
(defun number-of-days-from-1900 (y) |
61 |
|
(let ((y1 (1- y))) |
62 |
|
(+ (* (- y 1900) 365) |
63 |
|
(floor y1 4) (- (floor y1 100)) (floor y1 400) |
64 |
|
-460))) |
65 |
|
|
66 |
|
(defun decode-universal-time (ut &optional (tz *default-time-zone*)) |
67 |
|
(let (sec min h d m y dow) |
68 |
|
(decf ut (* tz 3600)) |
69 |
|
(multiple-value-setq (d ut) (floor ut seconds-per-day)) |
70 |
|
(setq dow (mod d 7)) |
71 |
|
(multiple-value-setq (h ut) (floor ut 3600)) |
72 |
|
(multiple-value-setq (min sec) (floor ut 60)) |
73 |
|
(setq y (+ 1900 (floor d 366))) ; Guess! |
74 |
|
(do ((x)) |
75 |
|
((< (setq x (- d (number-of-days-from-1900 y))) |
76 |
|
(if (leap-year-p y) 366 365)) |
77 |
|
(setq d (1+ x))) |
78 |
|
(incf y)) |
79 |
|
(when (leap-year-p y) |
80 |
|
(when (= d 60) |
81 |
|
(return-from decode-universal-time |
82 |
|
(values sec min h 29 2 y dow nil tz))) |
83 |
|
(when (> d 60) (decf d))) |
84 |
|
(do ((l month-days-list (cdr l))) |
85 |
|
((<= d (car l)) (setq m (- 13 (length l)))) |
86 |
|
(decf d (car l))) |
87 |
|
(values sec min h d m y dow nil tz))) |
88 |
|
|
89 |
|
(defun encode-universal-time (sec min h d m y |
90 |
|
&optional (tz *default-time-zone*)) |
91 |
|
(incf h tz) |
92 |
|
(when (<= 0 y 99) |
93 |
|
(multiple-value-bind (sec min h d m y1 dow dstp tz) |
94 |
|
(get-decoded-time) |
95 |
|
(declare (ignore sec min h d m dow dstp tz)) |
96 |
|
(incf y (- y1 (mod y1 100))) |
97 |
|
(cond ((< (- y y1) -50) (incf y 100)) |
98 |
|
((>= (- y y1) 50) (decf y 100))))) |
99 |
|
(unless (and (leap-year-p y) (> m 2)) (decf d 1)) |
100 |
|
(+ (* (apply #'+ d (number-of-days-from-1900 y) |
101 |
|
(butlast month-days-list (- 13 m))) |
102 |
|
seconds-per-day) |
103 |
|
(* h 3600) (* min 60) sec)) |
104 |
|
|
105 |
|
; Courtesy Paul Dietz |
106 |
|
(defmacro nth-value (n expr) |
107 |
|
`(nth ,n (multiple-value-list ,expr))) |
108 |
|
(defun compile-file-pathname (pathname) |
109 |
|
(make-pathname :defaults pathname :type "o")) |
110 |
|
(defun constantly (x) |
111 |
|
#'(lambda (&rest args) |
112 |
|
(declare (ignore args) (dynamic-extent args)) |
113 |
|
x)) |
114 |
|
(defun complement (fn) |
115 |
|
#'(lambda (&rest args) (not (apply fn args)))) |