/[gcl]/gcl/lsp/gcl_mislib.lsp
ViewVC logotype

Diff of /gcl/lsp/gcl_mislib.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by camm, Sun Sep 14 02:30:35 2003 UTC revision 1.2 by camm, Sun Sep 14 02:43:06 2003 UTC
# Line 0  Line 1 
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))))

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26