X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Fformat-time.lisp;h=147c15fd19d53970a2a02f443f2892ba00de6a62;hb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;hp=97361226f6212e305a23787198111ddcd24fa6bd;hpb=79cc569a97e444389350ea3f5b1017374fe16bec;p=sbcl.git diff --git a/src/code/format-time.lisp b/src/code/format-time.lisp index 9736122..147c15f 100644 --- a/src/code/format-time.lisp +++ b/src/code/format-time.lisp @@ -38,7 +38,7 @@ (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, @@ -46,7 +46,7 @@ ;;; 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 @@ -54,14 +54,14 @@ ;;; 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 @@ -85,84 +85,84 @@ (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 @@ -191,7 +191,7 @@ (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