From 79c5d188557c86998fe153d9e947e74f4aa7530d Mon Sep 17 00:00:00 2001 From: rtoy <rtoy> Date: Tue, 29 May 2007 16:33:16 +0000 Subject: [PATCH] Some changes proposed by Madhu on cmucl-imp, May 3, 2007. o Allow microseconds in the time. We don't do anything with the microseconds; we just recognize it and through it away. o Add a check that if the day of the week is specified, it actually makes sense with the given date. Thus, "Wed May 29, 2007" signals an error since May 29, 2007, is Tuesday. o Some slight rearrange of the code for consistency. --- code/parse-time.lisp | 102 ++++++++++++++++++++++++++++++++----------- 1 file changed, 77 insertions(+), 25 deletions(-) diff --git a/code/parse-time.lisp b/code/parse-time.lisp index 024fe27df..34655000b 100644 --- a/code/parse-time.lisp +++ b/code/parse-time.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/parse-time.lisp,v 1.16 2007/05/02 12:47:24 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/parse-time.lisp,v 1.17 2007/05/29 16:33:16 rtoy Exp $") ;;; ;;; ********************************************************************** @@ -155,6 +155,9 @@ 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 time-divider microsecond + (zone)) (hour (time-divider) (minute) (time-divider) (secondp) (am-pm) (date-divider) (zone) (weekday) month (date-divider) day (date-divider) year) @@ -383,6 +386,9 @@ (defun special-string-p (string) (and (simple-string-p string) (gethash string *special-strings*))) +(defun microsecond (number) + (integerp number)) + (defun secondp (number) (and (integerp number) (<= 0 number 59))) @@ -600,25 +606,72 @@ (setf (decoded-time-zone parsed-values) (- (+ hours (/ mins 60)))))) (defun check-days-per-month (parsed-values) - (cond ((= (decoded-time-month parsed-values) 2) - ;; February only has 28 days, except for leap years - (flet ((leap-year-p (y) - ;; Leap years are years divisible by 4. Except if - ;; it's divisible by 100, in which case, only if - ;; it's divisible by 400. - (let ((div-100 (mod y 100)) - (div-4 (mod y 4))) - (if (zerop div-100) - (zerop (mod y 400)) - (zerop div-4))))) - (<= (decoded-time-day parsed-values) - (if (leap-year-p (decoded-time-year parsed-values)) - 29 28)))) - ((member (decoded-time-month parsed-values) '(4 6 9 11)) - ;; These months only have 30 days - (<= (decoded-time-day parsed-values) 30)) - (t - t))) + (let ((ok + (cond ((= (decoded-time-month parsed-values) 2) + ;; February only has 28 days, except for leap years + (flet ((leap-year-p (y) + ;; Leap years are years divisible by 4. Except if + ;; it's divisible by 100, in which case, only if + ;; it's divisible by 400. + (let ((div-100 (mod y 100)) + (div-4 (mod y 4))) + (if (zerop div-100) + (zerop (mod y 400)) + (zerop div-4))))) + (<= (decoded-time-day parsed-values) + (if (leap-year-p (decoded-time-year parsed-values)) + 29 28)))) + ((member (decoded-time-month parsed-values) '(4 6 9 11)) + ;; These months only have 30 days + (<= (decoded-time-day parsed-values) 30)) + (t + t)))) + (unless ok + (error "Invalid number of days (~D) for month ~D in ~D" + (decoded-time-day parsed-values) + (decoded-time-month parsed-values) + (decoded-time-year parsed-values))))) + +(defun weekday-from-gregorian (month day year) + ;; TYPE gregorian-date -> weekday. adapted from reingold. 0 = sunday. + (mod + (+ 0 ; Days before start of calendar + (* 365 (1- year)) ; Ordinary days since epoch + (floor (1- year) + 4) ; Julian leap days since epoch... + (- ; ...minus century years since epoch... + (floor (1- year) 100)) + (floor ; ...plus years since epoch divisible... + (1- year) 400) ; ...by 400. + (floor ; Days in prior months this year... + (- (* 367 month) 362) ; ...assuming 30-day Feb + 12) + (if (<= month 2) ; Correct for 28- or 29-day Feb + 0 + (if (and (= (mod year 4) 0) ; gregorian-leap-year + (not (member (mod year 400) + (list 100 200 300)))) + -1 + -2)) + day) + 7)) + +(defun check-weekday (parsed-values) + (let ((dotw (mod (1- (weekday-from-gregorian (decoded-time-month parsed-values) + (decoded-time-day parsed-values) + (decoded-time-year parsed-values))) + 7))) + (flet ((lookup-name (day) + (maphash #'(lambda (k v) + (when (= v day) + (return-from lookup-name k))) + *weekday-strings*))) + (unless (= dotw (decoded-time-dotw parsed-values)) + (error "Specified day (~@(~A~)) doesn't match actual day (~@(~A~))" + (lookup-name (decoded-time-dotw parsed-values)) + (lookup-name dotw)))))) + + ;;; Set-time-values uses the association list of symbols and values ;;; to set the time in the decoded-time structure. @@ -628,6 +681,7 @@ (let ((form-type (car form-part)) (form-value (cdr form-part))) (case form-type + (microsecond 0) (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)) @@ -644,11 +698,9 @@ (t (error "Unrecognized symbol in form list: ~A." form-type))))) ;; Some simple sanity checks, like does the given month have that ;; many days? Is it a leap year? - (unless (check-days-per-month parsed-values) - (error "Invalid number of days (~D) for month ~D in ~D" - (decoded-time-day parsed-values) - (decoded-time-month parsed-values) - (decoded-time-year parsed-values)))) + (check-days-per-month parsed-values) + (check-weekday parsed-values)) + (defun parse-time (time-string &key (start 0) (end (length time-string)) (error-on-mismatch nil) -- GitLab