1 ;;;; time printing routines built upon the Common Lisp FORMAT function
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
12 (in-package "SB!IMPL")
14 (defparameter *abbrev-weekday-table
*
15 #("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun"))
17 (defparameter *long-weekday-table
*
18 #("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday"))
20 (defparameter *abbrev-month-table
*
21 #("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
23 (defparameter *long-month-table
*
24 #("January" "February" "March" "April" "May" "June" "July" "August"
25 "September" "October" "November" "December"))
27 ;;; The timezone table is incomplete but workable.
28 (defparameter *timezone-table
*
29 #("GMT" "" "" "" "" "EST" "CST" "MST" "PST"))
31 (defparameter *daylight-table
*
32 #(nil nil nil nil nil
"EDT" "CDT" "MDT" "PDT"))
34 ;;; VALID-DESTINATION-P ensures the destination stream is okay for the
36 (defun valid-destination-p (destination)
40 (and (stringp destination
)
41 (array-has-fill-pointer-p destination
))))
43 ;;; CMU CL made the default style :SHORT here. I've changed that to :LONG, on
44 ;;; the theory that since the 8/7/1999 style is hard to decode unambiguously,
45 ;;; you should have to ask for it explicitly. (I prefer YYYYMMDD myself, since
46 ;;; it sorts properly.:-) -- WHN 19990831
48 ;;; FIXME: On the CMU CL mailing list 30 Jan 2000, Pierre Mai suggested
49 ;;; OTOH it probably wouldn't be a major problem to change compile-file to
50 ;;; use for example :long, so that the output would be Month DD, YYYY, or
51 ;;; even better to extend format-universal-time with a flag to output ISO
52 ;;; 8601 formats (like e.g. :iso-8601 and :iso-8601-short) and migrate
53 ;;; slowly towards ISO dates in the user code...
54 ;;; The :ISO-8601 and :ISO-8601-SHORT options sound sensible to me. Maybe
55 ;;; someone will do them for CMU CL and we can steal them for SBCL.
56 (defun format-universal-time (destination universal-time
65 "Format-Universal-Time formats a string containing the time and date
66 given by universal-time in a common manner. The destination is any
67 destination which can be accepted by the Format function. The
68 timezone keyword is an integer specifying hours west of Greenwich.
69 The style keyword can be :SHORT (numeric date), :LONG (months and
70 weekdays expressed as words), :ABBREVIATED (like :LONG but words are
71 abbreviated), or :GOVERNMENT (of the form \"XX Month XXXX XX:XX:XX\")
72 The &KEY argument :DATE-FIRST, if NIL, will print the time first instead
73 of the date (the default). The PRINT- keywords, if NIL, inhibit
74 the printing of the obvious part of the time/date."
75 (unless (valid-destination-p destination
)
76 (error "~A: Not a valid format destination." destination
))
77 (unless (integerp universal-time
)
78 (error "~A: Universal-Time should be an integer." universal-time
))
80 (unless (and (rationalp timezone
) (<= -
24 timezone
24))
81 (error "~A: Timezone should be a rational between -24 and 24." timezone
))
82 (unless (zerop (rem timezone
1/3600))
83 (error "~A: Timezone is not a second (1/3600) multiple." timezone
)))
85 (multiple-value-bind (secs mins hours day month year dow dst tz
)
87 (decode-universal-time universal-time timezone
)
88 (decode-universal-time universal-time
))
89 (declare (fixnum secs mins hours day month year dow
))
90 (let ((time-string "~2,'0D:~2,'0D")
93 (:short
"~D/~D/~D") ;; MM/DD/Y
94 ((:abbreviated
:long
) "~A ~D, ~D") ;; Month DD, Y
95 (:government
"~2,'0D ~:@(~A~) ~D") ;; DD MON Y
97 (error "~A: Unrecognized :style keyword value." style
))))
99 (list mins
(max (mod hours
12) (1+ (mod (1- hours
) 12)))))
100 (date-args (case style
102 (list month day year
))
104 (list (svref *abbrev-month-table
* (1- month
)) day year
))
106 (list (svref *long-month-table
* (1- month
)) day year
))
108 (list day
(svref *abbrev-month-table
* (1- month
))
110 (declare (simple-string time-string date-string
))
113 ((:short
:long
) (svref *long-weekday-table
* dow
))
114 (:abbreviated
(svref *abbrev-weekday-table
* dow
))
115 (:government
(svref *abbrev-weekday-table
* dow
)))
118 (concatenate 'simple-string
"~A, " date-string
)))
119 (when (or print-seconds
(eq style
:government
))
120 (push secs time-args
)
122 (concatenate 'simple-string time-string
":~2,'0D")))
124 (push (signum (floor hours
12)) time-args
)
126 (concatenate 'simple-string time-string
" ~[AM~;PM~]")))
127 (apply #'format destination
129 (concatenate 'simple-string date-string
" " time-string
130 (if print-timezone
" ~A"))
131 (concatenate 'simple-string time-string
" " date-string
132 (if print-timezone
" ~A")))
134 (nconc date-args
(nreverse time-args
)
136 (list (timezone-name dst tz
))))
137 (nconc (nreverse time-args
) date-args
139 (list (timezone-name dst tz
)))))))))
141 (defun timezone-name (dst tz
)
142 (if (and (integerp tz
)
143 (or (and dst
(= tz
0))
145 (svref (if dst
*daylight-table
* *timezone-table
*) tz
)
146 (multiple-value-bind (rest seconds
) (truncate (* tz
60 60) 60)
147 (multiple-value-bind (hours minutes
) (truncate rest
60)
148 (format nil
"[~C~D~@[~*:~2,'0D~@[~*:~2,'0D~]~]]"
149 (if (minusp tz
) #\-
#\
+)
151 (not (and (zerop minutes
) (zerop seconds
)))
153 (not (zerop seconds
))
156 (defun format-decoded-time (destination seconds minutes hours
165 "FORMAT-DECODED-TIME formats a string containing decoded time
166 expressed in a humanly-readable manner. The destination is any
167 destination which can be accepted by the FORMAT function. The
168 timezone keyword is an integer specifying hours west of Greenwich.
169 The style keyword can be :SHORT (numeric date), :LONG (months and
170 weekdays expressed as words), or :ABBREVIATED (like :LONG but words are
171 abbreviated). The keyword DATE-FIRST, if NIL, will cause the time
172 to be printed first instead of the date (the default). The PRINT-
173 keywords, if nil, inhibit the printing of certain semi-obvious
174 parts of the string."
175 (unless (valid-destination-p destination
)
176 (error "~A: Not a valid format destination." destination
))
177 (unless (and (integerp seconds
) (<= 0 seconds
59))
178 (error "~A: Seconds should be an integer between 0 and 59." seconds
))
179 (unless (and (integerp minutes
) (<= 0 minutes
59))
180 (error "~A: Minutes should be an integer between 0 and 59." minutes
))
181 (unless (and (integerp hours
) (<= 0 hours
23))
182 (error "~A: Hours should be an integer between 0 and 23." hours
))
183 (unless (and (integerp day
) (<= 1 day
31))
184 (error "~A: Day should be an integer between 1 and 31." day
))
185 (unless (and (integerp month
) (<= 1 month
12))
186 (error "~A: Month should be an integer between 1 and 12." month
))
187 (unless (and (integerp year
) (plusp year
))
188 (error "~A: Hours should be an non-negative integer." year
))
190 (unless (and (integerp timezone
) (<= 0 timezone
32))
191 (error "~A: Timezone should be an integer between 0 and 32."
193 (format-universal-time destination
194 (encode-universal-time seconds minutes hours day month year
)
195 :timezone timezone
:style style
:date-first date-first
196 :print-seconds print-seconds
:print-meridian print-meridian
197 :print-timezone print-timezone
:print-weekday print-weekday
))