From ad9b0bb9a01eb6c1805a0923509be8708229a2a9 Mon Sep 17 00:00:00 2001
From: chiles <chiles>
Date: Fri, 26 Jul 1991 11:35:16 +0000
Subject: [PATCH] Lots of changes to the time parsing and printing extensions
 including bug fixes.

---
 code/parse-time.lisp | 99 ++++++++++++++++++++++++++++----------------
 1 file changed, 64 insertions(+), 35 deletions(-)

diff --git a/code/parse-time.lisp b/code/parse-time.lisp
index 52b2011a9..37b1b8f60 100644
--- a/code/parse-time.lisp
+++ b/code/parse-time.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/parse-time.lisp,v 1.2 1991/02/08 13:34:32 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/parse-time.lisp,v 1.3 1991/07/26 11:35:16 chiles Exp $")
 ;;;
 ;;; **********************************************************************
 
@@ -24,7 +24,7 @@
 
 (defconstant whitespace-chars '(#\space #\tab #\newline #\, #\' #\`))
 (defconstant time-dividers '(#\: #\.))
-(defconstant date-dividers '(#\- #\\ #\/))
+(defconstant date-dividers '(#\\ #\/ #\-))
 
 (defvar *error-on-mismatch* nil
   "If t, an error will be signalled if parse-time is unable
@@ -41,10 +41,10 @@
   `(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)
+(defparameter weekday-table-size 23)
+(defparameter month-table-size 31)
+(defparameter zone-table-size 11)
+(defparameter special-table-size 11)
 
 (defvar *weekday-strings* (make-hash-table :test #'equal
 					 :size weekday-table-size))
@@ -84,10 +84,10 @@
 	  *month-strings*)
 
 (hashlist '(("gmt" . 0) ("est" . 5)
-	    ("edt" . 5) ("cst" . 6)
-	    ("cdt" . 6) ("mst" . 7)
-	    ("mdt" . 7)	("pst" . 8)
-	    ("pdt" . 8)) 
+	    ("edt" . 4) ("cst" . 6)
+	    ("cdt" . 5) ("mst" . 7)
+	    ("mdt" . 6)	("pst" . 8)
+	    ("pdt" . 7)) 
 	  *zone-strings*)
 
 (hashlist '(("yesterday" . yesterday)  ("today" . today)
@@ -259,15 +259,23 @@
 
 ;;; Converts the values in the decoded-time structure to universal time
 ;;; by calling extensions:encode-universal-time.
+;;; If zone is in numerical form, tweeks it appropriately.
 
 (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)))
+  (let ((zone (decoded-time-zone 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)
+			   (if (or (> zone 23) (< zone -23))
+			       (let ((new-zone (/ zone 100)))
+				 (cond ((minusp new-zone) (- new-zone))
+				       ((plusp new-zone) (- 24 new-zone))
+				       ;; must be zero (GMT)
+				       (t new-zone)))
+			       zone))))
 
 ;;; Sets the current values for the time and/or date parts of the 
 ;;; decoded time structure.
@@ -335,8 +343,11 @@
   (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 zone (thing)
+  (or (and (simple-string-p thing) (gethash thing *zone-strings*))
+      (if (integerp thing)
+	  (let ((zone (/ thing 100)))
+	    (and (integerp zone) (<= -23 zone 23))))))
 
 (defun special (string)
   (and (simple-string-p string) (gethash string *special-strings*)))
@@ -398,9 +409,13 @@
 
 (defun decompose-string (string &key (start 0) (end (length string)) (radix 10))
   (do ((string-index start)
+       (next-negative nil)
        (parts-list nil))
       ((eq string-index end) (nreverse parts-list))
-    (let ((next-char (char string string-index)))
+    (let ((next-char (char string string-index))
+	  (prev-char (if (= string-index start)
+			 nil
+			 (char string (1- 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)))
@@ -419,8 +434,21 @@
 				      (digit-char-p (char string scan-index) radix))))
 		 ((or (eq scan-index end)
 		      (not (digit-char-p (char string scan-index) radix)))
+		  ;; If next-negative is t, set the numeric value to it's
+		  ;; opposite and reset next-negative to nil.
+		  (when next-negative
+		    (setf next-negative nil)
+		    (setf numeric-value (- numeric-value)))
 		  (push numeric-value parts-list)
 		  (setf string-index scan-index))))
+	    ((and (char= next-char #\-)
+		  (or (not prev-char)
+		      (member prev-char whitespace-chars :test #'char=)))
+	     ;; If we see a minus sign before a number, but not after one,
+	     ;; it is not a date divider, but a negative offset from GMT, so
+	     ;; set next-negative to t and continue.
+	     (setf next-negative t)
+	     (incf string-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)
@@ -476,19 +504,19 @@
 						  (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))))))))
+	  (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
@@ -542,7 +570,8 @@
 	(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)
+(defun parse-time (time-string &key (start 0) (end (length time-string))
+			       (error-on-mismatch nil)			       
 			       (default-seconds nil) (default-minutes nil)
 			       (default-hours nil) (default-day nil)
 			       (default-month nil) (default-year nil)
@@ -557,7 +586,7 @@
    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))
+  (let* ((string-parts (decompose-string time-string :start start :end end))
 	 (parts-length (length string-parts))
 	 (string-form (dolist (pattern patterns)
 			(let ((match-result (match-pattern pattern
-- 
GitLab