-;;; time printing routines built upon the Common Lisp FORMAT function
+;;;; time printing routines built upon the Common Lisp FORMAT function
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
-(in-package "SB!EXT")
+(in-package "SB!IMPL")
-(file-comment
- "$Header$")
+(defparameter *abbrev-weekday-table*
+ #("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun"))
-(defconstant abbrev-weekday-table
- '#("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun"))
+(defparameter *long-weekday-table*
+ #("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday"))
-(defconstant long-weekday-table
- '#("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"
- "Sunday"))
+(defparameter *abbrev-month-table*
+ #("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
-(defconstant abbrev-month-table
- '#("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov"
- "Dec"))
+(defparameter *long-month-table*
+ #("January" "February" "March" "April" "May" "June" "July" "August"
+ "September" "October" "November" "December"))
-(defconstant long-month-table
- '#("January" "February" "March" "April" "May" "June" "July" "August"
- "September" "October" "November" "December"))
+;;; The timezone table is incomplete but workable.
+(defparameter *timezone-table*
+ #("GMT" "" "" "" "" "EST" "CST" "MST" "PST"))
-;;; The timezone-table is incomplete but workable.
-
-(defconstant timezone-table
- '#("GMT" "" "" "" "" "EST" "CST" "MST" "PST"))
-
-(defconstant daylight-table
- '#(nil nil nil nil nil "EDT" "CDT" "MDT" "PDT"))
-
-;;; Valid-Destination-P ensures the destination stream is okay
-;;; for the Format function.
+(defparameter *daylight-table*
+ #(nil nil nil nil nil "EDT" "CDT" "MDT" "PDT"))
+;;; VALID-DESTINATION-P ensures the destination stream is okay for the
+;;; FORMAT function.
(defun valid-destination-p (destination)
(or (not destination)
- (eq destination 't)
+ (eq destination t)
(streamp destination)
(and (stringp destination)
- (array-has-fill-pointer-p destination))))
-
-;;; Format-Universal-Time - External.
+ (array-has-fill-pointer-p destination))))
;;; CMU CL made the default style :SHORT here. I've changed that to :LONG, on
;;; the theory that since the 8/7/1999 style is hard to decode unambiguously,
;;; it sorts properly.:-) -- WHN 19990831
;;;
;;; FIXME: On the CMU CL mailing list 30 Jan 2000, Pierre Mai suggested
-;;; OTOH it probably wouldn't be a major problem to change compile-file to
+;;; OTOH it probably wouldn't be a major problem to change compile-file to
;;; use for example :long, so that the output would be Month DD, YYYY, or
;;; even better to extend format-universal-time with a flag to output ISO
;;; 8601 formats (like e.g. :iso-8601 and :iso-8601-short) and migrate
;;; slowly towards ISO dates in the user code...
;;; The :ISO-8601 and :ISO-8601-SHORT options sound sensible to me. Maybe
-;;; someone will do them for CMU CL and we can steal them here.
+;;; someone will do them for CMU CL and we can steal them for SBCL.
(defun format-universal-time (destination universal-time
- &key
- (timezone nil)
- (style :long)
- (date-first t)
- (print-seconds t)
- (print-meridian t)
- (print-timezone t)
- (print-weekday t))
+ &key
+ (timezone nil)
+ (style :long)
+ (date-first t)
+ (print-seconds t)
+ (print-meridian t)
+ (print-timezone t)
+ (print-weekday t))
#!+sb-doc
"Format-Universal-Time formats a string containing the time and date
given by universal-time in a common manner. The destination is any
destination which can be accepted by the Format function. The
timezone keyword is an integer specifying hours west of Greenwich.
The style keyword can be :SHORT (numeric date), :LONG (months and
- weekdays expressed as words), :ABBREVIATED (like :long but words are
+ weekdays expressed as words), :ABBREVIATED (like :LONG but words are
abbreviated), or :GOVERNMENT (of the form \"XX Month XXXX XX:XX:XX\")
- The keyword argument DATE-FIRST, if nil, will print the time first instead
- of the date (the default). The PRINT- keywords, if nil, inhibit
+ The &KEY argument :DATE-FIRST, if NIL, will print the time first instead
+ of the date (the default). The PRINT- keywords, if NIL, inhibit
the printing of the obvious part of the time/date."
(unless (valid-destination-p destination)
(error "~A: Not a valid format destination." destination))
(multiple-value-bind (secs mins hours day month year dow dst tz)
(if timezone
- (decode-universal-time universal-time timezone)
- (decode-universal-time universal-time))
+ (decode-universal-time universal-time timezone)
+ (decode-universal-time universal-time))
(declare (fixnum secs mins hours day month year dow))
(let ((time-string "~2,'0D:~2,'0D")
- (date-string
- (case style
- (:short "~D/~D/~D") ;; MM/DD/Y
- ((:abbreviated :long) "~A ~D, ~D") ;; Month DD, Y
- (:government "~2,'0D ~:@(~A~) ~D") ;; DD MON Y
- (t
- (error "~A: Unrecognized :style keyword value." style))))
- (time-args
- (list mins (max (mod hours 12) (1+ (mod (1- hours) 12)))))
- (date-args (case style
- (:short
- (list month day year))
- (:abbreviated
- (list (svref abbrev-month-table (1- month)) day year))
- (:long
- (list (svref long-month-table (1- month)) day year))
- (:government
- (list day (svref abbrev-month-table (1- month))
- year)))))
+ (date-string
+ (case style
+ (:short "~D/~D/~D") ;; MM/DD/Y
+ ((:abbreviated :long) "~A ~D, ~D") ;; Month DD, Y
+ (:government "~2,'0D ~:@(~A~) ~D") ;; DD MON Y
+ (t
+ (error "~A: Unrecognized :style keyword value." style))))
+ (time-args
+ (list mins (max (mod hours 12) (1+ (mod (1- hours) 12)))))
+ (date-args (case style
+ (:short
+ (list month day year))
+ (:abbreviated
+ (list (svref *abbrev-month-table* (1- month)) day year))
+ (:long
+ (list (svref *long-month-table* (1- month)) day year))
+ (:government
+ (list day (svref *abbrev-month-table* (1- month))
+ year)))))
(declare (simple-string time-string date-string))
(when print-weekday
- (push (case style
- ((:short :long) (svref long-weekday-table dow))
- (:abbreviated (svref abbrev-weekday-table dow))
- (:government (svref abbrev-weekday-table dow)))
- date-args)
- (setq date-string
- (concatenate 'simple-string "~A, " date-string)))
+ (push (case style
+ ((:short :long) (svref *long-weekday-table* dow))
+ (:abbreviated (svref *abbrev-weekday-table* dow))
+ (:government (svref *abbrev-weekday-table* dow)))
+ date-args)
+ (setq date-string
+ (concatenate 'simple-string "~A, " date-string)))
(when (or print-seconds (eq style :government))
- (push secs time-args)
- (setq time-string
- (concatenate 'simple-string time-string ":~2,'0D")))
+ (push secs time-args)
+ (setq time-string
+ (concatenate 'simple-string time-string ":~2,'0D")))
(when print-meridian
- (push (signum (floor hours 12)) time-args)
- (setq time-string
- (concatenate 'simple-string time-string " ~[AM~;PM~]")))
+ (push (signum (floor hours 12)) time-args)
+ (setq time-string
+ (concatenate 'simple-string time-string " ~[AM~;PM~]")))
(apply #'format destination
- (if date-first
- (concatenate 'simple-string date-string " " time-string
- (if print-timezone " ~A"))
- (concatenate 'simple-string time-string " " date-string
- (if print-timezone " ~A")))
- (if date-first
- (nconc date-args (nreverse time-args)
- (if print-timezone
- (list (timezone-name dst tz))))
- (nconc (nreverse time-args) date-args
- (if print-timezone
- (list (timezone-name dst tz)))))))))
+ (if date-first
+ (concatenate 'simple-string date-string " " time-string
+ (if print-timezone " ~A"))
+ (concatenate 'simple-string time-string " " date-string
+ (if print-timezone " ~A")))
+ (if date-first
+ (nconc date-args (nreverse time-args)
+ (if print-timezone
+ (list (timezone-name dst tz))))
+ (nconc (nreverse time-args) date-args
+ (if print-timezone
+ (list (timezone-name dst tz)))))))))
(defun timezone-name (dst tz)
(if (and (integerp tz)
- (or (and dst (= tz 0))
- (<= 5 tz 8)))
- (svref (if dst daylight-table timezone-table) tz)
+ (or (and dst (= tz 0))
+ (<= 5 tz 8)))
+ (svref (if dst *daylight-table* *timezone-table*) tz)
(multiple-value-bind (rest seconds) (truncate (* tz 60 60) 60)
- (multiple-value-bind (hours minutes) (truncate rest 60)
- (format nil "[~C~D~@[~*:~2,'0D~@[~*:~2,'0D~]~]]"
- (if (minusp tz) #\- #\+)
- (abs hours)
- (not (and (zerop minutes) (zerop seconds)))
- (abs minutes)
- (not (zerop seconds))
- (abs seconds))))))
+ (multiple-value-bind (hours minutes) (truncate rest 60)
+ (format nil "[~C~D~@[~*:~2,'0D~@[~*:~2,'0D~]~]]"
+ (if (minusp tz) #\- #\+)
+ (abs hours)
+ (not (and (zerop minutes) (zerop seconds)))
+ (abs minutes)
+ (not (zerop seconds))
+ (abs seconds))))))
-;;; Format-Decoded-Time - External.
(defun format-decoded-time (destination seconds minutes hours
- day month year
- &key (timezone nil)
- (style :short)
- (date-first t)
- (print-seconds t)
- (print-meridian t)
- (print-timezone t)
- (print-weekday t))
+ day month year
+ &key (timezone nil)
+ (style :short)
+ (date-first t)
+ (print-seconds t)
+ (print-meridian t)
+ (print-timezone t)
+ (print-weekday t))
#!+sb-doc
- "Format-Decoded-Time formats a string containing decoded-time
+ "FORMAT-DECODED-TIME formats a string containing decoded time
expressed in a humanly-readable manner. The destination is any
- destination which can be accepted by the Format function. The
+ destination which can be accepted by the FORMAT function. The
timezone keyword is an integer specifying hours west of Greenwich.
- The style keyword can be :short (numeric date), :long (months and
- weekdays expressed as words), or :abbreviated (like :long but words are
- abbreviated). The keyword date-first, if nil, will cause the time
- to be printed first instead of the date (the default). The print-
+ The style keyword can be :SHORT (numeric date), :LONG (months and
+ weekdays expressed as words), or :ABBREVIATED (like :LONG but words are
+ abbreviated). The keyword DATE-FIRST, if NIL, will cause the time
+ to be printed first instead of the date (the default). The PRINT-
keywords, if nil, inhibit the printing of certain semi-obvious
parts of the string."
(unless (valid-destination-p destination)
(when timezone
(unless (and (integerp timezone) (<= 0 timezone 32))
(error "~A: Timezone should be an integer between 0 and 32."
- timezone)))
+ timezone)))
(format-universal-time destination
(encode-universal-time seconds minutes hours day month year)
:timezone timezone :style style :date-first date-first
projects / sbcl.git / blobdiff