diff --git a/dates.lisp b/dates.lisp index ef3ee4a..e05b761 100644 --- a/dates.lisp +++ b/dates.lisp @@ -57,10 +57,10 @@ or a numeric offset in fractions of an hour e.g., +5.5" (offset (zone-to-offset zone))) (- jdate (/ offset 24)))) -(defun date->ymd (date) - "Returns 6 values corresponding to the given datetime- -year, month, day, hour, minute, second. Second may be a floating -point value but the first five are aways integers" +(defun date->ymd (date &key (want-time nil)) + "Returns 6 values if :want-time is true: year, month, day, hour, minute, second. +Second may be a floating point value but the first five are aways integers. +If :want-time is NIL, returns year, month and day as integers." (let* ((jd (jday-number date)) (e (floor (/ (- jd 1867216.25d0) 36524.25d0))) (f (+ 1 jd e (- (floor (/ e 4))))) @@ -70,20 +70,21 @@ point value but the first five are aways integers" (j (floor (/ (- g i) 30.6001d0))) (dd (- g i (floor (* j 30.6001d0)))) (mm (- j (* 12 (floor (/ j 14))) 1)) - (yy (+ h (floor (* 1/12 (- 14 mm))) -4716)) - (day-frac (multiple-value-bind (day frac) (truncate date) - (declare (ignore day)) - (if (>= frac 0.5d0) - ;; midnight to noon - (- frac 0.5d0) - (+ frac 0.5d0))))) - (multiple-value-bind (h m s) (day-fraction->hms day-frac) - (values yy mm dd h m s)))) + (yy (+ h (floor (* 1/12 (- 14 mm))) -4716))) + (if want-time + (let ((day-frac (multiple-value-bind (day frac) (truncate date) + (declare (ignore day)) + (if (>= frac 0.5d0) + ;; midnight to noon + (- frac 0.5d0) + (+ frac 0.5d0))))) + (multiple-value-bind (h m s) (day-fraction->hms day-frac) + (values yy mm dd h m s))) + (values yy mm dd)))) (defun valid-date-p (yy mm dd) "Check that year, month and day form a valid calendar date" - (multiple-value-bind (y m d hr mn sc) (date->ymd (ymd->date yy mm dd)) - (declare (ignore hr mn sc)) + (multiple-value-bind (y m d) (date->ymd (ymd->date yy mm dd)) (and (= yy y) (= mm m) (= dd d)))) (defun valid-time-p (h m s) @@ -198,7 +199,7 @@ it returns year, month, day, hour, minute and second as 6 values" (t (error "Invalid param which: ~a" which))))) (setf date (apply-correction-factors yy date)) (if want-gregorian-date - (date->ymd date) + (date->ymd date :want-time t) date))) (defun cos-degrees (deg) diff --git a/parse-date.lisp b/parse-date.lisp index bbe8801..ed4c4bd 100644 --- a/parse-date.lisp +++ b/parse-date.lisp @@ -418,7 +418,7 @@ ((setf tmp (str-to-relative-date token)) (when (/= 0 num-date-comps) (return-from string->date nil)) - (multiple-value-bind (yy mm dd h m s) (date->ymd (+ reference-date tmp)) + (multiple-value-bind (yy mm dd h m s) (date->ymd (+ reference-date tmp) :want-time t) (setf (dt-yr res) yy (dt-mth res) mm (dt-day res) dd @@ -568,7 +568,7 @@ (when (dt-yr res) (setf (dt-yr res) (make-four-digit-year (dt-yr res)))) ;; copy all missing values from the reference date - (multiple-value-bind (yy mm dd h m s) (date->ymd reference-date) + (multiple-value-bind (yy mm dd h m s) (date->ymd reference-date :want-time t) (when-null-set res dt-yr yy) (when-null-set res dt-mth mm) (when-null-set res dt-day dd) diff --git a/print-date.lisp b/print-date.lisp index e688d79..14c22f3 100644 --- a/print-date.lisp +++ b/print-date.lisp @@ -40,7 +40,7 @@ The :human format is the same as :iso-8601 except that the separators between da time and timezone are spaces to make it more readable to the human eye." (let ((offset (zone-to-offset zone))) (incf date (/ offset 24)) - (multiple-value-bind (yy mm dd h m s) (date->ymd date) + (multiple-value-bind (yy mm dd h m s) (date->ymd date :want-time t) (let ((year (format nil "~d" yy)) (month (case format ((:asctime :rfc-822 :rfc-850) (three-letter-month mm)) @@ -61,7 +61,7 @@ e.g., \"Thursday, 6 July 2017, 09:38:43.567 +0900\". If :date-only is true, the time and timezone are omitted." (let ((offset (zone-to-offset zone))) (incf date (/ offset 24)) - (multiple-value-bind (yy mm dd h m s) (date->ymd date) + (multiple-value-bind (yy mm dd h m s) (date->ymd date :want-time t) (if date-only (format nil "~a, ~d ~a ~d" (dow->string (day-of-week date)) dd (month->string mm) yy)