home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / format-time.lisp < prev    next >
Encoding:
Text File  |  1992-05-30  |  7.7 KB  |  195 lines
  1. ;;; -*- Mode: Lisp; Package: Extensions; Log: code.log -*-
  2.  
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: format-time.lisp,v 1.3 91/02/08 13:32:55 ram Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13.  
  14. ;;; Really slick time printing routines built upon the Common Lisp
  15. ;;; format function.
  16.  
  17. ;;; Written by Jim Healy, September 1987. 
  18.  
  19. ;;; **********************************************************************
  20.  
  21. (in-package "EXTENSIONS" :use '("LISP"))
  22.  
  23. (export '(format-universal-time format-decoded-time))
  24.  
  25. (defconstant abbrev-weekday-table
  26.   '#("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun"))
  27.  
  28. (defconstant long-weekday-table
  29.   '#("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"
  30.      "Sunday"))
  31.  
  32. (defconstant abbrev-month-table
  33.   '#("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov"
  34.      "Dec"))
  35.  
  36. (defconstant long-month-table
  37.   '#("January" "February" "March" "April" "May" "June" "July" "August"
  38.      "September" "October" "November" "December"))
  39.  
  40. ;;; The timezone-table is incomplete but workable.
  41.  
  42. (defconstant timezone-table
  43.   '#("GMT" "" "" "" "" "EST" "CST" "MST" "PST"))
  44.  
  45. ;;; Valid-Destination-P ensures the destination stream is okay
  46. ;;; for the Format function.
  47.  
  48. (defun valid-destination-p (destination)
  49.   (or (not destination)
  50.       (eq destination 't)
  51.       (streamp destination)
  52.       (and (stringp destination)
  53.        (array-has-fill-pointer-p destination))))
  54.  
  55. ;;; Format-Universal-Time - External.
  56.  
  57. (defun format-universal-time (destination universal-time
  58.                       &key (timezone nil)
  59.                       (style :short)
  60.                       (date-first t)
  61.                       (print-seconds t)
  62.                       (print-meridian t)
  63.                       (print-timezone t)
  64.                       (print-weekday t))
  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 Mon XX XX:XX:XX\")
  72.    The keyword 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))
  79.   (when timezone
  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)))
  84.  
  85.   (multiple-value-bind (secs mins hours day month year dow dst tz)
  86.                (if timezone
  87.                (decode-universal-time universal-time timezone)
  88.                (decode-universal-time universal-time))
  89.     (declare (ignore dst) (fixnum secs mins hours day month year dow))
  90.     (let ((time-string "~2,'0D:~2,'0D")
  91.       (date-string
  92.        (case style
  93.          (:short "~D/~D/~2,'0D")             ;;  MM/DD/YY
  94.          ((:abbreviated :long) "~A ~D, ~D")  ;;  Month DD, YYYY
  95.          (:government "~2,'0D ~:@(~A~) ~D")      ;;  DD MON YY
  96.          (t
  97.           (error "~A: Unrecognized :style keyword value." style))))
  98.       (time-args
  99.        (list mins (max (mod hours 12) (1+ (mod (1- hours) 12)))))
  100.       (date-args (case style
  101.                (:short
  102.             (list month day (mod year 100)))
  103.                (:abbreviated
  104.             (list (svref abbrev-month-table (1- month)) day year))
  105.                (:long
  106.             (list (svref long-month-table (1- month)) day year))
  107.                (:government
  108.             (list day (svref abbrev-month-table (1- month))
  109.                   (mod year 100))))))
  110.       (declare (simple-string time-string date-string))
  111.       (when print-weekday
  112.     (push (case style
  113.         ((:short :long) (svref long-weekday-table dow))
  114.         (:abbreviated (svref abbrev-weekday-table dow))
  115.         (:government (svref abbrev-weekday-table dow)))
  116.           date-args)
  117.     (setq date-string
  118.           (concatenate 'simple-string "~A, " date-string)))
  119.       (when (or print-seconds (eq style :government))
  120.     (push secs time-args)
  121.     (setq time-string
  122.           (concatenate 'simple-string time-string ":~2,'0D")))
  123.       (when print-meridian
  124.     (push (signum (floor hours 12)) time-args)
  125.     (setq time-string
  126.           (concatenate 'simple-string time-string " ~[am~;pm~]")))
  127.       (apply #'format destination
  128.          (if date-first
  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")))
  133.          (if date-first
  134.          (nconc date-args (nreverse time-args)
  135.             (if print-timezone
  136.                 (list
  137.                  (let ((which-zone (or timezone tz)))
  138.                    (if (or (= 0 which-zone) (<= 5 which-zone 8))
  139.                    (svref timezone-table which-zone)
  140.                    (format nil "[~D]" which-zone))))))
  141.          (nconc (nreverse time-args) date-args
  142.             (if print-timezone
  143.                 (list
  144.                  (let ((which-zone (or timezone tz)))
  145.                    (if (or (= 0 which-zone) (< 5 which-zone 8))
  146.                    (svref timezone-table which-zone)
  147.                    (format nil "[~D]" which-zone)))))))))))
  148.  
  149. ;;; Format-Decoded-Time - External.
  150.  
  151. (defun format-decoded-time (destination seconds minutes hours
  152.                       day month year
  153.                       &key (timezone nil)
  154.                       (style :short)
  155.                       (date-first t)
  156.                       (print-seconds t)
  157.                       (print-meridian t)
  158.                       (print-timezone t)
  159.                       (print-weekday t))
  160.   "Format-Decoded-Time formats a string containing decoded-time
  161.    expressed in a humanly-readable manner.  The destination is any
  162.    destination which can be accepted by the Format function.  The
  163.    timezone keyword is an integer specifying hours west of Greenwich.
  164.    The style keyword can be :short (numeric date), :long (months and
  165.    weekdays expressed as words), or :abbreviated (like :long but words are
  166.    abbreviated).  The keyword date-first, if nil, will cause the time
  167.    to be printed first instead of the date (the default).  The print-
  168.    keywords, if nil, inhibit the printing of certain semi-obvious
  169.    parts of the string."
  170.   (unless (valid-destination-p destination)
  171.     (error "~A: Not a valid format destination." destination))
  172.   (unless (and (integerp seconds) (<= 0 seconds 59))
  173.     (error "~A: Seconds should be an integer between 0 and 59." seconds))
  174.   (unless (and (integerp minutes) (<= 0 minutes 59))
  175.     (error "~A: Minutes should be an integer between 0 and 59." minutes))
  176.   (unless (and (integerp hours) (<= 0 hours 23))
  177.     (error "~A: Hours should be an integer between 0 and 23." hours))
  178.   (unless (and (integerp day) (<= 1 day 31))
  179.     (error "~A: Day should be an integer between 1 and 31." day))
  180.   (unless (and (integerp month) (<= 1 month 12))
  181.     (error "~A: Month should be an integer between 1 and 12." month))
  182.   (unless (and (integerp year) (plusp year))
  183.     (error "~A: Hours should be an non-negative integer." year))
  184.   (when timezone
  185.     (unless (and (integerp timezone) (<= 0 timezone 32))
  186.       (error "~A: Timezone should be an integer between 0 and 32."
  187.          timezone)))
  188.   (format-universal-time destination
  189.    (encode-universal-time seconds minutes hours day month year)
  190.    :timezone timezone :style style :date-first date-first
  191.    :print-seconds print-seconds :print-meridian print-meridian
  192.    :print-timezone print-timezone :print-weekday print-weekday))
  193.  
  194.  
  195.