Skip to content
Snippets Groups Projects
Commit 79c5d188 authored by rtoy's avatar rtoy
Browse files

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.
parent 0c53d4eb
Branches
Tags
No related merge requests found
......@@ -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)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment