time.lisp patch
Alan Caulkins <[email protected]>
| Newsgroups | gmane.lisp.clsql.devel |
|---|---|
| Message-ID | <[email protected]> |
Hi, Here's a patch for some bugs I found in time.lisp. The first one was just a transposition of the bodies of current-month and current-day. I swapped a 'first' here and a 'second' there. The second one was some variable shadowing errors in the roll function. Basically, the roll function needs several versions of various time values over the course of it's calculations, and it looks like some names were intentionally shadowed in let and multiple-value-bind forms. However, mistakes were made in some of the re-bindings. The third bug was also in roll, in it's destructive mode. If the :year or :month keyword arguments were supplied, the date argument was set to a new wall-time object. Of course, that setf doesn't translate through to the variable in the caller, so the year and month components of durations were lost. Insert straw and enjoy, -A Maxint Consulting Linux: The ultimate video game. _______________________________________________ CLSQL-Devel mailing list [email protected] http://lists.b9.com/mailman/listinfo/clsql-devel
time.lisp.patch
(text/plain, 5.5 KB)
*** clsql-3.2.0o/sql/time.lisp 2005-05-18 02:27:55.000000000 -0500
--- clsql-3.2.0/sql/time.lisp 2005-06-10 04:14:08.000000000 -0500
***************
*** 664,677 ****
(let ((new-time (copy-time time)))
(dolist (duration durations)
(roll new-time
! :year (duration-year duration)
! :month (duration-month duration)
! :day (duration-day duration)
! :hour (duration-hour duration)
! :minute (duration-minute duration)
! :second (duration-second duration)
! :usec (duration-usec duration)
! :destructive t))
new-time))
(defun time- (time &rest durations)
--- 664,677 ----
(let ((new-time (copy-time time)))
(dolist (duration durations)
(roll new-time
! :year (duration-year duration)
! :month (duration-month duration)
! :day (duration-day duration)
! :hour (duration-hour duration)
! :minute (duration-minute duration)
! :second (duration-second duration)
! :usec (duration-usec duration)
! :destructive t))
new-time))
(defun time- (time &rest durations)
***************
*** 679,692 ****
(let ((new-time (copy-time time)))
(dolist (duration durations)
(roll new-time
! :year (- (duration-year duration))
! :month (- (duration-month duration))
! :day (- (duration-day duration))
! :hour (- (duration-hour duration))
! :minute (- (duration-minute duration))
! :second (- (duration-second duration))
! :usec (- (duration-usec duration))
! :destructive t))
new-time))
(defun time-difference (time1 time2)
--- 679,692 ----
(let ((new-time (copy-time time)))
(dolist (duration durations)
(roll new-time
! :year (- (duration-year duration))
! :month (- (duration-month duration))
! :day (- (duration-day duration))
! :hour (- (duration-hour duration))
! :minute (- (duration-minute duration))
! :second (- (duration-second duration))
! :usec (- (duration-usec duration))
! :destructive t))
new-time))
(defun time-difference (time1 time2)
***************
*** 766,775 ****
(third (mjd-to-gregorian (time-mjd (get-time)))))
(defun current-month ()
! (second (mjd-to-gregorian (time-mjd (get-time)))))
(defun current-day ()
! (first (mjd-to-gregorian (time-mjd (get-time)))))
(defun parse-date-time (string)
"parses date like 08/08/01, 8.8.2001, eg"
--- 766,775 ----
(third (mjd-to-gregorian (time-mjd (get-time)))))
(defun current-month ()
! (first (mjd-to-gregorian (time-mjd (get-time)))))
(defun current-day ()
! (second (mjd-to-gregorian (time-mjd (get-time)))))
(defun parse-date-time (string)
"parses date like 08/08/01, 8.8.2001, eg"
***************
*** 927,959 ****
(defun roll (date &key (year 0) (month 0) (day 0) (second 0) (hour 0)
(minute 0) (usec 0) (destructive nil))
! (unless (= 0 year month)
! (multiple-value-bind (year-orig month-orig day-orig)
! (time-ymd date)
! (setf date (make-time :year (+ year year-orig)
! :month (+ month month-orig)
! :day day-orig
! :second (time-second date)
! :usec usec))))
! (let ((mjd (time-mjd date))
(sec (time-second date))
! (usec (time-usec date)))
(multiple-value-bind (sec-new usec-new)
! (floor (+ usec
(* 1000000
(+ sec second
(* 60 minute)
(* 60 60 hour))))
1000000)
- (declare (ignore sec-new))
(multiple-value-bind (mjd-new sec-new)
! (floor sec (* 60 60 24))
(if destructive
(progn
(setf (time-mjd date) (+ mjd mjd-new day)
(time-second date) sec-new
(time-usec date) usec-new)
! date)
(%make-wall-time :mjd (+ mjd mjd-new day)
:second sec-new
:usec usec-new))))))
--- 927,956 ----
(defun roll (date &key (year 0) (month 0) (day 0) (second 0) (hour 0)
(minute 0) (usec 0) (destructive nil))
! (let ((mjd (if (= 0 year month)
! (time-mjd date)
! (multiple-value-bind (year-orig month-orig day-orig)
! (time-ymd date)
! (gregorian-to-mjd (+ month-orig month)
! day-orig
! (+ year-orig year)))))
(sec (time-second date))
! (usec-old (time-usec date)))
(multiple-value-bind (sec-new usec-new)
! (floor (+ usec-old usec
(* 1000000
(+ sec second
(* 60 minute)
(* 60 60 hour))))
1000000)
(multiple-value-bind (mjd-new sec-new)
! (floor sec-new (* 60 60 24))
(if destructive
(progn
(setf (time-mjd date) (+ mjd mjd-new day)
(time-second date) sec-new
(time-usec date) usec-new)
! date)
(%make-wall-time :mjd (+ mjd mjd-new day)
:second sec-new
:usec usec-new))))))