From db342e147980d3eb367255810750fc8fff306939 Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Thu, 22 Feb 1990 16:52:58 +0000
Subject: [PATCH] Initial revision

---
 code/format-time.lisp | 186 ++++++++++++++
 code/parse-time.lisp  | 574 ++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 760 insertions(+)
 create mode 100644 code/format-time.lisp
 create mode 100644 code/parse-time.lisp

diff --git a/code/format-time.lisp b/code/format-time.lisp
new file mode 100644
index 000000000..e57d2b371
--- /dev/null
+++ b/code/format-time.lisp
@@ -0,0 +1,186 @@
+;;; -*- Mode: Lisp; Package: Extensions; Log: code.log -*-
+
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+
+;;; Really slick time printing routines built upon the Common Lisp
+;;; format function.
+
+;;; Written by Jim Healy, September 1987. 
+
+;;; **********************************************************************
+
+(in-package "EXTENSIONS" :use '("LISP"))
+
+(export '(format-universal-time format-decoded-time))
+
+(defconstant abbrev-weekday-table
+  '#("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun"))
+
+(defconstant long-weekday-table
+  '#("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"
+     "Sunday"))
+
+(defconstant abbrev-month-table
+  '#("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov"
+     "Dec"))
+
+(defconstant long-month-table
+  '#("January" "February" "March" "April" "May" "June" "July" "August"
+     "September" "October" "November" "December"))
+
+;;; The timezone-table is incomplete but workable.
+
+(defconstant timezone-table
+  '#("GMT" "" "" "" "" "EST" "CST" "MST" "PST"))
+
+;;; Valid-Destination-P ensures the destination stream is okay
+;;; for the Format function.
+
+(defun valid-destination-p (destination)
+  (or (not destination)
+      (eq destination 't)
+      (streamp destination)
+      (and (stringp destination)
+	   (array-has-fill-pointer-p destination))))
+
+;;; Format-Universal-Time - External.
+
+(defun format-universal-time (destination universal-time
+					  &key (timezone nil)
+					  (style :short)
+					  (date-first t)
+					  (print-seconds t)
+					  (print-meridian t)
+					  (print-timezone t)
+					  (print-weekday t))
+  "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
+   abbreviated), or :government (of the form \"XX Mon XX XX:XX:XX\")
+   The keyword 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))
+  (unless (integerp universal-time)
+    (error "~A: Universal-Time should be an integer." universal-time))
+  (when timezone
+    (unless (and (integerp timezone) (<= 0 timezone 32))
+      (error "~A: Timezone should be an integer between 0 and 32."
+	     timezone)))
+  (multiple-value-bind (secs mins hours day month year dow dst tz)
+		       (decode-universal-time universal-time timezone)
+    (declare (ignore dst) (fixnum secs mins hours day month year dow))
+    (let ((time-string "~2,'0D:~2,'0D")
+	  (date-string
+	   (case style
+	     (:short "~D/~D/~2,'0D")             ;;  MM/DD/YY
+	     ((:abbreviated :long) "~A ~D, ~D")  ;;  Month DD, YYYY
+	     (:government "~2,'0D ~:@(~A~) ~D")      ;;  DD MON YY
+	     (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 (mod year 100)))
+		       (: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))
+			      (mod year 100))))))
+      (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)))
+      (when (or print-seconds (eq style :government))
+	(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~]")))
+      (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
+			     (let ((which-zone (or timezone tz)))
+			       (if (or (= 0 which-zone) (<= 5 which-zone 8))
+				   (svref timezone-table which-zone)
+				   (format nil "[~D]" which-zone))))))
+		 (nconc (nreverse time-args) date-args
+			(if print-timezone
+			    (list
+			     (let ((which-zone (or timezone tz)))
+			       (if (or (= 0 which-zone) (< 5 which-zone 8))
+				   (svref timezone-table which-zone)
+				   (format nil "[~D]" which-zone)))))))))))
+
+;;; 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))
+  "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
+   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-
+   keywords, if nil, inhibit the printing of certain semi-obvious
+   parts of the string."
+  (unless (valid-destination-p destination)
+    (error "~A: Not a valid format destination." destination))
+  (unless (and (integerp seconds) (<= 0 seconds 59))
+    (error "~A: Seconds should be an integer between 0 and 59." seconds))
+  (unless (and (integerp minutes) (<= 0 minutes 59))
+    (error "~A: Minutes should be an integer between 0 and 59." minutes))
+  (unless (and (integerp hours) (<= 0 hours 23))
+    (error "~A: Hours should be an integer between 0 and 23." hours))
+  (unless (and (integerp day) (<= 1 day 31))
+    (error "~A: Day should be an integer between 1 and 31." day))
+  (unless (and (integerp month) (<= 1 month 12))
+    (error "~A: Month should be an integer between 1 and 12." month))
+  (unless (and (integerp year) (plusp year))
+    (error "~A: Hours should be an non-negative integer." year))
+  (when timezone
+    (unless (and (integerp timezone) (<= 0 timezone 32))
+      (error "~A: Timezone should be an integer between 0 and 32."
+	     timezone)))
+  (format-universal-time destination
+   (encode-universal-time seconds minutes hours day month year)
+   :timezone timezone :style style :date-first date-first
+   :print-seconds print-seconds :print-meridian print-meridian
+   :print-timezone print-timezone :print-weekday print-weekday))
+
+
diff --git a/code/parse-time.lisp b/code/parse-time.lisp
new file mode 100644
index 000000000..50db34cc6
--- /dev/null
+++ b/code/parse-time.lisp
@@ -0,0 +1,574 @@
+;;;  -*- Mode: Lisp; Package: Extensions; Log: code.log -*-
+
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (FAHLMAN@CMUC). 
+;;; **********************************************************************
+
+;;; Parsing routines for time and date strings. Parse-time returns the
+;;; universal time integer for the time and/or date given in the string.
+
+;;; Written by Jim Healy, June 1987.
+
+;;; **********************************************************************
+
+(in-package "EXTENSIONS" :use "LISP")
+
+(export 'parse-time)
+
+(defconstant whitespace-chars '(#\space #\tab #\newline #\, #\' #\`))
+(defconstant time-dividers '(#\: #\.))
+(defconstant date-dividers '(#\- #\\ #\/))
+
+(defvar *error-on-mismatch* nil
+  "If t, an error will be signalled if parse-time is unable
+   to determine the time/date format of the string.")
+
+;;; Set up hash tables for month, weekday, zone, and special strings.
+;;; Provides quick, easy access to associated information for these items.
+
+;;; Hashlist takes an association list and hashes each pair into the
+;;; specified tables using the car of the pair as the key and the cdr as
+;;; the data object.
+
+(defmacro hashlist (list table)
+  `(dolist (item ,list)
+     (setf (gethash (car item) ,table) (cdr item))))
+
+(defparameter weekday-table-size 20)
+(defparameter month-table-size 30)
+(defparameter zone-table-size 10)
+(defparameter special-table-size 10)
+
+(defvar *weekday-strings* (make-hash-table :test #'equal
+					 :size weekday-table-size))
+
+(defvar *month-strings* (make-hash-table :test #'equal
+				       :size month-table-size))
+
+(defvar *zone-strings* (make-hash-table :test #'equal
+				      :size zone-table-size))
+
+(defvar *special-strings* (make-hash-table :test #'equal
+					 :size special-table-size))
+
+;;; Load-time creation of the hash tables.
+
+(hashlist '(("monday" . 0)    ("mon" . 0)
+	    ("tuesday" . 1)   ("tues" . 1)   ("tue" . 1)
+	    ("wednesday" . 2) ("wednes" . 2) ("wed" . 2)
+	    ("thursday" . 3)  ("thurs" . 3)  ("thu" . 3)
+	    ("friday" . 4)    ("fri" . 4)
+	    ("saturday" . 5)  ("sat" . 5)
+	    ("sunday" . 6)    ("sun" . 6))
+	  *weekday-strings*)
+
+(hashlist '(("january" . 1)   ("jan" . 1)
+	    ("february" . 2)  ("feb" . 2)
+	    ("march" . 3)     ("mar" . 3)
+	    ("april" . 4)     ("apr" . 4)
+	    ("may" . 5)       ("june" . 6)
+	    ("jun" . 6)       ("july" . 7)
+	    ("jul" . 7)	      ("august" . 8)
+	    ("aug" . 8)       ("september" . 9)
+	    ("sept" . 9)      ("sep" . 9)
+	    ("october" . 10)  ("oct" . 10)
+	    ("november" . 11) ("nov" . 11)
+	    ("december" . 12) ("dec" . 12))
+	  *month-strings*)
+
+(hashlist '(("gmt" . 0) ("est" . 5)
+	    ("edt" . 5) ("cst" . 6)
+	    ("cdt" . 6) ("mst" . 7)
+	    ("mdt" . 7)	("pst" . 8)
+	    ("pdt" . 8)) 
+	  *zone-strings*)
+
+(hashlist '(("yesterday" . yesterday)  ("today" . today)
+	    ("tomorrow" . tomorrow)   ("now" . now))
+	  *special-strings*)
+
+;;; Time/date format patterns are specified as lists of symbols repre-
+;;; senting the elements.  Optional elements can be specified by
+;;; enclosing them in parentheses.  Note that the order in which the
+;;; patterns are specified below determines the order of search.
+
+;;; Choices of pattern symbols are: second, minute, hour, day, month,
+;;; year, time-divider, date-divider, am-pm, zone, weekday, noon-midn,
+;;; and any special symbol.
+
+(defparameter patterns
+  '( 
+     ;; Date formats.
+    ((weekday) month (date-divider) day (date-divider) year (noon-midn))
+    ((weekday) day (date-divider) month (date-divider) year (noon-midn))
+    ((weekday) month (date-divider) day (noon-midn))
+    (year (date-divider) month (date-divider) day (noon-midn))
+    (month (date-divider) year (noon-midn))
+    (year (date-divider) month (noon-midn))
+
+    ((noon-midn) (weekday) month (date-divider) day (date-divider) year)
+    ((noon-midn) (weekday) day (date-divider) month (date-divider) year)
+    ((noon-midn) (weekday) month (date-divider) day)
+    ((noon-midn) year (date-divider) month (date-divider) day)
+    ((noon-midn) month (date-divider) year)
+    ((noon-midn) year (date-divider) month)
+
+     ;; Time formats.
+    (hour (time-divider) (minute) (time-divider) (secondp) (am-pm) 
+	  (date-divider) (zone))
+    (noon-midn)
+    (hour (noon-midn))
+
+     ;; Time/date combined formats.
+    ((weekday) month (date-divider) day (date-divider) year
+	   hour (time-divider) (minute) (time-divider) (secondp)
+	   (am-pm) (date-divider) (zone))
+    ((weekday) day (date-divider) month (date-divider) year
+	 hour (time-divider) (minute) (time-divider) (secondp)
+	 (am-pm) (date-divider) (zone))
+    ((weekday) month (date-divider) day
+	   hour (time-divider) (minute) (time-divider) (secondp)
+	   (am-pm) (date-divider) (zone))
+    (year (date-divider) month (date-divider) day
+	  hour (time-divider) (minute) (time-divider) (secondp)
+	  (am-pm) (date-divider) (zone))
+    (month (date-divider) year
+	   hour (time-divider) (minute) (time-divider) (secondp)
+	   (am-pm) (date-divider) (zone))
+    (year (date-divider) month
+	  hour (time-divider) (minute) (time-divider) (secondp)
+	  (am-pm) (date-divider) (zone))
+
+    (hour (time-divider) (minute) (time-divider) (secondp) (am-pm)
+	  (date-divider) (zone) (weekday) month (date-divider)
+	  day (date-divider) year)
+    (hour (time-divider) (minute) (time-divider) (secondp) (am-pm)
+	  (date-divider) (zone) (weekday) day (date-divider)
+	  month (date-divider) year)
+    (hour (time-divider) (minute) (time-divider) (secondp) (am-pm)
+	  (date-divider) (zone) (weekday) month (date-divider)
+	  day)
+    (hour (time-divider) (minute) (time-divider) (secondp) (am-pm)
+	  (date-divider) (zone) year (date-divider) month
+	  (date-divider) day)
+    (hour (time-divider) (minute) (time-divider) (secondp) (am-pm)
+	  (date-divider) (zone) month (date-divider) year)
+    (hour (time-divider) (minute) (time-divider) (secondp) (am-pm)
+	  (date-divider) (zone) year (date-divider) month)
+
+     ;; Weird, non-standard formats.
+    (weekday month day hour (time-divider) minute (time-divider)
+	     secondp (am-pm)
+	     (zone) year)
+    ((weekday) day (date-divider) month (date-divider) year hour
+     (time-divider) minute (time-divider) (secondp) (am-pm)
+     (date-divider) (zone))
+    ((weekday) month (date-divider) day (date-divider) year hour
+     (time-divider) minute (time-divider) (secondp) (am-pm)
+     (date-divider) (zone))
+
+    ;; Special-string formats.
+    (now (yesterday))
+    ((yesterday) now)
+    (now (today))
+    ((today) now)
+    (now (tomorrow))
+    ((tomorrow) now)
+    (yesterday (noon-midn))
+    ((noon-midn) yesterday)
+    (today (noon-midn))
+    ((noon-midn) today)
+    (tomorrow (noon-midn))
+    ((noon-midn) tomorrow)
+))
+
+;;; The decoded-time structure holds the time/date values which are
+;;; eventually passed to 'encode-universal-time' after parsing.
+
+;;; Note: Currently nothing is done with the day of the week.  It might
+;;; be appropriate to add a function to see if it matches the date.
+
+(defstruct decoded-time
+  (second 0    :type integer)    ; Value between 0 and 59.
+  (minute 0    :type integer)    ; Value between 0 and 59.
+  (hour   0    :type integer)    ; Value between 0 and 23.
+  (day    1    :type integer)    ; Value between 1 and 31.
+  (month  1    :type integer)    ; Value between 1 and 12.
+  (year   1900 :type integer)    ; Value above 1899 or between 0 and 99.
+  (zone   0    :type integer)    ; Value between 0 and 23.
+  (dotw   0    :type integer))   ; Value between 0 and 6.
+
+;;; Make-default-time returns a decoded-time structure with the default
+;;; time values already set.  The default time is currently 00:00 on
+;;; the current day, current month, current year, and current time-zone.
+
+(defun make-default-time (def-sec def-min def-hour def-day
+			   def-mon def-year def-zone def-dotw)
+  (let ((default-time (make-decoded-time)))
+    (multiple-value-bind (sec min hour day mon year dotw dst zone)
+			 (get-decoded-time)
+      (declare (ignore dst))
+      (if def-sec
+	  (if (eq def-sec :current)
+	      (setf (decoded-time-second default-time) sec)
+	      (setf (decoded-time-second default-time) def-sec))
+	  (setf (decoded-time-second default-time) 0))
+      (if def-min
+	  (if (eq def-min :current)
+	      (setf (decoded-time-minute default-time) min)
+	      (setf (decoded-time-minute default-time) def-min))
+	  (setf (decoded-time-minute default-time) 0))
+      (if def-hour
+	  (if (eq def-hour :current)
+	      (setf (decoded-time-hour default-time) hour)
+	      (setf (decoded-time-hour default-time) def-hour))
+	  (setf (decoded-time-hour default-time) 0))
+      (if def-day
+	  (if (eq def-day :current)
+	      (setf (decoded-time-day default-time) day)
+	      (setf (decoded-time-day default-time) def-day))
+	  (setf (decoded-time-day default-time) day))
+      (if def-mon
+	  (if (eq def-mon :current)
+	      (setf (decoded-time-month default-time) mon)
+	      (setf (decoded-time-month default-time) def-mon))
+	  (setf (decoded-time-month default-time) mon))
+      (if def-year
+	  (if (eq def-year :current)
+	      (setf (decoded-time-year default-time) year)
+	      (setf (decoded-time-year default-time) def-year))
+	  (setf (decoded-time-year default-time) year))
+      (if def-zone
+	  (if (eq def-zone :current)
+	      (setf (decoded-time-zone default-time) zone)
+	      (setf (decoded-time-zone default-time) def-zone))
+	  (setf (decoded-time-zone default-time) zone))
+      (if def-dotw
+	  (if (eq def-dotw :current)
+	      (setf (decoded-time-dotw default-time) dotw)
+	      (setf (decoded-time-dotw default-time) def-dotw))
+	  (setf (decoded-time-dotw default-time) dotw))
+      default-time)))
+
+;;; Converts the values in the decoded-time structure to universal time
+;;; by calling extensions:encode-universal-time.
+
+(defun convert-to-unitime (parsed-values)
+  (encode-universal-time (decoded-time-second parsed-values)
+			 (decoded-time-minute parsed-values)
+			 (decoded-time-hour parsed-values)
+			 (decoded-time-day parsed-values)
+			 (decoded-time-month parsed-values)
+			 (decoded-time-year parsed-values)
+			 (decoded-time-zone parsed-values)))
+
+;;; Sets the current values for the time and/or date parts of the 
+;;; decoded time structure.
+
+(defun set-current-value (values-structure &key (time nil) (date nil) (zone nil))
+  (multiple-value-bind (sec min hour day mon year dotw dst tz)
+		       (get-decoded-time)
+    (declare (ignore dst))
+    (when time
+      (setf (decoded-time-second values-structure) sec)
+      (setf (decoded-time-minute values-structure) min)
+      (setf (decoded-time-hour values-structure) hour))
+    (when date
+      (setf (decoded-time-day values-structure) day)
+      (setf (decoded-time-month values-structure) mon)
+      (setf (decoded-time-year values-structure) year)
+      (setf (decoded-time-dotw values-structure) dotw))
+    (when zone
+      (setf (decoded-time-zone values-structure) tz))))
+
+;;; Special function definitions.  To define a special substring, add
+;;; a dotted pair consisting of the substring and a symbol in the
+;;; *special-strings* hashlist statement above.  Then define a function
+;;; here which takes one argument- the decoded time structure- and
+;;; sets the values of the structure to whatever is necessary.  Also,
+;;; add a some patterns to the patterns list using whatever combinations
+;;; of special and pre-existing symbols desired.
+
+(defun yesterday (parsed-values)
+  (set-current-value parsed-values :date t :zone t)
+  (setf (decoded-time-day parsed-values)
+	(1- (decoded-time-day parsed-values))))
+
+(defun today (parsed-values)
+  (set-current-value parsed-values :date t :zone t))
+
+(defun tomorrow (parsed-values)
+  (set-current-value parsed-values :date t :zone t)
+  (setf (decoded-time-day parsed-values)
+	(1+ (decoded-time-day parsed-values))))
+
+(defun now (parsed-values)
+  (set-current-value parsed-values :time t))
+
+;;; Predicates for symbols.  Each symbol has a corresponding function
+;;; defined here which is applied to a part of the datum to see if
+;;; it matches the qualifications.
+
+(defun am-pm (string)
+  (and (simple-string-p string)
+       (cond ((string= string "am") 'am)
+	     ((string= string "pm") 'pm)
+	     (t nil))))
+
+(defun noon-midn (string)
+  (and (simple-string-p string)
+       (cond ((string= string "noon") 'noon)
+	     ((string= string "midnight") 'midn)
+	     (t nil))))
+
+(defun weekday (string)
+  (and (simple-string-p string) (gethash string *weekday-strings*)))
+
+(defun month (thing)
+  (or (and (simple-string-p thing) (gethash thing *month-strings*))
+      (and (integerp thing) (<= 1 thing 12))))
+
+(defun zone (string)
+  (and (simple-string-p string) (gethash string *zone-strings*)))
+
+(defun special (string)
+  (and (simple-string-p string) (gethash string *special-strings*)))
+
+(defun secondp (number)
+  (and (integerp number) (<= 0 number 59)))
+
+(defun minute (number)
+  (and (integerp number) (<= 0 number 59)))
+
+(defun hour (number)
+  (and (integerp number) (<= 0 number 23)))
+
+(defun day (number)
+  (and (integerp number) (<= 1 number 31)))
+
+(defun year (number)
+  (and (integerp number)
+       (or (<= 0 number 99)
+	   (<= 1900 number))))
+
+(defun time-divider (character)
+  (and (characterp character)
+       (member character time-dividers :test #'char=)))
+
+(defun date-divider (character)
+  (and (characterp character)
+       (member character date-dividers :test #'char=)))
+
+;;; Match-substring takes a string argument and tries to match it with
+;;; the strings in one of the four hash tables: *weekday-strings*, *month-
+;;; strings*, *zone-strings*, *special-strings*.  It returns a specific
+;;; keyword and/or the object it finds in the hash table.  If no match
+;;; is made then it immediately signals an error.
+
+(defun match-substring (substring)
+  (let ((substring (nstring-downcase substring)))
+    (or (let ((test-value (month substring)))
+	  (if test-value (cons 'month test-value)))
+	(let ((test-value (weekday substring)))
+	  (if test-value (cons 'weekday test-value)))
+	(let ((test-value (am-pm substring)))
+	  (if test-value (cons 'am-pm test-value)))
+	(let ((test-value (noon-midn substring)))
+	  (if test-value (cons 'noon-midn test-value)))
+	(let ((test-value (zone substring)))
+	  (if test-value (cons 'zone test-value)))
+	(let ((test-value (special substring)))
+	  (if test-value  (cons 'special test-value)))
+	(if *error-on-mismatch*
+	    (error "\"~A\" is not a recognized word or abbreviation."
+		   substring)
+	    (return-from match-substring nil)))))
+
+;;; Decompose-string takes the time/date string and decomposes it into a
+;;; list of alphabetic substrings, numbers, and special divider characters.
+;;; It matches whatever strings it can and replaces them with a dotted pair
+;;; containing a symbol and value.
+
+(defun decompose-string (string &key (start 0) (end (length string)) (radix 10))
+  (do ((string-index start)
+       (parts-list nil))
+      ((eq string-index end) (nreverse parts-list))
+    (let ((next-char (char string string-index)))
+      (cond ((alpha-char-p next-char)
+	     ;; Alphabetic character - scan to the end of the substring.
+	     (do ((scan-index (1+ string-index) (1+ scan-index)))
+		 ((or (eq scan-index end)
+		      (not (alpha-char-p (char string scan-index))))
+		  (let ((match-symbol (match-substring
+				       (subseq string string-index scan-index))))
+		    (if match-symbol
+			(push match-symbol parts-list)
+			(return-from decompose-string nil)))
+		  (setf string-index scan-index))))
+	    ((digit-char-p next-char radix)
+	     ;; Numeric digit - convert digit-string to a decimal value.
+	     (do ((scan-index string-index (1+ scan-index))
+		  (numeric-value 0 (+ (* numeric-value radix)
+				      (digit-char-p (char string scan-index) radix))))
+		 ((or (eq scan-index end)
+		      (not (digit-char-p (char string scan-index) radix)))
+		  (push numeric-value parts-list)
+		  (setf string-index scan-index))))
+	    ((member next-char time-dividers :test #'char=)
+ 	     ;; Time-divider - add it to the parts-list with symbol.
+	     (push (cons 'time-divider next-char) parts-list)
+	     (incf string-index))
+	    ((member next-char date-dividers :test #'char=)
+	     ;; Date-divider - add it to the parts-list with symbol.
+	     (push (cons 'date-divider next-char) parts-list)
+	     (incf string-index))
+	    ((member next-char whitespace-chars :test #'char=)
+	     ;; Whitespace character - ignore it completely.
+	     (incf string-index))
+	    ((char= next-char #\()
+	     ;; Parenthesized string - scan to the end and ignore it.
+	     (do ((scan-index string-index (1+ scan-index)))
+		 ((or (eq scan-index end)
+		      (char= (char string scan-index) #\)))
+ 		  (setf string-index (1+ scan-index)))))
+	    (t
+	     ;; Unrecognized character - barf voraciously.
+	     (if *error-on-mismatch*
+		 (error (concatenate 'simple-string ">>> " string
+				     "~%~VT^-- Bogus character encountered here.")
+			(+ string-index 4))
+		 (return-from decompose-string nil)))))))
+
+;;; Match-pattern-element tries to match a pattern element with a datum
+;;; element and returns the symbol associated with the datum element if
+;;; successful.  Otherwise nil is returned.
+
+(defun match-pattern-element (pattern-element datum-element)
+  (cond ((listp datum-element)
+	 (let ((datum-type (if (eq (car datum-element) 'special)
+			       (cdr datum-element)
+			       (car datum-element))))
+	   (if (eq datum-type pattern-element) datum-element)))
+	((funcall pattern-element datum-element)
+	 (cons pattern-element datum-element))
+	(t nil)))
+
+;;; Match-pattern matches a pattern against a datum, returning the
+;;; pattern if successful and nil otherwise.
+
+(defun match-pattern (pattern datum datum-length)
+  (if (>= (length pattern) datum-length)
+      (let ((form-list nil))
+	(do ((pattern pattern (cdr pattern))
+	     (datum datum (cdr datum)))
+	    ((or (null pattern) (null datum))
+	     (cond ((and (null pattern) (null datum))
+		    (nreverse form-list))
+		   ((null pattern) nil)
+		   ((null datum) (dolist (element pattern
+						  (nreverse form-list))
+				   (if (not (listp element))
+				       (return nil))))))
+	(let* ((pattern-element (car pattern))
+	       (datum-element (car datum))
+	       (optional (listp pattern-element))
+	       (matching (match-pattern-element (if optional
+						    (car pattern-element)
+						    pattern-element)
+						datum-element)))
+	  (cond (matching (let ((form-type (car matching)))
+			    (unless (or (eq form-type 'time-divider)
+					(eq form-type 'date-divider))
+			      (push matching form-list))))
+		(optional (push datum-element datum))
+		(t (return-from match-pattern nil))))))))
+
+;;; Deal-with-noon-midn sets the decoded-time values to either noon
+;;; or midnight depending on the argument form-value.  Form-value
+;;; can be either 'noon or 'midn.
+
+(defun deal-with-noon-midn (form-value parsed-values)
+  (cond ((eq form-value 'noon)
+	 (setf (decoded-time-hour parsed-values) 12))
+	((eq form-value 'midn)
+	 (setf (decoded-time-hour parsed-values) 0))
+	(t (error "Unrecognized symbol: ~A" form-value)))
+  (setf (decoded-time-minute parsed-values) 0)
+  (setf (decoded-time-second parsed-values) 0))
+
+;;; Deal-with-am-pm sets the decoded-time values to be in the am
+;;; or pm depending on the argument form-value.  Form-value can
+;;; be either 'am or 'pm.
+
+(defun deal-with-am-pm (form-value parsed-values)
+  (let ((hour (decoded-time-hour parsed-values)))
+    (cond ((eq form-value 'am)
+	   (cond ((eq hour 12)
+		  (setf (decoded-time-hour parsed-values) 0))
+		 ((not (<= 0 hour 12))
+		  (if *error-on-mismatch*
+		      (error "~D is not an AM hour, dummy." hour)))))
+	  ((eq form-value 'pm)
+	   (if (<= 0 hour 11)
+	       (setf (decoded-time-hour parsed-values)
+		     (mod (+ hour 12) 24))))
+	  (t (error "~A isn't AM/PM - this shouldn't happen.")))))
+
+;;; Set-time-values uses the association list of symbols and values
+;;; to set the time in the decoded-time structure.
+
+(defun set-time-values (string-form parsed-values)
+  (dolist (form-part string-form t)
+    (let ((form-type (car form-part))
+	  (form-value (cdr form-part)))
+      (case form-type
+	(secondp (setf (decoded-time-second parsed-values) form-value))
+	(minute (setf (decoded-time-minute parsed-values) form-value))
+	(hour (setf (decoded-time-hour parsed-values) form-value))
+	(day (setf (decoded-time-day parsed-values) form-value))
+	(month (setf (decoded-time-month parsed-values) form-value))
+	(year (setf (decoded-time-year parsed-values) form-value))
+	(zone (setf (decoded-time-zone parsed-values) form-value))
+	(weekday (setf (decoded-time-dotw parsed-values) form-value))
+	(am-pm (deal-with-am-pm form-value parsed-values))
+	(noon-midn (deal-with-noon-midn form-value parsed-values))
+	(special (funcall form-value parsed-values))
+	(t (error "Unrecognized symbol in form list: ~A." form-type))))))
+
+(defun parse-time (time-string &key (error-on-mismatch nil)
+			       (default-seconds nil) (default-minutes nil)
+			       (default-hours nil) (default-day nil)
+			       (default-month nil) (default-year nil)
+			       (default-zone nil) (default-weekday nil))
+  "Tries very hard to make sense out of the argument time-string and
+   returns a single integer representing the universal time if
+   successful.  If not, it returns nil.  If the :error-on-mismatch
+   keyword is true, parse-time will signal an error instead of
+   returning nil.  Default values for each part of the time/date
+   can be specified by the appropriate :default- keyword.  These
+   keywords can be given a numeric value or the keyword :current
+   to set them to the current value.  The default-default values
+   are 00:00:00 on the current date, current time-zone."
+  (setq *error-on-mismatch* error-on-mismatch)
+  (let* ((string-parts (decompose-string time-string))
+	 (parts-length (length string-parts))
+	 (string-form (dolist (pattern patterns)
+			(let ((match-result (match-pattern pattern
+							   string-parts
+							   parts-length)))
+			  (if match-result (return match-result))))))
+    (if string-form
+	(let ((parsed-values (make-default-time default-seconds default-minutes
+						default-hours default-day
+						default-month default-year
+						default-zone default-weekday)))
+	  (set-time-values string-form parsed-values)
+	  (convert-to-unitime parsed-values))
+	(if *error-on-mismatch*
+	  (error "\"~A\" is not a recognized time/date format." time-string)
+	  nil))))
+
+
-- 
GitLab