Changeset 12020 in project


Ignore:
Timestamp:
09/28/08 04:09:49 (12 years ago)
Author:
Kon Lovett
Message:

Save.

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

Legend:

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

    r10022 r12020  
    1414(define-constant SEC/HR   3600)
    1515(define-constant SEC/MIN  60)
     16
     17(define-constant iNS/S    1000000000.0)
     18(define-constant iSEC/DY  86400.0)
     19
     20(define-constant iONE-HALF  0.5)
    1621
    1722(define-constant HR/DY 24)
     
    3641  (if (fx< x 0) (fxneg x) x) )
    3742
     43(define-inline (inexact-integer? x)
     44  (and (inexact? x) (integer? x)) )
     45
    3846;; For storage savings since some aritmetic routines do not
    3947;; return fixnums when possible.
    4048
    41 ;When domain & range are fixnum
     49;; ##sys#number?
     50;; returns #t for fixnum or flonum
     51
     52;; ##sys#double->number
     53;; returns a fixnum for the flonum iff x isa integer in fixnum-range
     54;; otherwise the flonum
     55
     56; When domain is integer and range is fixnum
     57; Number MUST be a fixnum or flonum
     58
    4259(define-inline (->fixnum x)
     60  (if (fixnum? x) x (##sys#double->number x))
     61  #;
    4362  (inexact->exact x) )
    4463
    45 ;When domain & range are number
     64; When domain is integer and range is flonum-integer
     65; Conversion attemped only when number is a fixnum or flonum-integer
     66; Others returned
     67
    4668(define-inline (->fixnum* x)
    47   (cond [(and (inexact? x) (integer? x))
    48           (inexact->exact x)]
    49         [else
    50           x]) )
     69  (if (##sys#integer? x) (->fixnum x) x)
     70  #;
     71  (if (inexact-integer? x) (->fixnum x) x) )
    5172
    5273;;
     
    5677    (fx- day-of-week-starting-week (tm:week-day 1 1 (date-year date)))
    5778    DY/WK) )
    58 
    59 ;;
    60 
    61 (define-inline (%date-nanosecond-set! date x)
    62   (tm:date-nanosecond-set! date (->fixnum x)) )
    63 
    64 (define-inline (%date-second-set! date x)
    65   (tm:date-second-set! date (->fixnum x)) )
    66 
    67 (define-inline (%date-minute-set! date x)
    68   (tm:date-minute-set! date (->fixnum x)) )
    69 
    70 (define-inline (%date-hour-set! date x)
    71   (tm:date-hour-set! date (->fixnum x)) )
    72 
    73 (define-inline (%date-day-set! date x)
    74   (tm:date-day-set! date (->fixnum x)) )
    75 
    76 (define-inline (%date-month-set! date x)
    77   (tm:date-month-set! date (->fixnum x)) )
    78 
    79 (define-inline (%date-year-set! date x)
    80   (tm:date-year-set! date (->fixnum x)) )
    81 
    82 (define-inline (%date-zone-offset-set! date x)
    83   (tm:date-zone-offset-set! date (->fixnum x)) )
  • release/3/srfi-19/trunk/srfi-19-core.scm

    r10022 r12020  
    114114      ;; SRFI-19 extensions
    115115      ONE-SECOND-DURATION ONE-NANOSECOND-DURATION
     116      time-type?
    116117      make-duration
    117118      divide-duration divide-duration!
     
    143144      time->julian-day time->modified-julian-day
    144145      ;; SRFI-19
    145       time-tai time-utc time-monotonic time-thread time-process
    146       time-duration time-gc
     146      time-tai time-utc time-monotonic time-thread time-process time-duration time-gc
    147147      current-date
    148148      current-julian-day current-modified-julian-day
     
    194194      tm:make-date
    195195      tm:vali-date
    196       tm:time-check
     196      tm:check-time
    197197      tm:make-empty-time
    198198      tm:as-empty-time
     
    214214      tm:time-max
    215215      tm:time-min
    216       tm:duration-check
     216      tm:check-duration
    217217      tm:time-difference) ) )
    218218
     
    395395      (lsd tm:leap-second-table)) ) )
    396396
    397 ;; Is the time object one second before a leap second?
    398 
    399 (define (tm:tai-before-leap-second? time)
    400   (let ([sec (time-second time)])
    401     (let loop ([lst tm:second-before-leap-second-table])
    402       (and (not (null? lst))
    403            (or (= sec (car lst))
    404                (loop (cdr lst)) ) ) ) ) )
    405 
    406397;;
    407398
     
    431422;;
    432423
     424(define (time-type? type)
     425  (case type
     426    [(time-duration)    #t]
     427    [(time-monotonic)   #t]
     428    [(time-tai)         #t]
     429    [(time-utc)         #t]
     430    [(time-gc)          #t]
     431    [(time-process)     #t]
     432    [(time-thread)      #t]
     433    [else               #f]) )
     434
     435;;
     436
    433437(define default-date-clock-type
    434   (make-parameter time-utc
     438  (make-parameter 'time-utc
    435439    (lambda (x)
    436440      (if (and (symbol? x)
    437                (switch x
    438                 [time-monotonic #t]
    439                 [time-tai #t]
    440                 [time-utc #t]
    441                 [else #f]))
     441               (case x
     442                 [(time-monotonic) #t]
     443                 [(time-tai)        #t]
     444                 [(time-utc)        #t]
     445                 [else              #f]))
    442446        x
    443447        (default-date-clock-type)))))
    444448
     449;;
     450
     451(define (tm:check-time-type loc obj)
     452  (unless (time-type? obj)
     453    (error loc "invalid clock-type" obj)) )
     454
    445455;; There are 2 kinds of time record access procedures:
    446 ;; tm:... - generated
    447 ;; %*     - argument processing then tm:...
    448 
    449 (define-record-type time
    450   (tm:make-time type nanosecond second)
    451   time?
    452   (type time-type tm:set-time-type!)
    453   (nanosecond time-nanosecond tm:set-time-nanosecond!)
    454   (second time-second tm:set-time-second!) )
    455 
    456 ;;
    457 
    458 (define (%make-time type ns sec)
    459   (tm:make-time type (->fixnum ns) (->fixnum* sec)) )
    460 
    461 (define (%set-time-nanosecond! time ns)
    462   (tm:set-time-nanosecond! time (->fixnum ns)) )
    463 
    464 (define (%set-time-second! time sec)
    465   (tm:set-time-second! time (->fixnum* sec)) )
    466 
    467 (define-record-printer (time t out)
    468   (fprintf out "#,(time ~A ~A ~A)"
    469     (time-type t) (time-nanosecond t) (time-second t)) )
    470 
    471 (define-reader-ctor 'time %make-time)
     456;; %...   - generated
     457;; tm:... - argument processing then %...
     458;; ...    - argument checking then tm:...
     459
     460(define-record-type/unsafe-inline-unchecked time
     461  (%make-time type nanosecond second)
     462  %time?
     463  (type %time-type %set-time-type!)
     464  (nanosecond %time-nanosecond %set-time-nanosecond!)
     465  (second %time-second %set-time-second!) )
     466
     467(define-inline (%check-time loc obj)
     468  (##sys#check-structure obj 'time loc) )
     469
     470;;
     471
     472(define (tm:make-time timtyp ns sec)
     473  (%make-time timtyp (->fixnum ns) (->fixnum* sec)) )
     474
     475(define (tm:set-time-nanosecond! tim ns)
     476  (%set-time-nanosecond! tim (->fixnum ns)) )
     477
     478(define (tm:set-time-second! tim sec)
     479  (%set-time-second! tim (->fixnum* sec)) )
     480
     481;;
     482
     483(define-record-printer (time tim out)
     484  (fprintf out "#,(time ~A ~A ~A)" (%time-type tim) (%time-nanosecond tim) (%time-second tim)) )
     485
     486(define-reader-ctor 'time tm:make-time)
    472487
    473488;; Time Constants
    474489
    475 (define ONE-SECOND-DURATION (tm:make-time time-duration 0 1))
    476 
    477 (define ONE-NANOSECOND-DURATION (tm:make-time time-duration 1 0))
    478 
    479 (define (tm:make-empty-time typ)
    480   (tm:make-time typ 0 0) )
     490(define ONE-SECOND-DURATION (%make-time 'time-duration 0 1))
     491
     492(define ONE-NANOSECOND-DURATION (%make-time 'time-duration 1 0))
     493
     494(define (tm:make-empty-time timtyp)
     495  (%make-time timtyp 0 0) )
    481496
    482497(define (tm:as-empty-time tim)
    483   (tm:make-empty-time (time-type tim)) )
    484 
    485 ;; Parameter Checking
    486 
    487 (define (time-type? type)
    488   (switch type
    489     [time-duration #t]
    490     [time-gc #t]
    491     [time-monotonic #t]
    492     [time-process #t]
    493     [time-tai #t]
    494     [time-thread #t]
    495     [time-utc #t]
    496     [else #f]) )
    497 
    498 (define (tm:check-time-type loc type)
    499   (unless (time-type? type)
    500     (error loc "invalid clock-type" type)) )
    501 
    502 (define (tm:time-check obj loc)
    503   (unless (time? obj)
    504     (error loc "invalid time object" obj)) )
    505 
    506 (define (time-type-check tim typ loc)
    507   (unless (eq? typ (time-type tim))
    508     (error loc "incompatible clock-types" (time-type tim) typ)) )
    509 
    510 (define (tm:duration-check obj loc)
    511   (unless (and (time? obj) (eq? time-duration (time-type obj)))
    512     (error loc "invalid duration" obj)) )
    513 
    514 (define (tm:check-time-nanoseconds loc ns)
    515   (unless (and (integer? ns) (<= 0 ns) (< ns NS/S))
    516     (error loc "invalid nanoseconds" ns)) )
    517 
    518 (define (tm:check-time-seconds loc sec)
    519   (unless (integer? sec)
    520     (error loc "invalid seconds" sec)) )
    521 
    522 (define (tm:check-time-elements loc type ns sec)
    523   (tm:check-time-type loc type)
    524   (tm:check-time-nanoseconds loc ns)
    525   (tm:check-time-seconds loc sec) )
     498  (tm:make-empty-time (%time-type tim)) )
     499
     500;; Time Parameter Checking
     501
     502(define (tm:check-time-has-type loc tim timtyp)
     503  (unless (eq? timtyp (%time-type tim))
     504    (error loc "incompatible clock-types" (%time-type tim) timtyp)) )
     505
     506(define tm:check-time %check-time)
     507
     508(define (tm:check-duration loc obj)
     509  (%check-time loc obj)
     510  (tm:check-time-has-type loc obj 'time-duration) )
     511
     512(define (tm:check-time-nanoseconds loc obj)
     513  (unless (and (integer? obj) (<= 0 obj) (< obj NS/S))
     514    (error loc "invalid nanoseconds" obj)) )
     515
     516(define (tm:check-time-seconds loc obj)
     517  (unless (integer? obj)
     518    (error loc "invalid seconds" obj)) )
     519
     520(define (tm:check-time-elements loc obj1 obj2 obj3)
     521  (tm:check-time-type loc obj1)
     522  (tm:check-time-nanoseconds loc obj2)
     523  (tm:check-time-seconds loc obj3) )
     524
     525(define (tm:check-times loc objs)
     526  (for-each (cut tm:check-time loc <>) objs) )
     527
     528(define (tm:time-binop-check loc obj1 obj2)
     529  (%check-time loc obj1)
     530  (%check-time loc obj2) )
     531
     532(define (tm:time-compare-check loc obj1 obj2)
     533  (tm:time-binop-check loc obj1 obj2)
     534  (tm:check-time-has-type loc obj1 (%time-type obj2)) )
    526535
    527536;;
    528537
    529538(define (tm:nanoseconds->time-values ns)
    530   (values (abs (remainder ns NS/S)) (quotient ns NS/S)) )
     539  ??? (values (abs (remainder ns NS/S)) (quotient ns NS/S)) )
    531540
    532541;; Time CTOR
    533542
    534 (define (make-time type ns sec)
    535   (tm:check-time-elements 'make-time type ns sec)
    536   (%make-time type ns sec) )
     543(define (make-time timtyp ns sec)
     544  (tm:check-time-elements 'make-time timtyp ns sec)
     545  (tm:make-time timtyp ns sec) )
    537546
    538547(define (make-duration
     
    542551          (milliseconds 0) (microseconds 0) (nanoseconds 0))
    543552  (receive [ns sec]
    544       (tm:nanoseconds->time-values
    545         (+ (* milliseconds NS/MS) (* microseconds NS/MuS) nanoseconds))
     553      (tm:nanoseconds->time-values (+ (* milliseconds NS/MS) (* microseconds NS/MuS) nanoseconds))
    546554    (make-time
    547       time-duration
     555      'time-duration
    548556      ns
    549       (+ (* days SEC/DY)
    550          (* hours SEC/HR) (* minutes SEC/MIN) seconds
    551          sec)) ) )
    552 
    553 (define (copy-time time)
    554   (tm:make-time (time-type time)
    555     (time-second time) (time-nanosecond time)) )
     557      (+ (* days SEC/DY) (* hours SEC/HR) (* minutes SEC/MIN) seconds sec)) ) )
     558
     559(define (copy-time tim)
     560  (%make-time (%time-type tim) (%time-second tim) (%time-nanosecond tim)) )
    556561
    557562;; Converts a seconds value, may be fractional, into a time type.
    558 ;; The type of time default is time-duration.
    559 
    560 (define (seconds->time/type sec . tt)
     563;; The type of time default is 'time-duration.
     564
     565(define (seconds->time/type sec . timtyp)
    561566  (let ([tsec (truncate sec)])
    562     (make-time (optional tt time-duration)
     567    (make-time
     568      (optional timtyp 'time-duration)
    563569      (round (abs (* (- (exact->inexact sec) tsec) NS/S)))
    564570      tsec) ) )
    565571
    566 ;; Time Setters
    567 
    568 (define (set-time-type! t type)
    569   (tm:check-time-type 'set-time-type! type)
    570   (tm:set-time-type! t type) )
    571 
    572 (define (set-time-nanosecond! t ns)
     572;; Time record-type operations
     573
     574(define time? %time?)
     575
     576(define (time-type tim)
     577  (%check-time 'time-type tim)
     578  (%time-type tim) )
     579
     580(define (time-nanosecond tim)
     581  (%check-time 'time-nanosecond tim)
     582  (%time-nanosecond tim) )
     583
     584(define (time-second tim)
     585  (%check-time 'time-second tim)
     586  (%time-second tim) )
     587
     588(define (set-time-type! tim timtyp)
     589  (%check-time 'set-time-type! tim)
     590  (tm:check-time-type 'set-time-type! timtyp)
     591  (%set-time-type! tim timtyp) )
     592
     593(define (set-time-nanosecond! tim ns)
     594  (%check-time 'set-time-nanosecond! tim)
    573595  (tm:check-time-nanoseconds 'set-time-nanosecond! ns)
    574   (%set-time-nanosecond! t ns) )
    575 
    576 (define (set-time-second! t sec)
     596  (tm:set-time-nanosecond! tim ns) )
     597
     598(define (set-time-second! tim sec)
     599  (%check-time 'set-time-second! tim)
    577600  (tm:check-time-seconds 'set-time-second! sec)
    578   (%set-time-second! t sec) )
     601  (tm:set-time-second! tim sec) )
    579602
    580603;; Seconds Conversion
    581604
    582 (define (time->nanoseconds tm)
    583   (+ (time-nanosecond tm) (* (time-second tm) NS/S)) )
    584 
    585 (define (nanoseconds->time ns . tt)
    586   (receive [ns sec] (tm:nanoseconds->time-values ns)
    587     (%make-time (optional tt time-duration) ns sec) ) )
     605(define (time->nanoseconds tim)
     606  (%check-time 'time->nanoseconds tim)
     607  (+ (%time-nanosecond tim) (* (%time-second tim) NS/S)) )
     608
     609(define (nanoseconds->time ns . args)
     610  (let-optionals args ((timtyp 'time-duration))
     611    (tm:check-time-type 'nanoseconds->time timtyp)
     612    (receive [ns sec] (tm:nanoseconds->time-values ns)
     613      (tm:make-time timtyp ns sec) ) ) )
    588614
    589615(define (nanoseconds->seconds ns)
    590616  (/ ns NS/S) )
    591617
    592 (define (time->milliseconds tm)
    593   (+ (/ (time-nanosecond tm) NS/MS) (* (time-second tm) MS/S)) )
    594 
    595 (define (milliseconds->time ms . tt)
    596   (%make-time (optional tt time-duration)
    597     (fx* (remainder ms MS/S) NS/MS) (quotient ms MS/S)) )
     618(define (time->milliseconds tim)
     619  (%check-time 'time->milliseconds tim)
     620  (+ (/ (%time-nanosecond tim) NS/MS) (* (%time-second tim) MS/S)) )
     621
     622(define (milliseconds->time ms . args)
     623  (let-optionals args ((timtyp 'time-duration))
     624    (tm:check-time-type 'milliseconds->time timtyp)
     625    (tm:make-time timtyp (fx* (remainder ms MS/S) NS/MS) (quotient ms MS/S)) ) )
    598626
    599627(define (milliseconds->seconds ms)
     
    603631
    604632(define (tm:current-sub-milliseconds)
    605   ;Throw away everything but the sub-second bit.
    606   ;Chicken 'current-milliseconds' within positive fixnum range
     633  ; Throw away everything but the sub-second bit.
     634  ; Chicken 'current-milliseconds' within positive fixnum range
    607635  (fxmod (current-milliseconds) MS/S) )
    608636
     
    616644(define (tm:current-time-utc)
    617645  (receive [ns sec] (tm:current-time-values)
    618     (%make-time time-utc ns sec)) )
     646    (tm:make-time 'time-utc ns sec)) )
    619647
    620648(define (tm:current-time-tai)
    621649  (receive [ns sec] (tm:current-time-values)
    622     (%make-time time-tai ns (+ sec (tm:leap-second-delta sec))) ) )
     650    (tm:make-time 'time-tai ns (+ sec (tm:leap-second-delta sec))) ) )
    623651
    624652(define (tm:current-time-monotonic)
    625   (let ([tm (tm:current-time-tai)])
    626     (tm:set-time-type! tm time-monotonic)
     653  (let ([tim (tm:current-time-tai)])
     654    (%set-time-type! tim 'time-monotonic)
    627655    tm ) )
    628656
    629657(define (tm:current-time-thread)
    630   (milliseconds->time (current-thread-milliseconds) time-thread) )
     658  (milliseconds->time (current-thread-milliseconds) 'time-thread) )
    631659
    632660(define (tm:current-time-process)
    633   (milliseconds->time (current-process-milliseconds) time-process) )
     661  (milliseconds->time (current-process-milliseconds) 'time-process) )
    634662
    635663(define (tm:current-time-gc)
    636   (milliseconds->time (total-gc-milliseconds) time-gc) )
     664  (milliseconds->time (total-gc-milliseconds) 'time-gc) )
    637665
    638666;;
    639667
    640668(define (current-time . clock-type)
    641   (let ([clock-type (optional clock-type time-utc)])
     669  (let ([clock-type (optional clock-type 'time-utc)])
    642670    (tm:check-time-type 'current-time clock-type)
    643     (switch clock-type
    644       [time-gc (tm:current-time-gc)]
    645       [time-monotonic (tm:current-time-monotonic)]
    646       [time-process (tm:current-time-process)]
    647       [time-tai (tm:current-time-tai)]
    648       [time-thread (tm:current-time-thread)]
    649       [time-utc (tm:current-time-utc)]) ) )
     671    (case clock-type
     672      [(time-gc)        (tm:current-time-gc)]
     673      [(time-monotonic) (tm:current-time-monotonic)]
     674      [(time-process)  (tm:current-time-process)]
     675      [(time-tai)      (tm:current-time-tai)]
     676      [(time-thread)    (tm:current-time-thread)]
     677      [(time-utc)      (tm:current-time-utc)]) ) )
    650678
    651679;; SRFI-18 Routines
    652680;; Coupling here
    653681
    654 (define (srfi-18-time->time tm)
    655   (%make-time time-duration
    656     (* (##sys#slot tm 3) NS/MS) (##sys#slot tm 2)) )
    657 
    658 (define (time->srfi-18-time tm)
    659   (seconds->time (nanoseconds->seconds (time->nanoseconds tm))) )
     682(define (srfi-18-time->time srfi-18-tm)
     683  (tm:make-time 'time-duration (* (##sys#slot srfi-18-tm 3) NS/MS) (##sys#slot srfi-18-tm 2)) )
     684
     685(define (time->srfi-18-time tim)
     686  (%check-time 'time->srfi-18-time tim)
     687  (seconds->time (nanoseconds->seconds (time->nanoseconds tim))) )
    660688
    661689(define srfi-19:time? time?)
     
    668696
    669697(define (time-resolution . clock-type)
    670   (tm:check-time-type 'time-resolution (optional clock-type time-utc))
     698  (tm:check-time-type 'time-resolution (optional clock-type 'time-utc))
    671699  NS/MS )
    672700
    673701;; Time Comparison
    674702
    675 (define (tm:time-binop-check tim1 tim2 loc)
    676   (tm:time-check tim1 loc)
    677   (tm:time-check tim2 loc) )
    678 
    679 (define (tm:time-compare-check tim1 tim2 loc)
    680   (tm:time-binop-check tim1 tim2 loc)
    681   (time-type-check tim1 (time-type tim2) loc) )
    682 
    683703(define (tm:time=? tim1 tim2)
    684   (and (= (time-second tim1) (time-second tim2))
    685        (= (time-nanosecond tim1) (time-nanosecond tim2))) )
     704  (and (= (%time-second tim1) (%time-second tim2))
     705       (= (%time-nanosecond tim1) (%time-nanosecond tim2))) )
    686706
    687707(define (tm:time<? tim1 tim2)
    688   (or (< (time-second tim1) (time-second tim2))
    689       (and (= (time-second tim1) (time-second tim2))
    690            (< (time-nanosecond tim1) (time-nanosecond tim2)))) )
     708  (or (< (%time-second tim1) (%time-second tim2))
     709      (and (= (%time-second tim1) (%time-second tim2))
     710           (< (%time-nanosecond tim1) (%time-nanosecond tim2)))) )
    691711
    692712(define (tm:time<=? tim1 tim2)
    693   (or (< (time-second tim1) (time-second tim2))
    694       (and (= (time-second tim1) (time-second tim2))
    695            (<= (time-nanosecond tim1) (time-nanosecond tim2)))) )
     713  (or (< (%time-second tim1) (%time-second tim2))
     714      (and (= (%time-second tim1) (%time-second tim2))
     715           (<= (%time-nanosecond tim1) (%time-nanosecond tim2)))) )
    696716
    697717(define (tm:time>? tim1 tim2)
    698   (or (> (time-second tim1) (time-second tim2))
    699       (and (= (time-second tim1) (time-second tim2))
    700            (> (time-nanosecond tim1) (time-nanosecond tim2)))) )
     718  (or (> (%time-second tim1) (%time-second tim2))
     719      (and (= (%time-second tim1) (%time-second tim2))
     720           (> (%time-nanosecond tim1) (%time-nanosecond tim2)))) )
    701721
    702722(define (tm:time>=? tim1 tim2)
    703   (or (> (time-second tim1) (time-second tim2))
    704       (and (= (time-second tim1) (time-second tim2))
    705            (>= (time-nanosecond tim1) (time-nanosecond tim2)))) )
     723  (or (> (%time-second tim1) (%time-second tim2))
     724      (and (= (%time-second tim1) (%time-second tim2))
     725           (>= (%time-nanosecond tim1) (%time-nanosecond tim2)))) )
    706726
    707727(define (tm:time-max tim . rest)
     
    722742
    723743(define (time=? tim1 tim2)
    724   (tm:time-compare-check tim1 tim2 'time=?)
     744  (tm:time-compare-check 'time=? tim1 tim2)
    725745  (tm:time=? tim1 tim2) )
    726746
    727747(define (time>? tim1 tim2)
    728   (tm:time-compare-check tim1 tim2 'time>?)
     748  (tm:time-compare-check 'time>? tim1 tim2)
    729749  (tm:time>? tim1 tim2) )
    730750
    731751(define (time<? tim1 tim2)
    732   (tm:time-compare-check tim1 tim2 'time<?)
     752  (tm:time-compare-check 'time<? tim1 tim2)
    733753  (tm:time<? tim1 tim2) )
    734754
    735755(define (time>=? tim1 tim2)
    736   (tm:time-compare-check tim1 tim2 'time>=?)
     756  (tm:time-compare-check 'time>=? tim1 tim2)
    737757  (tm:time>=? tim1 tim2) )
    738758
    739759(define (time<=? tim1 tim2)
    740   (tm:time-compare-check tim1 tim2 'time<=?)
     760  (tm:time-compare-check 'time<=? tim1 tim2)
    741761  (tm:time<=? tim1 tim2) )
    742762
    743 (define (time-max tim1 tim2)
    744   (tm:time-compare-check tim1 tim2 'time-max)
    745   (tm:time-max tim1 tim2) )
    746 
    747 (define (time-min tim1 tim2)
    748   (tm:time-compare-check tim1 tim2 'time-min)
    749   (tm:time-min tim1 tim2) )
     763(define (time-max tim1 . rest)
     764  (tm:check-times 'time-max (cons tim1 rest))
     765  (apply tm:time-max tim1 rest) )
     766
     767(define (time-min tim1 . rest)
     768  (tm:check-times 'time-min (cons tim1 rest))
     769  (apply tm:time-min tim1 rest) )
    750770
    751771;; Time Arithmetic
    752772
    753773(define (tm:time-aritmetic-check tim dur loc)
    754   (tm:time-check tim loc)
    755   (tm:duration-check dur loc) )
     774  (%check-time loc tim)
     775  (tm:check-duration dur loc) )
    756776
    757777(define (tm:time-difference tim1 tim2 tim3)
    758   (tm:set-time-type! tim3 time-duration)
     778  (%set-time-type! tim3 'time-duration)
    759779  (if (tm:time=? tim1 tim2)
    760780    (begin
    761       (%set-time-second! tim3 0)
    762       (%set-time-nanosecond! tim3 0))
     781      (tm:set-time-second! tim3 0)
     782      (tm:set-time-nanosecond! tim3 0))
    763783    (receive [ns sec]
    764784        (tm:nanoseconds->time-values
    765785          (- (time->nanoseconds tim1) (time->nanoseconds tim2)))
    766       (%set-time-second! tim3 sec)
    767       (%set-time-nanosecond! tim3 ns)))
     786      (tm:set-time-second! tim3 sec)
     787      (tm:set-time-nanosecond! tim3 ns)))
    768788  tim3 )
    769789
    770790(define (tm:add-duration tim1 dur tim3)
    771   (let ([sec-plus (+ (time-second tim1) (time-second dur))]
    772         [nsec-plus (+ (time-nanosecond tim1) (time-nanosecond dur))])
    773     (%set-time-second! tim3 (+ sec-plus (quotient nsec-plus NS/S)))
    774     (%set-time-nanosecond! tim3 (remainder nsec-plus NS/S))
     791  (let ([sec-plus (+ (%time-second tim1) (%time-second dur))]
     792        [nsec-plus (+ (%time-nanosecond tim1) (%time-nanosecond dur))])
     793    (tm:set-time-second! tim3 (+ sec-plus (quotient nsec-plus NS/S)))
     794    (tm:set-time-nanosecond! tim3 (remainder nsec-plus NS/S))
    775795    tim3 ) )
    776796
    777797(define (tm:subtract-duration tim1 dur tim3)
    778   (let ([sec-minus (- (time-second tim1) (time-second dur))]
    779         [nsec-minus (fx- (time-nanosecond tim1) (time-nanosecond dur))])
     798  (let ([sec-minus (- (%time-second tim1) (%time-second dur))]
     799        [nsec-minus (fx- (%time-nanosecond tim1) (%time-nanosecond dur))])
    780800    (let ([r (fxmod nsec-minus NS/S)]
    781801          [secs (- sec-minus (fx/ nsec-minus NS/S))])
    782802      (if (fx< r 0)
    783803        (begin
    784           (%set-time-second! tim3 (- secs 1))
    785           (%set-time-nanosecond! tim3 (fx+ NS/S r)))
     804          (tm:set-time-second! tim3 (- secs 1))
     805          (tm:set-time-nanosecond! tim3 (fx+ NS/S r)))
    786806        (begin
    787           (%set-time-second! tim3 secs)
    788           (%set-time-nanosecond! tim3 r)))
     807          (tm:set-time-second! tim3 secs)
     808          (tm:set-time-nanosecond! tim3 r)))
    789809      tim3 ) ) )
    790810
     
    792812  (receive [ns sec]
    793813      (tm:nanoseconds->time-values (/ (time->nanoseconds dur1) num))
    794     (%set-time-nanosecond! dur3 ns)
    795     (%set-time-second! dur3 sec)
     814    (tm:set-time-nanosecond! dur3 ns)
     815    (tm:set-time-second! dur3 sec)
    796816    dur3 ) )
    797817
     
    799819  (receive [ns sec]
    800820      (tm:nanoseconds->time-values (* (time->nanoseconds dur1) num))
    801     (%set-time-nanosecond! dur3 ns)
    802     (%set-time-second! dur3 sec)
     821    (tm:set-time-nanosecond! dur3 ns)
     822    (tm:set-time-second! dur3 sec)
    803823    dur3 ) )
    804824
    805825(define (tm:time-abs tim1 tim3)
    806   (%set-time-second! tim3 (abs (time-second tim1)))
     826  (tm:set-time-second! tim3 (abs (%time-second tim1)))
    807827  tim3 )
    808828
    809829(define (tm:time-negate tim1 tim3)
    810   (%set-time-second! tim3 (- (time-second tim1)))
     830  (tm:set-time-second! tim3 (- (%time-second tim1)))
    811831  tim3 )
    812832
     
    814834
    815835(define (time-difference tim1 tim2)
    816   (tm:time-compare-check tim1 tim2 'time-difference)
     836  (tm:time-compare-check 'time-difference tim1 tim2)
    817837  (tm:time-difference tim1 tim2 (tm:as-empty-time tim1)) )
    818838
    819839(define (time-difference! tim1 tim2)
    820   (tm:time-compare-check tim1 tim2 'time-difference!)
     840  (tm:time-compare-check 'time-difference! tim1 tim2)
    821841  (tm:time-difference tim1 tim2 tim1) )
    822842
    823843(define (add-duration tim dur)
    824   (tm:time-aritmetic-check tim dur 'add-duration)
     844  (tm:time-aritmetic-check 'add-duration tim dur)
    825845  (tm:add-duration tim dur (tm:as-empty-time tim)) )
    826846
    827847(define (add-duration! tim dur)
    828   (tm:time-aritmetic-check tim dur 'add-duration!)
     848  (tm:time-aritmetic-check 'add-duration! tim dur 'add-duration!)
    829849  (tm:add-duration tim dur tim) )
    830850
    831851(define (subtract-duration tim dur)
    832   (tm:time-aritmetic-check tim dur 'subtract-duration)
     852  (tm:time-aritmetic-check 'subtract-duration tim dur)
    833853  (tm:subtract-duration tim dur (tm:as-empty-time tim)) )
    834854
    835855(define (subtract-duration! tim dur)
    836   (tm:time-aritmetic-check tim dur 'subtract-duration!)
     856  (tm:time-aritmetic-check 'subtract-duration! tim dur)
    837857  (tm:subtract-duration tim dur tim) )
    838858
    839859(define (divide-duration dur num)
    840   (tm:duration-check dur 'divide-duration)
     860  (tm:check-duration 'divide-duration dur)
    841861  (tm:divide-duration dur num (tm:as-empty-time dur)) )
    842862
    843863(define (divide-duration! dur num)
    844   (tm:duration-check dur 'divide-duration!)
     864  (tm:check-duration 'divide-duration! dur)
    845865  (tm:divide-duration dur num dur) )
    846866
    847867(define (multiply-duration dur num)
    848   (tm:duration-check dur 'multiply-duration)
     868  (tm:check-duration 'multiply-duration dur)
    849869  (tm:multiply-duration dur num (tm:as-empty-time dur)) )
    850870
    851871(define (multiply-duration! dur num)
    852   (tm:duration-check dur 'multiply-duration!)
     872  (tm:check-duration 'multiply-duration! dur)
    853873  (tm:multiply-duration dur num dur) )
    854874
    855875(define (time-negative? tim)
    856   (tm:time-check tim 'time-negative?)
    857   (negative? (time-second tim)) )
     876  (%check-time 'time-negative? tim)
     877  (negative? (%time-second tim)) )
    858878
    859879(define (time-positive? tim)
    860   (tm:time-check tim 'time-positive?)
    861   (positive? (time-second tim)) )
     880  (%check-time 'time-positive? tim)
     881  (positive? (%time-second tim)) )
    862882
    863883(define (time-zero? tim)
    864   (tm:time-check tim 'time-zero?)
    865   (and (zero? (time-nanosecond tim))
    866        (zero? (time-second tim))) )
     884  (%check-time 'time-zero? tim)
     885  (and (zero? (%time-nanosecond tim))
     886       (zero? (%time-second tim))) )
    867887
    868888(define (time-abs tim)
    869   (tm:time-check tim 'time-abs)
     889  (%check-time 'time-abs tim)
    870890  (tm:time-abs tim (tm:as-empty-time tim)) )
    871891
    872892(define (time-abs! tim)
    873   (tm:time-check tim 'time-abs!)
     893  (%check-time 'time-abs! tim)
    874894  (tm:time-abs tim tim) )
    875895
    876896(define (time-negate tim)
    877   (tm:time-check tim 'time-negate)
     897  (%check-time 'time-negate tim)
    878898  (tm:time-negate tim (tm:as-empty-time tim)) )
    879899
    880900(define (time-negate! tim)
    881   (tm:time-check tim 'time-negate!)
     901  (%check-time 'time-negate! tim)
    882902  (tm:time-negate tim tim) )
    883903
     
    885905
    886906(define (tm:time-tai->time-utc time-in time-out)
    887   (tm:set-time-type! time-out time-utc)
    888   (%set-time-nanosecond! time-out (time-nanosecond time-in))
    889   (%set-time-second! time-out
    890     (- (time-second time-in)
    891        (tm:leap-second-neg-delta (time-second time-in))))
     907  (%set-time-type! time-out 'time-utc)
     908  (tm:set-time-nanosecond! time-out (%time-nanosecond time-in))
     909  (tm:set-time-second! time-out
     910    (- (%time-second time-in) (tm:leap-second-neg-delta (%time-second time-in))))
    892911  time-out )
    893912
    894913(define (tm:time-utc->time-tai time-in time-out)
    895   (tm:set-time-type! time-out time-tai)
    896   (%set-time-nanosecond! time-out (time-nanosecond time-in))
    897   (%set-time-second! time-out
    898     (+ (time-second time-in)
    899        (tm:leap-second-delta (time-second time-in))))
     914  (%set-time-type! time-out 'time-tai)
     915  (tm:set-time-nanosecond! time-out (%time-nanosecond time-in))
     916  (tm:set-time-second! time-out
     917    (+ (%time-second time-in) (tm:leap-second-delta (%time-second time-in))))
    900918  time-out )
    901919
    902920(define (tm:time-monotonic->time-tai time-in time-out)
    903   (tm:set-time-type! time-out time-tai)
     921  (%set-time-type! time-out 'time-tai)
    904922  (unless (eq? time-in time-out)
    905     (%set-time-nanosecond! time-out (time-nanosecond time-in))
    906     (%set-time-second! time-out (time-second time-in)))
     923    (tm:set-time-nanosecond! time-out (%time-nanosecond time-in))
     924    (tm:set-time-second! time-out (%time-second time-in)))
    907925  time-out )
    908926
    909927(define (tm:time-tai->time-monotonic time-in time-out)
    910   (tm:set-time-type! time-out time-monotonic)
     928  (%set-time-type! time-out 'time-monotonic)
    911929  (unless (eq? time-in time-out)
    912     (%set-time-nanosecond! time-out (time-nanosecond time-in))
    913     (%set-time-second! time-out (time-second time-in)))
     930    (tm:set-time-nanosecond! time-out (%time-nanosecond time-in))
     931    (tm:set-time-second! time-out (%time-second time-in)))
    914932  time-out )
    915933
    916934(define (tm:time-monotonic->time-utc time-in time-out)
    917   (tm:set-time-type! time-in time-tai) ; fool converter (unnecessary)
     935  (%set-time-type! time-in 'time-tai) ; fool converter (unnecessary)
    918936  (tm:time-tai->time-utc time-in time-out) )
    919937
    920938(define (tm:time-utc->time-monotonic time-in time-out)
    921939  (let ([ntime (tm:time-utc->time-tai time-in time-out)])
    922     (tm:set-time-type! ntime time-monotonic)
     940    (%set-time-type! ntime 'time-monotonic)
    923941    ntime))
    924942
     
    926944
    927945(define (time-tai->time-utc time-in)
    928   (time-type-check time-in time-tai 'time-tai->time-utc)
     946  (tm:check-time-has-type 'time-tai->time-utc time-in 'time-tai)
    929947  (tm:time-tai->time-utc time-in (tm:as-empty-time time-in)) )
    930948
    931949(define (time-tai->time-utc! time-in)
    932   (time-type-check time-in time-tai 'time-tai->time-utc!)
     950  (tm:check-time-has-type 'time-tai->time-utc! time-in 'time-tai)
    933951  (tm:time-tai->time-utc time-in time-in) )
    934952
    935953(define (time-tai->time-monotonic time-in)
    936   (time-type-check time-in time-tai 'time-tai->time-monotonic)
     954  (tm:check-time-has-type 'time-tai->time-monotonic time-in 'time-tai)
    937955  (tm:time-tai->time-monotonic time-in (tm:as-empty-time time-in)) )
    938956
    939957(define (time-tai->time-monotonic! time-in)
    940   (time-type-check time-in time-tai 'time-tai->time-monotonic!)
     958  (tm:check-time-has-type 'time-tai->time-monotonic! time-in 'time-tai)
    941959  (tm:time-tai->time-monotonic time-in time-in) )
    942960
    943961(define (time-utc->time-tai time-in)
    944   (time-type-check time-in time-utc 'time-utc->time-tai)
     962  (tm:check-time-has-type 'time-utc->time-tai time-in 'time-utc)
    945963  (tm:time-utc->time-tai time-in (tm:as-empty-time time-in)) )
    946964
    947965(define (time-utc->time-tai! time-in)
    948   (time-type-check time-in time-utc 'time-utc->time-tai!)
     966  (tm:check-time-has-type 'time-utc->time-tai! time-in 'time-utc)
    949967  (tm:time-utc->time-tai time-in time-in) )
    950968
    951969(define (time-utc->time-monotonic time-in)
    952   (time-type-check time-in time-utc 'time-utc->time-monotonic)
     970  (tm:check-time-has-type 'time-utc->time-monotonic time-in 'time-utc)
    953971  (tm:time-utc->time-monotonic time-in (tm:as-empty-time time-in)) )
    954972
    955973(define (time-utc->time-monotonic! time-in)
    956   (time-type-check time-in time-utc 'time-utc->time-monotonic!)
     974  (tm:check-time-has-type 'time-utc->time-monotonic! time-in 'time-utc)
    957975  (tm:time-utc->time-monotonic time-in time-in) )
    958976
    959977(define (time-monotonic->time-utc time-in)
    960   (time-type-check time-in time-monotonic 'time-monotoinc->time-utc)
     978  (tm:check-time-has-type 'time-monotoinc->time-utc time-in 'time-monotonic)
    961979  (let ([ntime (copy-time time-in)])
    962980    (tm:time-monotonic->time-utc ntime ntime) ) )
    963981
    964982(define (time-monotonic->time-utc! time-in)
    965   (time-type-check time-in time-monotonic 'time-monotoinc->time-utc!)
     983  (tm:check-time-has-type 'time-monotoinc->time-utc! time-in 'time-monotonic)
    966984  (tm:time-monotonic->time-utc time-in time-in) )
    967985
    968986(define (time-monotonic->time-tai time-in)
    969   (time-type-check time-in time-monotonic 'time-monotoinc->time-tai)
     987  (tm:check-time-has-type 'time-monotoinc->time-tai time-in 'time-monotonic)
    970988  (tm:time-monotonic->time-tai time-in (tm:as-empty-time time-in)) )
    971989
    972990(define (time-monotonic->time-tai! time-in)
    973   (time-type-check time-in time-monotonic 'time-monotoinc->time-tai!)
     991  (tm:check-time-has-type 'time-monotoinc->time-tai! time-in 'time-monotonic)
    974992  (tm:time-monotonic->time-tai time-in time-in) )
    975993
     
    981999  (or (local-timezone-abbreviation) UNKNOWN-LOCAL-TZ-NAME))
    9821000
    983 (define %make-timezone-locale cons)
     1001(define tm:make-timezone-locale cons)
    9841002
    9851003(define %timezone-locale-dst? car)
     
    9911009  (unless (timezone-components? tzc)
    9921010    (error 'make-timezone-locale "invalid timezone components" tzc) )
    993   (%make-timezone-locale dstf tzc) )
     1011  (tm:make-timezone-locale dstf tzc) )
    9941012
    9951013(define (timezone-locale? obj)
     
    10501068(define utc-timezone-locale
    10511069  (make-parameter
    1052     (make-timezone-locale #f
    1053       (make-timezone-components 'std-name "UTC" 'std-offset 0))
     1070    (make-timezone-locale #f (make-timezone-components 'std-name "UTC" 'std-offset 0))
    10541071    (lambda (obj)
    10551072      (if (timezone-locale? obj)
     
    10621079  (let* ([tzi (optional r (local-timezone-locale))]
    10631080         [tzc (%timezone-locale-component tzi)]
    1064          [tzn (timezone-component-ref tzc
    1065                 (if (%timezone-locale-dst? tzi)
    1066                   'dst-name
    1067                   'std-name))])
     1081         [tzn (timezone-component-ref tzc (if (%timezone-locale-dst? tzi) 'dst-name 'std-name))])
    10681082    ; TZ may not be set
    10691083    (and (not (eq? tzn UNKNOWN-LOCAL-TZ-NAME)) tzn) ) )
     
    10741088  (let* ([tzi (optional r (local-timezone-locale))]
    10751089         [tzc (%timezone-locale-component tzi)]
    1076          [tzo (timezone-component-ref tzc
    1077                 (if (%timezone-locale-dst? tzi)
    1078                   'dst-offset
    1079                   'std-offset))])
     1090         [tzo (timezone-component-ref tzc (if (%timezone-locale-dst? tzi) 'dst-offset 'std-offset))])
    10801091    ; TZ may not be set but if it is then convert to ISO 8601
    10811092    (if tzo (fxneg tzo) 0) ) )
     
    10961107
    10971108(define-record-type date
    1098   (tm:make-date nanosecond second minute hour day month year zone-offset
    1099                 zone-name dstf wday yday jday)
    1100   date?
    1101   (nanosecond date-nanosecond tm:date-nanosecond-set!)
    1102   (second date-second tm:date-second-set!)
    1103   (minute date-minute tm:date-minute-set!)
    1104   (hour date-hour tm:date-hour-set!)
    1105   (day date-day tm:date-day-set!)
    1106   (month date-month tm:date-month-set!)
    1107   (year date-year tm:date-year-set!)
    1108   (zone-offset date-zone-offset tm:date-zone-offset-set!)
     1109  (%make-date nanosecond second minute hour day month year
     1110              zone-offset zone-name dstf
     1111              wday yday jday)
     1112  %date?
     1113  (nanosecond %date-nanosecond %date-nanosecond-set!)
     1114  (second %date-second %date-second-set!)
     1115  (minute %date-minute %date-minute-set!)
     1116  (hour %date-hour %date-hour-set!)
     1117  (day %date-day %date-day-set!)
     1118  (month %date-month %date-month-set!)
     1119  (year %date-year %date-year-set!)
     1120  (zone-offset %date-zone-offset %date-zone-offset-set!)
    11091121  ;; non-srfi extn
    1110   (zone-name date-zone-name #;tm:date-zone-name-set!)
    1111   (dstf date-dst? #;tm:date-dst-set!)
    1112   (wday date-wday tm:date-wday-set!)
    1113   (yday date-yday tm:date-yday-set!)
    1114   (jday date-jday tm:date-jday-set!) )
     1122  (zone-name %date-zone-name)
     1123  (dstf %date-dst?)
     1124  (wday %date-wday %date-wday-set!)
     1125  (yday %date-yday %date-yday-set!)
     1126  (jday %date-jday %date-jday-set!) )
     1127
     1128;;
     1129
     1130(define-inline (%check-date loc obj)
     1131  (##sys#check-structure obj 'date loc) )
     1132
     1133;;
     1134
     1135(define (tm:date-nanosecond-set! date x)
     1136  (%date-nanosecond-set! date (->fixnum x)) )
     1137
     1138(define (tm:date-second-set! date x)
     1139  (%date-second-set! date (->fixnum x)) )
     1140
     1141(define (tm:date-minute-set! date x)
     1142  (%date-minute-set! date (->fixnum x)) )
     1143
     1144(define (tm:date-hour-set! date x)
     1145  (%date-hour-set! date (->fixnum x)) )
     1146
     1147(define (tm:date-day-set! date x)
     1148  (%date-day-set! date (->fixnum x)) )
     1149
     1150(define (tm:date-month-set! date x)
     1151  (%date-month-set! date (->fixnum x)) )
     1152
     1153(define (tm:date-year-set! date x)
     1154  (%date-year-set! date (->fixnum x)) )
     1155
     1156(define (tm:date-zone-offset-set! date x)
     1157  (%date-zone-offset-set! date (->fixnum x)) )
    11151158
    11161159;; Internal Date CTOR
    11171160
    1118 (define (%make-date nanosecond second minute hour day month year zone-offset
    1119                     zone-name dstf wday yday jday)
    1120   (tm:make-date
     1161(define (tm:make-date nanosecond second minute hour day month year
     1162                      zone-offset zone-name dstf
     1163                      wday yday jday)
     1164  (%make-date
    11211165    (->fixnum nanosecond)
    1122     (->fixnum second)
    1123     (->fixnum minute)
    1124     (->fixnum hour)
    1125     (->fixnum day)
    1126     (->fixnum month)
    1127     (->fixnum year)
    1128     (->fixnum zone-offset)
    1129     zone-name dstf
     1166    (->fixnum second) (->fixnum minute) (->fixnum hour)
     1167    (->fixnum day) (->fixnum month) (->fixnum year)
     1168    (->fixnum zone-offset) zone-name dstf
    11301169    wday yday jday) )
    11311170
    11321171;; Parameter Checking
    11331172
    1134 (define (tm:check-date loc obj)
    1135   (unless (date? obj)
    1136     (error loc "invalid date" obj)) )
     1173(define tm:check-date %check-date)
    11371174
    11381175(define tm:vali-day
     
    11771214  (fprintf out
    11781215    "#,(date ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A)"
    1179     (date-nanosecond dt)
    1180     (date-second dt) (date-minute dt) (date-hour dt)
    1181     (date-day dt) (date-month dt) (date-year dt)
    1182     (date-zone-offset dt)
    1183     (date-zone-name dt) (date-dst? dt)
    1184     (date-wday dt) (date-yday dt) (date-jday dt)) )
     1216    (%date-nanosecond dt)
     1217    (%date-second dt) (%date-minute dt) (%date-hour dt)
     1218    (%date-day dt) (%date-month dt) (%date-year dt)
     1219    (%date-zone-offset dt)
     1220    (%date-zone-name dt) (%date-dst? dt)
     1221    (%date-wday dt) (%date-yday dt) (%date-jday dt)) )
    11851222
    11861223(define-reader-ctor 'date
    11871224  (lambda (nanosecond second minute hour day month year zone-offset . rest)
    11881225    (let-optionals rest ([zone-name #f] [dstf #f] [wday #f] [yday #f] [jday #f])
    1189       (%make-date
     1226      ($make-date
    11901227        nanosecond
    11911228        second minute hour
     
    11941231        zone-name dstf
    11951232        wday yday jday))))
    1196 
    1197 ;; Date Comparison
    1198 
    1199 (define (date=? dat1 dat2)
    1200   (= (date->julian-day dat1) (date->julian-day dat2)) )
    1201 
    1202 (define (date<? dat1 dat2)
    1203   (< (date->julian-day dat1) (date->julian-day dat2)) )
    1204 
    1205 (define (date>? dat1 dat2)
    1206   (> (date->julian-day dat1) (date->julian-day dat2)) )
    1207 
    1208 (define (date<=? dat1 dat2)
    1209   (<= (date->julian-day dat1) (date->julian-day dat2)) )
    1210 
    1211 (define (date>=? dat1 dat2)
    1212   (<= (date->julian-day dat1) (date->julian-day dat2)) )
    1213 
    1214 ;; Date Arithmetic
    1215 
    1216 (define (date-difference dat1 dat2 . clock-type)
    1217   (let ([tim1 (apply date->time dat1 clock-type)]
    1218         [tim2 (apply date->time dat2 clock-type)])
    1219     (tm:time-difference tim1 tim2 (tm:as-empty-time tim1)) ) )
    1220 
    1221 (define (date-add-duration dat dur . clock-type)
    1222   (let ([tim (apply date->time dat clock-type)])
    1223     (time->date (tm:add-duration tim dur (tm:as-empty-time tim))) ) )
    1224 
    1225 (define (date-subtract-duration dat dur . clock-type)
    1226   (let ([tim (apply date->time dat clock-type)])
    1227     (time->date (tm:subtract-duration tim dur (tm:as-empty-time tim))) ) )
    12281233
    12291234;; Date CTOR
     
    12401245        (set! dstf #f)))
    12411246    (tm:vali-date 'make-date nsec sec min hr dy mn yr tzo tzn)
    1242     (%make-date nsec sec min hr dy mn yr tzo tzn dstf #f #f #f) ) )
     1247    ($make-date nsec sec min hr dy mn yr tzo tzn dstf #f #f #f) ) )
    12431248
    12441249(define (copy-date date)
    1245   (tm:make-date
    1246     (date-nanosecond date)
    1247     (date-second date) (date-minute date) (date-hour date)
    1248     (date-day date) (date-month date) (date-year date)
    1249     (date-zone-offset date)
    1250     (date-zone-name date) (date-dst? date)
    1251     (date-wday date) (date-yday date) (date-jday date)) )
     1250  (%make-date
     1251    (%date-nanosecond date)
     1252    (%date-second date) (%date-minute date) (%date-hour date)
     1253    (%date-day date) (%date-month date) (%date-year date)
     1254    (%date-zone-offset date)
     1255    (%date-zone-name date) (%date-dst? date)
     1256    (%date-wday date) (%date-yday date) (%date-jday date)) )
    12521257
    12531258;; Converts a seconds value, may be fractional, into a date type.
     
    12681273           [tzo (timezone-locale-offset tzi)]
    12691274           [tv (seconds->utc-time (+ isec tzo))])
    1270       (%make-date
     1275      ($make-date
    12711276        (round (* (- fsec isec) NS/S))
    12721277        (vector-ref tv 0) (vector-ref tv 1) (vector-ref tv 2)
     
    12781283(define (current-date . tz-info)
    12791284  (apply time-utc->date (tm:current-time-utc) tz-info) )
     1285
     1286;;
     1287
     1288(define date? %date?)
     1289
     1290;;
     1291
     1292(define date-nanosecond %date-nanosecond)
     1293(define date-second %date-second)
     1294(define date-minute %date-minute)
     1295(define date-hour %date-hour)
     1296(define date-day %date-day)
     1297(define date-month %date-month)
     1298(define date-year %date-year)
     1299(define date-zone-offset %date-zone-offset)
     1300
     1301;; Date Comparison
     1302
     1303(define (%date-compare/fields loc x y)
     1304  (%check-date loc x)
     1305  (%check-date loc y)
     1306  (if (not (fx= (%date-zone-offset x) (%date-zone-offset y)))
     1307    (error loc "cannot compare dates from different time-zones" x y)
     1308    (let ((dif (fx- (%date-year x) (%date-year y))))
     1309      (if (not (fx= 0 dif))
     1310        dif
     1311        (let ((dif (fx- (%date-year x) (%date-year y))))
     1312          (if (not (fx= 0 dif))
     1313            dif
     1314            (let ((dif (fx- (%date-month x) (%date-month y))))
     1315              (if (not (fx= 0 dif))
     1316                dif
     1317                (let ((dif (fx- (%date-hour x) (%date-hour y))))
     1318                  (if (not (fx= 0 dif))
     1319                    dif
     1320                    (let ((dif (fx- (%date-minute x) (%date-minute y))))
     1321                      (if (not (fx= 0 dif))
     1322                        dif
     1323                        (let ((dif (fx- (%date-second x) (%date-second y))))
     1324                          (if (not (fx= 0 dif))
     1325                            dif
     1326                            (fx- (%date-nanosecond x) (%date-nanosecond y)) ) ) ) ) ) ) ) ) ) ) ) ) ) )
     1327
     1328(define (date=?/fields dat1 dat2)
     1329  (fx= 0 (%date-compare/fields 'date=?/fields dat1 dat2)) )
     1330
     1331(define (date<?/fields dat1 dat2)
     1332  (fx< 0 (%date-compare/fields 'date<?/fields dat1 dat2)) )
     1333
     1334(define (date<=?/fields dat1 dat2)
     1335  (fx<= 0 (%date-compare/fields 'date<=?/fields dat1 dat2)) )
     1336
     1337(define (date>?/fields dat1 dat2)
     1338  (fx> 0 (%date-compare/fields 'date>?/fields dat1 dat2)) )
     1339
     1340(define (date>=?/fields dat1 dat2)
     1341  (fx>= 0 (%date-compare/fields 'date>=?/fields dat1 dat2)) )
     1342
     1343(define (date=? dat1 dat2)
     1344  (= (date->julian-day dat1) (date->julian-day dat2)) )
     1345
     1346(define (date<? dat1 dat2)
     1347  (< (date->julian-day dat1) (date->julian-day dat2)) )
     1348
     1349(define (date>? dat1 dat2)
     1350  (> (date->julian-day dat1) (date->julian-day dat2)) )
     1351
     1352(define (date<=? dat1 dat2)
     1353  (<= (date->julian-day dat1) (date->julian-day dat2)) )
     1354
     1355(define (date>=? dat1 dat2)
     1356  (<= (date->julian-day dat1) (date->julian-day dat2)) )
     1357
     1358;; Date Arithmetic
     1359
     1360(define (date-difference dat1 dat2 . clock-type)
     1361  (let ([tim1 (apply date->time dat1 clock-type)]
     1362        [tim2 (apply date->time dat2 clock-type)])
     1363    (tm:time-difference tim1 tim2 (tm:as-empty-time tim1)) ) )
     1364
     1365(define (date-add-duration dat dur . clock-type)
     1366  (let ([tim (apply date->time dat clock-type)])
     1367    (time->date (tm:add-duration tim dur (tm:as-empty-time tim))) ) )
     1368
     1369(define (date-subtract-duration dat dur . clock-type)
     1370  (let ([tim (apply date->time dat clock-type)])
     1371    (time->date (tm:subtract-duration tim dur (tm:as-empty-time tim))) ) )
    12801372
    12811373;; Date/Time Conversion
     
    13201412     (/ (+ seconds tzo SEC/DY/2) SEC/DY)) )
    13211413
     1414;; Is the time object one second before a leap second?
     1415
     1416(define (tm:tai-before-leap-second? time)
     1417  (let ([sec (%time-second time)])
     1418    (let loop ([lst tm:second-before-leap-second-table])
     1419      (and (not (null? lst))
     1420           (or (= sec (car lst))
     1421               (loop (cdr lst)) ) ) ) ) )
     1422
     1423;; Time to Date
     1424
    13221425(define (tm:time->date time tz-info ttype loc)
    13231426  ; Validate time type for caller
    1324   (time-type-check time ttype loc)
     1427  (tm:check-time-has-type time ttype loc)
    13251428  ; The tz-info is caller's rest parameter
    13261429  (let ([tzo (optional tz-info (local-timezone-locale))]
     
    13351438      (receive [secs day month year]
    13361439          (tm:decode-julian-day-number
    1337             (tm:seconds->julian-day-number (time-second time) tzo))
     1440            (tm:seconds->julian-day-number (%time-second time) tzo))
    13381441        (let* ([hours (fx/ secs SEC/HR)]
    13391442               [rsecs (fxmod secs SEC/HR)]
    13401443               [minutes (fx/ rsecs SEC/MIN)]
    13411444               [seconds (fxmod rsecs SEC/MIN)])
    1342           (%make-date
    1343             (time-nanosecond time)
     1445          ($make-date
     1446            (%time-nanosecond time)
    13441447            seconds minutes hours
    13451448            day month year
     
    13561459              (tm:time->date
    13571460                (tm:subtract-duration tm-utc ONE-SECOND-DURATION tm-utc)
    1358                 tz-info time-utc 'time-tai->date)])
     1461                tz-info 'time-utc 'time-tai->date)])
    13591462        (%date-second-set! dt SEC/MIN) ; note full minute!
    13601463        dt )
    1361       (tm:time->date tm-utc tz-info time-utc 'time-tai->date)) ) )
     1464      (tm:time->date tm-utc tz-info 'time-utc 'time-tai->date)) ) )
    13621465
    13631466(define (time-utc->date time . tz-info)
    1364   (tm:time->date time tz-info time-utc 'time-utc->date) )
     1467  (tm:time->date time tz-info 'time-utc 'time-utc->date) )
    13651468
    13661469(define (time-monotonic->date time . tz-info)
    1367   (tm:time->date time tz-info time-monotonic 'time-monotonic->date) )
     1470  (tm:time->date time tz-info 'time-monotonic 'time-monotonic->date) )
    13681471
    13691472(define (time->date time . tz-info)
    1370   (switch (time-type time)
    1371     [time-monotonic (apply time-monotonic->date time tz-info)]
    1372     [time-tai (apply time-tai->date time tz-info)]
    1373     [time-utc (apply time-utc->date time tz-info)]
    1374     [else (error 'time->date "invalid clock-type" time)]) )
     1473  (case (%time-type time)
     1474    [(time-monotonic) (apply time-monotonic->date time tz-info)]
     1475    [(time-tai)       (apply time-tai->date time tz-info)]
     1476    [(time-utc)       (apply time-utc->date time tz-info)]
     1477    [else
     1478      (error 'time->date "invalid clock-type" time)]) )
    13751479
    13761480(define (date->time-utc date)
    1377   (let ([nanosecond (date-nanosecond date)]
    1378         [second (date-second date)]
    1379         [minute (date-minute date)]
    1380         [hour (date-hour date)]
    1381         [day (date-day date)]
    1382         [month (date-month date)]
    1383         [year (date-year date)]
    1384         [tzo (date-zone-offset date)])
     1481  (let ([nanosecond (%date-nanosecond date)]
     1482        [second (%date-second date)]
     1483        [minute (%date-minute date)]
     1484        [hour (%date-hour date)]
     1485        [day (%date-day date)]
     1486        [month (%date-month date)]
     1487        [year (%date-year date)]
     1488        [tzo (%date-zone-offset date)])
    13851489    (let ([jdays
    13861490            (- (tm:encode-julian-day-number day month year)
    13871491               TAI-EPOCH-IN-JD)])
    1388       (%make-time time-utc
     1492      (tm:make-time 'time-utc
    13891493        nanosecond
    13901494        (+ (* (- jdays ONE-HALF) SEC/DY)
    1391            (fx+ (fx+ (fx* hour SEC/HR) (fx+ (fx* minute SEC/MIN) second))
    1392                 (fxneg tzo)))) ) ) )
     1495           (fx+ (fx+ (fx* hour SEC/HR) (fx+ (fx* minute SEC/MIN) second)) (fxneg tzo)))) ) ) )
    13931496
    13941497(define (date->time-tai date)
    1395   (if (= (date-second date) 60)
     1498  (if (= (%date-second date) 60)
    13961499    (let ([tm-tai (time-utc->time-tai! (date->time-utc date))])
    13971500      (tm:subtract-duration tm-tai ONE-SECOND-DURATION tm-tai))
     
    14021505
    14031506(define (date->time date . clock-type)
    1404   (switch (optional clock-type (default-date-clock-type))
    1405     [time-monotonic (date->time-monotonic date)]
    1406     [time-tai (date->time-tai date)]
    1407     [time-utc (date->time-utc date)]
    1408     [else (error 'date->time "invalid clock-type" clock-type)]) )
     1507  (case (optional clock-type (default-date-clock-type))
     1508    [(time-monotonic) (date->time-monotonic date)]
     1509    [(time-tai)       (date->time-tai date)]
     1510    [(time-utc)       (date->time-utc date)]
     1511    [else
     1512      (error 'date->time "invalid clock-type" clock-type)]) )
    14091513
    14101514;;
    14111515
    14121516(define (leap-year? date)
    1413   (tm:leap-year? (date-year date)) )
     1517  (%check-date 'leap-year? obj)
     1518  (tm:leap-year? (%date-year date)) )
    14141519
    14151520;;
     
    14291534(define (date-year-day date)
    14301535  (or (date-yday date)
    1431       (let ([yday
    1432               (tm:year-day
    1433                 (date-day date) (date-month date) (date-year date))])
    1434         (tm:date-yday-set! date yday)
     1536      (let ([yday (tm:year-day (%date-day date) (%date-month date) (%date-year date))])
     1537        (%date-yday-set! date yday)
    14351538        yday ) ) )
    14361539
     
    14521555
    14531556(define (date-week-day date)
    1454   (or (date-wday date)
    1455       (let ([wday
    1456               (tm:week-day
    1457                 (date-day date) (date-month date) (date-year date))])
    1458         (tm:date-wday-set! date wday)
     1557  (or (%date-wday date)
     1558      (let ([wday (tm:week-day (%date-day date) (%date-month date) (%date-year date))])
     1559        (%date-wday-set! date wday)
    14591560        wday ) ) )
    14601561
    14611562(define (date-week-number date . rest)
    14621563  (let ([day-of-week-starting-week (optional rest 0)])
    1463     (fx/ (fx- (date-year-day date)
    1464               (tm:days-before-first-week date day-of-week-starting-week))
     1564    (fx/ (fx- (%date-year-day date) (tm:days-before-first-week date day-of-week-starting-week))
    14651565         DY/WK) ) )
    14661566
    1467 ;;
     1567;; tm:julian-day
    14681568
    14691569; Does the nanoseconds value contribute anything to the julian day?
    1470 ; The range is < 1 second!
    1471 (define (tm:julian-day nanosecond second minute hour day month year tzo)
     1570; The range is < 1 second here (but not in the reference).
     1571
     1572(define (tm:julian-day-exact nanosecond second minute hour day month year tzo)
    14721573  (+ (- (tm:encode-julian-day-number day month year) ONE-HALF)
    1473      (/ (+ (fx+ (fx* hour SEC/HR) (fx+ (fx* minute SEC/MIN) second))
    1474            (/ nanosecond NS/S)
    1475            (fxneg tzo))
     1574     (/ (+ (fx+ (fx+ (fx* hour SEC/HR) (fx+ (fx* minute SEC/MIN) second)) (fxneg tzo))
     1575           (/ nanosecond NS/S))
    14761576        SEC/DY)) )
    14771577
     1578#;
     1579(define (tm:julian-day-inexact nanosecond second minute hour day month year tzo)
     1580  (fp+ (fp- (exact->inexact (tm:encode-julian-day-number day month year)) iONE-HALF)
     1581       (fp/ (fp+ (exact->inexact
     1582                  (fx+ (fx+ (fx* hour SEC/HR) (fx+ (fx* minute SEC/MIN) second)) (fxneg tzo)))
     1583                 (fp/ (exact->inexact nanosecond) iNS/S))
     1584            iSEC/DY)) )
     1585
     1586(define tm:julian-day tm:julian-day-exact)
     1587
    14781588;;
    14791589
    14801590(define (date->julian-day date)
     1591  (%check-date 'date->julian-day date)
    14811592  (or (date-jday date)
    14821593      (let ([jdn
    14831594              (tm:julian-day
    1484                 (date-nanosecond date)
    1485                 (date-second date) (date-minute date) (date-hour date)
    1486                 (date-day date) (date-month date) (date-year date)
    1487                 (date-zone-offset date))])
    1488         (tm:date-jday-set! date jdn)
     1595                (%date-nanosecond date)
     1596                (%date-second date) (%date-minute date) (%date-hour date)
     1597                (%date-day date) (%date-month date) (%date-year date)
     1598                (%date-zone-offset date))])
     1599        (%date-jday-set! date jdn)
    14891600        jdn ) ) )
    14901601
     
    14921603  (- (date->julian-day date) TAI-EPOCH-IN-MODIFIED-JD) )
    14931604
    1494 ;;
     1605;; Time to Julian-day
    14951606
    14961607(define (tm:seconds->julian-day nanos secs)
     
    14981609
    14991610(define (tm:time-utc->julian-day time)
    1500   (tm:seconds->julian-day
    1501     (time-nanosecond time) (time-second time)) )
     1611  (tm:seconds->julian-day (%time-nanosecond time) (%time-second time)) )
    15021612
    15031613(define (tm:time-tai->julian-day time)
    1504   (let ([sec (time-second time)])
    1505     (tm:seconds->julian-day
    1506       (time-nanosecond time) (- sec (tm:leap-second-delta sec))) ) )
     1614  (let ([sec (%time-second time)])
     1615    (tm:seconds->julian-day (%time-nanosecond time) (- sec (tm:leap-second-delta sec))) ) )
     1616
     1617(define (time-utc->julian-day time)
     1618  (tm:check-time-has-type time 'time-utc 'time-utc->julian-day)
     1619  (tm:time-utc->julian-day time) )
     1620
     1621(define (time-tai->julian-day time)
     1622  (tm:check-time-has-type time 'time-tai 'time-tai->julian-day)
     1623  (tm:time-tai->julian-day time) )
     1624
     1625(define (time-monotonic->julian-day time)
     1626  (tm:check-time-has-type time 'time-monotonic 'time-monotonic->julian-day)
     1627  (tm:time-tai->julian-day time) )
     1628
     1629(define (time->julian-day time)
     1630  (case (%time-type time)
     1631    [(time-monotonic) (tm:time-tai->julian-day time)]
     1632    [(time-tai)       (tm:time-tai->julian-day time)]
     1633    [(time-utc)       (tm:time-utc->julian-day time)]
     1634    [else
     1635      (error 'time->julian-day "invalid clock-type" time)]) )
     1636
     1637;; Time to Modified-julian-day
    15071638
    15081639(define (tm:time-utc->modified-julian-day time)
     
    15121643  (- (tm:time-tai->julian-day time) TAI-EPOCH-IN-MODIFIED-JD) )
    15131644
    1514 ;;
    1515 
    1516 (define (time-utc->julian-day time)
    1517   (time-type-check time time-utc 'time-utc->julian-day)
    1518   (tm:time-utc->julian-day time) )
    1519 
    1520 (define (time-tai->julian-day time)
    1521   (time-type-check time time-tai 'time-tai->julian-day)
    1522   (tm:time-tai->julian-day time) )
    1523 
    1524 (define (time-monotonic->julian-day time)
    1525   (time-type-check time time-monotonic 'time-monotonic->julian-day)
    1526   (tm:time-tai->julian-day time) )
    1527 
    1528 (define (time->julian-day time)
    1529   (switch (time-type time)
    1530     [time-monotonic (tm:time-tai->julian-day time)]
    1531     [time-tai (tm:time-tai->julian-day time)]
    1532     [time-utc (tm:time-utc->julian-day time)]
    1533     [else (error 'time->julian-day "invalid clock-type" time)]) )
    1534 
    1535 ;;
    1536 
    15371645(define (time-utc->modified-julian-day time)
    1538   (time-type-check time time-utc 'time-utc->modified-julian-day)
     1646  (tm:check-time-has-type time 'time-utc 'time-utc->modified-julian-day)
    15391647  (tm:time-utc->modified-julian-day time) )
    15401648
    15411649(define (time-tai->modified-julian-day time)
    1542   (time-type-check time time-tai 'time-tai->modified-julian-day)
     1650  (tm:check-time-has-type time 'time-tai 'time-tai->modified-julian-day)
    15431651  (tm:time-tai->modified-julian-day time) )
    15441652
    15451653(define (time-monotonic->modified-julian-day time)
    1546   (time-type-check time time-monotonic 'time-monotonic->modified-julian-day)
     1654  (tm:check-time-has-type time 'time-monotonic 'time-monotonic->modified-julian-day)
    15471655  (tm:time-tai->modified-julian-day time) )
    15481656
    15491657(define (time->modified-julian-day time)
    1550   (switch (time-type time)
    1551     [time-monotonic (tm:time-tai->modified-julian-day time)]
    1552     [time-tai (tm:time-tai->modified-julian-day time)]
    1553     [time-utc (tm:time-utc->modified-julian-day time)]
    1554     [else (error 'time->modified-julian-day "invalid clock-type" time)]) )
    1555 
    1556 ;;
     1658  (case (%time-type time)
     1659    [(time-monotonic) (tm:time-tai->modified-julian-day time)]
     1660    [(time-tai)       (tm:time-tai->modified-julian-day time)]
     1661    [(time-utc)       (tm:time-utc->modified-julian-day time)]
     1662    [else
     1663      (error 'time->modified-julian-day "invalid clock-type" time)]) )
     1664
     1665;; Julian-day to Time
    15571666
    15581667(define (julian-day->time-utc jdn)
    15591668  (let ([ns (* (- jdn TAI-EPOCH-IN-JD) SEC/DY NS/S)])
    1560     (%make-time time-utc
    1561       (abs (remainder ns NS/S)) (floor (/ ns NS/S))) ) )
     1669    (tm:make-time 'time-utc (abs (remainder ns NS/S)) (floor (/ ns NS/S))) ) )
    15621670
    15631671(define (julian-day->time-tai jdn)
     
    15701678  (apply time-utc->date (julian-day->time-utc jdn) tz-info) )
    15711679
    1572 ;;
     1680;; Modified-julian-day to Time
    15731681
    15741682(define (modified-julian-day->time-utc jdn)
     
    15841692  (apply julian-day->date (+ jdn TAI-EPOCH-IN-MODIFIED-JD) tz-info) )
    15851693
    1586 ;;
     1694;; The Julian-day
    15871695
    15881696(define (current-julian-day)
  • release/3/srfi-19/trunk/srfi-19-io.scm

    r11875 r12020  
    593593
    594594      (list #\b char-alphabetic? locale-reader-abbr-month
    595         (lambda (val object) (%date-month-set! object val)))
     595        (lambda (val object) (tm:date-month-set! object val)))
    596596
    597597      (list #\B char-alphabetic? locale-reader-long-month
    598         (lambda (val object) (%date-month-set! object val)))
     598        (lambda (val object) (tm:date-month-set! object val)))
    599599
    600600      (list #\d char-numeric? ireader2
    601         (lambda (val object) (%date-day-set! object val)))
     601        (lambda (val object) (tm:date-day-set! object val)))
    602602
    603603      (list #\e char-fail eireader2
    604         (lambda (val object) (%date-day-set! object val)))
     604        (lambda (val object) (tm:date-day-set! object val)))
    605605
    606606      (list #\h char-alphabetic? locale-reader-abbr-month
    607         (lambda (val object) (%date-month-set! object val)))
     607        (lambda (val object) (tm:date-month-set! object val)))
    608608
    609609      (list #\H char-numeric? ireader2
    610         (lambda (val object) (%date-hour-set! object val)))
     610        (lambda (val object) (tm:date-hour-set! object val)))
    611611
    612612      (list #\k char-fail eireader2
    613         (lambda (val object) (%date-hour-set! object val)))
     613        (lambda (val object) (tm:date-hour-set! object val)))
    614614
    615615      (list #\m char-numeric? ireader2
    616         (lambda (val object) (%date-month-set! object val)))
     616        (lambda (val object) (tm:date-month-set! object val)))
    617617
    618618      (list #\M char-numeric? ireader2
    619         (lambda (val object) (%date-minute-set! object val)))
     619        (lambda (val object) (tm:date-minute-set! object val)))
    620620
    621621      (list #\N char-numeric? ireader7
    622         (lambda (val object) (%date-nanosecond-set! object val)))
     622        (lambda (val object) (tm:date-nanosecond-set! object val)))
    623623
    624624      (list #\S char-numeric? ireader2
    625         (lambda (val object) (%date-second-set! object val)))
     625        (lambda (val object) (tm:date-second-set! object val)))
    626626
    627627      (list #\y char-fail eireader2
    628628        (lambda (val object)
    629           (%date-year-set! object (tm:natural-year val))))
     629          (tm:date-year-set! object (tm:natural-year val))))
    630630
    631631      (list #\Y char-numeric? ireader4
    632         (lambda (val object) (%date-year-set! object val)))
     632        (lambda (val object) (tm:date-year-set! object val)))
    633633
    634634      (list #\z
     
    640640        tm:zone-reader
    641641        (lambda (val object)
    642           (%date-zone-offset-set! object val))) ) ) )
     642          (tm:date-zone-offset-set! object val))) ) ) )
    643643
    644644(define (tm:date-reader date format-rem len-rem port)
     
    681681  (let ([port #f]
    682682        [newdate
    683           (tm:make-date 0 0 0 0 #f #f #f
    684             (local-timezone-offset) (local-timezone-name) (local-timezone-dst?) #f #f #f)])
     683          (tm:make-date
     684            0 0 0 0 #f #f #f
     685            (local-timezone-offset) (local-timezone-name) (local-timezone-dst?)
     686            #f #f #f)])
    685687    (let ([date-compl?
    686688            (lambda ()
  • release/3/srfi-19/trunk/srfi-19-period.scm

    r10022 r12020  
    4747
    4848(define-record-type time-period
    49   (tm:make-time-period beg end)
     49  (%make-time-period beg end)
    5050  time-period?
    51   (beg time-period-begin #;tm:set-time-period-begin!)
    52   (end time-period-end #;tm:set-time-period-end!) )
     51  (beg time-period-begin #;%set-time-period-begin!)
     52  (end time-period-end #;%set-time-period-end!) )
    5353
    5454(define-record-printer (time-period per out)
     
    5656    (time-period-begin per) (time-period-end per)) )
    5757
    58 (define-reader-ctor 'time-period tm:make-time-period)
     58(define-reader-ctor 'time-period %make-time-period)
    5959
    6060(define (tm:time-period-check obj loc)
     
    7373
    7474(define (tm:as-empty-time-period per)
    75   (tm:make-time-period
     75  (%make-time-period
    7676    (tm:as-empty-time (time-period-begin per))
    7777    (tm:as-empty-time (time-period-end per))) )
     
    129129            (if (eq? (tm:time-period-type per1) (tm:time-period-type per2))
    130130              per2
    131               (tm:make-time-period
     131              (%make-time-period
    132132                (tm:ensure-compatible-time
    133133                  (time-period-begin per1) (time-period-begin per2)
     
    202202  (when (eq? time-duration (time-type end))
    203203    (set! end (tm:add-duration beg end (tm:as-empty-time beg))))
    204   (tm:make-time-period
     204  (%make-time-period
    205205    beg
    206206    (tm:ensure-compatible-time beg end 'make-time-period)) )
     
    208208(define (copy-time-period per)
    209209  (tm:time-period-check per 'copy-time-period)
    210   (tm:make-time-period
     210  (%make-time-period
    211211    (copy-time (time-period-begin per))
    212212    (copy-time (time-period-end per))) )
     
    303303      (tm:time-period-intersection-values per1 per2 'time-period-intersection)
    304304    (and (tm:time<=? bi ei)
    305          (tm:make-time-period bi ei)) ) )
     305         (%make-time-period bi ei)) ) )
    306306
    307307(define (time-period-union per1 per2)
     
    319319               (receive [bu eu]
    320320                   (tm:time-point-union-values b1 e1 b2 e2)
    321                  (tm:make-time-period bu eu))) ) ) ) )
     321                 (%make-time-period bu eu))) ) ) ) )
    322322
    323323(define (time-period-span per1 per2)
     
    333333          (tm:ensure-compatible-time e1 (time-period-end per2)
    334334                                     'time-period-span))
    335       (tm:make-time-period bu eu) ) ) )
     335      (%make-time-period bu eu) ) ) )
    336336
    337337(define (time-period-shift per dur)
Note: See TracChangeset for help on using the changeset viewer.