Changeset 13899 in project


Ignore:
Timestamp:
03/24/09 19:30:55 (11 years ago)
Author:
Kon Lovett
Message:

Canonical form.

Location:
release/3/srfi-19/trunk
Files:
5 edited

Legend:

Unmodified
Added
Removed
  • release/3/srfi-19/trunk/srfi-19-common.scm

    r12793 r13899  
    1515(define-constant SEC/MIN  60)
    1616
    17 #|
    18 (define-constant iNS/S    1000000000.0)
    19 (define-constant iSEC/DY  86400.0)
    20 (define-constant iONE-HALF  0.5)
    21 |#
     17#;(define-constant iNS/S    1000000000.0)
     18#;(define-constant iSEC/DY  86400.0)
     19#;(define-constant iONE-HALF  0.5)
    2220
    2321(define-constant HR/DY 24)
     
    3129;;
    3230
    33 (define-inline (->boolean obj)
    34   (and obj
    35        #t) )
     31(define-inline (%->boolean obj) (and obj #t))
    3632
    37 (define-inline (fxabs x)
    38   (if (fx< x 0) (fxneg x) x) )
     33(define-inline (%fxabs x) (if (fx< x 0) (fxneg x) x))
    3934
    40 #;
    41 (define-inline (inexact-integer? x)
    42   (and (inexact? x) (integer? x)) )
     35#;(define-inline (%inexact-integer? x) (and (inexact? x) (integer? x)))
    4336
    4437;; For storage savings since some aritmetic routines do not
     
    5548; Number MUST be a fixnum or flonum
    5649
    57 (define-inline (->fixnum x)
     50(define-inline (%->fixnum x)
    5851  (if (fixnum? x) x (##sys#double->number x))
    59   #;
    60   (inexact->exact x) )
     52  #;(inexact->exact x) )
    6153
    6254; When domain is integer and range is flonum-integer
     
    6456; Others returned
    6557
    66 (define-inline (->fixnum* x)
    67   (if (##sys#integer? x) (->fixnum x) x)
    68   #;
    69   (if (inexact-integer? x) (->fixnum x) x) )
     58(define-inline (%->fixnum* x)
     59  (if (##sys#integer? x) (%->fixnum x) x)
     60  #;(if (%inexact-integer? x) (%->fixnum x) x) )
  • release/3/srfi-19/trunk/srfi-19-core.scm

    r12943 r13899  
    3939
    4040;; To Do
     41;;
     42;; - Time -> Date conversion takes account of the state of the converted date
     43;; daylight saving time state.
    4144;;
    4245;; - Date/Time field minimums & maximums (useful for UI)
     
    281284      tm:time-difference) ) )
    282285
    283 (require-extension
    284   srfi-6 srfi-8 srfi-9 posix
    285   numbers locale
    286   misc-extn-record)
     286(require-extension srfi-6 srfi-8 srfi-9 posix numbers locale misc-extn-record)
    287287
    288288(register-feature! 'srfi-19)
     
    304304
    305305(define total-gc-milliseconds
    306   (let ([accum-ms 0])
     306  (let ((accum-ms 0))
    307307    (lambda ()
    308308      (set! accum-ms (+ accum-ms (current-gc-milliseconds)))
     
    310310
    311311(define (current-process-milliseconds)
    312   (receive [ums sms] (cpu-time)
     312  (receive (ums sms) (cpu-time)
    313313    (+ ums sms) ) )
    314314
     
    385385
    386386(define (tm:read-tai-utc-data flnm)
    387   (let ([convert-jd
    388           (lambda (jd)
    389             (* (- (inexact->exact jd) TAI-EPOCH-IN-JD) SEC/DY))]
    390         [convert-sec
    391           (lambda (sec)
    392             (inexact->exact sec))])
    393     (let ([read-data
    394             (lambda ()
    395               (let loop ([lst '()])
    396                 (let ([line (read-line)])
    397                   (if (eof-object? line)
    398                     lst
    399                     (let ([data (with-input-from-string (string-append "(" line ")") read)])
    400                       (let ([year (car data)]
    401                             [jd   (cadddr (cdr data))]
    402                             [secs (cadddr (cdddr data))])
    403                         (loop
    404                           (if (>= year FIRST-LEAP-YEAR)
    405                             (cons (cons (convert-jd jd) (convert-sec secs)) lst)
    406                             lst))))))))])
     387  (let ((convert-jd (lambda (jd) (* (- (inexact->exact jd) TAI-EPOCH-IN-JD) SEC/DY)))
     388        (convert-sec (lambda (sec) (inexact->exact sec))))
     389    (let ((read-data
     390           (lambda ()
     391             (let loop ((lst '()))
     392               (let ((line (read-line)))
     393                 (if (eof-object? line) lst
     394                     (let ((data (with-input-from-string (string-append "(" line ")") read)))
     395                       (let ((year (car data))
     396                             (jd   (cadddr (cdr data)))
     397                             (secs (cadddr (cdddr data))))
     398                         (loop
     399                           (if (< year FIRST-LEAP-YEAR) lst
     400                               (cons (cons (convert-jd jd) (convert-sec secs)) lst))) ) ) ) ) ) ) ) )
    407401      (with-input-from-port (open-input-file flnm) read-data) ) ) )
    408402
     
    410404
    411405(define (tm:calc-second-before-leap-second-table table)
    412   (let loop ([inlst table] [outlst '()])
    413     (if (null? inlst)
    414       (reverse outlst) ; doesn't matter but keep input order anyway
    415       (let ([itm (car inlst)])
    416        (loop (cdr inlst) (cons (- (+ (car itm) (cdr itm)) 1) outlst)))) ) )
     406  (let loop ((inlst table) (outlst '()))
     407    (if (null? inlst) (reverse outlst) ; doesn't matter but keep input order anyway
     408        (let ((itm (car inlst)))
     409          (loop (cdr inlst) (cons (- (+ (car itm) (cdr itm)) 1) outlst)))) ) )
    417410
    418411(define tm:second-before-leap-second-table
     
    429422
    430423(define (tm:leap-second-delta utc-seconds)
    431   (letrec ([lsd
     424  (letrec ((lsd
    432425            (lambda (lst)
    433               (if (null? lst)
    434                 0
    435                 (let ([itm (car lst)])
    436                   (if (<= (car itm) utc-seconds)
    437                     (cdr itm)
    438                     (lsd (cdr lst))))))])
    439     (if (< utc-seconds LEAP-START)
    440       0
    441       (lsd tm:leap-second-table)) ) )
     426              (if (null? lst) 0
     427                  (let ((itm (car lst)))
     428                    (if (<= (car itm) utc-seconds) (cdr itm)
     429                        (lsd (cdr lst))))))))
     430    (if (< utc-seconds LEAP-START) 0
     431        (lsd tm:leap-second-table)) ) )
    442432
    443433;; Going from tai seconds to utc seconds ...
    444434
    445435(define (tm:leap-second-neg-delta tai-seconds)
    446   (letrec ([lsd
     436  (letrec ((lsd
    447437            (lambda (lst)
    448               (if (null? lst)
    449                 0
    450                 (let ([itm (car lst)])
    451                   (if (<= (cdr itm) (- tai-seconds (car itm)))
    452                     (cdr itm)
    453                     (lsd (cdr lst))))))])
    454     (if (< tai-seconds LEAP-START)
    455       0
    456       (lsd tm:leap-second-table)) ) )
     438              (if (null? lst) 0
     439                  (let ((itm (car lst)))
     440                    (if (<= (cdr itm) (- tai-seconds (car itm))) (cdr itm)
     441                        (lsd (cdr lst))))))))
     442    (if (< tai-seconds LEAP-START) 0
     443        (lsd tm:leap-second-table)) ) )
    457444
    458445;;; Time Object (Public Mutable)
     
    473460(define (time-type? obj)
    474461  (case obj
    475     [(time-monotonic)   #t]
    476     [(time-utc)         #t]
    477     [(time-tai)         #t]
    478     [(time-gc)          #t]
    479     [(time-duration)    #t]
    480     [(time-process)     #t]
    481     [(time-thread)      #t]
    482     [else               #f]) )
     462    ((time-monotonic)   #t)
     463    ((time-utc)         #t)
     464    ((time-tai)         #t)
     465    ((time-gc)          #t)
     466    ((time-duration)    #t)
     467    ((time-process)     #t)
     468    ((time-thread)      #t)
     469    (else               #f)) )
    483470
    484471(define (clock-time-type? obj)
    485472  (case obj
    486     [(time-monotonic)   #t]
    487     [(time-tai)         #t]
    488     [(time-utc)         #t]
    489     [else               #f]) )
     473    ((time-monotonic)   #t)
     474    ((time-tai)         #t)
     475    ((time-utc)         #t)
     476    (else               #f)) )
    490477
    491478;;
     
    494481  (make-parameter 'time-utc
    495482    (lambda (x)
    496       (if (clock-time-type? x)
    497         x
    498         (default-date-clock-type)))))
     483      (cond ((clock-time-type? x) x)
     484            (else
     485             (warning 'default-date-clock-type "bad argument type - expected clock-time-type" x)
     486             (default-date-clock-type) ) ) ) ) )
    499487
    500488(define (tm:check-time-type loc obj)
    501489  (unless (time-type? obj)
    502     (error loc "invalid time type" obj)) )
     490    (error loc "invalid time type" obj) ) )
    503491
    504492;; There are 3 kinds of time record procedures:
     
    514502  (sec    %time-second      %set-time-second!) )
    515503
    516 (define-inline (%check-time loc obj)
    517   (##sys#check-structure obj 'time loc) )
     504(define-inline (%check-time loc obj) (##sys#check-structure obj 'time loc))
    518505
    519506;;
     
    521508(define tm:time-type %time-type)
    522509
    523 (define (tm:make-time timtyp ns sec)
    524   (%make-time timtyp (->fixnum ns) (->fixnum* sec)) )
    525 
    526 (define (tm:set-time-nanosecond! tim ns)
    527   (%set-time-nanosecond! tim (->fixnum ns)) )
    528 
    529 (define (tm:set-time-second! tim sec)
    530   (%set-time-second! tim (->fixnum* sec)) )
     510(define (tm:make-time timtyp ns sec) (%make-time timtyp (%->fixnum ns) (%->fixnum* sec)))
     511
     512(define (tm:set-time-nanosecond! tim ns) (%set-time-nanosecond! tim (%->fixnum ns)))
     513
     514(define (tm:set-time-second! tim sec) (%set-time-second! tim (%->fixnum* sec)))
    531515
    532516;;
    533517
    534518(define-record-printer (time tim out)
    535   (fprintf out "#,(time ~A ~A ~A)" (%time-type tim) (%time-nanosecond tim) (%time-second tim)) )
     519  (format out "#,(time ~A ~A ~A)" (%time-type tim) (%time-nanosecond tim) (%time-second tim)) )
    536520
    537521(define-reader-ctor 'time tm:make-time)
     
    543527(define ONE-NANOSECOND-DURATION (%make-time 'time-duration 1 0))
    544528
    545 (define (tm:make-empty-time timtyp)
    546   (%make-time timtyp 0 0) )
    547 
    548 (define (tm:as-empty-time tim)
    549   (tm:make-empty-time (%time-type tim)) )
     529(define (tm:make-empty-time timtyp) (%make-time timtyp 0 0))
     530
     531(define (tm:as-empty-time tim) (tm:make-empty-time (%time-type tim)))
    550532
    551533;; Time Parameter Checking
     
    553535(define (tm:check-time-has-type loc tim timtyp)
    554536  (unless (eq? timtyp (%time-type tim))
    555     (error loc "incompatible time types" (%time-type tim) timtyp)) )
     537    (error loc "incompatible time types" (%time-type tim) timtyp) ) )
    556538
    557539(define (tm:check-time-and-type loc tim timtyp)
     
    561543(define tm:check-time %check-time)
    562544
    563 (define (tm:check-duration loc obj)
    564   (tm:check-time-and-type loc obj 'time-duration) )
     545(define (tm:check-duration loc obj) (tm:check-time-and-type loc obj 'time-duration))
    565546
    566547(define (tm:check-time-nanoseconds loc obj)
     
    570551(define (tm:check-time-seconds loc obj)
    571552  (unless (fixnum? obj)
    572     (error loc "invalid seconds" obj)) )
     553    (error loc "invalid seconds" obj) ) )
    573554
    574555(define (tm:check-time-elements loc obj1 obj2 obj3)
     
    577558  (tm:check-time-seconds loc obj3) )
    578559
    579 (define (tm:check-times loc objs)
    580   (for-each (cut tm:check-time loc <>) objs) )
     560(define (tm:check-times loc objs) (for-each (cut tm:check-time loc <>) objs))
    581561
    582562(define (tm:time-binop-check loc obj1 obj2)
     
    594574;; Rem & Quo of nanoseconds per second
    595575
    596 (define (tm:split-nanoseconds nanos)
    597   (values (abs (remainder nanos NS/S)) (quotient nanos NS/S)) )
     576(define (tm:split-nanoseconds nanos) (values (abs (remainder nanos NS/S)) (quotient nanos NS/S)))
    598577
    599578;; Time CTOR
     
    608587          (hours 0) (minutes 0) (seconds 0)
    609588          (milliseconds 0) (microseconds 0) (nanoseconds 0))
    610   (let ([nanos (+ (* milliseconds NS/MS) (* microseconds NS/MuS) nanoseconds)]
    611         [secs (+ (* days SEC/DY) (* hours SEC/HR) (* minutes SEC/MIN) seconds)])
    612     (receive [ns sec] (tm:split-nanoseconds nanos)
     589  (let ((nanos (+ (* milliseconds NS/MS) (* microseconds NS/MuS) nanoseconds))
     590        (secs (+ (* days SEC/DY) (* hours SEC/HR) (* minutes SEC/MIN) seconds)))
     591    (receive (ns sec) (tm:split-nanoseconds nanos)
    613592      (make-time 'time-duration ns (+ secs sec)) ) ) )
    614593
    615 (define (copy-time tim)
    616   (%make-time (%time-type tim) (%time-second tim) (%time-nanosecond tim)) )
     594(define (copy-time tim) (%make-time (%time-type tim) (%time-second tim) (%time-nanosecond tim)))
    617595
    618596;; Converts a seconds value, may be fractional, into a time type.
     
    620598
    621599(define (seconds->time/type sec . timtyp)
    622   (let ([tsec (truncate sec)])
     600  (let ((tsec (truncate sec)))
    623601    (make-time
    624       (optional timtyp 'time-duration)
    625       (round (abs (* (- (exact->inexact sec) tsec) NS/S)))
    626       tsec) ) )
     602     (optional timtyp 'time-duration)
     603     (round (abs (* (- (exact->inexact sec) tsec) NS/S)))
     604     tsec) ) )
    627605
    628606;; Time record-type operations
     
    666644  (let-optionals args ((timtyp 'time-duration))
    667645    (tm:check-time-type 'nanoseconds->time timtyp)
    668     (receive [ns sec] (tm:split-nanoseconds ns)
     646    (receive (ns sec) (tm:split-nanoseconds ns)
    669647      (tm:make-time timtyp ns sec) ) ) )
    670648
     
    681659    (tm:make-time timtyp (fx* (remainder ms MS/S) NS/MS) (quotient ms MS/S)) ) )
    682660
    683 (define (milliseconds->seconds ms)
    684   (/ (exact->inexact ms) MS/S) )
     661(define (milliseconds->seconds ms) (/ (exact->inexact ms) MS/S))
    685662
    686663;; Current time routines
    687664
    688 (define (tm:current-sub-milliseconds)
    689   ; Throw away everything but the sub-second bit.
    690   ; Chicken 'current-milliseconds' within positive fixnum range
    691   (fxmod (current-milliseconds) MS/S) )
    692 
    693 (define (tm:current-nanoseconds)
    694   (* (tm:current-sub-milliseconds) NS/MS) )
    695 
    696 (define (tm:current-time-values)
    697   ;Use the 'official' seconds & nanoseconds values
    698   (values (tm:current-nanoseconds) (current-seconds)) )
     665; Throw away everything but the sub-second bit.
     666; Chicken 'current-milliseconds' within positive fixnum range
     667(define (tm:current-sub-milliseconds) (fxmod (current-milliseconds) MS/S))
     668
     669(define (tm:current-nanoseconds) (* (tm:current-sub-milliseconds) NS/MS))
     670
     671;Use the 'official' seconds & nanoseconds values
     672(define (tm:current-time-values) (values (tm:current-nanoseconds) (current-seconds)))
    699673
    700674(define (tm:current-time-utc)
    701   (receive [ns sec] (tm:current-time-values)
     675  (receive (ns sec) (tm:current-time-values)
    702676    (tm:make-time 'time-utc ns sec)) )
    703677
    704678(define (tm:current-time-tai)
    705   (receive [ns sec] (tm:current-time-values)
     679  (receive (ns sec) (tm:current-time-values)
    706680    (tm:make-time 'time-tai ns (+ sec (tm:leap-second-delta sec))) ) )
    707681
    708682(define (tm:current-time-monotonic)
    709   (let ([tim (tm:current-time-tai)])
     683  (let ((tim (tm:current-time-tai)))
    710684    (%set-time-type! tim 'time-monotonic)
    711685    tim ) )
     
    723697
    724698(define (current-time . timtyp)
    725   (let ([timtyp (optional timtyp 'time-utc)])
     699  (let ((timtyp (optional timtyp 'time-utc)))
    726700    (tm:check-time-type 'current-time timtyp)
    727701    (case timtyp
    728       [(time-monotonic) (tm:current-time-monotonic)]
    729       [(time-utc)       (tm:current-time-utc)]
    730       [(time-tai)       (tm:current-time-tai)]
    731       [(time-gc)        (tm:current-time-gc)]
    732       [(time-process)   (tm:current-time-process)]
    733       [(time-thread)    (tm:current-time-thread)]) ) )
     702      ((time-monotonic) (tm:current-time-monotonic))
     703      ((time-utc)       (tm:current-time-utc))
     704      ((time-tai)       (tm:current-time-tai))
     705      ((time-gc)        (tm:current-time-gc))
     706      ((time-process)   (tm:current-time-process))
     707      ((time-thread)    (tm:current-time-thread))) ) )
    734708
    735709;; SRFI-18 Routines
     
    758732
    759733(define (tm:time-compare tim1 tim2)
    760   (let ([dif (- (%time-second tim1) (%time-second tim2))])
    761     (if (not (zero? dif))
    762       dif
    763       (fx- (%time-nanosecond tim1) (%time-nanosecond tim2)) ) ) )
     734  (let ((dif (- (%time-second tim1) (%time-second tim2))))
     735    (if (not (zero? dif)) dif
     736        (fx- (%time-nanosecond tim1) (%time-nanosecond tim2)) ) ) )
    764737
    765738(define (tm:time=? tim1 tim2)
     
    788761
    789762(define (tm:time-max tim . rest)
    790   (let loop ([acc tim] [lst rest])
    791     (if (null? lst)
    792       acc
    793       (let ([tim (car lst)])
    794         (loop (if (tm:time<? acc tim) tim acc) (cdr lst)))) ) )
     763  (let loop ((acc tim) (lst rest))
     764    (if (null? lst) acc
     765        (let ((tim (car lst)))
     766          (loop (if (tm:time<? acc tim) tim acc) (cdr lst)))) ) )
    795767
    796768(define (tm:time-min tim . rest)
    797   (let loop ([acc tim] [lst rest])
    798     (if (null? lst)
    799       acc
    800       (let ([tim (car lst)])
    801         (loop (if (tm:time>? acc tim) tim acc) (cdr lst)))) ) )
     769  (let loop ((acc tim) (lst rest))
     770    (if (null? lst) acc
     771        (let ((tim (car lst)))
     772          (loop (if (tm:time>? acc tim) tim acc) (cdr lst)))) ) )
    802773
    803774(define (time-compare tim1 tim2)
    804775  (tm:time-compare-check 'time-compare tim1 tim2)
    805   (let ([dif (tm:time-compare tim1 tim2)])
    806     (cond
    807       [(negative? dif)  -1]
    808       [(positive? dif)  1]
    809       [else             0] ) ) )
     776  (let ((dif (tm:time-compare tim1 tim2)))
     777    (cond ((negative? dif)  -1)
     778          ((positive? dif)  1)
     779          (else             0) ) ) )
    810780
    811781(define (time=? tim1 tim2)
     
    842812  (%set-time-type! tim3 'time-duration)
    843813  (if (tm:time=? tim1 tim2)
    844     (begin
    845       (tm:set-time-second! tim3 0)
    846       (tm:set-time-nanosecond! tim3 0))
    847     (receive [ns sec] (tm:split-nanoseconds (- (time->nanoseconds tim1) (time->nanoseconds tim2)))
    848       (tm:set-time-second! tim3 sec)
    849       (tm:set-time-nanosecond! tim3 ns)))
     814      (begin
     815        (tm:set-time-second! tim3 0)
     816        (tm:set-time-nanosecond! tim3 0))
     817      (receive (ns sec)
     818          (tm:split-nanoseconds (- (time->nanoseconds tim1) (time->nanoseconds tim2)))
     819        (tm:set-time-second! tim3 sec)
     820        (tm:set-time-nanosecond! tim3 ns)))
    850821  tim3 )
    851822
    852823(define (tm:add-duration tim1 dur tim3)
    853   (let ([sec-plus (+ (%time-second tim1) (%time-second dur))]
    854         [nsec-plus (+ (%time-nanosecond tim1) (%time-nanosecond dur))])
     824  (let ((sec-plus (+ (%time-second tim1) (%time-second dur)))
     825        (nsec-plus (+ (%time-nanosecond tim1) (%time-nanosecond dur))))
    855826    (tm:set-time-second! tim3 (+ sec-plus (quotient nsec-plus NS/S)))
    856827    (tm:set-time-nanosecond! tim3 (remainder nsec-plus NS/S))
     
    858829
    859830(define (tm:subtract-duration tim1 dur tim3)
    860   (let ([sec-minus (- (%time-second tim1) (%time-second dur))]
    861         [nsec-minus (fx- (%time-nanosecond tim1) (%time-nanosecond dur))])
    862     (let ([r (fxmod nsec-minus NS/S)]
    863           [secs (- sec-minus (fx/ nsec-minus NS/S))])
     831  (let ((sec-minus (- (%time-second tim1) (%time-second dur)))
     832        (nsec-minus (fx- (%time-nanosecond tim1) (%time-nanosecond dur))))
     833    (let ((r (fxmod nsec-minus NS/S))
     834          (secs (- sec-minus (fx/ nsec-minus NS/S))))
    864835      (if (fx< r 0)
    865         (begin
    866           (tm:set-time-second! tim3 (- secs 1))
    867           (tm:set-time-nanosecond! tim3 (fx+ NS/S r)))
    868         (begin
    869           (tm:set-time-second! tim3 secs)
    870           (tm:set-time-nanosecond! tim3 r)))
     836          (begin
     837            (tm:set-time-second! tim3 (- secs 1))
     838            (tm:set-time-nanosecond! tim3 (fx+ NS/S r)))
     839          (begin
     840            (tm:set-time-second! tim3 secs)
     841            (tm:set-time-nanosecond! tim3 r)))
    871842      tim3 ) ) )
    872843
    873844(define (tm:divide-duration dur1 num dur3)
    874   (receive [ns sec] (tm:split-nanoseconds (/ (time->nanoseconds dur1) num))
     845  (receive (ns sec)
     846      (tm:split-nanoseconds (/ (time->nanoseconds dur1) num))
    875847    (tm:set-time-nanosecond! dur3 ns)
    876848    (tm:set-time-second! dur3 sec)
     
    878850
    879851(define (tm:multiply-duration dur1 num dur3)
    880   (receive [ns sec] (tm:split-nanoseconds (* (time->nanoseconds dur1) num))
     852  (receive (ns sec)
     853      (tm:split-nanoseconds (* (time->nanoseconds dur1) num))
    881854    (tm:set-time-nanosecond! dur3 ns)
    882855    (tm:set-time-second! dur3 sec)
     
    968941  (tm:set-time-nanosecond! tim-out (%time-nanosecond tim-in))
    969942  (tm:set-time-second! tim-out
    970     (- (%time-second tim-in) (tm:leap-second-neg-delta (%time-second tim-in))))
     943   (- (%time-second tim-in) (tm:leap-second-neg-delta (%time-second tim-in))))
    971944  tim-out )
    972945
     
    975948  (tm:set-time-nanosecond! tim-out (%time-nanosecond tim-in))
    976949  (tm:set-time-second! tim-out
    977     (+ (%time-second tim-in) (tm:leap-second-delta (%time-second tim-in))))
     950   (+ (%time-second tim-in) (tm:leap-second-delta (%time-second tim-in))))
    978951  tim-out )
    979952
     
    997970
    998971(define (tm:time-utc->time-monotonic tim-in tim-out)
    999   (let ([ntim (tm:time-utc->time-tai tim-in tim-out)])
     972  (let ((ntim (tm:time-utc->time-tai tim-in tim-out)))
    1000973    (%set-time-type! ntim 'time-monotonic)
    1001974    ntim ) )
     
    10371010(define (time-monotonic->time-utc tim)
    10381011  (tm:check-time-and-type 'time-monotoinc->time-utc tim 'time-monotonic)
    1039   (let ([ntim (copy-time tim)])
     1012  (let ((ntim (copy-time tim)))
    10401013    (tm:time-monotonic->time-utc ntim ntim) ) )
    10411014
     
    10791052
    10801053(define local-timezone-locale
    1081   (make-parameter
    1082     (make-timezone-locale (current-dstflag) (current-timezone-components))
     1054  (make-parameter (make-timezone-locale (current-dstflag) (current-timezone-components))
    10831055    (lambda (obj)
    1084       (if (timezone-locale? obj)
    1085           obj
    1086           (local-timezone-locale)))) )
     1056      (cond ((timezone-locale? obj) obj)
     1057            (else
     1058             (warning 'local-timezone-locale "bad argument type - expected a timezone-locale" obj)
     1059             (local-timezone-locale) ) ) ) ) )
     1060
     1061(define (make-utc-timezone)
     1062  (let ((tz (make-timezone-components "UTC0" "BUILTIN")))
     1063    (update-timezone-components! tz 'std-name "UTC" 'std-offset 0) ) )
    10871064
    10881065(define utc-timezone-locale
    1089   (make-parameter
    1090     (make-timezone-locale #f (make-timezone-components 'std-name "UTC" 'std-offset 0))
     1066  (make-parameter (make-timezone-locale #f (make-utc-timezone))
    10911067    (lambda (obj)
    1092       (if (timezone-locale? obj)
    1093           obj
    1094           (utc-timezone-locale)))) )
     1068      (cond ((timezone-locale? obj) obj)
     1069            (else
     1070             (warning 'utc-timezone-locale "bad argument type - expected a timezone-locale" obj)
     1071             (utc-timezone-locale) ) ) ) ) )
    10951072
    10961073;; Returns #f or a valid tz-name
     
    10991076  (let-optionals args ((tzi (local-timezone-locale)))
    11001077    (check-timezone-locale 'timezone-locale-name tzi)
    1101     (let* ([tzc (%timezone-locale-component tzi)]
    1102            [tzn (timezone-component-ref
    1103                   tzc
    1104                   (if (%timezone-locale-dst? tzi) 'dst-name 'std-name))])
     1078    (let* ((tzc (%timezone-locale-component tzi))
     1079           (tzn (timezone-component-ref tzc (if (%timezone-locale-dst? tzi) 'dst-name 'std-name))))
    11051080      ; TZ may not be set
    11061081      (and (not (eq? UNKNOWN-LOCAL-TZ-NAME tzn))
    1107            tzn) ) ) )
     1082           tzn ) ) ) )
    11081083
    11091084;;
     
    11121087  (let-optionals args ((tzi (local-timezone-locale)))
    11131088    (check-timezone-locale 'timezone-locale-offset tzi)
    1114     (let* ([tzc (%timezone-locale-component tzi)]
    1115            [tzo (timezone-component-ref
    1116                   tzc
    1117                   (if (%timezone-locale-dst? tzi) 'dst-offset 'std-offset))])
     1089    (let* ((tzc (%timezone-locale-component tzi))
     1090           (tzo (timezone-component-ref tzc (if (%timezone-locale-dst? tzi) 'dst-offset 'std-offset))))
    11181091      ; TZ may not be set but if it is then convert to ISO 8601
    11191092      (if tzo (fxneg tzo) 0) ) ) )
     
    11481121;;
    11491122
    1150 (define-inline (%check-date loc obj)
    1151   (##sys#check-structure obj 'date loc) )
    1152 
    1153 ;;
    1154 
    1155 (define (tm:date-nanosecond-set! dat x)
    1156   (%date-nanosecond-set! dat (->fixnum x)) )
    1157 
    1158 (define (tm:date-second-set! dat x)
    1159   (%date-second-set! dat (->fixnum x)) )
    1160 
    1161 (define (tm:date-minute-set! dat x)
    1162   (%date-minute-set! dat (->fixnum x)) )
    1163 
    1164 (define (tm:date-hour-set! dat x)
    1165   (%date-hour-set! dat (->fixnum x)) )
    1166 
    1167 (define (tm:date-day-set! dat x)
    1168   (%date-day-set! dat (->fixnum x)) )
    1169 
    1170 (define (tm:date-month-set! dat x)
    1171   (%date-month-set! dat (->fixnum x)) )
    1172 
    1173 (define (tm:date-year-set! dat x)
    1174   (%date-year-set! dat (->fixnum x)) )
    1175 
    1176 (define (tm:date-zone-offset-set! dat x)
    1177   (%date-zone-offset-set! dat (->fixnum x)) )
     1123(define-inline (%check-date loc obj) (##sys#check-structure obj 'date loc))
     1124
     1125;;
     1126
     1127(define (tm:date-nanosecond-set! dat x) (%date-nanosecond-set! dat (%->fixnum x)))
     1128
     1129(define (tm:date-second-set! dat x) (%date-second-set! dat (%->fixnum x)))
     1130
     1131(define (tm:date-minute-set! dat x) (%date-minute-set! dat (%->fixnum x)))
     1132
     1133(define (tm:date-hour-set! dat x) (%date-hour-set! dat (%->fixnum x)))
     1134
     1135(define (tm:date-day-set! dat x) (%date-day-set! dat (%->fixnum x)))
     1136
     1137(define (tm:date-month-set! dat x) (%date-month-set! dat (%->fixnum x)))
     1138
     1139(define (tm:date-year-set! dat x) (%date-year-set! dat (%->fixnum x)))
     1140
     1141(define (tm:date-zone-offset-set! dat x) (%date-zone-offset-set! dat (%->fixnum x)))
    11781142
    11791143;; Leap Year Test
     
    12051169(define (tm:make-incomplete-date)
    12061170  (%make-date
    1207     0
    1208     0 0 0
    1209     #f #f #f
    1210     (timezone-locale-offset) (timezone-locale-name) (timezone-locale-dst?)
    1211     #f #f #f) )
     1171   0
     1172   0 0 0
     1173   #f #f #f
     1174   (timezone-locale-offset) (timezone-locale-name) (timezone-locale-dst?)
     1175   #f #f #f) )
    12121176
    12131177;; Internal Date CTOR
     
    12151179(define (tm:make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)
    12161180  (%make-date
    1217     (->fixnum ns)
    1218     (->fixnum sec) (->fixnum min) (->fixnum hr)
    1219     (->fixnum dy) (->fixnum mn) (->fixnum yr)
    1220     (->fixnum tzo) tzn dstf
    1221     wdy ydy jdy) )
     1181   (%->fixnum ns)
     1182   (%->fixnum sec) (%->fixnum min) (%->fixnum hr)
     1183   (%->fixnum dy) (%->fixnum mn) (%->fixnum yr)
     1184   (%->fixnum tzo) tzn dstf
     1185   wdy ydy jdy) )
    12221186
    12231187;; Parameter Checking
     
    12251189(define tm:check-date %check-date)
    12261190
     1191; No year 0!
    12271192(define (tm:check-year loc yr)
    1228   ; No year 0!
    12291193  (unless (and (fixnum? yr) (not (fx= 0 yr)))
    12301194    (error loc "invalid year" yr) ) )
    12311195
     1196; Months in [1 12]
    12321197(define (tm:check-month loc mn)
    1233   ; Months in [1 12]
    12341198  (unless (and (fixnum? mn) (fx<= 1 mn) (fx<= mn 12))
    12351199    (error loc "invalid month" mn) ) )
    12361200
     1201; Days in [1 28/29/30/31] - depending on month & year
    12371202(define (tm:check-day loc dy mn yr)
    1238   ; Days in [1 28/29/30/31] - depending on month & year
    12391203  (unless (and (fixnum? dy) (fx<= 1 dy) (fx<= dy (tm:days-in-month mn yr)))
    12401204    (error loc "invalid day" dy) ) )
    12411205
    12421206(define (tm:check-exploded-date loc ns sec min hr dy mn yr tzo tzn)
     1207
    12431208  ; Same as time object
    12441209  (tm:check-time-nanoseconds loc ns)
     1210
    12451211  ; Seconds in [0 60] ; 60 legal due to leap second
    12461212  (unless (and (fixnum? sec) (fx<= 0 sec) (fx<= sec 60))
    12471213    (error loc "invalid seconds" sec))
     1214
    12481215  ; Minutes in [0 59]
    12491216  (unless (and (fixnum? min) (and (fx<= 0 min) (fx< min 60)))
    12501217    (error loc "invalid minutes" min))
     1218
    12511219  ; Hours in [0 23]
    12521220  (unless (and (fixnum? hr) (and (<= 0 hr) (< hr 24)))
    12531221    (error loc "invalid hours" hr))
     1222
    12541223  ; Year, Month & Day within limits
    12551224  (tm:check-year loc yr)
    12561225  (tm:check-month loc mn)
    12571226  (tm:check-day loc dy mn yr)
     1227
    12581228  ; Timezone offset in (-SEC/DY +SEC/DY)
    1259   (unless (and (fixnum? tzo) (let ([atzo (fxabs tzo)]) (and (fx<= 0 atzo) (fx< atzo SEC/DY))))
     1229  (unless (and (fixnum? tzo) (let ((atzo (%fxabs tzo))) (and (fx<= 0 atzo) (fx< atzo SEC/DY))))
    12601230    (error loc "invalid timezone offset" tzo))
    1261   ;
     1231
     1232  ; Timezone not specified or a string
    12621233  (unless (or (not tzn) (string? tzn))
    12631234    (error loc "invalid timezone name" tzn)) )
     
    12661237
    12671238(define-record-printer (date dat out)
    1268   (fprintf out
    1269     "#,(date ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A)"
    1270     (%date-nanosecond dat)
    1271     (%date-second dat) (%date-minute dat) (%date-hour dat)
    1272     (%date-day dat) (%date-month dat) (%date-year dat)
    1273     (%date-zone-offset dat)
    1274     (%date-zone-name dat) (%date-dst? dat)
    1275     (%date-wday dat) (%date-yday dat) (%date-jday dat)) )
     1239  (format out
     1240   "#,(date ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A)"
     1241   (%date-nanosecond dat)
     1242   (%date-second dat) (%date-minute dat) (%date-hour dat)
     1243   (%date-day dat) (%date-month dat) (%date-year dat)
     1244   (%date-zone-offset dat)
     1245   (%date-zone-name dat) (%date-dst? dat)
     1246   (%date-wday dat) (%date-yday dat) (%date-jday dat)) )
    12761247
    12771248(define-reader-ctor 'date
    12781249  (lambda (ns sec min hr dy mn yr tzo . rest)
    1279     (let-optionals rest ([tzn #f] [dstf #f] [wdy #f] [ydy #f] [jdy #f])
     1250    (let-optionals rest ((tzn #f) (dstf #f) (wdy #f) (ydy #f) (jdy #f))
    12801251      (tm:make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy))))
    12811252
     
    12831254
    12841255(define (make-date ns sec min hr dy mn yr tzo . rest)
    1285   (let-optionals rest ([tzn #f] [dstf (void)])
    1286     (if (timezone-locale? tzo)
    1287       (begin
    1288         ; Supplied parameters override
    1289         (set! dstf (if (eq? (void) dstf) (timezone-locale-dst? tzo) dstf))
    1290         (set! tzn (or tzn (timezone-locale-name tzo)))
    1291         (set! tzo (timezone-locale-offset tzo)))
    1292       (when (eq? (void) dstf)
    1293         (set! dstf #f)))
     1256  (let-optionals rest ((tzn #f) (dstf (void)))
     1257    (if (not (timezone-locale? tzo))
     1258        (when (eq? (void) dstf) (set! dstf #f))
     1259        (begin
     1260          ; Supplied parameters override
     1261          (set! dstf (if (eq? (void) dstf) (timezone-locale-dst? tzo) dstf))
     1262          (set! tzn (or tzn (timezone-locale-name tzo)))
     1263          (set! tzo (timezone-locale-offset tzo)) ) )
    12941264    (tm:check-exploded-date 'make-date ns sec min hr dy mn yr tzo tzn)
    12951265    (tm:make-date ns sec min hr dy mn yr tzo tzn dstf #f #f #f) ) )
     
    12971267(define (copy-date dat)
    12981268  (%make-date
    1299     (%date-nanosecond dat)
    1300     (%date-second dat) (%date-minute dat) (%date-hour dat)
    1301     (%date-day dat) (%date-month dat) (%date-year dat)
    1302     (%date-zone-offset dat)
    1303     (%date-zone-name dat) (%date-dst? dat)
    1304     (%date-wday dat) (%date-yday dat) (%date-jday dat)) )
     1269   (%date-nanosecond dat)
     1270   (%date-second dat) (%date-minute dat) (%date-hour dat)
     1271   (%date-day dat) (%date-month dat) (%date-year dat)
     1272   (%date-zone-offset dat)
     1273   (%date-zone-name dat) (%date-dst? dat)
     1274   (%date-wday dat) (%date-yday dat) (%date-jday dat)) )
    13051275
    13061276;; Converts a seconds value, may be fractional, into a date type.
     
    13121282  (unless (number? sec)
    13131283    (error 'seconds->date/type "invalid seconds" sec))
    1314   (let ([tzi (optional r #f)])
     1284  (let ((tzi (optional r #f)))
    13151285    (when (boolean? tzi)
    13161286      (set! tzi ((if tzi local-timezone-locale utc-timezone-locale))) )
    13171287    (unless (timezone-locale? tzi)
    13181288      (error 'seconds->date/type "invalid timezone-locale" tzi) )
    1319     (let* ([fsec (exact->inexact sec)]
    1320            [isec (truncate fsec)]
    1321            [tzo (timezone-locale-offset tzi)]
    1322            [tv (seconds->utc-time (+ isec tzo))])
     1289    (let* ((fsec (exact->inexact sec))
     1290           (isec (truncate fsec))
     1291           (tzo (timezone-locale-offset tzi))
     1292           (tv (seconds->utc-time (+ isec tzo))))
    13231293      (tm:make-date
    1324         (round (* (- fsec isec) NS/S))
    1325         (vector-ref tv 0) (vector-ref tv 1) (vector-ref tv 2)
    1326         (vector-ref tv 3) (fx+ 1 (vector-ref tv 4)) (fx+ 1900 (vector-ref tv 5))
    1327         tzo (timezone-locale-name tzi) (timezone-locale-dst? tzi)
    1328         (vector-ref tv 6) (fx+ 1 (vector-ref tv 7)) #f) ) ) )
    1329 
    1330 (define (current-date . tzi)
    1331   (apply time-utc->date (tm:current-time-utc) tzi) )
     1294       (round (* (- fsec isec) NS/S))
     1295       (vector-ref tv 0) (vector-ref tv 1) (vector-ref tv 2)
     1296       (vector-ref tv 3) (fx+ 1 (vector-ref tv 4)) (fx+ 1900 (vector-ref tv 5))
     1297       tzo (timezone-locale-name tzi) (timezone-locale-dst? tzi)
     1298       (vector-ref tv 6) (fx+ 1 (vector-ref tv 7)) #f) ) ) )
     1299
     1300(define (current-date . tzi) (apply time-utc->date (tm:current-time-utc) tzi))
    13321301
    13331302;;
     
    13831352  (%check-date loc dat2)
    13841353  (if (not (fx= (%date-zone-offset dat1) (%date-zone-offset dat2)))
    1385     (error loc "cannot compare dates from different time-zones" dat1 dat2)
    1386     (let ([dif (fx- (%date-year dat1) (%date-year dat2))])
    1387       (if (not (fx= 0 dif))
    1388         dif
    1389         (let ([dif (fx- (%date-month dat1) (%date-month dat2))])
    1390           (if (not (fx= 0 dif))
    1391             dif
    1392             (let ([dif (fx- (%date-day dat1) (%date-day dat2))])
    1393               (if (not (fx= 0 dif))
    1394                 dif
    1395                 (let ([dif (fx- (%date-hour dat1) (%date-hour dat2))])
    1396                   (if (not (fx= 0 dif))
    1397                     dif
    1398                     (let ([dif (fx- (%date-minute dat1) (%date-minute dat2))])
    1399                       (if (not (fx= 0 dif))
    1400                         dif
    1401                         (let ([dif (fx- (%date-second dat1) (%date-second dat2))])
    1402                           (if (not (fx= 0 dif))
    1403                             dif
    1404                             (fx- (%date-nanosecond dat1) (%date-nanosecond dat2)) ) ) ) ) ) ) ) ) ) ) ) ) ) )
     1354      (error loc "cannot compare dates from different time-zones" dat1 dat2)
     1355      (let ((dif (fx- (%date-year dat1) (%date-year dat2))))
     1356        (if (not (fx= 0 dif)) dif
     1357            (let ((dif (fx- (%date-month dat1) (%date-month dat2))))
     1358              (if (not (fx= 0 dif)) dif
     1359                  (let ((dif (fx- (%date-day dat1) (%date-day dat2))))
     1360                    (if (not (fx= 0 dif)) dif
     1361                        (let ((dif (fx- (%date-hour dat1) (%date-hour dat2))))
     1362                          (if (not (fx= 0 dif)) dif
     1363                              (let ((dif (fx- (%date-minute dat1) (%date-minute dat2))))
     1364                                (if (not (fx= 0 dif)) dif
     1365                                    (let ((dif (fx- (%date-second dat1) (%date-second dat2))))
     1366                                      (if (not (fx= 0 dif)) dif
     1367                                          (fx- (%date-nanosecond dat1) (%date-nanosecond dat2)) ) ) ) ) ) ) ) ) ) ) ) ) ) )
    14051368
    14061369(define (date-compare dat1 dat2)
    1407   (let ([dif (tm:date-compare 'date-compare dat1 dat2)])
    1408     (cond
    1409       [(fx> 0 dif)  -1]
    1410       [(fx< 0 dif)  1]
    1411       [else         0] ) ) )
     1370  (let ((dif (tm:date-compare 'date-compare dat1 dat2)))
     1371    (cond ((fx> 0 dif)  -1)
     1372          ((fx< 0 dif)  1)
     1373          (else         0) ) ) )
    14121374
    14131375(define (date=? dat1 dat2)
     
    14311393  (%check-date 'date-difference dat1)
    14321394  (%check-date 'date-difference dat2)
    1433   (let ([tim1 (apply date->time dat1 timtyp)]
    1434         [tim2 (apply date->time dat2 timtyp)])
     1395  (let ((tim1 (apply date->time dat1 timtyp))
     1396        (tim2 (apply date->time dat2 timtyp)))
    14351397    (tm:time-difference tim1 tim2 (tm:as-empty-time tim1)) ) )
    14361398
     
    14381400  (%check-date 'date-add-duration dat)
    14391401  (tm:check-duration 'date-add-duration dur)
    1440   (let ([tim (apply date->time dat timtyp)])
     1402  (let ((tim (apply date->time dat timtyp)))
    14411403    (time->date (tm:add-duration tim dur (tm:as-empty-time tim))) ) )
    14421404
     
    14441406  (%check-date 'date-subtract-duration dat)
    14451407  (tm:check-duration 'date-subtract-duration dur)
    1446   (let ([tim (apply date->time dat timtyp)])
     1408  (let ((tim (apply date->time dat timtyp)))
    14471409    (time->date (tm:subtract-duration tim dur (tm:as-empty-time tim))) ) )
    14481410
     
    14521414
    14531415(define (tm:decode-julian-day-number jdn)
    1454   (let* ([dys (->fixnum (truncate jdn))]
    1455          [a (fx+ dys 32044)]
    1456          [b (fx/ (fx+ (fx* 4 a) 3) 146097)]
    1457          [c (fx- a (fx/ (fx* 146097 b) 4))]
    1458          [d (fx/ (fx+ (fx* 4 c) 3) 1461)]
    1459          [e (fx- c (fx/ (fx* 1461 d) 4))]
    1460          [m (fx/ (fx+ (fx* 5 e) 2) 153)]
    1461          [y (fx+ (fx* 100 b) (fx+ d (fx- (fx/ m 10) 4800)))])
     1416  (let* ((dys (%->fixnum (truncate jdn)))
     1417         (a (fx+ dys 32044))
     1418         (b (fx/ (fx+ (fx* 4 a) 3) 146097))
     1419         (c (fx- a (fx/ (fx* 146097 b) 4)))
     1420         (d (fx/ (fx+ (fx* 4 c) 3) 1461))
     1421         (e (fx- c (fx/ (fx* 1461 d) 4)))
     1422         (m (fx/ (fx+ (fx* 5 e) 2) 153))
     1423         (y (fx+ (fx* 100 b) (fx+ d (fx- (fx/ m 10) 4800)))))
    14621424    (values ; seconds day month year
    1463       (->fixnum (floor (* (- jdn dys) SEC/DY)))
     1425      (%->fixnum (floor (* (- jdn dys) SEC/DY)))
    14641426      (fx+ (fx- e (fx/ (fx+ (fx* 153 m) 2) 5)) 1)
    14651427      (fx- (fx+ m 3) (fx* (fx/ m 10) MN/YR))
     
    14761438
    14771439(define (tm:tai-before-leap-second? tim)
    1478   (let ([sec (%time-second tim)])
    1479     (let loop ([lst tm:second-before-leap-second-table])
     1440  (let ((sec (%time-second tim)))
     1441    (let loop ((lst tm:second-before-leap-second-table))
    14801442      (and (not (null? lst))
    14811443           (or (= sec (car lst))
     
    14841446(define (tm:time->date loc tim tzi)
    14851447  ; The tz-info is caller's rest parameter
    1486   (let ([tzo (optional tzi (local-timezone-locale))]
    1487         [tzn #f]
    1488         [dstf #f])
     1448  (let ((tzo (optional tzi (local-timezone-locale)))
     1449        (tzn #f)
     1450        (dstf #f))
    14891451      (when (timezone-locale? tzo)
    14901452        (set! dstf (timezone-locale-dst? tzo))
     
    14931455      (unless (fixnum? tzo)
    14941456        (error loc "invalid timezone offset" tzo) )
    1495       (receive [secs dy mn yr]
     1457      (receive (secs dy mn yr)
    14961458          (tm:decode-julian-day-number (tm:seconds->julian-day-number (%time-second tim) tzo))
    1497         (let ([hr (fx/ secs SEC/HR)]
    1498               [rsecs (fxmod secs SEC/HR)])
    1499           (let ([min (fx/ rsecs SEC/MIN)]
    1500                 [sec (fxmod rsecs SEC/MIN)])
     1459        (let ((hr (fx/ secs SEC/HR))
     1460              (rsecs (fxmod secs SEC/HR)))
     1461          (let ((min (fx/ rsecs SEC/MIN))
     1462                (sec (fxmod rsecs SEC/MIN)))
    15011463            (tm:make-date (%time-nanosecond tim) sec min hr dy mn yr tzo tzn dstf #f #f #f) ) ) ) ) )
    15021464
    15031465(define (tm:time-tai->date loc tim tzi)
    1504   (let ([tm-utc (tm:time-tai->time-utc tim (tm:as-empty-time tim))])
     1466  (let ((tm-utc (tm:time-tai->time-utc tim (tm:as-empty-time tim))))
    15051467    (if (tm:tai-before-leap-second? tim)
    1506       ; then time is *right* before the leap, we need to pretend to subtract a second ...
    1507       (let ([dat (tm:time->date loc (tm:subtract-duration tm-utc ONE-SECOND-DURATION tm-utc) tzi)])
    1508         (%date-second-set! dat SEC/MIN) ; Note full minute!
    1509         dat )
    1510       (tm:time->date loc tm-utc tzi) ) ) )
     1468        ; then time is *right* before the leap, we need to pretend to subtract a second ...
     1469        (let ((dat (tm:time->date loc (tm:subtract-duration tm-utc ONE-SECOND-DURATION tm-utc) tzi)))
     1470          (%date-second-set! dat SEC/MIN) ; Note full minute!
     1471          dat )
     1472        (tm:time->date loc tm-utc tzi) ) ) )
    15111473
    15121474(define (time-tai->date tim . tzi)
     
    15251487  (%check-time 'time->date tim)
    15261488  (case (%time-type tim)
    1527     [(time-monotonic) (tm:time->date 'time->date tim tzi)]
    1528     [(time-utc)       (tm:time->date 'time->date tim tzi)]
    1529     [(time-tai)       (tm:time-tai->date 'time->date tim tzi)]
    1530     [else ; This shouldn't happen
    1531       (error 'time->date "invalid clock type" tim)]) )
     1489    ((time-monotonic) (tm:time->date 'time->date tim tzi))
     1490    ((time-utc)       (tm:time->date 'time->date tim tzi))
     1491    ((time-tai)       (tm:time-tai->date 'time->date tim tzi))
     1492    (else ; This shouldn't happen
     1493     (error 'time->date "invalid clock type" tim))) )
    15321494
    15331495;; Date to Time
     
    15361498
    15371499(define (tm:encode-julian-day-number dy mn yr)
    1538   (let* ([a (fx/ (fx- 14 mn) MN/YR)]
    1539          [b (fx- (fx+ yr 4800) a)]
    1540          [y (if (negative? yr) (fx+ b 1) b)] ; BCE?
    1541          [m (fx- (fx+ mn (fx* a MN/YR)) 3)])
     1500  (let* ((a (fx/ (fx- 14 mn) MN/YR))
     1501         (b (fx- (fx+ yr 4800) a))
     1502         (y (if (negative? yr) (fx+ b 1) b)) ; BCE?
     1503         (m (fx- (fx+ mn (fx* a MN/YR)) 3)))
    15421504    (+ dy
    15431505      (fx/ (fx+ (fx* 153 m) 2) 5)
     
    15491511
    15501512(define (tm:date->time-utc loc dat)
    1551   (let ([ns (%date-nanosecond dat)]
    1552         [sec (%date-second dat)]
    1553         [min (%date-minute dat)]
    1554         [hr (%date-hour dat)]
    1555         [dy (%date-day dat)]
    1556         [mn (%date-month dat)]
    1557         [yr (%date-year dat)]
    1558         [tzo (%date-zone-offset dat)])
    1559     (let ([jdys (- (tm:encode-julian-day-number dy mn yr) TAI-EPOCH-IN-JD)]
    1560           [secs (fx+ (fx+ (fx* hr SEC/HR) (fx+ (fx* min SEC/MIN) sec)) (fxneg tzo))])
     1513  (let ((ns (%date-nanosecond dat))
     1514        (sec (%date-second dat))
     1515        (min (%date-minute dat))
     1516        (hr (%date-hour dat))
     1517        (dy (%date-day dat))
     1518        (mn (%date-month dat))
     1519        (yr (%date-year dat))
     1520        (tzo (%date-zone-offset dat)))
     1521    (let ((jdys (- (tm:encode-julian-day-number dy mn yr) TAI-EPOCH-IN-JD))
     1522          (secs (fx+ (fx+ (fx* hr SEC/HR) (fx+ (fx* min SEC/MIN) sec)) (fxneg tzo))))
    15611523      (tm:make-time 'time-utc ns (+ (* (- jdys ONE-HALF) SEC/DY) secs)) ) ) )
    15621524
    15631525(define (tm:date->time-tai loc dat)
    1564   (let* ([tm-utc (tm:date->time-utc loc dat)]
    1565          [tm-tai (tm:time-utc->time-tai tm-utc tm-utc)])
     1526  (let* ((tm-utc (tm:date->time-utc loc dat))
     1527         (tm-tai (tm:time-utc->time-tai tm-utc tm-utc)))
    15661528    (if (fx= 60 (%date-second dat))
    1567       (tm:subtract-duration tm-tai ONE-SECOND-DURATION tm-tai)
    1568       tm-tai ) ) )
     1529        (tm:subtract-duration tm-tai ONE-SECOND-DURATION tm-tai)
     1530        tm-tai ) ) )
    15691531
    15701532(define (tm:date->time-monotonic loc dat)
    1571   (let ([tim-utc (tm:date->time-utc loc dat)])
     1533  (let ((tim-utc (tm:date->time-utc loc dat)))
    15721534    (tm:time-utc->time-monotonic tim-utc tim-utc) ) )
    15731535
     
    15871549  (%check-date 'date->time dat)
    15881550  (case (optional timtyp (default-date-clock-type))
    1589     [(time-monotonic) (tm:date->time-monotonic  'date->time dat)]
    1590     [(time-utc)       (tm:date->time-utc 'date->time dat)]
    1591     [(time-tai)       (tm:date->time-tai 'date->time dat)]
    1592     [else
    1593       (error 'date->time "invalid clock type" timtyp)]) )
     1551    ((time-monotonic) (tm:date->time-monotonic  'date->time dat))
     1552    ((time-utc)       (tm:date->time-utc 'date->time dat))
     1553    ((time-tai)       (tm:date->time-tai 'date->time dat))
     1554    (else
     1555     (error 'date->time "invalid clock type" timtyp))) )
    15941556
    15951557;; Leap Year
     
    16021564
    16031565(define (tm:year-day dy mn yr)
    1604   (let ([yrdy (fx+ dy (vector-ref tm:cumulative-month-days mn))])
    1605     (if (and (tm:leap-year? yr) (fx< 2 mn))
    1606       (fx+ yrdy 1)
    1607       yrdy ) ) )
     1566  (let ((yrdy (fx+ dy (vector-ref tm:cumulative-month-days mn))))
     1567    (if (and (tm:leap-year? yr) (fx< 2 mn)) (fx+ yrdy 1)
     1568        yrdy ) ) )
    16081569
    16091570(define (date-year-day dat)
    16101571  (%check-date 'date-year-day dat)
    16111572  (or (%date-yday dat)
    1612       (let ([yrdy (tm:year-day (%date-day dat) (%date-month dat) (%date-year dat))])
     1573      (let ((yrdy (tm:year-day (%date-day dat) (%date-month dat) (%date-year dat))))
    16131574        (%date-yday-set! dat yrdy)
    16141575        yrdy ) ) )
     
    16191580
    16201581(define (tm:week-day dy mn yr)
    1621   (let* ([a (fx/ (fx- 14 mn) MN/YR)]
    1622          [y (fx- yr a)]
    1623          [m (fx- (fx+ mn (fx* a MN/YR)) 2)])
     1582  (let* ((a (fx/ (fx- 14 mn) MN/YR))
     1583         (y (fx- yr a))
     1584         (m (fx- (fx+ mn (fx* a MN/YR)) 2)))
    16241585    (fxmod
    1625       (fx+ (fx+ dy y) (fx+ (fx- (fx/ y 4) (fx/ y 100)) (fx+ (fx/ y 400) (fx/ (fx* m DY/MN) MN/YR))))
    1626       DY/WK) ) )
     1586     (fx+ (fx+ dy y)
     1587          (fx+ (fx- (fx/ y 4) (fx/ y 100))
     1588               (fx+ (fx/ y 400)
     1589                    (fx/ (fx* m DY/MN) MN/YR))))
     1590     DY/WK) ) )
    16271591
    16281592(define (tm:days-before-first-week dat day-of-week-starting-week)
    16291593  (fxmod
    1630     (fx- day-of-week-starting-week (tm:week-day 1 1 (%date-year dat)))
    1631     DY/WK) )
     1594   (fx- day-of-week-starting-week (tm:week-day 1 1 (%date-year dat)))
     1595   DY/WK) )
    16321596
    16331597(define (date-week-day dat)
    16341598  (%check-date 'date-week-day dat)
    16351599  (or (%date-wday dat)
    1636       (let ([wdy (tm:week-day (%date-day dat) (%date-month dat) (%date-year dat))])
     1600      (let ((wdy (tm:week-day (%date-day dat) (%date-month dat) (%date-year dat))))
    16371601        (%date-wday-set! dat wdy)
    16381602        wdy ) ) )
     
    16401604(define (date-week-number dat . args)
    16411605  (%check-date 'date-week-number dat)
    1642   (let ([day-of-week-starting-week (optional args 0)])
     1606  (let ((day-of-week-starting-week (optional args 0)))
    16431607    (fx/
    1644       (fx- (date-year-day dat) (tm:days-before-first-week dat day-of-week-starting-week))
    1645       DY/WK) ) )
     1608     (fx- (date-year-day dat) (tm:days-before-first-week dat day-of-week-starting-week))
     1609     DY/WK) ) )
    16461610
    16471611;; Julian-day Operations
     
    16531617
    16541618(define (tm:julian-day ns sec min hr dy mn yr tzo)
    1655   (+
    1656     (- (tm:encode-julian-day-number dy mn yr) ONE-HALF)
    1657     (/
    1658       (+ (fx+ (fx+ (fx* hr SEC/HR) (fx+ (fx* min SEC/MIN) sec)) (fxneg tzo)) (/ ns NS/S))
    1659       SEC/DY)) )
     1619  (+ (- (tm:encode-julian-day-number dy mn yr) ONE-HALF)
     1620     (/ (+ (fx+ (fx+ (fx* hr SEC/HR)
     1621                     (fx+ (fx* min SEC/MIN) sec))
     1622                (fxneg tzo))
     1623           (/ ns NS/S))
     1624        SEC/DY)) )
    16601625
    16611626#; ; inexact version
    16621627(define (tm:julian-day ns sec min hr dy mn yr tzo)
    1663   (fp+
    1664     (fp- (exact->inexact (tm:encode-julian-day-number dy mn yr)) iONE-HALF)
    1665     (fp/
    1666       (fp+
    1667         (exact->inexact (fx+ (fx+ (fx* hr SEC/HR) (fx+ (fx* min SEC/MIN) sec)) (fxneg tzo)))
    1668         (fp/ (exact->inexact ns) iNS/S))
    1669       iSEC/DY)) )
     1628  (fp+ (fp- (exact->inexact (tm:encode-julian-day-number dy mn yr)) iONE-HALF)
     1629       (fp/ (fp+ (exact->inexact (fx+ (fx+ (fx* hr SEC/HR)
     1630                                           (fx+ (fx* min SEC/MIN) sec))
     1631                                      (fxneg tzo)))
     1632                 (fp/ (exact->inexact ns) iNS/S))
     1633            iSEC/DY)) )
    16701634
    16711635(define (tm:date->julian-day loc dat)
    16721636  (%check-date loc dat)
    16731637  (or (%date-jday dat)
    1674       (let ([jdn
    1675               (tm:julian-day
    1676                 (%date-nanosecond dat)
    1677                 (%date-second dat) (%date-minute dat) (%date-hour dat)
    1678                 (%date-day dat) (%date-month dat) (%date-year dat)
    1679                 (%date-zone-offset dat))])
     1638      (let ((jdn
     1639             (tm:julian-day
     1640              (%date-nanosecond dat)
     1641              (%date-second dat) (%date-minute dat) (%date-hour dat)
     1642              (%date-day dat) (%date-month dat) (%date-year dat)
     1643              (%date-zone-offset dat))))
    16801644        (%date-jday-set! dat jdn)
    16811645        jdn ) ) )
    16821646
    1683 (define (date->julian-day dat)
    1684   (tm:date->julian-day 'date->julian-day dat) )
     1647(define (date->julian-day dat) (tm:date->julian-day 'date->julian-day dat))
    16851648
    16861649(define (date->modified-julian-day dat)
     
    16891652;; Time to Julian-day
    16901653
    1691 (define (tm:seconds->julian-day ns sec)
    1692   (+ TAI-EPOCH-IN-JD (/ (+ sec (/ ns NS/S)) SEC/DY)) )
     1654(define (tm:seconds->julian-day ns sec) (+ TAI-EPOCH-IN-JD (/ (+ sec (/ ns NS/S)) SEC/DY)))
    16931655
    16941656(define-inline (%time-tai->julian-day tim)
    1695   (let ([sec (%time-second tim)])
     1657  (let ((sec (%time-second tim)))
    16961658    (tm:seconds->julian-day (%time-nanosecond tim) (- sec (tm:leap-second-delta sec))) ) )
    16971659
     
    16991661  (tm:seconds->julian-day (%time-nanosecond tim) (%time-second tim)) )
    17001662
    1701 (define (tm:time-tai->julian-day tim)
    1702   (%time-tai->julian-day tim) )
    1703 
    1704 (define (tm:time-monotonic->julian-day tim)
    1705   (%time-tai->julian-day tim) )
     1663(define (tm:time-tai->julian-day tim) (%time-tai->julian-day tim))
     1664
     1665(define (tm:time-monotonic->julian-day tim) (%time-tai->julian-day tim))
    17061666
    17071667(define (time-utc->julian-day tim)
     
    17201680  (%check-time 'time->julian-day tim)
    17211681  (case (%time-type tim)
    1722     [(time-monotonic) (tm:time-monotonic->julian-day tim)]
    1723     [(time-utc)       (tm:time-utc->julian-day tim)]
    1724     [(time-tai)       (tm:time-tai->julian-day tim)]
    1725     [else
    1726       (error 'time->julian-day "invalid clock type" tim)]) )
     1682    ((time-monotonic) (tm:time-monotonic->julian-day tim))
     1683    ((time-utc)       (tm:time-utc->julian-day tim))
     1684    ((time-tai)       (tm:time-tai->julian-day tim))
     1685    (else
     1686     (error 'time->julian-day "invalid clock type" tim))) )
    17271687
    17281688(define (tm:time-utc->modified-julian-day tim)
     
    17501710  (%check-time 'time->modified-julian-day tim)
    17511711  (case (%time-type tim)
    1752     [(time-monotonic) (tm:time-monotonic->modified-julian-day tim)]
    1753     [(time-utc)       (tm:time-utc->modified-julian-day tim)]
    1754     [(time-tai)       (tm:time-tai->modified-julian-day tim)]
    1755     [else
    1756       (error 'time->modified-julian-day "invalid clock type" tim)]) )
     1712    ((time-monotonic) (tm:time-monotonic->modified-julian-day tim))
     1713    ((time-utc)       (tm:time-utc->modified-julian-day tim))
     1714    ((time-tai)       (tm:time-tai->modified-julian-day tim))
     1715    (else
     1716     (error 'time->modified-julian-day "invalid clock type" tim))) )
    17571717
    17581718;; Julian-day to Time
    17591719
    17601720(define (julian-day->time-utc jdn)
    1761   (receive [ns sec] (tm:split-nanoseconds (* (- jdn TAI-EPOCH-IN-JD) SEC/DY NS/S))
     1721  (receive (ns sec) (tm:split-nanoseconds (* (- jdn TAI-EPOCH-IN-JD) SEC/DY NS/S))
    17621722    (tm:make-time 'time-utc ns sec) ) )
    17631723
  • release/3/srfi-19/trunk/srfi-19-io.scm

    r12073 r13899  
    5656      string->date) ) )
    5757
    58 (use srfi-1 srfi-13
    59      srfi-29 locale numbers
    60      srfi-19-core)
     58(use srfi-1 srfi-13 srfi-29 locale numbers srfi-19-core)
    6159
    6260;;;
     
    8987(load-best-available-bundle! (most-specific-bundle-specifier 'srfi-19))
    9088
    91 (define-inline (item@ key)
    92   (localized-template/default 'srfi-19 key) )
     89;; SRFI-29 Helper
     90
     91(define-inline (%item@ key) (localized-template/default 'srfi-19 key))
    9392
    9493;;; Date & Time Formatted I/O
     
    9796
    9897(define (tm:natural-year n)
    99   (let* ([current-year (date-year (current-date))]
    100          [current-century (fx* (fx/ current-year 100) 100)])
    101     (cond
    102       [(fx>= n 100)
    103         n]
    104       [(fx< n 0)
    105         n]
    106       [(fx<= (fx- (fx+ current-century n) current-year) 50)
    107         (fx+ current-century n)]
    108       [else
    109         (fx+ (fx- current-century 100) n)]) ) )
     98  (let* ((current-year (date-year (current-date)))
     99         (current-century (fx* (fx/ current-year 100) 100)))
     100    (cond ((fx>= n 100) n)
     101          ((fx< n 0) n)
     102          ((fx<= (fx- (fx+ current-century n) current-year) 50)
     103           (fx+ current-century n))
     104          (else
     105           (fx+ (fx- current-century 100) n))) ) )
    110106
    111107;; Return a string representing the decimal expansion of the fractional
     
    113109
    114110(define (tm:decimal-expansion r precision)
    115   (let loop ([num (- r (round r))]
    116              [p precision]
    117              [lst '()])
    118     (if (or (fx= 0 p) (zero? num))
    119       (apply string-append (reverse! lst))
    120       (let* ([num-times-10 (* 10 num)]
    121              [round-num-times-10 (round num-times-10)])
    122         (loop (- num-times-10 round-num-times-10)
    123               (fx- p 1)
    124               (cons (number->string (inexact->exact round-num-times-10))
    125                     lst)) ) ) ) )
     111  (let loop ((num (- r (round r)))
     112             (p precision)
     113             (lst '()))
     114    (if (or (fx= 0 p) (zero? num)) (apply string-append (reverse! lst))
     115        (let* ((num-times-10 (* 10 num))
     116               (round-num-times-10 (round num-times-10)))
     117          (loop (- num-times-10 round-num-times-10)
     118                (fx- p 1)
     119                (cons (number->string (inexact->exact round-num-times-10))
     120                      lst)) ) ) ) )
    126121
    127122;; Returns a string rep. of number N, of minimum LENGTH,
     
    130125;; if string is longer than LENGTH, it's as if number->string was used.
    131126
     127(define-inline (%trailing-dotzero? str len)
     128  (and (fx>= len 2)
     129       (char=? #\. (string-ref str (fx- len 2)))
     130       (char=? #\0 (string-ref str (fx- len 1))) ) )
     131
    132132(define (tm:padding n pad-with length)
    133   (let* ([str (number->string n)]
    134          [len (string-length str)])
    135     (let ((str (if (and (fx>= len 2)
    136                         (char=? #\. (string-ref str (fx- len 2)))
    137                         (char=? #\0 (string-ref str (fx- len 1))) )
    138                (substring str 0 (fx- len 2))
    139                str) ) )
    140       (if (or (not pad-with) (> len length))
    141         str
    142         (string-pad str length pad-with)) ) ) )
    143 
    144 (define (tm:last-n-digits i n)
    145   (abs (remainder i (expt 10 n))) )
    146 
    147 (define (tm:locale-abbr-weekday n)
    148   (item@ (vector-ref LOCALE-ABRV-WEEKDAYS n)) )
    149 
    150 (define (tm:locale-long-weekday n)
    151   (item@ (vector-ref LOCALE-LONG-WEEKDAYS n)) )
    152 
    153 (define (tm:locale-abbr-month n)
    154   (item@ (vector-ref LOCALE-ABRV-MONTHS n)) )
    155 
    156 (define (tm:locale-long-month n)
    157   (item@ (vector-ref LOCALE-LONG-MONTHS n)) )
     133  (let* ((str (number->string n))
     134         (len (string-length str)))
     135    (let ((str
     136           (if (not (%trailing-dotzero? str len)) str
     137               (substring str 0 (fx- len 2)) ) ) )
     138      (if (or (not pad-with) (fx> len length)) str
     139          (string-pad str length pad-with)) ) ) )
     140
     141(define (tm:last-n-digits i n) (abs (remainder i (expt 10 n))))
     142
     143(define (tm:locale-abbr-weekday n) (%item@ (vector-ref LOCALE-ABRV-WEEKDAYS n)))
     144
     145(define (tm:locale-long-weekday n) (%item@ (vector-ref LOCALE-LONG-WEEKDAYS n)))
     146
     147(define (tm:locale-abbr-month n) (%item@ (vector-ref LOCALE-ABRV-MONTHS n)))
     148
     149(define (tm:locale-long-month n) (%item@ (vector-ref LOCALE-LONG-MONTHS n)))
    158150
    159151(define (tm:locale-find-string str vec)
    160   (let loop ([idx (fx- (vector-length vec) 1)])
     152  (let loop ((idx (fx- (vector-length vec) 1)))
    161153    (and (fx< 0 idx)
    162          (or (and (string=? str (item@ (vector-ref vec idx)))
     154         (or (and (string=? str (%item@ (vector-ref vec idx)))
    163155                  idx)
    164156             (loop (fx- idx 1))) ) ) )
    165157
    166 (define (tm:locale-abbr-weekday->index str)
    167   (tm:locale-find-string str LOCALE-ABRV-WEEKDAYS) )
    168 
    169 (define (tm:locale-long-weekday->index str)
    170   (tm:locale-find-string str LOCALE-LONG-WEEKDAYS) )
    171 
    172 (define (tm:locale-abbr-month->index str)
    173   (tm:locale-find-string str LOCALE-ABRV-MONTHS) )
    174 
    175 (define (tm:locale-long-month->index str)
    176   (tm:locale-find-string str LOCALE-LONG-MONTHS) )
     158(define (tm:locale-abbr-weekday->index str) (tm:locale-find-string str LOCALE-ABRV-WEEKDAYS))
     159
     160(define (tm:locale-long-weekday->index str) (tm:locale-find-string str LOCALE-LONG-WEEKDAYS))
     161
     162(define (tm:locale-abbr-month->index str) (tm:locale-find-string str LOCALE-ABRV-MONTHS))
     163
     164(define (tm:locale-long-month->index str) (tm:locale-find-string str LOCALE-LONG-MONTHS))
    177165
    178166;; There is no unique way to map a timezone offset to a political timezone!
     
    184172;; Again, locale specific.
    185173
    186 (define (tm:locale-am/pm hr)
    187   (item@ (if (fx> hr 11) LOCALE-PM LOCALE-AM)) )
     174(define (tm:locale-am/pm hr) (%item@ (if (fx> hr 11) LOCALE-PM LOCALE-AM)))
    188175
    189176(define (tm:tz-printer offset port)
    190   (if (= offset 0)
    191     (display "Z" port)
    192     (let ((isneg (fx< offset 0)))
    193       (display (if isneg #\- #\+) port)
    194       (let ([offset (if isneg (fxneg offset) offset)])
    195         (display (tm:padding (quotient offset SEC/HR) #\0 2) port)
    196         (display (tm:padding (quotient (remainder offset SEC/HR) SEC/MIN) #\0 2) port) ) ) ) )
     177  (if (= offset 0) (display "Z" port)
     178      (let ((isneg (fx< offset 0)))
     179        (display (if isneg #\- #\+) port)
     180        (let ((offset (if isneg (fxneg offset) offset)))
     181          (display (tm:padding (quotient offset SEC/HR) #\0 2) port)
     182          (display (tm:padding (quotient (remainder offset SEC/HR) SEC/MIN) #\0 2) port) ) ) ) )
    197183
    198184;; A table of output formatting directives.
     
    225211    (cons #\c
    226212      (lambda (date pad-with port)
    227         (display (date->string date (item@ LOCALE-DATE-TIME-FORMAT)) port)))
     213        (display (date->string date (%item@ LOCALE-DATE-TIME-FORMAT)) port)))
    228214
    229215    (cons #\d
     
    241227    (cons #\f
    242228      (lambda (date pad-with port)
    243         (let ([ns (date-nanosecond date)] [sec (date-second date)])
     229        (let ((ns (date-nanosecond date)) (sec (date-second date)))
    244230          (if (> ns NS/S) ; This shouldn't happen!
    245             (display (tm:padding (+ sec 1) pad-with 2) port)
    246             (display (tm:padding sec pad-with 2) port))
    247           (let ([f (tm:decimal-expansion (/ ns NS/S) 6)])
     231              (display (tm:padding (+ sec 1) pad-with 2) port)
     232              (display (tm:padding sec pad-with 2) port))
     233          (let ((f (tm:decimal-expansion (/ ns NS/S) 6)))
    248234            (when (fx> (string-length f) 0)
    249               (display (item@ LOCALE-NUMBER-SEPARATOR) port)
     235              (display (%item@ LOCALE-NUMBER-SEPARATOR) port)
    250236              (display f port))))))
    251237
     
    260246    (cons #\I
    261247      (lambda (date pad-with port)
    262         (let ([hr (date-hour date)])
     248        (let ((hr (date-hour date)))
    263249          (if (fx> hr 12)
    264             (display (tm:padding (fx- hr 12) pad-with 2) port)
    265             (display (tm:padding hr pad-with 2) port)))))
     250              (display (tm:padding (fx- hr 12) pad-with 2) port)
     251              (display (tm:padding hr pad-with 2) port)))))
    266252
    267253    (cons #\j
     
    275261    (cons #\l
    276262      (lambda (date pad-with port)
    277         (let ([hr (date-hour date)])
     263        (let ((hr (date-hour date)))
    278264          (display (tm:padding (if (fx> hr 12) (fx- hr 12) hr) #\space 2) port))))
    279265
     
    308294    (cons #\S
    309295      (lambda (date pad-with port)
    310         (let ([sec (date-second date)])
     296        (let ((sec (date-second date)))
    311297          (if (> (date-nanosecond date) NS/S) ; This shouldn't happen!
    312             (display (tm:padding (+ sec 1) pad-with 2) port)
    313             (display (tm:padding sec pad-with 2) port)))))
     298              (display (tm:padding (+ sec 1) pad-with 2) port)
     299              (display (tm:padding sec pad-with 2) port)))))
    314300
    315301    (cons #\t
     
    323309    (cons #\U
    324310      (lambda (date pad-with port)
    325         (let ([wkno (date-week-number date 0)])
     311        (let ((wkno (date-week-number date 0)))
    326312          (if (fx> (tm:days-before-first-week date 0) 0)
    327             (display (tm:padding (fx+ wkno 1) #\0 2) port)
    328             (display (tm:padding wkno #\0 2) port)))))
     313              (display (tm:padding (fx+ wkno 1) #\0 2) port)
     314              (display (tm:padding wkno #\0 2) port)))))
    329315
    330316    (cons #\V
     
    338324    (cons #\W
    339325      (lambda (date pad-with port)
    340         (let ([wkno (date-week-number date 1)])
     326        (let ((wkno (date-week-number date 1)))
    341327          (if (fx> (tm:days-before-first-week date 1) 0)
    342             (display (tm:padding (fx+ wkno 1) #\0 2) port)
    343             (display (tm:padding wkno #\0 2) port)))))
     328              (display (tm:padding (fx+ wkno 1) #\0 2) port)
     329              (display (tm:padding wkno #\0 2) port)))))
    344330
    345331    (cons #\x
    346332      (lambda (date pad-with port)
    347         (display (date->string date (item@ LOCALE-SHORT-DATE-FORMAT)) port)))
     333        (display (date->string date (%item@ LOCALE-SHORT-DATE-FORMAT)) port)))
    348334
    349335    (cons #\X
    350336      (lambda (date pad-with port)
    351         (display (date->string date (item@ LOCALE-TIME-FORMAT)) port)))
     337        (display (date->string date (%item@ LOCALE-TIME-FORMAT)) port)))
    352338
    353339    (cons #\y
     
    390376(define (tm:date-printer loc date format-rem len-rem port)
    391377  (when (fx< 0 len-rem)
    392     (let ([current-char
    393             (car format-rem)]
    394           [get-formatter
    395             (lambda (char)
    396               (and-let* ([associated (assoc char tm:display-directives)])
    397                 (cdr associated)))])
    398       (cond
    399         [(not (char=? current-char #\~))
    400           (display current-char port)
    401           (tm:date-printer loc date (cdr format-rem) (fx- len-rem 1) port)]
    402         [(fx< len-rem 2)
    403           (error loc "bad date format" (list->string format-rem))]
    404         [else
    405           (let ([pad-ch (cadr format-rem)])
    406             (cond
    407               [(char=? pad-ch #\-)
    408                 (if (fx< len-rem 3)
    409                   (error loc "bad date format" (list->string format-rem))
    410                   (let ([formatter (get-formatter (caddr format-rem))])
    411                     (if (not formatter)
    412                       (error loc "bad date format" (list->string format-rem))
    413                       (begin
    414                         (formatter date #f port)
    415                         (tm:date-printer loc date (cdddr format-rem)
    416                                          (fx- len-rem 3) port)))))]
    417               [(char=? pad-ch #\_)
    418                 (if (fx< len-rem 3)
    419                   (error loc "bad date format" (list->string format-rem))
    420                   (let ([formatter (get-formatter (caddr format-rem))])
    421                     (if (not formatter)
    422                       (error loc "bad date format" (list->string format-rem))
    423                       (begin
    424                         (formatter date #\space port)
    425                         (tm:date-printer loc date (cdddr format-rem)
    426                                          (fx- len-rem 3) port)))))]
    427               [else
    428                 (let ([formatter (get-formatter pad-ch)])
    429                   (if (not formatter)
    430                     (error loc "bad date format" (list->string format-rem))
    431                     (begin
    432                       (formatter date #\0 port)
    433                       (tm:date-printer loc date (cddr format-rem)
    434                                        (fx- len-rem 2) port))))]))]) )) )
     378    (let ((current-char (car format-rem))
     379          (get-formatter
     380           (lambda (char)
     381             (and-let* ((associated (assoc char tm:display-directives)))
     382               (cdr associated)))))
     383      (cond ((not (char=? current-char #\~))
     384             (display current-char port)
     385             (tm:date-printer loc date (cdr format-rem) (fx- len-rem 1) port))
     386            ((fx< len-rem 2)
     387             (error loc "bad date format" (list->string format-rem)))
     388            (else
     389             (let ((pad-ch (cadr format-rem)))
     390               (cond ((char=? pad-ch #\-)
     391                      (if (fx< len-rem 3)
     392                          (error loc "bad date format" (list->string format-rem))
     393                          (let ((formatter (get-formatter (caddr format-rem))))
     394                            (if (not formatter)
     395                                (error loc "bad date format" (list->string format-rem))
     396                                (begin
     397                                  (formatter date #f port)
     398                                  (tm:date-printer loc date (cdddr format-rem)
     399                                                   (fx- len-rem 3) port))))))
     400                      ((char=? pad-ch #\_)
     401                       (if (fx< len-rem 3)
     402                           (error loc "bad date format" (list->string format-rem))
     403                           (let ((formatter (get-formatter (caddr format-rem))))
     404                             (if (not formatter)
     405                                 (error loc "bad date format" (list->string format-rem))
     406                                 (begin
     407                                   (formatter date #\space port)
     408                                   (tm:date-printer loc date (cdddr format-rem)
     409                                                     (fx- len-rem 3) port))))))
     410                      (else
     411                       (let ((formatter (get-formatter pad-ch)))
     412                         (if (not formatter)
     413                             (error loc "bad date format" (list->string format-rem))
     414                             (begin
     415                               (formatter date #\0 port)
     416                               (tm:date-printer loc date (cddr format-rem)
     417                                                (fx- len-rem 2) port))))))))) )) )
    435418
    436419(define (format-date dest fmt-str . r)
    437   (let ([port #f] [date (optional r #f)])
    438     (cond
    439       [(not dest)
    440         (set! port (open-output-string))]
    441       [(string? dest)
    442         (set! date fmt-str)
    443         (set! fmt-str dest)
    444         (set! port (open-output-string))]
    445       [(number? dest)
    446         (set! port (current-error-port))]
    447       [(port? dest)
    448         (set! port dest)]
    449       [else
    450         (set! port (current-output-port))])
     420  (let ((port #f) (date (optional r #f)))
     421    (cond ((not dest) (set! port (open-output-string)))
     422          ((string? dest)
     423            (set! date fmt-str)
     424            (set! fmt-str dest)
     425            (set! port (open-output-string)))
     426          ((number? dest) (set! port (current-error-port)))
     427          ((port? dest) (set! port dest))
     428          (else
     429            (set! port (current-output-port))))
    451430    (tm:date-printer 'display-date date (string->list fmt-str) (string-length fmt-str) port)
    452431    (or dest
     
    459438;;; Input
    460439
    461 (define (tm:char->int ch)
    462   (switch ch
    463     [#\0 0]
    464     [#\1 1]
    465     [#\2 2]
    466     [#\3 3]
    467     [#\4 4]
    468     [#\5 5]
    469     [#\6 6]
    470     [#\7 7]
    471     [#\8 8]
    472     [#\9 9]
    473     [else (error 'date-read "bad date template: non-integer character" ch)]) )
     440(define (tm:digit->int ch)
     441  (case ch
     442    ((#\0) 0)
     443    ((#\1) 1)
     444    ((#\2) 2)
     445    ((#\3) 3)
     446    ((#\4) 4)
     447    ((#\5) 5)
     448    ((#\6) 6)
     449    ((#\7) 7)
     450    ((#\8) 8)
     451    ((#\9) 9)
     452    (else
     453     (error 'date-read "bad date template: not a decimal digit" ch))) )
    474454
    475455;; read an integer upto n characters long on port;
     
    477457
    478458(define (tm:integer-reader upto port)
    479   (let loop ([accum 0] [nchars 0])
    480     (let ([ch (peek-char port)])
     459  (let loop ((accum 0) (nchars 0))
     460    (let ((ch (peek-char port)))
    481461      (if (or (eof-object? ch)
    482462              (not (char-numeric? ch))
    483463              (and upto (fx>= nchars upto)))
    484         accum
    485         (loop (fx+ (fx* accum 10) (tm:char->int (read-char port))) (fx+ nchars 1))) ) ) )
     464          accum
     465          (loop (fx+ (fx* accum 10) (tm:digit->int (read-char port))) (fx+ nchars 1))) ) ) )
    486466
    487467(define (tm:make-integer-reader upto)
    488468  (lambda (port)
    489     (tm:integer-reader upto port)) )
     469    (tm:integer-reader upto port) ) )
    490470
    491471;; read *exactly* n characters and convert to integer; could be padded
    492472
    493473(define (tm:integer-reader-exact n port)
    494   (let ([padding-ok #t])
    495     (let loop ([accum 0] [nchars 0])
    496       (let ([ch (peek-char port)])
    497         (cond
    498           [(fx>= nchars n)
    499             accum]
    500           [(eof-object? ch)
    501             (error 'string->date "bad date template: premature ending to integer read")]
    502           [(char-numeric? ch)
    503             (set! padding-ok #f)
    504             (loop (fx+ (fx* accum 10) (tm:char->int (read-char port))) (fx+ nchars 1))]
    505           [padding-ok
    506             (read-char port)    ; consume padding
    507             (loop accum (fx+ nchars 1))]
    508           [else                 ; padding where it shouldn't be
    509             (error 'string->date "bad date template: non-numeric characters in integer read")]) ) ) ) )
     474  (let ((padding-ok #t))
     475    (let loop ((accum 0) (nchars 0))
     476      (let ((ch (peek-char port)))
     477        (cond ((fx>= nchars n)
     478               accum)
     479              ((eof-object? ch)
     480               (error 'string->date "bad date template: premature ending to integer read"))
     481              ((char-numeric? ch)
     482               (set! padding-ok #f)
     483               (loop (fx+ (fx* accum 10) (tm:digit->int (read-char port))) (fx+ nchars 1)))
     484              (padding-ok
     485               (read-char port)    ; consume padding
     486               (loop accum (fx+ nchars 1)))
     487              (else                 ; padding where it shouldn't be
     488               (error 'string->date "bad date template: non-numeric characters in integer read"))) ) ) ) )
    510489
    511490(define (tm:make-integer-exact-reader n)
     
    514493
    515494(define (tm:zone-reader port)
    516   (let ([offset 0] [is-pos #t])
    517     (let ([ch (read-char port)])
    518       (when (eof-object? ch)
    519         (error 'string->date "bad date template: invalid time zone +/-"))
    520       (if (or (char=? ch #\Z) (char=? ch #\z))
    521         0
     495  (let ((offset 0)
     496        (is-pos #t)
     497        (ch (read-char port)) )
     498    (when (eof-object? ch)
     499      (error 'string->date "bad date template: invalid time zone +/-"))
     500    (if (or (char=? ch #\Z) (char=? ch #\z)) 0
    522501        (begin
    523           (cond
    524             [(char=? ch #\+) (set! is-pos #t)]
    525             [(char=? ch #\-) (set! is-pos #f)]
    526             [else
    527               (error 'string->date "bad date template: invalid time zone +/-" ch)])
    528           (let ([ch (read-char port)])
     502          (cond ((char=? ch #\+) (set! is-pos #t))
     503                ((char=? ch #\-) (set! is-pos #f))
     504                (else
     505                 (error 'string->date "bad date template: invalid time zone +/-" ch)))
     506          (let ((ch (read-char port)))
    529507            (when (eof-object? ch)
    530508              (error 'string->date "bad date template: invalid time zone number"))
    531             (set! offset (fx* (tm:char->int ch) (fx* 10 SEC/HR))))
     509            (set! offset (fx* (tm:digit->int ch) (fx* 10 SEC/HR))))
    532510          ;; non-existing values are considered zero
    533           (let ([ch (read-char port)])
     511          (let ((ch (read-char port)))
    534512            (unless (eof-object? ch)
    535               (set! offset (fx+ offset (fx* (tm:char->int ch) SEC/HR)))))
    536           (let ([ch (read-char port)])
     513              (set! offset (fx+ offset (fx* (tm:digit->int ch) SEC/HR)))))
     514          (let ((ch (read-char port)))
    537515            (unless (eof-object? ch)
    538               (set! offset (fx+ offset (fx* (tm:char->int ch) 600)))))
    539           (let ([ch (read-char port)])
     516              (set! offset (fx+ offset (fx* (tm:digit->int ch) 600)))))
     517          (let ((ch (read-char port)))
    540518            (unless (eof-object? ch)
    541               (set! offset (fx+ offset (fx* (tm:char->int ch) 60)))))
    542           (if is-pos offset (fxneg offset)))) ) ) )
     519              (set! offset (fx+ offset (fx* (tm:digit->int ch) 60)))))
     520          (if is-pos offset (fxneg offset)))) ) )
    543521
    544522;; Looking at a char, read the char string, run thru indexer, return index
     
    546524(define (tm:locale-reader port indexer)
    547525  (letrec (
    548     [read-char-string
     526    (read-char-string
    549527      (lambda ()
    550         (let ([ch (peek-char port)])
     528        (let ((ch (peek-char port)))
    551529          (when (char-alphabetic? ch)
    552530            (write-char (read-char port))
    553             (read-char-string)) ) )])
    554     (let* ([str (with-output-to-string read-char-string)]
    555            [index (indexer str)])
     531            (read-char-string)) ) )))
     532    (let* ((str (with-output-to-string read-char-string))
     533           (index (indexer str)))
    556534      (unless index
    557535        (error 'string->date "bad date template: invalid string for indexer" str))
     
    564542(define (tm:make-char-id-reader char)
    565543  (lambda (port)
    566     (if (char=? char (read-char port))
    567       char
    568       (error 'string->date "bad date template: invalid character match"))) )
     544    (if (char=? char (read-char port)) char
     545        (error 'string->date "bad date template: invalid character match"))) )
    569546
    570547;; A List of formatted read directives.
     
    581558
    582559(define tm:read-directives
    583   (let ([ireader4 (tm:make-integer-reader 4)]
    584         [ireader2 (tm:make-integer-reader 2)]
    585         [ireader7 (tm:make-integer-reader 7)]
    586         [ireaderf (tm:make-integer-reader #f)]
    587         [eireader2 (tm:make-integer-exact-reader 2)]
    588         [eireader4 (tm:make-integer-exact-reader 4)]
    589         [locale-reader-abbr-weekday (tm:make-locale-reader tm:locale-abbr-weekday->index)]
    590         [locale-reader-long-weekday (tm:make-locale-reader tm:locale-long-weekday->index)]
    591         [locale-reader-abbr-month   (tm:make-locale-reader tm:locale-abbr-month->index)]
    592         [locale-reader-long-month   (tm:make-locale-reader tm:locale-long-month->index)]
    593         [char-fail (lambda (ch) #t)]
    594         [do-nothing noop #;(lambda (val object) (void))])
     560  (let ((ireader4 (tm:make-integer-reader 4))
     561        (ireader2 (tm:make-integer-reader 2))
     562        (ireader7 (tm:make-integer-reader 7))
     563        (ireaderf (tm:make-integer-reader #f))
     564        (eireader2 (tm:make-integer-exact-reader 2))
     565        (eireader4 (tm:make-integer-exact-reader 4))
     566        (locale-reader-abbr-weekday (tm:make-locale-reader tm:locale-abbr-weekday->index))
     567        (locale-reader-long-weekday (tm:make-locale-reader tm:locale-long-weekday->index))
     568        (locale-reader-abbr-month   (tm:make-locale-reader tm:locale-abbr-month->index))
     569        (locale-reader-long-month   (tm:make-locale-reader tm:locale-long-month->index))
     570        (char-fail (lambda (ch) #t))
     571        (do-nothing noop #;(lambda (val object) (void))))
    595572
    596573    (list
     
    652629
    653630(define (tm:date-reader date format-rem len-rem port)
    654   (let loop ([format-rem format-rem] [len-rem len-rem])
    655     (let ([skip-until
    656             (lambda (skipper)
    657               (let loop ([ch (peek-char port)])
    658                 (if (eof-object? ch)
    659                   (error 'scan-date "bad date template" (list->string format-rem))
    660                   (unless (skipper ch)
    661                     (read-char port)
    662                     (loop (peek-char port))))))])
     631  (let loop ((format-rem format-rem) (len-rem len-rem))
     632    (let ((skip-until
     633           (lambda (skipper)
     634             (let loop ((ch (peek-char port)))
     635               (if (eof-object? ch)
     636                   (error 'scan-date "bad date template" (list->string format-rem))
     637                   (unless (skipper ch)
     638                     (read-char port)
     639                     (loop (peek-char port))))))))
    663640      (when (fx< 0 len-rem)
    664         (let ([current-char (car format-rem)])
    665           (cond
    666             [(not (char=? current-char #\~))
    667               (let ([port-char (read-char port)])
    668                 (when (or (eof-object? port-char)
    669                           (not (char=? current-char port-char)))
    670                   (error 'scan-date "bad date template" (list->string format-rem))))
    671               (loop (cdr format-rem) (fx- len-rem 1))]
    672               ;; otherwise, it's an escape, we hope
    673             [(fx< len-rem 2)
    674               (error 'scan-date "bad date template" (list->string format-rem))]
    675             [else
    676               (let* ([format-char (cadr format-rem)]
    677                      [format-info (assoc format-char tm:read-directives)])
    678                 (unless format-info
    679                   (error 'scan-date "bad date template" (list->string format-rem)))
    680                 (let ([skipper (cadr format-info)]
    681                       [reader (caddr format-info)]
    682                       [actor (cadddr format-info)])
    683                   (skip-until skipper)
    684                   (let ([val (reader port)])
    685                     (if (eof-object? val)
    686                       (error 'scan-date "bad date template" (list->string format-rem))
    687                       (actor val date))))
    688                 (loop (cddr format-rem) (fx- len-rem 2)))]) ) ) ) ) )
     641        (let ((current-char (car format-rem)))
     642          (cond ((not (char=? current-char #\~))
     643                 (let ((port-char (read-char port)))
     644                   (when (or (eof-object? port-char)
     645                             (not (char=? current-char port-char)))
     646                     (error 'scan-date "bad date template" (list->string format-rem))))
     647                 (loop (cdr format-rem) (fx- len-rem 1)))
     648                ;; otherwise, it's an escape, we hope
     649                ((fx< len-rem 2)
     650                 (error 'scan-date "bad date template" (list->string format-rem)))
     651                (else
     652                 (let* ((format-char (cadr format-rem))
     653                        (format-info (assoc format-char tm:read-directives)))
     654                   (unless format-info
     655                     (error 'scan-date "bad date template" (list->string format-rem)))
     656                   (let ((skipper (cadr format-info))
     657                         (reader (caddr format-info))
     658                         (actor (cadddr format-info)))
     659                     (skip-until skipper)
     660                     (let ((val (reader port)))
     661                       (if (eof-object? val)
     662                         (error 'scan-date "bad date template" (list->string format-rem))
     663                         (actor val date))))
     664                   (loop (cddr format-rem) (fx- len-rem 2))))) ) ) ) ) )
    689665
    690666(define (scan-date src template-string)
    691   (let ([port #f]
    692         [newdate (tm:make-incomplete-date)])
    693     (let ([date-compl?
    694             (lambda ()
    695               (and (date-nanosecond newdate)
    696                    (date-second newdate) (date-minute newdate) (date-hour newdate)
    697                    (date-day newdate) (date-month newdate) (date-year newdate)
    698                    (date-zone-offset newdate)))]
    699           [date-ok
    700             (lambda ()
    701               (tm:check-exploded-date
    702                 'scan-date
    703                 (date-nanosecond newdate)
    704                 (date-second newdate) (date-minute newdate) (date-hour newdate)
    705                 (date-day newdate) (date-month newdate) (date-year newdate)
    706                 (date-zone-offset newdate)
    707                 (date-zone-name newdate)))])
    708       (cond
    709         [(string? src)  (set! port (open-input-string src))]
    710         [(port? src)    (set! port src)]
    711         [src            (set! port (current-input-port))])
     667  (let ((port #f)
     668        (newdate (tm:make-incomplete-date)))
     669    (let ((date-compl?
     670           (lambda ()
     671             (and (date-nanosecond newdate)
     672                  (date-second newdate) (date-minute newdate) (date-hour newdate)
     673                  (date-day newdate) (date-month newdate) (date-year newdate)
     674                  (date-zone-offset newdate))))
     675          (date-ok
     676           (lambda ()
     677             (tm:check-exploded-date
     678               'scan-date
     679               (date-nanosecond newdate)
     680               (date-second newdate) (date-minute newdate) (date-hour newdate)
     681               (date-day newdate) (date-month newdate) (date-year newdate)
     682               (date-zone-offset newdate)
     683               (date-zone-name newdate)))))
     684      (cond ((string? src)  (set! port (open-input-string src)))
     685            ((port? src)    (set! port src))
     686            (src            (set! port (current-input-port))))
    712687      (tm:date-reader newdate (string->list template-string) (string-length template-string) port)
    713688      (unless (date-compl?)
     
    717692
    718693(define (string->date src . template-string)
    719   (scan-date src (optional template-string (item@ LOCALE-DATE-TIME-FORMAT))) )
     694  (scan-date src (optional template-string (%item@ LOCALE-DATE-TIME-FORMAT))) )
  • release/3/srfi-19/trunk/srfi-19-period.scm

    r12073 r13899  
    5151      time-period-succeeding) ) )
    5252
    53 (use srfi-8
    54     srfi-19-core
    55     misc-extn-record)
     53(use srfi-8 srfi-19-core misc-extn-record)
    5654
    5755;;;
     
    7977  (%check-time-period loc obj2) )
    8078
    81 (define (tm:time-period-type per)
    82    (tm:time-type (%time-period-begin per)) )
    83 
    84 (define (tm:time-period-null? per)
    85   (tm:time<=? (%time-period-end per) (%time-period-begin per)) )
     79(define (tm:time-period-type per) (tm:time-type (%time-period-begin per)))
     80
     81(define (tm:time-period-null? per) (tm:time<=? (%time-period-end per) (%time-period-begin per)))
    8682
    8783(define (tm:as-empty-time-period per)
    8884  (%make-time-period
    89     (tm:as-empty-time (%time-period-begin per))
    90     (tm:as-empty-time (%time-period-end per))) )
     85   (tm:as-empty-time (%time-period-begin per))
     86   (tm:as-empty-time (%time-period-end per))) )
    9187
    9288(define (tm:ensure-compatible-time loc t1 t2)
    93   (let ([tt1 (tm:time-type t1)]
    94         [tt2 (tm:time-type t2)]
    95         [errtt (lambda () (error loc "incompatible clock-types" t1 t2))])
    96     (if (eq? tt1 tt2)
    97       t2
    98       (let ([ntime (tm:as-empty-time t1)])
    99         (case tt1
    100           [(time-tai)
    101             (case tt2
    102               [(time-utc)       (tm:time-utc->time-tai t2 ntime)]
    103               [(time-monotonic) (tm:time-monotonic->time-tai t2 ntime)]
    104               [else
    105                 (errtt)])]
    106           [(time-utc)
    107             (case tt2
    108               [(time-tai)       (tm:time-tai->time-utc t2 ntime)]
    109               [(time-monotonic) (tm:time-monotonic->time-utc t2 ntime)]
    110               [else
    111                 (errtt)])]
    112           [(time-monotonic)
    113             (case tt2
    114               [(time-utc) (tm:time-utc->time-monotonic t2 ntime)]
    115               [(time-tai) (tm:time-tai->time-monotonic t2 ntime)]
    116               [else
    117                 (errtt)])]
    118           [else
    119             (errtt)]))) ) )
     89  (let ((tt1 (tm:time-type t1))
     90        (tt2 (tm:time-type t2))
     91        (errtt (lambda () (error loc "incompatible clock-types" t1 t2))))
     92    (if (eq? tt1 tt2) t2
     93        (let ((ntime (tm:as-empty-time t1)))
     94          (case tt1
     95            ((time-tai)
     96              (case tt2
     97                ((time-utc)       (tm:time-utc->time-tai t2 ntime))
     98                ((time-monotonic) (tm:time-monotonic->time-tai t2 ntime))
     99                (else
     100                 (errtt))))
     101            ((time-utc)
     102              (case tt2
     103                ((time-tai)       (tm:time-tai->time-utc t2 ntime))
     104                ((time-monotonic) (tm:time-monotonic->time-utc t2 ntime))
     105                (else
     106                 (errtt))))
     107            ((time-monotonic)
     108              (case tt2
     109                ((time-utc) (tm:time-utc->time-monotonic t2 ntime))
     110                ((time-tai) (tm:time-tai->time-monotonic t2 ntime))
     111                (else
     112                 (errtt))))
     113            (else
     114             (errtt))))) ) )
    120115
    121116(define (tm:ensure-compatible-date tim dat loc)
    122117  (case (tm:time-type tim)
    123     [(time-utc)       (date->time-utc dat)]
    124     [(time-tai)       (date->time-tai dat)]
    125     [(time-monotonic) (date->time-monotonic dat)]
    126     [else
    127       (error loc "incompatible clock type" tim)]) )
     118    ((time-utc)       (date->time-utc dat))
     119    ((time-tai)       (date->time-tai dat))
     120    ((time-monotonic) (date->time-monotonic dat))
     121    (else
     122     (error loc "incompatible clock type" tim))) )
    128123
    129124#;
     
    133128
    134129(define (tm:time-period=? per1 per2)
    135   (and
    136     (tm:time=? (%time-period-begin per1) (%time-period-begin per2))
    137     (tm:time=? (%time-period-end per1) (%time-period-end per2))) )
     130  (and (tm:time=? (%time-period-begin per1) (%time-period-begin per2))
     131       (tm:time=? (%time-period-end per1) (%time-period-end per2))) )
    138132
    139133(define (tm:time-points-within? b1 e1 b2 e2)
     
    142136
    143137(define (tm:time-period-contains/period? loc per1 per2)
    144   (and
    145     (not (tm:time-period-null? per1))
    146     (let ([tper
    147             (if (eq? (tm:time-period-type per1) (tm:time-period-type per2))
    148               per2
    149               (%make-time-period
    150                 (tm:ensure-compatible-time loc (%time-period-begin per1) (%time-period-begin per2))
    151                 (tm:ensure-compatible-time loc (%time-period-end per1) (%time-period-end per2))))])
    152       (tm:time-points-within?
    153         (%time-period-begin per1) (%time-period-end per1)
    154         (%time-period-begin tper) (%time-period-end tper)) ) ) )
     138  (and (not (tm:time-period-null? per1))
     139       (let ((tper
     140              (if (eq? (tm:time-period-type per1) (tm:time-period-type per2)) per2
     141                  (%make-time-period
     142                   (tm:ensure-compatible-time loc (%time-period-begin per1) (%time-period-begin per2))
     143                   (tm:ensure-compatible-time loc (%time-period-end per1) (%time-period-end per2))))))
     144         (tm:time-points-within?
     145          (%time-period-begin per1) (%time-period-end per1)
     146          (%time-period-begin tper) (%time-period-end tper)) ) ) )
    155147
    156148(define (tm:time-period-contains/time? loc per tim)
    157   (and
    158     (not (tm:time-period-null? per))
    159     (let ([tpt (tm:ensure-compatible-time loc (%time-period-begin per) tim)])
    160       (tm:time-points-within? (%time-period-begin per) (%time-period-end per) tpt tpt) ) ) )
     149  (and (not (tm:time-period-null? per))
     150       (let ((tpt (tm:ensure-compatible-time loc (%time-period-begin per) tim)))
     151         (tm:time-points-within? (%time-period-begin per) (%time-period-end per) tpt tpt) ) ) )
    161152
    162153(define (tm:time-period-contains/date? loc per dat)
     
    171162
    172163(define (tm:time-period-intersection-values per1 per2 loc)
    173   (and
    174     (not (or (tm:time-period-null? per1) (tm:time-period-null? per2)))
    175     (let ([b1 (%time-period-begin per1)]
    176           [e1 (%time-period-end per1)])
    177       (let ([b2 (tm:ensure-compatible-time loc b1 (%time-period-begin per2))]
    178             [e2 (tm:ensure-compatible-time loc e1 (%time-period-end per2))])
    179         (tm:time-point-intersection b1 e1 b2 e2) ) ) ) )
     164  (and (not (or (tm:time-period-null? per1) (tm:time-period-null? per2)))
     165       (let ((b1 (%time-period-begin per1))
     166             (e1 (%time-period-end per1)))
     167         (let ((b2 (tm:ensure-compatible-time loc b1 (%time-period-begin per2)))
     168               (e2 (tm:ensure-compatible-time loc e1 (%time-period-end per2))))
     169           (tm:time-point-intersection b1 e1 b2 e2) ) ) ) )
    180170
    181171(define (tm:time-period-shift per-in dur per-out)
     
    197187
    198188(define (make-null-time-period . args)
    199   (let-optionals args ([timtyp (default-date-clock-type)])
     189  (let-optionals args ((timtyp (default-date-clock-type)))
    200190    (tm:as-empty-time-period (tm:make-empty-time timtyp)) ) )
    201191
    202192(define (make-time-period beg end . args)
    203   (let-optionals args ([timtyp (default-date-clock-type)])
    204     (cond
    205       [(number? beg)
    206         (set! beg (seconds->time/type beg timtyp))]
    207       [(date? beg)
    208         (set! beg (date->time beg timtyp))])
     193  (let-optionals args ((timtyp (default-date-clock-type)))
     194    (cond ((number? beg)
     195           (set! beg (seconds->time/type beg timtyp)) )
     196          ((date? beg)
     197           (set! beg (date->time beg timtyp)) ) )
    209198    (tm:check-time 'make-time-period beg)
    210199    (when (eq? 'time-duration (tm:time-type beg))
    211200      (error 'make-time-period "invalid time" beg))
    212     (cond
    213       [(number? end)
    214         (set! end (seconds->time/type end 'time-duration))]
    215       [(date? end)
    216         (set! end (tm:ensure-compatible-date 'make-time-period beg end))])
     201    (cond ((number? end)
     202           (set! end (seconds->time/type end 'time-duration)) )
     203          ((date? end)
     204           (set! end (tm:ensure-compatible-date 'make-time-period beg end)) ) )
    217205    (tm:check-time 'make-time-period end)
    218206    (when (eq? 'time-duration (tm:time-type end))
     
    264252(define (time-period-last per)
    265253  (%check-time-period 'time-period-last per)
    266   (let ([end (%time-period-end per)])
     254  (let ((end (%time-period-end per)))
    267255    (tm:subtract-duration end ONE-NANOSECOND-DURATION (tm:as-empty-time end)) ) )
    268256
    269257(define (time-period-length per)
    270258  (%check-time-period 'time-period-length per)
    271   (let ([dur (tm:make-empty-time time-duration)])
    272     (if (tm:time-period-null? per)
    273       dur
    274       (tm:time-difference (%time-period-begin per) (%time-period-end per) dur)) ) )
     259  (let ((dur (tm:make-empty-time time-duration)))
     260    (if (tm:time-period-null? per) dur
     261        (tm:time-difference (%time-period-begin per) (%time-period-end per) dur)) ) )
    275262
    276263(define (time-period-contains/period? per1 per2)
     
    291278(define (time-period-contains? per obj)
    292279  (%check-time-period 'time-period-contains? per)
    293   (cond
    294     [(time-period? obj)
    295       (tm:time-period-contains/period? 'time-period-contains? per obj)]
    296     [(time? obj)
    297       (tm:time-period-contains/time? 'time-period-contains? per obj)]
    298     [(date? obj)
    299       (tm:time-period-contains/date? 'time-period-contains? per obj)]
    300     [else
    301       (error 'time-period-contains? "invalid time object" obj)]) )
     280  (cond ((time-period? obj)
     281         (tm:time-period-contains/period? 'time-period-contains? per obj))
     282        ((time? obj)
     283         (tm:time-period-contains/time? 'time-period-contains? per obj))
     284        ((date? obj)
     285         (tm:time-period-contains/date? 'time-period-contains? per obj))
     286        (else
     287         (error 'time-period-contains? "invalid time object" obj))) )
    302288
    303289(define (time-period-intersects? per1 per2)
    304290  (%check-time-period 'time-period-intersects? per1)
    305291  (%check-time-period 'time-period-intersects? per2)
    306   (receive [bi ei] (tm:time-period-intersection-values 'time-period-intersects? per1 per2)
     292  (receive (bi ei) (tm:time-period-intersection-values 'time-period-intersects? per1 per2)
    307293    (tm:time<=? bi ei) ) )
    308294
     
    310296  (%check-time-period 'time-period-intersection per1)
    311297  (%check-time-period 'time-period-intersection per2)
    312   (receive [bi ei] (tm:time-period-intersection-values 'time-period-intersection per1 per2)
     298  (receive (bi ei) (tm:time-period-intersection-values 'time-period-intersection per1 per2)
    313299    (and (tm:time<=? bi ei)
    314300         (%make-time-period bi ei)) ) )
     
    317303  (%check-time-period 'time-period-union per1)
    318304  (%check-time-period 'time-period-union per2)
    319   (let ([b1 (%time-period-begin per1)]
    320         [e1 (%time-period-end per1)])
    321     (let ([b2 (tm:ensure-compatible-time 'time-period-union b1 (time-period-begin per2))]
    322           [e2 (tm:ensure-compatible-time 'time-period-union e1 (time-period-end per2))])
    323       (receive [bi ei] (tm:time-point-intersection b1 e1 b2 e2)
     305  (let ((b1 (%time-period-begin per1))
     306        (e1 (%time-period-end per1)))
     307    (let ((b2 (tm:ensure-compatible-time 'time-period-union b1 (time-period-begin per2)))
     308          (e2 (tm:ensure-compatible-time 'time-period-union e1 (time-period-end per2))))
     309      (receive (bi ei) (tm:time-point-intersection b1 e1 b2 e2)
    324310        (and (tm:time<=? bi ei)
    325              (receive [bu eu] (tm:time-point-union-values b1 e1 b2 e2)
     311             (receive (bu eu) (tm:time-point-union-values b1 e1 b2 e2)
    326312               (%make-time-period bu eu) ) ) ) ) ) )
    327313
     
    329315  (%check-time-period 'time-period-span per1)
    330316  (%check-time-period 'time-period-span per2)
    331   (let ([b1 (%time-period-begin per1)]
    332         [e1 (%time-period-end per1)])
    333     (let ([b2 (tm:ensure-compatible-time 'time-period-span b1 (%time-period-begin per2))]
    334           [e2 (tm:ensure-compatible-time 'time-period-span e1 (%time-period-end per2))])
    335     (receive [bu eu] (tm:time-point-union-values b1 e1 b2 e2)
     317  (let ((b1 (%time-period-begin per1))
     318        (e1 (%time-period-end per1)))
     319    (let ((b2 (tm:ensure-compatible-time 'time-period-span b1 (%time-period-begin per2)))
     320          (e2 (tm:ensure-compatible-time 'time-period-span e1 (%time-period-end per2))))
     321    (receive (bu eu) (tm:time-point-union-values b1 e1 b2 e2)
    336322      (%make-time-period bu eu) ) ) ) )
    337323
  • release/3/srfi-19/trunk/srfi-19.html

    r12808 r13899  
    487487<h3>Version</h3>
    488488<ul>
    489 <li>2.8.0 Timezone locale creation removed.</li>
     489<li>2.8.0 Timezone locale creation removed. Removed 'make-local-timezone-locale'.</li>
    490490<li>2.7.1 Fix for 'add/subtract-duration[!].</li>
    491491<li>2.7.0 Replaced date comparison w/ a field by field algorithm. Removed local-timezone-info, local-timezone-name, local-timezone-offset, and local-timezone-dst?.</li>
Note: See TracChangeset for help on using the changeset viewer.