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.
17 (defconstant abbrev-weekday-table
18 '#("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun"))
20 (defconstant long-weekday-table
21 '#("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"
24 (defconstant abbrev-month-table
25 '#("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov"
28 (defconstant long-month-table
29 '#("January" "February" "March" "April" "May" "June" "July" "August"
30 "September" "October" "November" "December"))
32 ;;; The timezone-table is incomplete but workable.
34 (defconstant timezone-table
35 '#("GMT" "" "" "" "" "EST" "CST" "MST" "PST"))
37 (defconstant daylight-table
38 '#(nil nil nil nil nil "EDT" "CDT" "MDT" "PDT"))
40 ;;; Valid-Destination-P ensures the destination stream is okay
41 ;;; for the Format function.
43 (defun valid-destination-p (destination)
47 (and (stringp destination)
48 (array-has-fill-pointer-p destination))))
50 ;;; Format-Universal-Time - External.
52 ;;; CMU CL made the default style :SHORT here. I've changed that to :LONG, on
53 ;;; the theory that since the 8/7/1999 style is hard to decode unambiguously,
54 ;;; you should have to ask for it explicitly. (I prefer YYYYMMDD myself, since
55 ;;; it sorts properly.:-) -- WHN 19990831
57 ;;; FIXME: On the CMU CL mailing list 30 Jan 2000, Pierre Mai suggested
58 ;;; OTOH it probably wouldn't be a major problem to change compile-file to
59 ;;; use for example :long, so that the output would be Month DD, YYYY, or
60 ;;; even better to extend format-universal-time with a flag to output ISO
61 ;;; 8601 formats (like e.g. :iso-8601 and :iso-8601-short) and migrate
62 ;;; slowly towards ISO dates in the user code...
63 ;;; The :ISO-8601 and :ISO-8601-SHORT options sound sensible to me. Maybe
64 ;;; someone will do them for CMU CL and we can steal them here.
65 (defun format-universal-time (destination universal-time
75 "Format-Universal-Time formats a string containing the time and date
76 given by universal-time in a common manner. The destination is any
77 destination which can be accepted by the Format function. The
78 timezone keyword is an integer specifying hours west of Greenwich.
79 The style keyword can be :SHORT (numeric date), :LONG (months and
80 weekdays expressed as words), :ABBREVIATED (like :long but words are
81 abbreviated), or :GOVERNMENT (of the form \"XX Month XXXX XX:XX:XX\")
82 The keyword argument DATE-FIRST, if nil, will print the time first instead
83 of the date (the default). The PRINT- keywords, if nil, inhibit
84 the printing of the obvious part of the time/date."
85 (unless (valid-destination-p destination)
86 (error "~A: Not a valid format destination." destination))
87 (unless (integerp universal-time)
88 (error "~A: Universal-Time should be an integer." universal-time))
90 (unless (and (rationalp timezone) (<= -24 timezone 24))
91 (error "~A: Timezone should be a rational between -24 and 24." timezone))
92 (unless (zerop (rem timezone 1/3600))
93 (error "~A: Timezone is not a second (1/3600) multiple." timezone)))
95 (multiple-value-bind (secs mins hours day month year dow dst tz)
97 (decode-universal-time universal-time timezone)
98 (decode-universal-time universal-time))
99 (declare (fixnum secs mins hours day month year dow))
100 (let ((time-string "~2,'0D:~2,'0D")
103 (:short "~D/~D/~D") ;; MM/DD/Y
104 ((:abbreviated :long) "~A ~D, ~D") ;; Month DD, Y
105 (:government "~2,'0D ~:@(~A~) ~D") ;; DD MON Y
107 (error "~A: Unrecognized :style keyword value." style))))
109 (list mins (max (mod hours 12) (1+ (mod (1- hours) 12)))))
110 (date-args (case style
112 (list month day year))
114 (list (svref abbrev-month-table (1- month)) day year))
116 (list (svref long-month-table (1- month)) day year))
118 (list day (svref abbrev-month-table (1- month))
120 (declare (simple-string time-string date-string))
123 ((:short :long) (svref long-weekday-table dow))
124 (:abbreviated (svref abbrev-weekday-table dow))
125 (:government (svref abbrev-weekday-table dow)))
128 (concatenate 'simple-string "~A, " date-string)))
129 (when (or print-seconds (eq style :government))
130 (push secs time-args)
132 (concatenate 'simple-string time-string ":~2,'0D")))
134 (push (signum (floor hours 12)) time-args)
136 (concatenate 'simple-string time-string " ~[AM~;PM~]")))
137 (apply #'format destination
139 (concatenate 'simple-string date-string " " time-string
140 (if print-timezone " ~A"))
141 (concatenate 'simple-string time-string " " date-string
142 (if print-timezone " ~A")))
144 (nconc date-args (nreverse time-args)
146 (list (timezone-name dst tz))))
147 (nconc (nreverse time-args) date-args
149 (list (timezone-name dst tz)))))))))
151 (defun timezone-name (dst tz)
152 (if (and (integerp tz)
153 (or (and dst (= tz 0))
155 (svref (if dst daylight-table timezone-table) tz)
156 (multiple-value-bind (rest seconds) (truncate (* tz 60 60) 60)
157 (multiple-value-bind (hours minutes) (truncate rest 60)
158 (format nil "[~C~D~@[~*:~2,'0D~@[~*:~2,'0D~]~]]"
159 (if (minusp tz) #\- #\+)
161 (not (and (zerop minutes) (zerop seconds)))
163 (not (zerop seconds))
166 ;;; Format-Decoded-Time - External.
167 (defun format-decoded-time (destination seconds minutes hours
177 "Format-Decoded-Time formats a string containing decoded-time
178 expressed in a humanly-readable manner. The destination is any
179 destination which can be accepted by the Format function. The
180 timezone keyword is an integer specifying hours west of Greenwich.
181 The style keyword can be :short (numeric date), :long (months and
182 weekdays expressed as words), or :abbreviated (like :long but words are
183 abbreviated). The keyword date-first, if nil, will cause the time
184 to be printed first instead of the date (the default). The print-
185 keywords, if nil, inhibit the printing of certain semi-obvious
186 parts of the string."
187 (unless (valid-destination-p destination)
188 (error "~A: Not a valid format destination." destination))
189 (unless (and (integerp seconds) (<= 0 seconds 59))
190 (error "~A: Seconds should be an integer between 0 and 59." seconds))
191 (unless (and (integerp minutes) (<= 0 minutes 59))
192 (error "~A: Minutes should be an integer between 0 and 59." minutes))
193 (unless (and (integerp hours) (<= 0 hours 23))
194 (error "~A: Hours should be an integer between 0 and 23." hours))
195 (unless (and (integerp day) (<= 1 day 31))
196 (error "~A: Day should be an integer between 1 and 31." day))
197 (unless (and (integerp month) (<= 1 month 12))
198 (error "~A: Month should be an integer between 1 and 12." month))
199 (unless (and (integerp year) (plusp year))
200 (error "~A: Hours should be an non-negative integer." year))
202 (unless (and (integerp timezone) (<= 0 timezone 32))
203 (error "~A: Timezone should be an integer between 0 and 32."
205 (format-universal-time destination
206 (encode-universal-time seconds minutes hours day month year)
207 :timezone timezone :style style :date-first date-first
208 :print-seconds print-seconds :print-meridian print-meridian
209 :print-timezone print-timezone :print-weekday print-weekday))