diff --git a/code/parse-time.lisp b/code/parse-time.lisp index 024fe27df397f015b7f3e7a62b854ac1ecb24ba4..34655000b23a3ff97a94531a8001cdd4f1400f92 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)