(eq destination t)
(streamp destination)
(and (stringp destination)
- (array-has-fill-pointer-p destination))))
+ (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
;;; 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 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
(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)))
+ (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))))))
(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
expressed in a humanly-readable manner. The destination is any
(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