mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

Fix typos, indentation and error reporting in SRFI-19.

Browse source 
* module/srfi/srfi-19.scm: Fix typos in comments, indentation, and pass
the correct 'caller' name to 'time-error' in several places.
This commit is contained in:
Mark H Weaver 2018-10-16 04:20:47 -04:00 • committed by Andy Wingo
parent d61da427e1
commit a47a5e6828
1 changed files with 99 additions and 91 deletions
Download patch file Download diff file Expand all files Collapse all files

190
module/srfi/srfi-19.scm
View file

@ -311,7 +311,7 @@
;; (* (remainder current-ms 1000) 10000)))) ;; (* (remainder current-ms 1000) 10000))))
;; -- we define it to be the same as TAI. ;; -- we define it to be the same as TAI.
;; A different implemation of current-time-montonic ;; A different implemention of current-time-monotonic
;; will require rewriting all of the time-monotonic converters, ;; will require rewriting all of the time-monotonic converters,
;; of course. ;; of course.
@ -323,7 +323,7 @@
(time-second tai)))) (time-second tai))))
(define (current-time-thread) (define (current-time-thread)
(time-error 'current-time 'unsupported-clock-type 'time-thread)) (time-error 'current-time-thread 'unsupported-clock-type 'time-thread))
(define ns-per-guile-tick (/ 1000000000 internal-time-units-per-second)) (define ns-per-guile-tick (/ 1000000000 internal-time-units-per-second))
@ -371,8 +371,13 @@
;; also presume it will be rare to check two times of different types. ;; also presume it will be rare to check two times of different types.
(and (= (time-second t1) (time-second t2)) (and (= (time-second t1) (time-second t2))
(= (time-nanosecond t1) (time-nanosecond t2)) (= (time-nanosecond t1) (time-nanosecond t2))
;; XXX The SRFI-19 reference implementation raises an error in
;; case of unequal time types. Here we return #false.
(eq? (time-type t1) (time-type t2)))) (eq? (time-type t1) (time-type t2))))
;; XXX In the following comparison procedures, the SRFI-19 reference
;; implementation raises an error in case of unequal time types.
(define (time>? t1 t2) (define (time>? t1 t2)
(or (> (time-second t1) (time-second t2)) (or (> (time-second t1) (time-second t2))
(and (= (time-second t1) (time-second t2)) (and (= (time-second t1) (time-second t2))
@ -395,6 +400,9 @@
;; -- Time arithmetic ;; -- Time arithmetic
;; XXX In the following comparison procedures, the SRFI-19 reference
;; implementation raises an error in case of unequal time types.
(define (time-difference! time1 time2) (define (time-difference! time1 time2)
(let ((sec-diff (- (time-second time1) (time-second time2))) (let ((sec-diff (- (time-second time1) (time-second time2)))
(nsec-diff (- (time-nanosecond time1) (time-nanosecond time2)))) (nsec-diff (- (time-nanosecond time1) (time-nanosecond time2))))
@ -409,7 +417,7 @@
(define (add-duration! t duration) (define (add-duration! t duration)
(if (not (eq? (time-type duration) time-duration)) (if (not (eq? (time-type duration) time-duration))
(time-error 'add-duration 'not-duration duration) (time-error 'add-duration! 'not-duration duration)
(let ((sec-plus (+ (time-second t) (time-second duration))) (let ((sec-plus (+ (time-second t) (time-second duration)))
(nsec-plus (+ (time-nanosecond t) (time-nanosecond duration)))) (nsec-plus (+ (time-nanosecond t) (time-nanosecond duration))))
(set-time-second! t sec-plus) (set-time-second! t sec-plus)
@ -422,7 +430,7 @@
(define (subtract-duration! t duration) (define (subtract-duration! t duration)
(if (not (eq? (time-type duration) time-duration)) (if (not (eq? (time-type duration) time-duration))
(time-error 'add-duration 'not-duration duration) (time-error 'subtract-duration! 'not-duration duration)
(let ((sec-minus (- (time-second t) (time-second duration))) (let ((sec-minus (- (time-second t) (time-second duration)))
(nsec-minus (- (time-nanosecond t) (time-nanosecond duration)))) (nsec-minus (- (time-nanosecond t) (time-nanosecond duration))))
(set-time-second! t sec-minus) (set-time-second! t sec-minus)
@ -472,7 +480,7 @@
(define (time-monotonic->time-utc time-in) (define (time-monotonic->time-utc time-in)
(if (not (eq? (time-type time-in) time-monotonic)) (if (not (eq? (time-type time-in) time-monotonic))
(time-error 'time-monotonic->time-utc (time-error 'time-monotonic->time-utc
'incompatible-time-types time-in)) 'incompatible-time-types time-in))
(let ((ntime (copy-time time-in))) (let ((ntime (copy-time time-in)))
(set-time-type! ntime time-tai) (set-time-type! ntime time-tai)
(priv:time-tai->time-utc! ntime ntime 'time-monotonic->time-utc))) (priv:time-tai->time-utc! ntime ntime 'time-monotonic->time-utc)))
@ -480,14 +488,14 @@
(define (time-monotonic->time-utc! time-in) (define (time-monotonic->time-utc! time-in)
(if (not (eq? (time-type time-in) time-monotonic)) (if (not (eq? (time-type time-in) time-monotonic))
(time-error 'time-monotonic->time-utc! (time-error 'time-monotonic->time-utc!
'incompatible-time-types time-in)) 'incompatible-time-types time-in))
(set-time-type! time-in time-tai) (set-time-type! time-in time-tai)
(priv:time-tai->time-utc! time-in time-in 'time-monotonic->time-utc)) (priv:time-tai->time-utc! time-in time-in 'time-monotonic->time-utc))
(define (time-monotonic->time-tai time-in) (define (time-monotonic->time-tai time-in)
(if (not (eq? (time-type time-in) time-monotonic)) (if (not (eq? (time-type time-in) time-monotonic))
(time-error 'time-monotonic->time-tai (time-error 'time-monotonic->time-tai
'incompatible-time-types time-in)) 'incompatible-time-types time-in))
(let ((ntime (copy-time time-in))) (let ((ntime (copy-time time-in)))
(set-time-type! ntime time-tai) (set-time-type! ntime time-tai)
ntime)) ntime))
@ -495,14 +503,14 @@
(define (time-monotonic->time-tai! time-in) (define (time-monotonic->time-tai! time-in)
(if (not (eq? (time-type time-in) time-monotonic)) (if (not (eq? (time-type time-in) time-monotonic))
(time-error 'time-monotonic->time-tai! (time-error 'time-monotonic->time-tai!
'incompatible-time-types time-in)) 'incompatible-time-types time-in))
(set-time-type! time-in time-tai) (set-time-type! time-in time-tai)
time-in) time-in)
(define (time-utc->time-monotonic time-in) (define (time-utc->time-monotonic time-in)
(if (not (eq? (time-type time-in) time-utc)) (if (not (eq? (time-type time-in) time-utc))
(time-error 'time-utc->time-monotonic (time-error 'time-utc->time-monotonic
'incompatible-time-types time-in)) 'incompatible-time-types time-in))
(let ((ntime (priv:time-utc->time-tai! time-in (make-time-unnormalized #f #f #f) (let ((ntime (priv:time-utc->time-tai! time-in (make-time-unnormalized #f #f #f)
'time-utc->time-monotonic))) 'time-utc->time-monotonic)))
(set-time-type! ntime time-monotonic) (set-time-type! ntime time-monotonic)
@ -511,7 +519,7 @@
(define (time-utc->time-monotonic! time-in) (define (time-utc->time-monotonic! time-in)
(if (not (eq? (time-type time-in) time-utc)) (if (not (eq? (time-type time-in) time-utc))
(time-error 'time-utc->time-monotonic! (time-error 'time-utc->time-monotonic!
'incompatible-time-types time-in)) 'incompatible-time-types time-in))
(let ((ntime (priv:time-utc->time-tai! time-in time-in (let ((ntime (priv:time-utc->time-tai! time-in time-in
'time-utc->time-monotonic!))) 'time-utc->time-monotonic!)))
(set-time-type! ntime time-monotonic) (set-time-type! ntime time-monotonic)
@ -520,7 +528,7 @@
(define (time-tai->time-monotonic time-in) (define (time-tai->time-monotonic time-in)
(if (not (eq? (time-type time-in) time-tai)) (if (not (eq? (time-type time-in) time-tai))
(time-error 'time-tai->time-monotonic (time-error 'time-tai->time-monotonic
'incompatible-time-types time-in)) 'incompatible-time-types time-in))
(let ((ntime (copy-time time-in))) (let ((ntime (copy-time time-in)))
(set-time-type! ntime time-monotonic) (set-time-type! ntime time-monotonic)
ntime)) ntime))
@ -528,7 +536,7 @@
(define (time-tai->time-monotonic! time-in) (define (time-tai->time-monotonic! time-in)
(if (not (eq? (time-type time-in) time-tai)) (if (not (eq? (time-type time-in) time-tai))
(time-error 'time-tai->time-monotonic! (time-error 'time-tai->time-monotonic!
'incompatible-time-types time-in)) 'incompatible-time-types time-in))
(set-time-type! time-in time-monotonic) (set-time-type! time-in time-monotonic)
time-in) time-in)
@ -600,15 +608,15 @@
(define (time-utc->date time . tz-offset) (define (time-utc->date time . tz-offset)
(if (not (eq? (time-type time) time-utc)) (if (not (eq? (time-type time) time-utc))
(time-error 'time->date 'incompatible-time-types time)) (time-error 'time-utc->date 'incompatible-time-types time))
(let* ((offset (if (null? tz-offset) (let* ((offset (if (null? tz-offset)
(local-tz-offset time) (local-tz-offset time)
(car tz-offset))) (car tz-offset)))
(leap-second? (leap-second? (+ offset (time-second time)))) (leap-second? (leap-second? (+ offset (time-second time))))
(jdn (time->julian-day-number (if leap-second? (jdn (time->julian-day-number (if leap-second?
(- (time-second time) 1) (- (time-second time) 1)
(time-second time)) (time-second time))
offset))) offset)))
(call-with-values (lambda () (decode-julian-day-number jdn)) (call-with-values (lambda () (decode-julian-day-number jdn))
(lambda (secs date month year) (lambda (secs date month year)
@ -630,7 +638,7 @@
(define (time-tai->date time . tz-offset) (define (time-tai->date time . tz-offset)
(if (not (eq? (time-type time) time-tai)) (if (not (eq? (time-type time) time-tai))
(time-error 'time->date 'incompatible-time-types time)) (time-error 'time-tai->date 'incompatible-time-types time))
(let* ((offset (if (null? tz-offset) (let* ((offset (if (null? tz-offset)
(local-tz-offset (time-tai->time-utc time)) (local-tz-offset (time-tai->time-utc time))
(car tz-offset))) (car tz-offset)))
@ -638,9 +646,9 @@
(leap-second-delta (time-second time)))) (leap-second-delta (time-second time))))
(leap-second? (leap-second? (+ offset seconds))) (leap-second? (leap-second? (+ offset seconds)))
(jdn (time->julian-day-number (if leap-second? (jdn (time->julian-day-number (if leap-second?
(- seconds 1) (- seconds 1)
seconds) seconds)
offset))) offset)))
(call-with-values (lambda () (decode-julian-day-number jdn)) (call-with-values (lambda () (decode-julian-day-number jdn))
(lambda (secs date month year) (lambda (secs date month year)
;; secs is a real because jdn is a real in Guile; ;; secs is a real because jdn is a real in Guile;
@ -663,7 +671,7 @@
;; this is the same as time-tai->date. ;; this is the same as time-tai->date.
(define (time-monotonic->date time . tz-offset) (define (time-monotonic->date time . tz-offset)
(if (not (eq? (time-type time) time-monotonic)) (if (not (eq? (time-type time) time-monotonic))
(time-error 'time->date 'incompatible-time-types time)) (time-error 'time-monotonic->date 'incompatible-time-types time))
(let* ((offset (if (null? tz-offset) (let* ((offset (if (null? tz-offset)
(local-tz-offset (time-monotonic->time-utc time)) (local-tz-offset (time-monotonic->time-utc time))
(car tz-offset))) (car tz-offset)))
@ -671,9 +679,9 @@
(leap-second-delta (time-second time)))) (leap-second-delta (time-second time))))
(leap-second? (leap-second? (+ offset seconds))) (leap-second? (leap-second? (+ offset seconds)))
(jdn (time->julian-day-number (if leap-second? (jdn (time->julian-day-number (if leap-second?
(- seconds 1) (- seconds 1)
seconds) seconds)
offset))) offset)))
(call-with-values (lambda () (decode-julian-day-number jdn)) (call-with-values (lambda () (decode-julian-day-number jdn))
(lambda (secs date month year) (lambda (secs date month year)
;; secs is a real because jdn is a real in Guile; ;; secs is a real because jdn is a real in Guile;
@ -722,8 +730,8 @@
;; Map 1-based month number M to number of days in the year before the ;; Map 1-based month number M to number of days in the year before the
;; start of month M (in a non-leap year). ;; start of month M (in a non-leap year).
(define month-assoc '((1 . 0) (2 . 31) (3 . 59) (4 . 90) (define month-assoc '((1 . 0) (2 . 31) (3 . 59) (4 . 90)
(5 . 120) (6 . 151) (7 . 181) (8 . 212) (5 . 120) (6 . 151) (7 . 181) (8 . 212)
(9 . 243) (10 . 273) (11 . 304) (12 . 334))) (9 . 243) (10 . 273) (11 . 304) (12 . 334)))
(define (year-day day month year) (define (year-day day month year)
(let ((days-pr (assoc month month-assoc))) (let ((days-pr (assoc month month-assoc)))
@ -814,7 +822,7 @@
(define (time-utc->julian-day time) (define (time-utc->julian-day time)
(if (not (eq? (time-type time) time-utc)) (if (not (eq? (time-type time) time-utc))
(time-error 'time->date 'incompatible-time-types time)) (time-error 'time-utc->julian-day 'incompatible-time-types time))
(+ (/ (+ (time-second time) (/ (time-nanosecond time) nano)) (+ (/ (+ (time-second time) (/ (time-nanosecond time) nano))
sid) sid)
tai-epoch-in-jd)) tai-epoch-in-jd))
@ -825,7 +833,7 @@
(define (time-tai->julian-day time) (define (time-tai->julian-day time)
(if (not (eq? (time-type time) time-tai)) (if (not (eq? (time-type time) time-tai))
(time-error 'time->date 'incompatible-time-types time)) (time-error 'time-tai->julian-day 'incompatible-time-types time))
(+ (/ (+ (- (time-second time) (+ (/ (+ (- (time-second time)
(leap-second-delta (time-second time))) (leap-second-delta (time-second time)))
(/ (time-nanosecond time) nano)) (/ (time-nanosecond time) nano))
@ -839,7 +847,7 @@
;; this is the same as time-tai->julian-day ;; this is the same as time-tai->julian-day
(define (time-monotonic->julian-day time) (define (time-monotonic->julian-day time)
(if (not (eq? (time-type time) time-monotonic)) (if (not (eq? (time-type time) time-monotonic))
(time-error 'time->date 'incompatible-time-types time)) (time-error 'time-monotonic->julian-day 'incompatible-time-types time))
(+ (/ (+ (- (time-second time) (+ (/ (+ (- (time-second time)
(leap-second-delta (time-second time))) (leap-second-delta (time-second time)))
(/ (time-nanosecond time) nano)) (/ (time-nanosecond time) nano))
@ -979,13 +987,13 @@
(display (date->string date locale-date-time-format) port))) (display (date->string date locale-date-time-format) port)))
(cons #\d (lambda (date pad-with port) (cons #\d (lambda (date pad-with port)
(display (padding (date-day date) (display (padding (date-day date)
#\0 2) #\0 2)
port))) port)))
(cons #\D (lambda (date pad-with port) (cons #\D (lambda (date pad-with port)
(display (date->string date "~m/~d/~y") port))) (display (date->string date "~m/~d/~y") port)))
(cons #\e (lambda (date pad-with port) (cons #\e (lambda (date pad-with port)
(display (padding (date-day date) (display (padding (date-day date)
#\Space 2) #\Space 2)
port))) port)))
(cons #\f (lambda (date pad-with port) (cons #\f (lambda (date pad-with port)
(receive (s ns) (floor/ (+ (* (date-second date) nano) (receive (s ns) (floor/ (+ (* (date-second date) nano)
@ -1000,24 +1008,24 @@
(display (date->string date "~b") port))) (display (date->string date "~b") port)))
(cons #\H (lambda (date pad-with port) (cons #\H (lambda (date pad-with port)
(display (padding (date-hour date) (display (padding (date-hour date)
pad-with 2) pad-with 2)
port))) port)))
(cons #\I (lambda (date pad-with port) (cons #\I (lambda (date pad-with port)
(let ((hr (date-hour date))) (let ((hr (date-hour date)))
(if (> hr 12) (if (> hr 12)
(display (padding (- hr 12) (display (padding (- hr 12)
pad-with 2) pad-with 2)
port) port)
(display (padding hr (display (padding hr
pad-with 2) pad-with 2)
port))))) port)))))
(cons #\j (lambda (date pad-with port) (cons #\j (lambda (date pad-with port)
(display (padding (date-year-day date) (display (padding (date-year-day date)
pad-with 3) pad-with 3)
port))) port)))
(cons #\k (lambda (date pad-with port) (cons #\k (lambda (date pad-with port)
(display (padding (date-hour date) (display (padding (date-hour date)
#\Space 2) #\Space 2)
port))) port)))
(cons #\l (lambda (date pad-with port) (cons #\l (lambda (date pad-with port)
(let ((hr (if (> (date-hour date) 12) (let ((hr (if (> (date-hour date) 12)
@ -1026,17 +1034,17 @@
port)))) port))))
(cons #\m (lambda (date pad-with port) (cons #\m (lambda (date pad-with port)
(display (padding (date-month date) (display (padding (date-month date)
pad-with 2) pad-with 2)
port))) port)))
(cons #\M (lambda (date pad-with port) (cons #\M (lambda (date pad-with port)
(display (padding (date-minute date) (display (padding (date-minute date)
pad-with 2) pad-with 2)
port))) port)))
(cons #\n (lambda (date pad-with port) (cons #\n (lambda (date pad-with port)
(newline port))) (newline port)))
(cons #\N (lambda (date pad-with port) (cons #\N (lambda (date pad-with port)
(display (padding (date-nanosecond date) (display (padding (date-nanosecond date)
pad-with 9) pad-with 9)
port))) port)))
(cons #\p (lambda (date pad-with port) (cons #\p (lambda (date pad-with port)
(display (locale-am-string/pm (date-hour date)) port))) (display (locale-am-string/pm (date-hour date)) port)))
@ -1048,10 +1056,10 @@
(if (> (date-nanosecond date) (if (> (date-nanosecond date)
nano) nano)
(display (padding (+ (date-second date) 1) (display (padding (+ (date-second date) 1)
pad-with 2) pad-with 2)
port) port)
(display (padding (date-second date) (display (padding (date-second date)
pad-with 2) pad-with 2)
port)))) port))))
(cons #\t (lambda (date pad-with port) (cons #\t (lambda (date pad-with port)
(display #\Tab port))) (display #\Tab port)))
@ -1060,12 +1068,12 @@
(cons #\U (lambda (date pad-with port) (cons #\U (lambda (date pad-with port)
(if (> (days-before-first-week date 0) 0) (if (> (days-before-first-week date 0) 0)
(display (padding (+ (date-week-number date 0) 1) (display (padding (+ (date-week-number date 0) 1)
#\0 2) port) #\0 2) port)
(display (padding (date-week-number date 0) (display (padding (date-week-number date 0)
#\0 2) port)))) #\0 2) port))))
(cons #\V (lambda (date pad-with port) (cons #\V (lambda (date pad-with port)
(display (padding (date-week-number date 1) (display (padding (date-week-number date 1)
#\0 2) port))) #\0 2) port)))
(cons #\w (lambda (date pad-with port) (cons #\w (lambda (date pad-with port)
(display (date-week-day date) port))) (display (date-week-day date) port)))
(cons #\x (lambda (date pad-with port) (cons #\x (lambda (date pad-with port)
@ -1075,14 +1083,14 @@
(cons #\W (lambda (date pad-with port) (cons #\W (lambda (date pad-with port)
(if (> (days-before-first-week date 1) 0) (if (> (days-before-first-week date 1) 0)
(display (padding (+ (date-week-number date 1) 1) (display (padding (+ (date-week-number date 1) 1)
#\0 2) port) #\0 2) port)
(display (padding (date-week-number date 1) (display (padding (date-week-number date 1)
#\0 2) port)))) #\0 2) port))))
(cons #\y (lambda (date pad-with port) (cons #\y (lambda (date pad-with port)
(display (padding (last-n-digits (display (padding (last-n-digits
(date-year date) 2) (date-year date) 2)
pad-with pad-with
2) 2)
port))) port)))
(cons #\Y (lambda (date pad-with port) (cons #\Y (lambda (date pad-with port)
(display (date-year date) port))) (display (date-year date) port)))
@ -1115,63 +1123,63 @@
(date-printer date (+ index 1) format-string str-len port)) (date-printer date (+ index 1) format-string str-len port))
(if (= (+ index 1) str-len) ; bad format string. (if (= (+ index 1) str-len) ; bad format string.
(time-error 'date-printer 'bad-date-format-string (time-error 'date-printer 'bad-date-format-string
format-string) format-string)
(let ((pad-char? (string-ref format-string (+ index 1)))) (let ((pad-char? (string-ref format-string (+ index 1))))
(cond (cond
((char=? pad-char? #\-) ((char=? pad-char? #\-)
(if (= (+ index 2) str-len) ; bad format string. (if (= (+ index 2) str-len) ; bad format string.
(time-error 'date-printer (time-error 'date-printer
'bad-date-format-string 'bad-date-format-string
format-string) format-string)
(let ((formatter (get-formatter (let ((formatter (get-formatter
(string-ref format-string (string-ref format-string
(+ index 2))))) (+ index 2)))))
(if (not formatter) (if (not formatter)
(time-error 'date-printer (time-error 'date-printer
'bad-date-format-string 'bad-date-format-string
format-string) format-string)
(begin (begin
(formatter date #f port) (formatter date #f port)
(date-printer date (date-printer date
(+ index 3) (+ index 3)
format-string format-string
str-len str-len
port)))))) port))))))
((char=? pad-char? #\_) ((char=? pad-char? #\_)
(if (= (+ index 2) str-len) ; bad format string. (if (= (+ index 2) str-len) ; bad format string.
(time-error 'date-printer (time-error 'date-printer
'bad-date-format-string 'bad-date-format-string
format-string) format-string)
(let ((formatter (get-formatter (let ((formatter (get-formatter
(string-ref format-string (string-ref format-string
(+ index 2))))) (+ index 2)))))
(if (not formatter) (if (not formatter)
(time-error 'date-printer (time-error 'date-printer
'bad-date-format-string 'bad-date-format-string
format-string) format-string)
(begin (begin
(formatter date #\Space port) (formatter date #\Space port)
(date-printer date (date-printer date
(+ index 3) (+ index 3)
format-string format-string
str-len str-len
port)))))) port))))))
(else (else
(let ((formatter (get-formatter (let ((formatter (get-formatter
(string-ref format-string (string-ref format-string
(+ index 1))))) (+ index 1)))))
(if (not formatter) (if (not formatter)
(time-error 'date-printer (time-error 'date-printer
'bad-date-format-string 'bad-date-format-string
format-string) format-string)
(begin (begin
(formatter date #\0 port) (formatter date #\0 port)
(date-printer date (date-printer date
(+ index 2) (+ index 2)
format-string format-string
str-len str-len
port)))))))))))) port))))))))))))
(define (date->string date . format-string) (define (date->string date . format-string)
@ -1193,7 +1201,7 @@
((#\8) 8) ((#\8) 8)
((#\9) 9) ((#\9) 9)
(else (time-error 'char->int 'bad-date-template-string (else (time-error 'char->int 'bad-date-template-string
(list "Non-integer character" ch))))) (list "Non-integer character" ch)))))
;; read an integer upto n characters long on port; upto -> #f is any length ;; read an integer upto n characters long on port; upto -> #f is any length
(define (integer-reader upto port) (define (integer-reader upto port)
@ -1219,7 +1227,7 @@
((>= nchars n) accum) ((>= nchars n) accum)
((eof-object? ch) ((eof-object? ch)
(time-error 'string->date 'bad-date-template-string (time-error 'string->date 'bad-date-template-string
"Premature ending to integer read.")) "Premature ending to integer read."))
((char-numeric? ch) ((char-numeric? ch)
(set! padding-ok #f) (set! padding-ok #f)
(accum-int port (accum-int port
@ -1230,7 +1238,7 @@
(accum-int port accum (+ nchars 1))) (accum-int port accum (+ nchars 1)))
(else ; padding where it shouldn't be (else ; padding where it shouldn't be
(time-error 'string->date 'bad-date-template-string (time-error 'string->date 'bad-date-template-string
"Non-numeric characters in integer read."))))) "Non-numeric characters in integer read.")))))
(accum-int port 0 0))) (accum-int port 0 0)))
@ -1244,7 +1252,7 @@
(let ((ch (read-char port))) (let ((ch (read-char port)))
(if (eof-object? ch) (if (eof-object? ch)
(time-error 'string->date 'bad-date-template-string (time-error 'string->date 'bad-date-template-string
(list "Invalid time zone +/-" ch))) (list "Invalid time zone +/-" ch)))
(if (or (char=? ch #\Z) (char=? ch #\z)) (if (or (char=? ch #\Z) (char=? ch #\z))
0 0
(begin (begin
@ -1253,29 +1261,29 @@
((char=? ch #\-) (set! positive? #f)) ((char=? ch #\-) (set! positive? #f))
(else (else
(time-error 'string->date 'bad-date-template-string (time-error 'string->date 'bad-date-template-string
(list "Invalid time zone +/-" ch)))) (list "Invalid time zone +/-" ch))))
(let ((ch (read-char port))) (let ((ch (read-char port)))
(if (eof-object? ch) (if (eof-object? ch)
(time-error 'string->date 'bad-date-template-string (time-error 'string->date 'bad-date-template-string
(list "Invalid time zone number" ch))) (list "Invalid time zone number" ch)))
(set! offset (* (char->int ch) (set! offset (* (char->int ch)
10 60 60))) 10 60 60)))
(let ((ch (read-char port))) (let ((ch (read-char port)))
(if (eof-object? ch) (if (eof-object? ch)
(time-error 'string->date 'bad-date-template-string (time-error 'string->date 'bad-date-template-string
(list "Invalid time zone number" ch))) (list "Invalid time zone number" ch)))
(set! offset (+ offset (* (char->int ch) (set! offset (+ offset (* (char->int ch)
60 60)))) 60 60))))
(let ((ch (read-char port))) (let ((ch (read-char port)))
(if (eof-object? ch) (if (eof-object? ch)
(time-error 'string->date 'bad-date-template-string (time-error 'string->date 'bad-date-template-string
(list "Invalid time zone number" ch))) (list "Invalid time zone number" ch)))
(set! offset (+ offset (* (char->int ch) (set! offset (+ offset (* (char->int ch)
10 60)))) 10 60))))
(let ((ch (read-char port))) (let ((ch (read-char port)))
(if (eof-object? ch) (if (eof-object? ch)
(time-error 'string->date 'bad-date-template-string (time-error 'string->date 'bad-date-template-string
(list "Invalid time zone number" ch))) (list "Invalid time zone number" ch)))
(set! offset (+ offset (* (char->int ch) (set! offset (+ offset (* (char->int ch)
60)))) 60))))
(if positive? offset (- offset))))))) (if positive? offset (- offset)))))))
@ -1292,8 +1300,8 @@
(let* ((str (read-char-string '())) (let* ((str (read-char-string '()))
(index (indexer str))) (index (indexer str)))
(if index index (time-error 'string->date (if index index (time-error 'string->date
'bad-date-template-string 'bad-date-template-string
(list "Invalid string for " indexer))))) (list "Invalid string for " indexer)))))
(define (make-locale-reader indexer) (define (make-locale-reader indexer)
(lambda (port) (lambda (port)
@ -1304,8 +1312,8 @@
(if (char=? char (read-char port)) (if (char=? char (read-char port))
char char
(time-error 'string->date (time-error 'string->date
'bad-date-template-string 'bad-date-template-string
"Invalid character match.")))) "Invalid character match."))))
;; A List of formatted read directives. ;; A List of formatted read directives.
;; Each entry is a list. ;; Each entry is a list.
@ -1373,7 +1381,7 @@
(char=? c #\+) (char=? c #\+)
(char=? c #\-))) (char=? c #\-)))
zone-reader (lambda (val object) zone-reader (lambda (val object)
(set-date-zone-offset! object val)))))) (set-date-zone-offset! object val))))))
(define (priv:string->date date index format-string str-len port template-string) (define (priv:string->date date index format-string str-len port template-string)
(define (skip-until port skipper) (define (skip-until port skipper)
@ -1389,7 +1397,7 @@
(if (or (eof-object? port-char) (if (or (eof-object? port-char)
(not (char=? current-char port-char))) (not (char=? current-char port-char)))
(time-error 'string->date (time-error 'string->date
'bad-date-format-string template-string)) 'bad-date-format-string template-string))
(priv:string->date date (priv:string->date date
(+ index 1) (+ index 1)
format-string format-string
@ -1399,12 +1407,12 @@
;; otherwise, it's an escape, we hope ;; otherwise, it's an escape, we hope
(if (> (+ index 1) str-len) (if (> (+ index 1) str-len)
(time-error 'string->date (time-error 'string->date
'bad-date-format-string template-string) 'bad-date-format-string template-string)
(let* ((format-char (string-ref format-string (+ index 1))) (let* ((format-char (string-ref format-string (+ index 1)))
(format-info (assoc format-char read-directives))) (format-info (assoc format-char read-directives)))
(if (not format-info) (if (not format-info)
(time-error 'string->date (time-error 'string->date
'bad-date-format-string template-string) 'bad-date-format-string template-string)
(begin (begin
(let ((skipper (cadr format-info)) (let ((skipper (cadr format-info))
(reader (caddr format-info)) (reader (caddr format-info))
@ -1413,8 +1421,8 @@
(let ((val (reader port))) (let ((val (reader port)))
(if (eof-object? val) (if (eof-object? val)
(time-error 'string->date (time-error 'string->date
'bad-date-format-string 'bad-date-format-string
template-string) template-string)
(if actor (actor val date)))) (if actor (actor val date))))
(priv:string->date date (priv:string->date date
(+ index 2) (+ index 2)