Changeset 12029 in project


Ignore:
Timestamp:
09/29/08 06:37:55 (12 years ago)
Author:
Kon Lovett
Message:

Save.

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

Legend:

Unmodified
Added
Removed

  • release/3/srfi-19/trunk/srfi-19-common.scm

    r12020 r12029  
    1515(define-constant SEC/MIN  60)
    1616
     17#|
    1718(define-constant iNS/S    1000000000.0)
    1819(define-constant iSEC/DY  86400.0)
    19 
    2020(define-constant iONE-HALF  0.5)
     21|#
    2122
    2223(define-constant HR/DY 24)
    … …  
    4142  (if (fx< x 0) (fxneg x) x) )
    4243
     44#;
    4345(define-inline (inexact-integer? x)
    4446  (and (inexact? x) (integer? x)) )
    … …  
    7779    (fx- day-of-week-starting-week (tm:week-day 1 1 (date-year date)))
    7880    DY/WK) )
     81
     82;; There are 3 kinds of time record procedures:
     83;; %...   - generated (these are inline!)
     84;; tm:... - argument processing then %...
     85;; ...    - argument checking then tm:...
     86
     87(define-record-type/unsafe-inline-unchecked time
     88  (%make-time timtyp ns sec)
     89  %time?
     90  (timtyp %time-type        %set-time-type!)
     91  (ns     %time-nanosecond  %set-time-nanosecond!)
     92  (sec    %time-second      %set-time-second!) )
     93
     94(define-inline (%check-time loc obj)
     95  (##sys#check-structure obj 'time loc) )

  • release/3/srfi-19/trunk/srfi-19-core.scm

    r12020 r12029  
    109109      seconds->time)
    110110    (export
    111       ;; Deprecated
    112       local-timezone-info
    113       local-timezone-name local-timezone-offset local-timezone-dst?
    114111      ;; SRFI-19 extensions
    115112      ONE-SECOND-DURATION ONE-NANOSECOND-DURATION
    116113      time-type?
    117114      make-duration
    118       divide-duration divide-duration!
    119       multiply-duration multiply-duration!
    120       srfi-19:current-time srfi-19:time?
    121       time->srfi-18-time srfi-18-time->time
    122       time-max time-min
    123       time-negative? time-positive? time-zero?
    124       time-abs time-abs!
    125       time-negate time-negate!
    126       seconds->time/type seconds->date/type
    127       time->nanoseconds nanoseconds->time
     115      divide-duration
     116      divide-duration!
     117      multiply-duration
     118      multiply-duration!
     119      srfi-19:current-time
     120      srfi-19:time?
     121      time->srfi-18-time
     122      srfi-18-time->time
     123      date-compare/fields
     124      date=?/fields
     125      date>?/fields
     126      date<?/fields
     127      date>=?/fields
     128      date<=?/fields
     129      date-compare
     130      time-max
     131      time-min
     132      time-negative?
     133      time-positive?
     134      time-zero?
     135      time-abs
     136      time-abs!
     137      time-negate
     138      time-negate!
     139      seconds->time/type
     140      seconds->date/type
     141      time->nanoseconds
     142      nanoseconds->time
    128143      nanoseconds->seconds
    129144      read-leap-second-table
    130       time->milliseconds milliseconds->time
     145      time->milliseconds
     146      milliseconds->time
    131147      milliseconds->seconds
    132148      time->date
    133       make-timezone-locale timezone-locale?
    134       timezone-locale-name timezone-locale-offset timezone-locale-dst?
     149      make-timezone-locale
     150      timezone-locale?
     151      timezone-locale-name
     152      timezone-locale-offset
     153      timezone-locale-dst?
    135154      make-local-timezone-locale
    136       local-timezone-locale utc-timezone-locale
     155      local-timezone-locale
     156      utc-timezone-locale
    137157      default-date-clock-type
    138158      date-zone-name
    … …  
    140160      copy-date
    141161      date->time
    142       date-difference date-add-duration date-subtract-duration
    143       date=? date>? date<? date>=? date<=?
    144       time->julian-day time->modified-julian-day
     162      date-difference
     163      date-add-duration
     164      date-subtract-duration
     165      date=?
     166      date>?
     167      date<?
     168      date>=?
     169      date<=?
     170      time->julian-day
     171      time->modified-julian-day
     172      leap-year?
     173      date-leap-year?
    145174      ;; SRFI-19
    146       time-tai time-utc time-monotonic time-thread time-process time-duration time-gc
     175      time-tai
     176      time-utc
     177      time-monotonic
     178      time-thread
     179      time-process
     180      time-duration
     181      time-gc
    147182      current-date
    148       current-julian-day current-modified-julian-day
     183      current-julian-day
     184      current-modified-julian-day
    149185      current-time
    150186      time-resolution
    151187      make-time time?
    152       time-type time-nanosecond time-second
    153       set-time-type! set-time-nanosecond! set-time-second!
     188      time-type
     189      time-nanosecond
     190      time-second
     191      set-time-type!
     192      set-time-nanosecond!
     193      set-time-second!
    154194      copy-time
    155       time<=? time<? time=? time>=? time>?
    156       time-difference time-difference! add-duration add-duration!
    157       subtract-duration subtract-duration!
     195      time<=?
     196      time<?
     197      time=?
     198      time>=?
     199      time>?
     200      time-difference
     201      time-difference!
     202      add-duration
     203      add-duration!
     204      subtract-duration
     205      subtract-duration!
    158206      make-date date?
    159207      date-nanosecond
    160       date-second date-minute date-hour
    161       date-day date-month date-year
     208      date-second
     209      date-minute
     210      date-hour
     211      date-day
     212      date-month
     213      date-year
    162214      date-zone-offset
    163       date-year-day date-week-day
     215      date-year-day
     216      date-week-day
    164217      date-week-number
    165       leap-year?
    166       date->julian-day date->modified-julian-day
    167       date->time-monotonic date->time-tai date->time-utc
    168       julian-day->date julian-day->time-monotonic julian-day->time-tai
     218      date->julian-day
     219      date->modified-julian-day
     220      date->time-monotonic
     221      date->time-tai
     222      date->time-utc
     223      julian-day->date
     224      julian-day->time-monotonic
     225      julian-day->time-tai
    169226      julian-day->time-utc
    170227      modified-julian-day->date
    171       modified-julian-day->time-monotonic modified-julian-day->time-tai
     228      modified-julian-day->time-monotonic
     229      modified-julian-day->time-tai
    172230      modified-julian-day->time-utc
    173231      time-monotonic->date
    174       time-monotonic->julian-day time-monotonic->modified-julian-day
    175       time-monotonic->time-tai time-monotonic->time-tai!
    176       time-monotonic->time-utc time-monotonic->time-utc!
    177       time-tai->date time-tai->julian-day time-tai->modified-julian-day
    178       time-tai->time-monotonic time-tai->time-monotonic! time-tai->time-utc
    179       time-tai->time-utc! time-utc->date
    180       time-utc->julian-day time-utc->modified-julian-day
    181       time-utc->time-monotonic time-utc->time-monotonic!
    182       time-utc->time-tai time-utc->time-tai!
     232      time-monotonic->julian-day
     233      time-monotonic->modified-julian-day
     234      time-monotonic->time-tai
     235      time-monotonic->time-tai!
     236      time-monotonic->time-utc
     237      time-monotonic->time-utc!
     238      time-tai->date
     239      time-tai->julian-day
     240      time-tai->modified-julian-day
     241      time-tai->time-monotonic
     242      time-tai->time-monotonic!
     243      time-tai->time-utc
     244      time-tai->time-utc!
     245      time-utc->date
     246      time-utc->julian-day
     247      time-utc->modified-julian-day
     248      time-utc->time-monotonic
     249      time-utc->time-monotonic!
     250      time-utc->time-tai
     251      time-utc->time-tai!
    183252      ;; Internal API, for srfi-19-io & srfi-19-period
    184253      tm:date-day-set!
    … …  
    331400                  (if (eof-object? line)
    332401                    lst
    333                     (let ([data
    334                             (with-input-from-string
    335                               (string-append "(" line ")")
    336                               read)])
     402                    (let ([data (with-input-from-string (string-append "(" line ")") read)])
    337403                      (let ([year (car data)]
    338404                            [jd   (cadddr (cdr data))]
    … …  
    340406                        (loop
    341407                          (if (>= year FIRST-LEAP-YEAR)
    342                             (cons
    343                               (cons (convert-jd jd) (convert-sec secs))
    344                               lst)
     408                            (cons (cons (convert-jd jd) (convert-sec secs)) lst)
    345409                            lst))))))))])
    346410      (with-input-from-port (open-input-file flnm) read-data) ) ) )
    … …  
    395459      (lsd tm:leap-second-table)) ) )
    396460
    397 ;;
    398 
    399 ;; E.R. Hope. "Further adjustment of the Gregorian calendar year."
    400 ;; The Journal of the Royal Astronomical Society of Canada.
    401 ;; Part I, volume 58, number 1, pages 3-9 (February, 1964).
    402 ;; Part II, volume 58, number 2, pages 79-87 (April 1964).
    403 
    404 (define (tm:leap-year? year)
    405   (and (not (fx= (fxmod year 4000) 0)) ;Not officially adopted!
    406        (or (fx= (fxmod year 400) 0)
    407                 (and (fx= (fxmod year 4) 0)
    408                      (not (fx= (fxmod year 100) 0))))) )
    409 
    410461;;; Time Object (Public Mutable)
    411462
    412463;; Clock Type Constants
     464;; (Not used internally)
    413465
    414466(define time-duration 'time-duration)
    … …  
    422474;;
    423475
    424 (define (time-type? type)
    425   (case type
     476(define (time-type? obj)
     477  (case obj
     478    [(time-monotonic)   #t]
     479    [(time-utc)         #t]
     480    [(time-tai)         #t]
     481    [(time-gc)          #t]
    426482    [(time-duration)    #t]
     483    [(time-process)     #t]
     484    [(time-thread)      #t]
     485    [else               #f]) )
     486
     487(define (clock-time-type? obj)
     488  (case obj
    427489    [(time-monotonic)   #t]
    428490    [(time-tai)         #t]
    429491    [(time-utc)         #t]
    430     [(time-gc)          #t]
    431     [(time-process)     #t]
    432     [(time-thread)      #t]
    433492    [else               #f]) )
    434493
    … …  
    438497  (make-parameter 'time-utc
    439498    (lambda (x)
    440       (if (and (symbol? x)
    441                (case x
    442                  [(time-monotonic)  #t]
    443                  [(time-tai)        #t]
    444                  [(time-utc)        #t]
    445                  [else              #f]))
     499      (if (clock-time-type? x)
    446500        x
    447501        (default-date-clock-type)))))
    448502
    449 ;;
    450 
    451503(define (tm:check-time-type loc obj)
    452504  (unless (time-type? obj)
    453     (error loc "invalid clock-type" obj)) )
    454 
    455 ;; There are 2 kinds of time record access procedures:
    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) )
     505    (error loc "invalid time type" obj)) )
     506
     507;;
     508;; NOTE - record type "time" is defined in "srfi-19-common"
     509;;
    469510
    470511;;
    … …  
    502543(define (tm:check-time-has-type loc tim timtyp)
    503544  (unless (eq? timtyp (%time-type tim))
    504     (error loc "incompatible clock-types" (%time-type tim) timtyp)) )
     545    (error loc "incompatible time types" (%time-type tim) timtyp)) )
     546
     547(define (tm:check-time-and-type loc tim timtyp)
     548  (%check-time loc tim)
     549  (tm:check-time-has-type loc tim timtyp) )
    505550
    506551(define tm:check-time %check-time)
    507552
    508553(define (tm:check-duration loc obj)
    509   (%check-time loc obj)
    510   (tm:check-time-has-type loc obj 'time-duration) )
     554  (tm:check-time-and-type loc obj 'time-duration) )
    511555
    512556(define (tm:check-time-nanoseconds loc obj)
    513   (unless (and (integer? obj) (<= 0 obj) (< obj NS/S))
     557  (unless (and (fixnum? obj) (fx<= 0 obj) (fx< obj NS/S))
    514558    (error loc "invalid nanoseconds" obj)) )
    515559
    516560(define (tm:check-time-seconds loc obj)
    517   (unless (integer? obj)
     561  (unless (fixnum? obj)
    518562    (error loc "invalid seconds" obj)) )
    519563
    … …  
    534578  (tm:check-time-has-type loc obj1 (%time-type obj2)) )
    535579
     580(define (tm:time-aritmetic-check tim dur loc)
     581  (%check-time loc tim)
     582  (tm:check-duration dur loc) )
     583
    536584;;
    537585
    … …  
    547595(define (make-duration
    548596          #!key
    549           (days 0)
     597          (dys 0)
    550598          (hours 0) (minutes 0) (seconds 0)
    551599          (milliseconds 0) (microseconds 0) (nanoseconds 0))
    … …  
    555603      'time-duration
    556604      ns
    557       (+ (* days SEC/DY) (* hours SEC/HR) (* minutes SEC/MIN) seconds sec)) ) )
     605      (+ (* dys SEC/DY) (* hours SEC/HR) (* minutes SEC/MIN) seconds sec)) ) )
    558606
    559607(define (copy-time tim)
    … …  
    653701  (let ([tim (tm:current-time-tai)])
    654702    (%set-time-type! tim 'time-monotonic)
    655     tm ) )
     703    tim ) )
    656704
    657705(define (tm:current-time-thread)
    … …  
    666714;;
    667715
    668 (define (current-time . clock-type)
    669   (let ([clock-type (optional clock-type 'time-utc)])
    670     (tm:check-time-type 'current-time clock-type)
    671     (case clock-type
     716(define (current-time . timtyp)
     717  (let ([timtyp (optional timtyp 'time-utc)])
     718    (tm:check-time-type 'current-time timtyp)
     719    (case timtyp
     720      [(time-monotonic) (tm:current-time-monotonic)]
     721      [(time-utc)       (tm:current-time-utc)]
     722      [(time-tai)       (tm:current-time-tai)]
    672723      [(time-gc)        (tm:current-time-gc)]
    673       [(time-monotonic) (tm:current-time-monotonic)]
    674724      [(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)]) ) )
     725      [(time-thread)    (tm:current-time-thread)]) ) )
    678726
    679727;; SRFI-18 Routines
    680728;; Coupling here
    681729
    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)) )
     730(define (srfi-18-time->time srfi-18-tim)
     731  (tm:make-time 'time-duration (* (##sys#slot srfi-18-tim 3) NS/MS) (##sys#slot srfi-18-tim 2)) )
    684732
    685733(define (time->srfi-18-time tim)
    … …  
    695743;; This will be implementation specific.
    696744
    697 (define (time-resolution . clock-type)
    698   (tm:check-time-type 'time-resolution (optional clock-type 'time-utc))
     745(define (time-resolution . timtyp)
     746  (tm:check-time-type 'time-resolution (optional timtyp 'time-utc))
    699747  NS/MS )
    700748
    … …  
    770818
    771819;; Time Arithmetic
    772 
    773 (define (tm:time-aritmetic-check tim dur loc)
    774   (%check-time loc tim)
    775   (tm:check-duration dur loc) )
    776820
    777821(define (tm:time-difference tim1 tim2 tim3)
    … …  
    782826      (tm:set-time-nanosecond! tim3 0))
    783827    (receive [ns sec]
    784         (tm:nanoseconds->time-values
    785           (- (time->nanoseconds tim1) (time->nanoseconds tim2)))
     828        (tm:nanoseconds->time-values (- (time->nanoseconds tim1) (time->nanoseconds tim2)))
    786829      (tm:set-time-second! tim3 sec)
    787830      (tm:set-time-nanosecond! tim3 ns)))
    … …  
    904947;; Time Type Converters
    905948
    906 (define (tm:time-tai->time-utc time-in time-out)
    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))))
    911   time-out )
    912 
    913 (define (tm:time-utc->time-tai time-in time-out)
    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))))
    918   time-out )
    919 
    920 (define (tm:time-monotonic->time-tai time-in time-out)
    921   (%set-time-type! time-out 'time-tai)
    922   (unless (eq? time-in time-out)
    923     (tm:set-time-nanosecond! time-out (%time-nanosecond time-in))
    924     (tm:set-time-second! time-out (%time-second time-in)))
    925   time-out )
    926 
    927 (define (tm:time-tai->time-monotonic time-in time-out)
    928   (%set-time-type! time-out 'time-monotonic)
    929   (unless (eq? time-in time-out)
    930     (tm:set-time-nanosecond! time-out (%time-nanosecond time-in))
    931     (tm:set-time-second! time-out (%time-second time-in)))
    932   time-out )
    933 
    934 (define (tm:time-monotonic->time-utc time-in time-out)
    935   (%set-time-type! time-in 'time-tai) ; fool converter (unnecessary)
    936   (tm:time-tai->time-utc time-in time-out) )
    937 
    938 (define (tm:time-utc->time-monotonic time-in time-out)
    939   (let ([ntime (tm:time-utc->time-tai time-in time-out)])
    940     (%set-time-type! ntime 'time-monotonic)
    941     ntime))
    942 
    943 ;;
    944 
    945 (define (time-tai->time-utc time-in)
    946   (tm:check-time-has-type 'time-tai->time-utc time-in 'time-tai)
    947   (tm:time-tai->time-utc time-in (tm:as-empty-time time-in)) )
    948 
    949 (define (time-tai->time-utc! time-in)
    950   (tm:check-time-has-type 'time-tai->time-utc! time-in 'time-tai)
    951   (tm:time-tai->time-utc time-in time-in) )
    952 
    953 (define (time-tai->time-monotonic time-in)
    954   (tm:check-time-has-type 'time-tai->time-monotonic time-in 'time-tai)
    955   (tm:time-tai->time-monotonic time-in (tm:as-empty-time time-in)) )
    956 
    957 (define (time-tai->time-monotonic! time-in)
    958   (tm:check-time-has-type 'time-tai->time-monotonic! time-in 'time-tai)
    959   (tm:time-tai->time-monotonic time-in time-in) )
    960 
    961 (define (time-utc->time-tai time-in)
    962   (tm:check-time-has-type 'time-utc->time-tai time-in 'time-utc)
    963   (tm:time-utc->time-tai time-in (tm:as-empty-time time-in)) )
    964 
    965 (define (time-utc->time-tai! time-in)
    966   (tm:check-time-has-type 'time-utc->time-tai! time-in 'time-utc)
    967   (tm:time-utc->time-tai time-in time-in) )
    968 
    969 (define (time-utc->time-monotonic time-in)
    970   (tm:check-time-has-type 'time-utc->time-monotonic time-in 'time-utc)
    971   (tm:time-utc->time-monotonic time-in (tm:as-empty-time time-in)) )
    972 
    973 (define (time-utc->time-monotonic! time-in)
    974   (tm:check-time-has-type 'time-utc->time-monotonic! time-in 'time-utc)
    975   (tm:time-utc->time-monotonic time-in time-in) )
    976 
    977 (define (time-monotonic->time-utc time-in)
    978   (tm:check-time-has-type 'time-monotoinc->time-utc time-in 'time-monotonic)
    979   (let ([ntime (copy-time time-in)])
    980     (tm:time-monotonic->time-utc ntime ntime) ) )
    981 
    982 (define (time-monotonic->time-utc! time-in)
    983   (tm:check-time-has-type 'time-monotoinc->time-utc! time-in 'time-monotonic)
    984   (tm:time-monotonic->time-utc time-in time-in) )
    985 
    986 (define (time-monotonic->time-tai time-in)
    987   (tm:check-time-has-type 'time-monotoinc->time-tai time-in 'time-monotonic)
    988   (tm:time-monotonic->time-tai time-in (tm:as-empty-time time-in)) )
    989 
    990 (define (time-monotonic->time-tai! time-in)
    991   (tm:check-time-has-type 'time-monotoinc->time-tai! time-in 'time-monotonic)
    992   (tm:time-monotonic->time-tai time-in time-in) )
     949(define (tm:time-tai->time-utc tim-in tim-out)
     950  (%set-time-type! tim-out 'time-utc)
     951  (tm:set-time-nanosecond! tim-out (%time-nanosecond tim-in))
     952  (tm:set-time-second! tim-out
     953    (- (%time-second tim-in) (tm:leap-second-neg-delta (%time-second tim-in))))
     954  tim-out )
     955
     956(define (tm:time-utc->time-tai tim-in tim-out)
     957  (%set-time-type! tim-out 'time-tai)
     958  (tm:set-time-nanosecond! tim-out (%time-nanosecond tim-in))
     959  (tm:set-time-second! tim-out
     960    (+ (%time-second tim-in) (tm:leap-second-delta (%time-second tim-in))))
     961  tim-out )
     962
     963(define (tm:time-monotonic->time-tai tim-in tim-out)
     964  (%set-time-type! tim-out 'time-tai)
     965  (unless (eq? tim-in tim-out)
     966    (tm:set-time-nanosecond! tim-out (%time-nanosecond tim-in))
     967    (tm:set-time-second! tim-out (%time-second tim-in)))
     968  tim-out )
     969
     970(define (tm:time-tai->time-monotonic tim-in tim-out)
     971  (%set-time-type! tim-out 'time-monotonic)
     972  (unless (eq? tim-in tim-out)
     973    (tm:set-time-nanosecond! tim-out (%time-nanosecond tim-in))
     974    (tm:set-time-second! tim-out (%time-second tim-in)))
     975  tim-out )
     976
     977(define (tm:time-monotonic->time-utc tim-in tim-out)
     978  (%set-time-type! tim-in 'time-tai) ; fool converter (unnecessary)
     979  (tm:time-tai->time-utc tim-in tim-out) )
     980
     981(define (tm:time-utc->time-monotonic tim-in tim-out)
     982  (let ([ntim (tm:time-utc->time-tai tim-in tim-out)])
     983    (%set-time-type! ntim 'time-monotonic)
     984    ntim ) )
     985
     986;; Time Type Conversion
     987
     988(define (time-tai->time-utc tim)
     989  (tm:check-time-and-type 'time-tai->time-utc tim 'time-tai)
     990  (tm:time-tai->time-utc tim (tm:as-empty-time tim)) )
     991
     992(define (time-tai->time-utc! tim)
     993  (tm:check-time-and-type 'time-tai->time-utc! tim 'time-tai)
     994  (tm:time-tai->time-utc tim tim) )
     995
     996(define (time-tai->time-monotonic tim)
     997  (tm:check-time-and-type 'time-tai->time-monotonic tim 'time-tai)
     998  (tm:time-tai->time-monotonic tim (tm:as-empty-time tim)) )
     999
     1000(define (time-tai->time-monotonic! tim)
     1001  (tm:check-time-and-type 'time-tai->time-monotonic! tim 'time-tai)
     1002  (tm:time-tai->time-monotonic tim tim) )
     1003
     1004(define (time-utc->time-tai tim)
     1005  (tm:check-time-and-type 'time-utc->time-tai tim 'time-utc)
     1006  (tm:time-utc->time-tai tim (tm:as-empty-time tim)) )
     1007
     1008(define (time-utc->time-tai! tim)
     1009  (tm:check-time-and-type 'time-utc->time-tai! tim 'time-utc)
     1010  (tm:time-utc->time-tai tim tim) )
     1011
     1012(define (time-utc->time-monotonic tim)
     1013  (tm:check-time-and-type 'time-utc->time-monotonic tim 'time-utc)
     1014  (tm:time-utc->time-monotonic tim (tm:as-empty-time tim)) )
     1015
     1016(define (time-utc->time-monotonic! tim)
     1017  (tm:check-time-and-type 'time-utc->time-monotonic! tim 'time-utc)
     1018  (tm:time-utc->time-monotonic tim tim) )
     1019
     1020(define (time-monotonic->time-utc tim)
     1021  (tm:check-time-and-type 'time-monotoinc->time-utc tim 'time-monotonic)
     1022  (let ([ntim (copy-time tim)])
     1023    (tm:time-monotonic->time-utc ntim ntim) ) )
     1024
     1025(define (time-monotonic->time-utc! tim)
     1026  (tm:check-time-and-type 'time-monotoinc->time-utc! tim 'time-monotonic)
     1027  (tm:time-monotonic->time-utc tim tim) )
     1028
     1029(define (time-monotonic->time-tai tim)
     1030  (tm:check-time-and-type 'time-monotoinc->time-tai tim 'time-monotonic)
     1031  (tm:time-monotonic->time-tai tim (tm:as-empty-time tim)) )
     1032
     1033(define (time-monotonic->time-tai! tim)
     1034  (tm:check-time-and-type 'time-monotoinc->time-tai! tim 'time-monotonic)
     1035  (tm:time-monotonic->time-tai tim tim) )
    9931036
    9941037;;; Timezone Locale Object (Public Immutable)
    … …  
    10151058       (boolean? (%timezone-locale-dst? obj))
    10161059       (timezone-components? (%timezone-locale-component obj)) ) )
     1060
     1061(define (check-timezone-locale loc obj)
     1062  (unless (timezone-locale? obj)
     1063    (error loc "invalid timezone locale" obj) )
     1064
     1065(define make-posix-timezone
     1066  (let ([hms
     1067          (lambda (secs)
     1068            (let* ([asecs (abs secs)]
     1069                   [rsecs (remainder asecs SEC/HR)])
     1070              (string-append
     1071                (if (negative? secs) "-" "+")
     1072                (number->string (quotient asecs SEC/HR))
     1073                ":" (number->string (quotient rsecs SEC/MIN))
     1074                ":" (number->string (remainder rsecs SEC/MIN)))))])
     1075    (lambda (dst-tzn dst-off std-tzn std-off)
     1076      (string-append dst-tzn (hms dst-off) std-tzn (hms std-off)) ) ) )
    10171077
    10181078(define (make-local-timezone-locale)
    … …  
    10241084    ; time info.
    10251085    (unless (current-timezone)
    1026       (let ([tzn LOCAL-TZ-NAME]
    1027             [hms
    1028               (lambda (secs)
    1029                 (let* ([asecs (abs secs)]
    1030                        [rsecs (remainder asecs SEC/HR)])
    1031                   (string-append
    1032                     (if (negative? secs) "-" "+")
    1033                     (number->string (quotient asecs SEC/HR))
    1034                     ":" (number->string (quotient rsecs SEC/MIN))
    1035                     ":" (number->string (remainder rsecs SEC/MIN)))))])
    1036           ; Set the current-timezone for future reference.
    1037           (current-timezone
    1038             (cond-expand
    1039               [macosx
    1040                 ; Since the tzo reflects the dst status need to fake
    1041                 ; the one not in effect.
    1042                 (let ([tzo (vector-ref tv 9)])
    1043                   (string-append
    1044                     (if dstf UNKNOWN-LOCAL-TZ-NAME tzn)
    1045                     (hms (if dstf (+ tzo DEFAULT-DST-OFFSET) tzo))
    1046                     (if dstf tzn UNKNOWN-LOCAL-TZ-NAME)
    1047                     (hms (if dstf tzo (- tzo DEFAULT-DST-OFFSET)))))]
    1048               [else
    1049                 ; Since only the standard tzn & tzo are available need to
    1050                 ; fake summer time.
    1051                 (let ([tzo (vector-ref tv 9)])
    1052                   (string-append
    1053                     tzn
    1054                     (hms tzo)
    1055                     UNKNOWN-LOCAL-TZ-NAME
    1056                     (hms (- tzo DEFAULT-DST-OFFSET))))])) ) )
     1086      (let ([tzn LOCAL-TZ-NAME])
     1087        ; Set the current-timezone for future reference.
     1088        (current-timezone
     1089          (cond-expand
     1090            [macosx
     1091              ; Since the tzo reflects the dst status need to fake
     1092              ; the one not in effect.
     1093              (let ([tzo (vector-ref tv 9)])
     1094                (if dstf
     1095                  (make-posix-timezone
     1096                    UNKNOWN-LOCAL-TZ-NAME (+ tzo DEFAULT-DST-OFFSET) tzn tzo)
     1097                  (make-posix-timezone
     1098                    tzn tzo UNKNOWN-LOCAL-TZ-NAME (- tzo DEFAULT-DST-OFFSET)) ) ) ]
     1099            [else
     1100              ; Since only the standard tzn & tzo are available need to
     1101              ; fake summer time.
     1102              (let ([tzo (vector-ref tv 9)])
     1103                (make-posix-timezone
     1104                  tzn tzo UNKNOWN-LOCAL-TZ-NAME (- tzo DEFAULT-DST-OFFSET)) ) ] ) ) ) )
    10571105    ; Return local tz info
    10581106    (make-timezone-locale dstf (current-timezone-components)) ) )
    … …  
    10761124;; Returns #f or a valid tz-name
    10771125
    1078 (define (timezone-locale-name . r)
    1079   (let* ([tzi (optional r (local-timezone-locale))]
    1080          [tzc (%timezone-locale-component tzi)]
    1081          [tzn (timezone-component-ref tzc (if (%timezone-locale-dst? tzi) 'dst-name 'std-name))])
    1082     ; TZ may not be set
    1083     (and (not (eq? tzn UNKNOWN-LOCAL-TZ-NAME)) tzn) ) )
    1084 
    1085 ;;
    1086 
    1087 (define (timezone-locale-offset . r)
    1088   (let* ([tzi (optional r (local-timezone-locale))]
    1089          [tzc (%timezone-locale-component tzi)]
    1090          [tzo (timezone-component-ref tzc (if (%timezone-locale-dst? tzi) 'dst-offset 'std-offset))])
    1091     ; TZ may not be set but if it is then convert to ISO 8601
    1092     (if tzo (fxneg tzo) 0) ) )
    1093 
    1094 ;;
    1095 
    1096 (define (timezone-locale-dst? . r)
    1097   (%timezone-locale-dst? (optional r (local-timezone-locale))) )
    1098 
    1099 ;; Deprecated
    1100 
    1101 (define local-timezone-info local-timezone-locale)
    1102 (define local-timezone-name timezone-locale-name)
    1103 (define local-timezone-offset timezone-locale-offset)
    1104 (define local-timezone-dst? timezone-locale-dst?)
     1126(define (timezone-locale-name . args)
     1127  (let-optionals args ((tzi (local-timezone-locale)))
     1128    (check-timezone-locale 'timezone-locale-name tzi)
     1129    (let* ([tzc (%timezone-locale-component tzi)]
     1130           [tzn (timezone-component-ref
     1131                  tzc
     1132                  (if (%timezone-locale-dst? tzi) 'dst-name 'std-name))])
     1133      ; TZ may not be set
     1134      (and (not (eq? tzn UNKNOWN-LOCAL-TZ-NAME)) tzn) ) ) )
     1135
     1136;;
     1137
     1138(define (timezone-locale-offset . args)
     1139  (let-optionals args ((tzi (local-timezone-locale)))
     1140    (check-timezone-locale 'timezone-locale-offset tzi)
     1141    (let* ([tzc (%timezone-locale-component tzi)]
     1142           [tzo (timezone-component-ref
     1143                  tzc
     1144                  (if (%timezone-locale-dst? tzi) 'dst-offset 'std-offset))])
     1145      ; TZ may not be set but if it is then convert to ISO 8601
     1146      (if tzo (fxneg tzo) 0) ) ) )
     1147
     1148;;
     1149
     1150(define (timezone-locale-dst? . args)
     1151  (let-optionals args ((tzi (local-timezone-locale)))
     1152    (check-timezone-locale 'timezone-locale-offset tzij)
     1153    (%timezone-locale-dst? tzi) ) )
    11051154
    11061155;;; Date Object (Public Immutable)
    11071156
    1108 (define-record-type date
    1109   (%make-date nanosecond second minute hour day month year
    1110               zone-offset zone-name dstf
    1111               wday yday jday)
     1157(define-record-type/unsafe-inline-unchecked date
     1158  (%make-date ns sec mn hr dy mn yr tzo tzn dstf wdy ydy jdy)
    11121159  %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!)
     1160  (ns     %date-nanosecond %date-nanosecond-set!)
     1161  (sec    %date-second      %date-second-set!)
     1162  (mn     %date-minute      %date-minute-set!)
     1163  (hr     %date-hour        %date-hour-set!)
     1164  (dy     %date-day        %date-day-set!)
     1165  (mn     %date-month      %date-month-set!)
     1166  (yr     %date-year        %date-year-set!)
     1167  (tzo    %date-zone-offset %date-zone-offset-set!)
    11211168  ;; non-srfi extn
    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!) )
     1169  (tzn    %date-zone-name)
     1170  (dstf   %date-dst?)
     1171  (wdy    %date-wday        %date-wday-set!)
     1172  (ydy    %date-yday        %date-yday-set!)
     1173  (jdy  %date-jday          %date-jday-set!) )
    11271174
    11281175;;
    … …  
    11561203(define (tm:date-zone-offset-set! date x)
    11571204  (%date-zone-offset-set! date (->fixnum x)) )
     1205
     1206;; Leap Year Test
     1207
     1208;; E.R. Hope. "Further adjustment of the Gregorian calendar year."
     1209;; The Journal of the Royal Astronomical Society of Canada.
     1210;; Part I, volume 58, number 1, pages 3-9 (February, 1964).
     1211;; Part II, volume 58, number 2, pages 79-87 (April 1964).
     1212
     1213(define (tm:leap-year? year)
     1214  (and (not (fx= (fxmod year 4000) 0)) ;Not officially adopted!
     1215       (or (fx= (fxmod year 400) 0)
     1216                (and (fx= (fxmod year 4) 0)
     1217                     (not (fx= (fxmod year 100) 0))))) )
     1218
     1219;; Days per Month
     1220
     1221(define tm:dy/mn '#(0 31 28 31 30 31 30 31 31 30 31 30 31))
     1222
     1223(define tm:dy/mn-leap '#(0 31 29 31 30 31 30 31 31 30 31 30 31))
     1224
     1225(define tm:cumulative-month-days '#(0 0 31 59 90 120 151 181 212 243 273 304 334))
    11581226
    11591227;; Internal Date CTOR
    … …  
    11731241(define tm:check-date %check-date)
    11741242
    1175 (define tm:vali-day
    1176   (let ([dy/mn '#(0 31 28 31 30 31 30 31 31 30 31 30 31)]
    1177         [dy/mn-leap '#(0 31 29 31 30 31 30 31 31 30 31 30 31)])
    1178     (lambda (dy mn yr)
    1179       (<= 1 dy (vector-ref (if (tm:leap-year? yr) dy/mn-leap dy/mn) mn)) ) ) )
     1243(define (tm:check-year loc yr)
     1244  ; No year 0!
     1245  (unless (and (fixnum? yr) (not (fx= 0 yr)))
     1246    (error loc "invalid year" yr) ) )
     1247
     1248(define (tm:check-month loc mn)
     1249  ; Months in [1 12]
     1250  (unless (and (fixnum? mn) (fx<= 1 mn) (fx<= mn 12))
     1251    (error loc "invalid month" mn) ) )
     1252
     1253(define (tm:check-day loc dy mn yr)
     1254  ; Days in [1 31] - depending o month
     1255  (unless (and (fixnum? dy)
     1256               (fx<= 1 dy)
     1257               (fx<= dy (vector-ref (if (tm:leap-year? yr) tm:dy/mn-leap tm:dy/mn) mn)))
     1258    (error loc "invalid days" dy) ) )
    11801259
    11811260(define (tm:vali-date loc ns sec min hr dy mn yr tzo tzn)
    1182     ; Same as time object
    1183     (tm:check-time-nanoseconds loc ns)
    1184     ; Seconds in [0 60] ; 60 due to leap second
    1185     (unless (and (integer? sec) (<= 0 sec 60))
    1186       (error loc "invalid seconds" sec))
    1187     ; Minutes in [0 59]
    1188     (unless (and (integer? min) (and (<= 0 min) (< min 60)))
    1189       (error loc "invalid minutes" min))
    1190     ; Hours in [0 23]
    1191     (unless (and (integer? hr) (and (<= 0 hr) (< hr 24)))
    1192       (error loc "invalid hours" hr))
    1193     ; No year 0!
    1194     (unless (and (integer? yr) (not (zero? yr)))
    1195       (error loc "invalid year" yr))
    1196     ; Months in [1 12]
    1197     (unless (and (integer? mn) (<= 1 mn 12))
    1198       (error loc "invalid month" mn))
    1199     ; Days in [1 31] - depending o month
    1200     (unless (and (integer? dy) (tm:vali-day dy mn yr))
    1201       (error loc "invalid days" dy))
    1202     ; Timezone offset in (-SEC/DY +SEC/DY)
    1203     (unless (and (integer? tzo)
    1204                  (let ([atzo (abs tzo)]) (and (<= 0 atzo) (< atzo SEC/DY))))
    1205       (error loc "invalid timezone offset" tzo))
    1206     ;
    1207     (unless (or (not tzn) (string? tzn))
    1208       (error loc "invalid timezone name" tzn))
    1209     #t )
     1261  ; Same as time object
     1262  (tm:check-time-nanoseconds loc ns)
     1263  ; Seconds in [0 60] ; 60 legal due to leap second
     1264  (unless (and (fixnum? sec) (fx<= 0 sec) (fx<= sec 60))
     1265    (error loc "invalid seconds" sec))
     1266  ; Minutes in [0 59]
     1267  (unless (and (fixnum? min) (and (fx<= 0 min) (fx< min 60)))
     1268    (error loc "invalid minutes" min))
     1269  ; Hours in [0 23]
     1270  (unless (and (fixnum? hr) (and (<= 0 hr) (< hr 24)))
     1271    (error loc "invalid hours" hr))
     1272  ; Year, Month & Day within limits
     1273  (tm:check-year loc yr)
     1274  (tm:check-month loc mn)
     1275  (tm:check-day loc dy mn yr)
     1276  ; Timezone offset in (-SEC/DY +SEC/DY)
     1277  (unless (and (fixnum? tzo)
     1278               (let ([atzo (abs tzo)]) (and (<= 0 atzo) (< atzo SEC/DY))))
     1279    (error loc "invalid timezone offset" tzo))
     1280  ;
     1281  (unless (or (not tzn) (string? tzn))
     1282    (error loc "invalid timezone name" tzn))
     1283  #t )
    12101284
    12111285;; Date Syntax
    12121286
    1213 (define-record-printer (date dt out)
     1287(define-record-printer (date dat out)
    12141288  (fprintf out
    12151289    "#,(date ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A ~A)"
    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)) )
     1290    (%date-nanosecond dat)
     1291    (%date-second dat) (%date-minute dat) (%date-hour dat)
     1292    (%date-day dat) (%date-month dat) (%date-year dat)
     1293    (%date-zone-offset dat)
     1294    (%date-zone-name dat) (%date-dst? dat)
     1295    (%date-wday dat) (%date-yday dat) (%date-jday dat)) )
    12221296
    12231297(define-reader-ctor 'date
    1224   (lambda (nanosecond second minute hour day month year zone-offset . rest)
    1225     (let-optionals rest ([zone-name #f] [dstf #f] [wday #f] [yday #f] [jday #f])
     1298  (lambda (ns sec min hr dy mn yr tzo . rest)
     1299    (let-optionals rest ([tzn #f] [dstf #f] [wdy #f] [ydy #f] [jdy #f])
    12261300      ($make-date
    1227         nanosecond
    1228         second minute hour
    1229         day month year
    1230         zone-offset
    1231         zone-name dstf
    1232         wday yday jday))))
     1301        ns
     1302        sec min hr
     1303        dy mn yr
     1304        tzo
     1305        tzn dstf
     1306        wdy ydy jdy))))
    12331307
    12341308;; Date CTOR
    … …  
    12811355        (vector-ref tv 6) (fx+ 1 (vector-ref tv 7)) #f) ) ) )
    12821356
    1283 (define (current-date . tz-info)
    1284   (apply time-utc->date (tm:current-time-utc) tz-info) )
     1357(define (current-date . tzi)
     1358  (apply time-utc->date (tm:current-time-utc) tzi) )
    12851359
    12861360;;
    … …  
    12901364;;
    12911365
    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)
     1366(define (date-nanosecond dat)
     1367        (%check-date 'date-nanosecond dat)
     1368        (%date-nanosecond date-nanosecond) )
     1369
     1370(define (date-second dat)
     1371        (%check-date 'date-second dat)
     1372        (%date-second date-second) )
     1373
     1374(define (date-minute dat)
     1375        (%check-date 'date-minute dat)
     1376        (%date-minute date-minute) )
     1377
     1378(define (date-hour dat)
     1379        (%check-date 'date-hour dat)
     1380        (%date-hour date-hour) )
     1381
     1382(define (date-day dat)
     1383        (%check-date 'date-day dat)
     1384        (%date-day date-day) )
     1385
     1386(define (date-month dat)
     1387        (%check-date 'date-month dat)
     1388        (%date-month date-month) )
     1389
     1390(define (date-year dat)
     1391        (%check-date 'date-year dat)
     1392        (%date-year date-year) )
     1393
     1394(define (date-zone-offset dat)
     1395        (%check-date 'date-zone-offset dat)
     1396        (%date-zone-offset date-zone-offset) )
     1397
    13001398
    13011399;; Date Comparison
    13021400
    1303 (define (%date-compare/fields loc x y)
     1401(define (*date-compare/fields loc x y)
    13041402  (%check-date loc x)
    13051403  (%check-date loc y)
    … …  
    13261424                            (fx- (%date-nanosecond x) (%date-nanosecond y)) ) ) ) ) ) ) ) ) ) ) ) ) ) )
    13271425
     1426(define (date-compare/fields x y)
     1427  (*date-compare/fields 'date-compare/fields x y) )
     1428
    13281429(define (date=?/fields dat1 dat2)
    1329   (fx= 0 (%date-compare/fields 'date=?/fields dat1 dat2)) )
     1430  (fx= 0 (*date-compare/fields 'date=?/fields dat1 dat2)) )
    13301431
    13311432(define (date<?/fields dat1 dat2)
    1332   (fx< 0 (%date-compare/fields 'date<?/fields dat1 dat2)) )
     1433  (fx< 0 (*date-compare/fields 'date<?/fields dat1 dat2)) )
    13331434
    13341435(define (date<=?/fields dat1 dat2)
    1335   (fx<= 0 (%date-compare/fields 'date<=?/fields dat1 dat2)) )
     1436  (fx<= 0 (*date-compare/fields 'date<=?/fields dat1 dat2)) )
    13361437
    13371438(define (date>?/fields dat1 dat2)
    1338   (fx> 0 (%date-compare/fields 'date>?/fields dat1 dat2)) )
     1439  (fx> 0 (*date-compare/fields 'date>?/fields dat1 dat2)) )
    13391440
    13401441(define (date>=?/fields dat1 dat2)
    1341   (fx>= 0 (%date-compare/fields 'date>=?/fields dat1 dat2)) )
     1442  (fx>= 0 (*date-compare/fields 'date>=?/fields dat1 dat2)) )
     1443
     1444;;
     1445
     1446(define (*date-compare loc x y)
     1447  (%check-date loc x)
     1448  (%check-date loc y)
     1449  (- (date->julian-day x) (date->julian-day y)) )
     1450
     1451(define (date-compare x y)
     1452  (*date-compare 'date-compare x y) )
    13421453
    13431454(define (date=? dat1 dat2)
    1344   (= (date->julian-day dat1) (date->julian-day dat2)) )
     1455  (= 0 (*date-compare 'date=? x y)) )
    13451456
    13461457(define (date<? dat1 dat2)
    1347   (< (date->julian-day dat1) (date->julian-day dat2)) )
     1458  (< 0 (*date-compare 'date=<? x y)) )
    13481459
    13491460(define (date>? dat1 dat2)
    1350   (> (date->julian-day dat1) (date->julian-day dat2)) )
     1461  (> 0 (*date-compare 'date>? x y)) )
    13511462
    13521463(define (date<=? dat1 dat2)
    1353   (<= (date->julian-day dat1) (date->julian-day dat2)) )
     1464  (<= 0 (*date-compare 'date<=? x y)) )
    13541465
    13551466(define (date>=? dat1 dat2)
    1356   (<= (date->julian-day dat1) (date->julian-day dat2)) )
     1467  (>= 0 (*date-compare 'date>=? x y)) )
    13571468
    13581469;; Date Arithmetic
    13591470
    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)])
     1471(define (date-difference dat1 dat2 . timtyp)
     1472  (%check-date 'date-difference dat1)
     1473  (%check-date 'date-difference dat2)
     1474  (let ([tim1 (apply date->time dat1 timtyp)]
     1475        [tim2 (apply date->time dat2 timtyp)])
    13631476    (tm:time-difference tim1 tim2 (tm:as-empty-time tim1)) ) )
    13641477
    1365 (define (date-add-duration dat dur . clock-type)
    1366   (let ([tim (apply date->time dat clock-type)])
     1478(define (date-add-duration dat dur . timtyp)
     1479  (%check-date 'date-add-duration dat)
     1480  (tm:check-duration 'date-add-duration dur)
     1481  (let ([tim (apply date->time dat timtyp)])
    13671482    (time->date (tm:add-duration tim dur (tm:as-empty-time tim))) ) )
    13681483
    1369 (define (date-subtract-duration dat dur . clock-type)
    1370   (let ([tim (apply date->time dat clock-type)])
     1484(define (date-subtract-duration dat dur . timtyp)
     1485  (%check-date 'date-subtract-duration dat)
     1486  (tm:check-duration 'date-subtract-duration dur)
     1487  (let ([tim (apply date->time dat timtyp)])
    13711488    (time->date (tm:subtract-duration tim dur (tm:as-empty-time tim))) ) )
    13721489
    … …  
    13751492;; Gives the Julian day number - Gregorian proleptic calendar
    13761493
    1377 (define (tm:encode-julian-day-number day month year)
    1378   (let* ([a (fx/ (fx- 14 month) MN/YR)]
    1379          [b (fx- (fx+ year 4800) a)]
    1380          [y (if (negative? year) (fx+ b 1) b)] ; BCE?
    1381          [m (fx- (fx+ month (fx* a MN/YR)) 3)])
    1382     (+ day
     1494(define (tm:encode-julian-day-number dy mn yr)
     1495  (let* ([a (fx/ (fx- 14 mn) MN/YR)]
     1496         [b (fx- (fx+ yr 4800) a)]
     1497         [y (if (negative? yr) (fx+ b 1) b)] ; BCE?
     1498         [m (fx- (fx+ mn (fx* a MN/YR)) 3)])
     1499    (+ dy
    13831500      (fx/ (fx+ (fx* 153 m) 2) 5)
    13841501      (fx* y DY/YR)
    … …  
    13911508
    13921509(define (tm:decode-julian-day-number jdn)
    1393   (let* ([days (inexact->exact (truncate jdn))]
    1394          [a (fx+ days 32044)]
     1510  (let* ([dys (inexact->exact (truncate jdn))]
     1511         [a (fx+ dys 32044)]
    13951512         [b (fx/ (fx+ (fx* 4 a) 3) 146097)]
    13961513         [c (fx- a (fx/ (fx* 146097 b) 4))]
    … …  
    14001517         [y (fx+ (fx* 100 b) (fx+ d (fx- (fx/ m 10) 4800)))])
    14011518    (values ; seconds day month year
    1402       (->fixnum (floor (* (- jdn days) SEC/DY)))
     1519      (->fixnum (floor (* (- jdn dys) SEC/DY)))
    14031520      (fx+ (fx- e (fx/ (fx+ (fx* 153 m) 2) 5)) 1)
    14041521      (fx- (fx+ m 3) (fx* (fx/ m 10) MN/YR))
    … …  
    14071524;; Gives the Julian day number - rounds up to the nearest day
    14081525
    1409 (define (tm:seconds->julian-day-number seconds tzo)
     1526(define (tm:seconds->julian-day-number sec tzo)
    14101527  (+ TAI-EPOCH-IN-JD
    14111528     ; Round to day boundary
    1412      (/ (+ seconds tzo SEC/DY/2) SEC/DY)) )
     1529     (/ (+ sec tzo SEC/DY/2) SEC/DY)) )
    14131530
    14141531;; Is the time object one second before a leap second?
    14151532
    1416 (define (tm:tai-before-leap-second? time)
    1417   (let ([sec (%time-second time)])
     1533(define (tm:tai-before-leap-second? tim)
     1534  (let ([sec (%time-second tim)])
    14181535    (let loop ([lst tm:second-before-leap-second-table])
    14191536      (and (not (null? lst))
    … …  
    14231540;; Time to Date
    14241541
    1425 (define (tm:time->date time tz-info ttype loc)
     1542(define (tm:time->date loc tim tzi timtyp)
    14261543  ; Validate time type for caller
    1427   (tm:check-time-has-type time ttype loc)
     1544  (tm:check-time-and-type loc tim timtyp)
    14281545  ; The tz-info is caller's rest parameter
    1429   (let ([tzo (optional tz-info (local-timezone-locale))]
     1546  (let ([tzo (optional tzi (local-timezone-locale))]
    14301547        [tzn #f]
    14311548        [dstf #f])
    … …  
    14341551        (set! tzn (timezone-locale-name tzo))
    14351552        (set! tzo (timezone-locale-offset tzo)))
    1436       (unless (integer? tzo)
     1553      (unless (fixnum? tzo)
    14371554        (error loc "invalid timezone offset" tzo) )
    14381555      (receive [secs day month year]
    1439           (tm:decode-julian-day-number
    1440             (tm:seconds->julian-day-number (%time-second time) tzo))
     1556          (tm:decode-julian-day-number (tm:seconds->julian-day-number (%time-second tim) tzo))
    14411557        (let* ([hours (fx/ secs SEC/HR)]
    14421558               [rsecs (fxmod secs SEC/HR)]
    … …  
    14441560               [seconds (fxmod rsecs SEC/MIN)])
    14451561          ($make-date
    1446             (%time-nanosecond time)
     1562            (%time-nanosecond tim)
    14471563            seconds minutes hours
    14481564            day month year
    … …  
    14511567            #f #f #f) ) ) ) )
    14521568
    1453 (define (time-tai->date time . tz-info)
    1454   (let ([tm-utc (time-tai->time-utc time)])
    1455     (if (tm:tai-before-leap-second? time)
    1456         ;If it's *right* before the leap, we need to
    1457         ;pretend to subtract a second ...
    1458       (let ([dt
     1569(define (time-tai->date tim . tzi)
     1570  (%check-time 'time-tai->date tim)
     1571  (let ([tm-utc (time-tai->time-utc tim)])
     1572    (if (tm:tai-before-leap-second? tim)
     1573      ; then time is *right* before the leap, we need to pretend to subtract a second ...
     1574      (let ([dat
    14591575              (tm:time->date
    1460                 (tm:subtract-duration tm-utc ONE-SECOND-DURATION tm-utc)
    1461                 tz-info 'time-utc 'time-tai->date)])
    1462         (%date-second-set! dt SEC/MIN) ; note full minute!
    1463         dt )
    1464       (tm:time->date tm-utc tz-info 'time-utc 'time-tai->date)) ) )
    1465 
    1466 (define (time-utc->date time . tz-info)
    1467   (tm:time->date time tz-info 'time-utc 'time-utc->date) )
    1468 
    1469 (define (time-monotonic->date time . tz-info)
    1470   (tm:time->date time tz-info 'time-monotonic 'time-monotonic->date) )
    1471 
    1472 (define (time->date time . tz-info)
     1576                'time-tai->date
     1577                (tm:subtract-duration tm-utc ONE-SECOND-DURATION tm-utc) tzi 'time-utc)])
     1578        (%date-second-set! dat SEC/MIN) ; Note full minute!
     1579        dat )
     1580      (tm:time->date 'time-tai->date tm-utc tzi 'time-utc)) ) )
     1581
     1582(define (time-utc->date tim . tzi)
     1583  (%check-time 'time-utc->date tim)
     1584  (tm:time->date 'time-utc->date tim tzi 'time-utc) )
     1585
     1586(define (time-monotonic->date tim . tzi)
     1587  (%check-time 'time-monotonic->date tim)
     1588  (tm:time->date 'time-monotonic->date tim tzi 'time-monotonic) )
     1589
     1590(define (time->date tim . tzi)
     1591  (%check-time 'time->date tim)
    14731592  (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)]
     1593    [(time-monotonic) (apply time-monotonic->date tim tzi)]
     1594    [(time-utc)       (apply time-utc->date tim tzi)]
     1595    [(time-tai)       (apply time-tai->date tim tzi)]
     1596    [else ; This shouldn't happen
     1597      (error 'time->date "invalid clock type" tim)]) )
     1598
     1599(define (date->time-utc dat)
     1600  (%check-date 'date->time-utc dat)
     1601  (let ([ns (%date-nanosecond dat)]
     1602        [sec (%date-second dat)]
     1603        [min (%date-minute dat)]
     1604        [hr (%date-hour dat)]
     1605        [dy (%date-day dat)]
     1606        [mn (%date-month dat)]
     1607        [yr (%date-year dat)]
     1608        [tzo (%date-zone-offset dat)])
     1609    (let ([jdys (- (tm:encode-julian-day-number dy mn yr) TAI-EPOCH-IN-JD)])
     1610      (tm:make-time
     1611        'time-utc
     1612        ns
     1613        (+ (* (- jdys ONE-HALF) SEC/DY)
     1614           (fx+ (fx+ (fx* hr SEC/HR) (fx+ (fx* min SEC/MIN) sec)) (fxneg tzo)))) ) ) )
     1615
     1616(define (date->time-tai dat)
     1617  (%check-date 'date->time-tai dat)
     1618  (if (= 60 (%date-second dat)) ; FIXME fixnum?
     1619    (let ([tm-tai (time-utc->time-tai! (date->time-utc dat))])
     1620      (tm:subtract-duration tm-tai ONE-SECOND-DURATION tm-tai))
     1621    (time-utc->time-tai! (date->time-utc dat))) )
     1622
     1623(define (date->time-monotonic dat)
     1624  (time-utc->time-monotonic! (date->time-utc dat)) )
     1625
     1626(define (date->time dat . timtyp)
     1627  (%check-date 'date->time dat)
     1628  (case (optional timtyp (default-date-clock-type))
     1629    [(time-monotonic) (date->time-monotonic dat)]
     1630    [(time-utc)       (date->time-utc dat)]
     1631    [(time-tai)       (date->time-tai dat)]
    14771632    [else
    1478       (error 'time->date "invalid clock-type" time)]) )
    1479 
    1480 (define (date->time-utc 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)])
    1489     (let ([jdays
    1490             (- (tm:encode-julian-day-number day month year)
    1491                TAI-EPOCH-IN-JD)])
    1492       (tm:make-time 'time-utc
    1493         nanosecond
    1494         (+ (* (- jdays ONE-HALF) SEC/DY)
    1495            (fx+ (fx+ (fx* hour SEC/HR) (fx+ (fx* minute SEC/MIN) second)) (fxneg tzo)))) ) ) )
    1496 
    1497 (define (date->time-tai date)
    1498   (if (= (%date-second date) 60)
    1499     (let ([tm-tai (time-utc->time-tai! (date->time-utc date))])
    1500       (tm:subtract-duration tm-tai ONE-SECOND-DURATION tm-tai))
    1501     (time-utc->time-tai! (date->time-utc date))) )
    1502 
    1503 (define (date->time-monotonic date)
    1504   (time-utc->time-monotonic! (date->time-utc date)) )
    1505 
    1506 (define (date->time date . 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)]) )
    1513 
    1514 ;;
    1515 
    1516 (define (leap-year? date)
    1517   (%check-date 'leap-year? obj)
    1518   (tm:leap-year? (%date-year date)) )
    1519 
    1520 ;;
    1521 
    1522 (define tm:year-day
    1523   (let ([cumul-month-days '#(0 0 31 59 90 120 151 181 212 243 273 304 334)])
    1524     (lambda (day month year)
    1525       (if (and (fx<= 1 month) (fx<= month 12))
    1526         (let ([yd (fx+ day (vector-ref cumul-month-days month))])
    1527           (if (and (tm:leap-year? year) (fx< 2 month))
    1528             (fx+ yd 1)
    1529             yd) )
    1530         (error 'srfi-19 "invalid month" month)) ) ) )
    1531 
    1532 ;;
    1533 
    1534 (define (date-year-day date)
    1535   (or (date-yday date)
    1536       (let ([yday (tm:year-day (%date-day date) (%date-month date) (%date-year date))])
    1537         (%date-yday-set! date yday)
    1538         yday ) ) )
     1633      (error 'date->time "invalid clock type" timtyp)]) )
     1634
     1635;;
     1636
     1637(define (leap-year? yr)
     1638  (tm:check-year 'leap-year? yr)
     1639  (tm:leap-year? yr) )
     1640
     1641;;
     1642
     1643(define (date-leap-year? dat)
     1644  (%check-date 'date-leap-year? dat)
     1645  (tm:leap-year? (%date-year dat)) )
     1646
     1647;;
     1648
     1649(define (tm:year-day dy mn yr)
     1650  (let ([yrdy (fx+ dy (vector-ref tm:cumulative-month-days mn))])
     1651    (if (and (tm:leap-year? yr) (fx< 2 mn))
     1652      (fx+ yrdy 1)
     1653      yrdy ) ) )
     1654
     1655(define (year-day dy mn yr)
     1656  (tm:check-year 'year-day yr)
     1657  (tm:check-month 'year-day mn)
     1658  (tm:check-day 'year-day yr mn dy)
     1659  (tm:year-day dy mn yr) )
     1660
     1661;;
     1662
     1663(define (date-year-day dat)
     1664  (%check-date 'date-year-day dat)
     1665  (or (date-yday dat)
     1666      (let ([yrdy (tm:year-day (%date-day dat) (%date-month dat) (%date-year dat))])
     1667        (%date-yday-set! dat yrdy)
     1668        yrdy ) ) )
    15391669
    15401670;; Using Gregorian Calendar (from Calendar FAQ)
    15411671
    1542 (define (tm:week-day day month year)
    1543   (let* ([a (fx/ (fx- 14 month) MN/YR)]
    1544          [y (fx- year a)]
    1545          [m (fx- (fx+ month (fx* a MN/YR)) 2)])
     1672(define (tm:week-day dy mn yr)
     1673  (let* ([a (fx/ (fx- 14 mn) MN/YR)]
     1674         [y (fx- yr a)]
     1675         [m (fx- (fx+ mn (fx* a MN/YR)) 2)])
    15461676    (modulo
    1547       (fx+ day
     1677      (fx+ dy
    15481678           (fx+ y
    15491679                (fx+ (fx/ y 4)
    … …  
    15541684;;
    15551685
    1556 (define (date-week-day date)
    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)
    1560         wday ) ) )
    1561 
    1562 (define (date-week-number date . rest)
    1563   (let ([day-of-week-starting-week (optional rest 0)])
    1564     (fx/ (fx- (%date-year-day date) (tm:days-before-first-week date day-of-week-starting-week))
     1686(define (date-week-day dat)
     1687  (%check-date 'date-week-day dat)
     1688  (or (%date-wday dat)
     1689      (let ([wdy (tm:week-day (%date-day dat) (%date-month dat) (%date-year dat))])
     1690        (%date-wday-set! dat wdy)
     1691        wdy ) ) )
     1692
     1693(define (date-week-number dat . args)
     1694  (%check-date 'date-week-number dat)
     1695  (let ([day-of-week-starting-week (optional args 0)])
     1696    (fx/ (fx- (%date-year-day dat) (tm:days-before-first-week dat day-of-week-starting-week))
    15651697         DY/WK) ) )
    15661698
    … …  
    15701702; The range is < 1 second here (but not in the reference).
    15711703
    1572 (define (tm:julian-day-exact nanosecond second minute hour day month year tzo)
     1704(define (tm:julian-day nanosecond second minute hour day month year tzo)
    15731705  (+ (- (tm:encode-julian-day-number day month year) ONE-HALF)
    15741706     (/ (+ (fx+ (fx+ (fx* hour SEC/HR) (fx+ (fx* minute SEC/MIN) second)) (fxneg tzo))
    … …  
    15761708        SEC/DY)) )
    15771709
    1578 #;
    1579 (define (tm:julian-day-inexact nanosecond second minute hour day month year tzo)
     1710#; ; inexact version
     1711(define (tm:julian-day nanosecond second minute hour day month year tzo)
    15801712  (fp+ (fp- (exact->inexact (tm:encode-julian-day-number day month year)) iONE-HALF)
    15811713       (fp/ (fp+ (exact->inexact
    … …  
    15841716            iSEC/DY)) )
    15851717
    1586 (define tm:julian-day tm:julian-day-exact)
    1587 
    1588 ;;
    1589 
    1590 (define (date->julian-day date)
    1591   (%check-date 'date->julian-day date)
    1592   (or (date-jday date)
     1718;;
     1719
     1720(define (date->julian-day dat)
     1721  (%check-date 'date->julian-day dat)
     1722  (or (date-jday dat)
    15931723      (let ([jdn
    15941724              (tm:julian-day
    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)
     1725                (%date-nanosecond dat)
     1726                (%date-second dat) (%date-minute dat) (%date-hour dat)
     1727                (%date-day dat) (%date-month dat) (%date-year dat)
     1728                (%date-zone-offset dat))])
     1729        (%date-jday-set! dat jdn)
    16001730        jdn ) ) )
    16011731
    1602 (define (date->modified-julian-day date)
    1603   (- (date->julian-day date) TAI-EPOCH-IN-MODIFIED-JD) )
     1732(define (date->modified-julian-day dat)
     1733  (- (date->julian-day dat) TAI-EPOCH-IN-MODIFIED-JD) )
    16041734
    16051735;; Time to Julian-day
    16061736
    1607 (define (tm:seconds->julian-day nanos secs)
    1608   (+ TAI-EPOCH-IN-JD (/ (+ secs (/ nanos NS/S)) SEC/DY)) )
    1609 
    1610 (define (tm:time-utc->julian-day time)
    1611   (tm:seconds->julian-day (%time-nanosecond time) (%time-second time)) )
    1612 
    1613 (define (tm:time-tai->julian-day time)
    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)]
     1737(define (tm:seconds->julian-day ns sec)
     1738  (+ TAI-EPOCH-IN-JD (/ (+ sec (/ ns NS/S)) SEC/DY)) )
     1739
     1740(define (tm:time-utc->julian-day tim)
     1741  (tm:seconds->julian-day (%time-nanosecond tim) (%time-second tim)) )
     1742
     1743(define (tm:time-tai->julian-day tim)
     1744  (let ([sec (%time-second tim)])
     1745    (tm:seconds->julian-day (%time-nanosecond tim) (- sec (tm:leap-second-delta sec))) ) )
     1746
     1747(define (time-utc->julian-day tim)
     1748  (tm:check-time-and-type'time-utc->julian-day tim 'time-utc)
     1749  (tm:time-utc->julian-day tim) )
     1750
     1751(define (time-tai->julian-day tim)
     1752  (tm:check-time-and-type 'time-tai->julian-day tim 'time-tai)
     1753  (tm:time-tai->julian-day tim) )
     1754
     1755(define (time-monotonic->julian-day tim)
     1756  (tm:check-time-and-type 'time-monotonic->julian-day tim 'time-monotonic)
     1757  (tm:time-tai->julian-day tim) )
     1758
     1759(define (time->julian-day tim)
     1760  (%check-time 'time->julian-day tim)
     1761  (case (%time-type tim)
     1762    [(time-monotonic) (tm:time-tai->julian-day tim)]
     1763    [(time-utc)       (tm:time-utc->julian-day tim)]
     1764    [(time-tai)       (tm:time-tai->julian-day tim)]
    16341765    [else
    1635       (error 'time->julian-day "invalid clock-type" time)]) )
     1766      (error 'time->julian-day "invalid clock type" tim)]) )
    16361767
    16371768;; Time to Modified-julian-day
    16381769
    1639 (define (tm:time-utc->modified-julian-day time)
    1640   (- (tm:time-utc->julian-day time) TAI-EPOCH-IN-MODIFIED-JD) )
    1641 
    1642 (define (tm:time-tai->modified-julian-day time)
    1643   (- (tm:time-tai->julian-day time) TAI-EPOCH-IN-MODIFIED-JD) )
    1644 
    1645 (define (time-utc->modified-julian-day time)
    1646   (tm:check-time-has-type time 'time-utc 'time-utc->modified-julian-day)
    1647   (tm:time-utc->modified-julian-day time) )
    1648 
    1649 (define (time-tai->modified-julian-day time)
    1650   (tm:check-time-has-type time 'time-tai 'time-tai->modified-julian-day)
    1651   (tm:time-tai->modified-julian-day time) )
    1652 
    1653 (define (time-monotonic->modified-julian-day time)
    1654   (tm:check-time-has-type time 'time-monotonic 'time-monotonic->modified-julian-day)
    1655   (tm:time-tai->modified-julian-day time) )
    1656 
    1657 (define (time->modified-julian-day time)
    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)]
     1770(define (tm:time-utc->modified-julian-day tim)
     1771  (- (tm:time-utc->julian-day tim) TAI-EPOCH-IN-MODIFIED-JD) )
     1772
     1773(define (tm:time-tai->modified-julian-day tim)
     1774  (- (tm:time-tai->julian-day tim) TAI-EPOCH-IN-MODIFIED-JD) )
     1775
     1776(define (time-utc->modified-julian-day tim)
     1777  (tm:check-time-and-type 'time-utc->modified-julian-day tim 'time-utc)
     1778  (tm:time-utc->modified-julian-day tim) )
     1779
     1780(define (time-tai->modified-julian-day tim)
     1781  (tm:check-time-and-type 'time-tai->modified-julian-day tim 'time-tai)
     1782  (tm:time-tai->modified-julian-day tim) )
     1783
     1784(define (time-monotonic->modified-julian-day tim)
     1785  (tm:check-time-and-type 'time-monotonic->modified-julian-day tim 'time-monotonic)
     1786  (tm:time-tai->modified-julian-day tim) )
     1787
     1788(define (time->modified-julian-day tim)
     1789  (%check-time 'time->modified-julian-day tim)
     1790  (case (%time-type tim)
     1791    [(time-monotonic) (tm:time-tai->modified-julian-day tim)]
     1792    [(time-utc)       (tm:time-utc->modified-julian-day tim)]
     1793    [(time-tai)       (tm:time-tai->modified-julian-day tim)]
    16621794    [else
    1663       (error 'time->modified-julian-day "invalid clock-type" time)]) )
     1795      (error 'time->modified-julian-day "invalid clock type" tim)]) )
    16641796
    16651797;; Julian-day to Time
    … …  
    16751807  (time-utc->time-monotonic! (julian-day->time-utc jdn)) )
    16761808
    1677 (define (julian-day->date jdn . tz-info)
    1678   (apply time-utc->date (julian-day->time-utc jdn) tz-info) )
     1809(define (julian-day->date jdn . tzi)
     1810  (apply time-utc->date (julian-day->time-utc jdn) tzi) )
    16791811
    16801812;; Modified-julian-day to Time
    16811813
    1682 (define (modified-julian-day->time-utc jdn)
    1683   (julian-day->time-utc (+ jdn TAI-EPOCH-IN-MODIFIED-JD)) )
    1684 
    1685 (define (modified-julian-day->time-tai jdn)
    1686   (julian-day->time-tai (+ jdn TAI-EPOCH-IN-MODIFIED-JD)) )
    1687 
    1688 (define (modified-julian-day->time-monotonic jdn)
    1689   (julian-day->time-monotonic (+ jdn TAI-EPOCH-IN-MODIFIED-JD)) )
    1690 
    1691 (define (modified-julian-day->date jdn . tz-info)
    1692   (apply julian-day->date (+ jdn TAI-EPOCH-IN-MODIFIED-JD) tz-info) )
     1814(define (modified-julian-day->time-utc mjdn)
     1815  (julian-day->time-utc (+ mjdn TAI-EPOCH-IN-MODIFIED-JD)) )
     1816
     1817(define (modified-julian-day->time-tai mjdn)
     1818  (julian-day->time-tai (+ mjdn TAI-EPOCH-IN-MODIFIED-JD)) )
     1819
     1820(define (modified-julian-day->time-monotonic mjdn)
     1821  (julian-day->time-monotonic (+ mjdn TAI-EPOCH-IN-MODIFIED-JD)) )
     1822
     1823(define (modified-julian-day->date mjdn . tzi)
     1824  (apply julian-day->date (+ mjdn TAI-EPOCH-IN-MODIFIED-JD) tzi) )
    16931825
    16941826;; The Julian-day

  • release/3/srfi-19/trunk/srfi-19-io.scm

    r12020 r12029  
    5050    (export
    5151      ;; SRFI-19 extensions
    52       format-date scan-date
     52      format-date
     53      scan-date
    5354      ;; SRFI-19
    54       date->string string->date) ) )
     55      date->string
     56      string->date) ) )
    5557
    5658(use srfi-1 srfi-13
    … …  
    9799  (let* ([current-year (date-year (current-date))]
    98100         [current-century (fx* (fx/ current-year 100) 100)])
    99     (cond [(fx>= n 100)
    100             n]
    101           [(fx< n 0)
    102             n]
    103           [(fx<= (fx- (fx+ current-century n) current-year) 50)
    104             (fx+ current-century n)]
    105           [else
    106             (fx+ (fx- current-century 100) n)]) ) )
     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)]) ) )
    107110
    108111;; Return a string representing the decimal expansion of the fractional
    … …  
    114117             [lst '()])
    115118    (if (or (fx= 0 p) (zero? num))
    116         (apply string-append (reverse! lst))
    117         (let* ([num-times-10 (* 10 num)]
    118                [round-num-times-10 (round num-times-10)])
    119           (loop (- num-times-10 round-num-times-10)
    120                 (fx- p 1)
    121                 (cons (number->string (inexact->exact round-num-times-10))
    122                       lst)) ) ) ) )
     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)) ) ) ) )
    123126
    124127;; Returns a string rep. of number N, of minimum LENGTH,
    … …  
    133136                        (char=? #\. (string-ref str (fx- len 2)))
    134137                        (char=? #\0 (string-ref str (fx- len 1))) )
    135                    (substring str 0 (fx- len 2))
    136                    str) ) )
     138               (substring str 0 (fx- len 2))
     139               str) ) )
    137140      (if (or (not pad-with) (> len length))
    138           str
    139           (string-pad str length pad-with)) ) ) )
     141        str
     142        (string-pad str length pad-with)) ) ) )
    140143
    141144(define (tm:last-n-digits i n)
    … …  
    185188(define (tm:tz-printer offset port)
    186189  (if (= offset 0)
    187       (display "Z" port)
    188       (let ((isneg (fx< offset 0)))
    189         (display (if isneg #\- #\+) port)
    190         (let ([offset (if isneg (fxneg offset) offset)])
    191           (display (tm:padding (quotient offset SEC/HR) #\0 2) port)
    192           (display (tm:padding (quotient (remainder offset SEC/HR) SEC/MIN) #\0 2) port) ) ) ) )
     190    (display "Z" port)
     191    (let ((isneg (fx< offset 0)))
     192      (display (if isneg #\- #\+) port)
     193      (let ([offset (if isneg (fxneg offset) offset)])
     194        (display (tm:padding (quotient offset SEC/HR) #\0 2) port)
     195        (display (tm:padding (quotient (remainder offset SEC/HR) SEC/MIN) #\0 2) port) ) ) ) )
    193196
    194197;; A table of output formatting directives.
    … …  
    239242        (let ([ns (date-nanosecond date)] [sec (date-second date)])
    240243          (if (> ns NS/S) ; This shouldn't happen!
    241               (display (tm:padding (+ sec 1) pad-with 2) port)
    242               (display (tm:padding sec pad-with 2) port))
     244            (display (tm:padding (+ sec 1) pad-with 2) port)
     245            (display (tm:padding sec pad-with 2) port))
    243246          (let ([f (tm:decimal-expansion (/ ns NS/S) 6)])
    244247            (when (fx> (string-length f) 0)
    … …  
    258261        (let ([hr (date-hour date)])
    259262          (if (fx> hr 12)
    260               (display (tm:padding (fx- hr 12) pad-with 2) port)
    261               (display (tm:padding hr pad-with 2) port)))))
     263            (display (tm:padding (fx- hr 12) pad-with 2) port)
     264            (display (tm:padding hr pad-with 2) port)))))
    262265
    263266    (cons #\j
    … …  
    306309        (let ([sec (date-second date)])
    307310          (if (> (date-nanosecond date) NS/S) ; This shouldn't happen!
    308               (display (tm:padding (+ sec 1) pad-with 2) port)
    309               (display (tm:padding sec pad-with 2) port)))))
     311            (display (tm:padding (+ sec 1) pad-with 2) port)
     312            (display (tm:padding sec pad-with 2) port)))))
    310313
    311314    (cons #\t
    … …  
    321324        (let ([wkno (date-week-number date 0)])
    322325          (if (fx> (tm:days-before-first-week date 0) 0)
    323               (display (tm:padding (fx+ wkno 1) #\0 2) port)
    324               (display (tm:padding wkno #\0 2) port)))))
     326            (display (tm:padding (fx+ wkno 1) #\0 2) port)
     327            (display (tm:padding wkno #\0 2) port)))))
    325328
    326329    (cons #\V
    … …  
    336339        (let ([wkno (date-week-number date 1)])
    337340          (if (fx> (tm:days-before-first-week date 1) 0)
    338               (display (tm:padding (fx+ wkno 1) #\0 2) port)
    339               (display (tm:padding wkno #\0 2) port)))))
     341            (display (tm:padding (fx+ wkno 1) #\0 2) port)
     342            (display (tm:padding wkno #\0 2) port)))))
    340343
    341344    (cons #\x
    … …  
    392395              (and-let* ([associated (assoc char tm:display-directives)])
    393396                (cdr associated)))])
    394       (cond [(not (char=? current-char #\~))
    395               (display current-char port)
    396               (tm:date-printer loc date (cdr format-rem) (fx- len-rem 1) port)]
    397             [(fx< len-rem 2)
    398               (error loc "bad date format" (list->string format-rem))]
    399             [else
    400               (let ([pad-ch (cadr format-rem)])
    401                 (cond [(char=? pad-ch #\-)
    402                         (if (fx< len-rem 3)
    403                             (error loc "bad date format" (list->string format-rem))
    404                             (let ([formatter (get-formatter (caddr format-rem))])
    405                               (if (not formatter)
    406                                   (error loc "bad date format" (list->string format-rem))
    407                                   (begin
    408                                     (formatter date #f port)
    409                                     (tm:date-printer loc date (cdddr format-rem)
    410                                                      (fx- len-rem 3) port)))))]
    411                       [(char=? pad-ch #\_)
    412                         (if (fx< len-rem 3)
    413                             (error loc "bad date format" (list->string format-rem))
    414                             (let ([formatter (get-formatter (caddr format-rem))])
    415                               (if (not formatter)
    416                                   (error loc "bad date format" (list->string format-rem))
    417                                   (begin
    418                                     (formatter date #\space port)
    419                                     (tm:date-printer loc date (cdddr format-rem)
    420                                                      (fx- len-rem 3) port)))))]
    421                       [else
    422                         (let ([formatter (get-formatter pad-ch)])
    423                           (if (not formatter)
    424                               (error loc "bad date format" (list->string format-rem))
    425                               (begin
    426                                 (formatter date #\0 port)
    427                                 (tm:date-printer loc date (cddr format-rem)
    428                                                  (fx- len-rem 2) port))))]))]) )) )
     397      (cond
     398        [(not (char=? current-char #\~))
     399          (display current-char port)
     400          (tm:date-printer loc date (cdr format-rem) (fx- len-rem 1) port)]
     401        [(fx< len-rem 2)
     402          (error loc "bad date format" (list->string format-rem))]
     403        [else
     404          (let ([pad-ch (cadr format-rem)])
     405            (cond
     406              [(char=? pad-ch #\-)
     407                (if (fx< len-rem 3)
     408                  (error loc "bad date format" (list->string format-rem))
     409                  (let ([formatter (get-formatter (caddr format-rem))])
     410                    (if (not formatter)
     411                      (error loc "bad date format" (list->string format-rem))
     412                      (begin
     413                        (formatter date #f port)
     414                        (tm:date-printer loc date (cdddr format-rem)
     415                                         (fx- len-rem 3) port)))))]
     416              [(char=? pad-ch #\_)
     417                (if (fx< len-rem 3)
     418                  (error loc "bad date format" (list->string format-rem))
     419                  (let ([formatter (get-formatter (caddr format-rem))])
     420                    (if (not formatter)
     421                      (error loc "bad date format" (list->string format-rem))
     422                      (begin
     423                        (formatter date #\space port)
     424                        (tm:date-printer loc date (cdddr format-rem)
     425                                         (fx- len-rem 3) port)))))]
     426              [else
     427                (let ([formatter (get-formatter pad-ch)])
     428                  (if (not formatter)
     429                    (error loc "bad date format" (list->string format-rem))
     430                    (begin
     431                      (formatter date #\0 port)
     432                      (tm:date-printer loc date (cddr format-rem)
     433                                       (fx- len-rem 2) port))))]))]) )) )
    429434
    430435(define (format-date dest fmt-str . r)
    431436  (let ([port #f] [date (optional r #f)])
    432     (cond [(not dest)
    433             (set! port (open-output-string))]
    434           [(string? dest)
    435             (set! date fmt-str)
    436             (set! fmt-str dest)
    437             (set! port (open-output-string))]
    438           [(number? dest)
    439             (set! port (current-error-port))]
    440           [(port? dest)
    441             (set! port dest)]
    442           [else
    443             (set! port (current-output-port))])
     437    (cond
     438      [(not dest)
     439        (set! port (open-output-string))]
     440      [(string? dest)
     441        (set! date fmt-str)
     442        (set! fmt-str dest)
     443        (set! port (open-output-string))]
     444      [(number? dest)
     445        (set! port (current-error-port))]
     446      [(port? dest)
     447        (set! port dest)]
     448      [else
     449        (set! port (current-output-port))])
    444450    (tm:date-printer 'display-date date (string->list fmt-str) (string-length fmt-str) port)
    445     (if (or (not dest) (string? dest))
    446         (get-output-string port)
    447         #t) ) )
     451    (or dest
     452        (not (string? dest)))
     453        (get-output-string port) ) )
    448454
    449455(define (date->string date . format-string)
    … …  
    475481              (not (char-numeric? ch))
    476482              (and upto (fx>= nchars upto)))
    477           accum
    478           (loop (fx+ (fx* accum 10) (tm:char->int (read-char port))) (fx+ nchars 1))) ) ) )
     483        accum
     484        (loop (fx+ (fx* accum 10) (tm:char->int (read-char port))) (fx+ nchars 1))) ) ) )
    479485
    480486(define (tm:make-integer-reader upto)
    … …  
    488494    (let loop ([accum 0] [nchars 0])
    489495      (let ([ch (peek-char port)])
    490         (cond [(fx>= nchars n)
    491                 accum]
    492               [(eof-object? ch)
    493                 (error 'string->date "bad date template: premature ending to integer read")]
    494               [(char-numeric? ch)
    495                 (set! padding-ok #f)
    496                 (loop (fx+ (fx* accum 10) (tm:char->int (read-char port))) (fx+ nchars 1))]
    497               [padding-ok
    498                 (read-char port)    ; consume padding
    499                 (loop accum (fx+ nchars 1))]
    500               [else                 ; padding where it shouldn't be
    501                 (error 'string->date "bad date template: non-numeric characters in integer read")]) ) ) ) )
     496        (cond
     497          [(fx>= nchars n)
     498            accum]
     499          [(eof-object? ch)
     500            (error 'string->date "bad date template: premature ending to integer read")]
     501          [(char-numeric? ch)
     502            (set! padding-ok #f)
     503            (loop (fx+ (fx* accum 10) (tm:char->int (read-char port))) (fx+ nchars 1))]
     504          [padding-ok
     505            (read-char port)    ; consume padding
     506            (loop accum (fx+ nchars 1))]
     507          [else                 ; padding where it shouldn't be
     508            (error 'string->date "bad date template: non-numeric characters in integer read")]) ) ) ) )
    502509
    503510(define (tm:make-integer-exact-reader n)
    … …  
    511518        (error 'string->date "bad date template: invalid time zone +/-"))
    512519      (if (or (char=? ch #\Z) (char=? ch #\z))
    513           0
    514           (begin
    515             (cond [(char=? ch #\+) (set! is-pos #t)]
    516                   [(char=? ch #\-) (set! is-pos #f)]
    517                   [else
    518                     (error 'string->date "bad date template: invalid time zone +/-" ch)])
    519             (let ([ch (read-char port)])
    520               (when (eof-object? ch)
    521                 (error 'string->date "bad date template: invalid time zone number"))
    522               (set! offset (fx* (tm:char->int ch) (fx* 10 SEC/HR))))
    523             ;; non-existing values are considered zero
    524             (let ([ch (read-char port)])
    525               (unless (eof-object? ch)
    526                 (set! offset (fx+ offset (fx* (tm:char->int ch) SEC/HR)))))
    527             (let ([ch (read-char port)])
    528               (unless (eof-object? ch)
    529                 (set! offset (fx+ offset (fx* (tm:char->int ch) 600)))))
    530             (let ([ch (read-char port)])
    531               (unless (eof-object? ch)
    532                 (set! offset (fx+ offset (fx* (tm:char->int ch) 60)))))
    533             (if is-pos offset (fxneg offset)))) ) ) )
     520        0
     521        (begin
     522          (cond
     523            [(char=? ch #\+) (set! is-pos #t)]
     524            [(char=? ch #\-) (set! is-pos #f)]
     525            [else
     526              (error 'string->date "bad date template: invalid time zone +/-" ch)])
     527          (let ([ch (read-char port)])
     528            (when (eof-object? ch)
     529              (error 'string->date "bad date template: invalid time zone number"))
     530            (set! offset (fx* (tm:char->int ch) (fx* 10 SEC/HR))))
     531          ;; non-existing values are considered zero
     532          (let ([ch (read-char port)])
     533            (unless (eof-object? ch)
     534              (set! offset (fx+ offset (fx* (tm:char->int ch) SEC/HR)))))
     535          (let ([ch (read-char port)])
     536            (unless (eof-object? ch)
     537              (set! offset (fx+ offset (fx* (tm:char->int ch) 600)))))
     538          (let ([ch (read-char port)])
     539            (unless (eof-object? ch)
     540              (set! offset (fx+ offset (fx* (tm:char->int ch) 60)))))
     541          (if is-pos offset (fxneg offset)))) ) ) )
    534542
    535543;; Looking at a char, read the char string, run thru indexer, return index
    … …  
    556564  (lambda (port)
    557565    (if (char=? char (read-char port))
    558         char
    559         (error 'string->date "bad date template: invalid character match"))) )
     566      char
     567      (error 'string->date "bad date template: invalid character match"))) )
    560568
    561569;; A List of formatted read directives.
    … …  
    648656              (let loop ([ch (peek-char port)])
    649657                (if (eof-object? ch)
    650                     (error 'scan-date "bad date template" (list->string format-rem))
    651                     (unless (skipper ch)
    652                       (read-char port)
    653                       (loop (peek-char port))))))])
     658                  (error 'scan-date "bad date template" (list->string format-rem))
     659                  (unless (skipper ch)
     660                    (read-char port)
     661                    (loop (peek-char port))))))])
    654662      (when (fx< 0 len-rem)
    655663        (let ([current-char (car format-rem)])
    656           (cond [(not (char=? current-char #\~))
    657                   (let ([port-char (read-char port)])
    658                     (when (or (eof-object? port-char)
    659                               (not (char=? current-char port-char)))
    660                       (error 'scan-date "bad date template" (list->string format-rem))))
    661                   (loop (cdr format-rem) (fx- len-rem 1))]
    662                   ;; otherwise, it's an escape, we hope
    663                 [(fx< len-rem 2)
    664                   (error 'scan-date "bad date template" (list->string format-rem))]
    665                 [else
    666                   (let* ([format-char (cadr format-rem)]
    667                          [format-info (assoc format-char tm:read-directives)])
    668                     (unless format-info
    669                       (error 'scan-date "bad date template" (list->string format-rem)))
    670                     (let ([skipper (cadr format-info)]
    671                           [reader (caddr format-info)]
    672                           [actor (cadddr format-info)])
    673                       (skip-until skipper)
    674                       (let ([val (reader port)])
    675                         (if (eof-object? val)
    676                             (error 'scan-date "bad date template" (list->string format-rem))
    677                             (actor val date))))
    678                     (loop (cddr format-rem) (fx- len-rem 2)))]) ) ) ) ) )
     664          (cond
     665            [(not (char=? current-char #\~))
     666              (let ([port-char (read-char port)])
     667                (when (or (eof-object? port-char)
     668                          (not (char=? current-char port-char)))
     669                  (error 'scan-date "bad date template" (list->string format-rem))))
     670              (loop (cdr format-rem) (fx- len-rem 1))]
     671              ;; otherwise, it's an escape, we hope
     672            [(fx< len-rem 2)
     673              (error 'scan-date "bad date template" (list->string format-rem))]
     674            [else
     675              (let* ([format-char (cadr format-rem)]
     676                     [format-info (assoc format-char tm:read-directives)])
     677                (unless format-info
     678                  (error 'scan-date "bad date template" (list->string format-rem)))
     679                (let ([skipper (cadr format-info)]
     680                      [reader (caddr format-info)]
     681                      [actor (cadddr format-info)])
     682                  (skip-until skipper)
     683                  (let ([val (reader port)])
     684                    (if (eof-object? val)
     685                      (error 'scan-date "bad date template" (list->string format-rem))
     686                      (actor val date))))
     687                (loop (cddr format-rem) (fx- len-rem 2)))]) ) ) ) ) )
    679688
    680689(define (scan-date src template-string)
    … …  
    700709                (date-zone-offset newdate)
    701710                (date-zone-name newdate)))])
    702       (cond [(string? src)  (set! port (open-input-string src))]
    703             [(port? src)    (set! port src)]
    704             [src            (set! port (current-input-port))])
     711      (cond
     712        [(string? src)  (set! port (open-input-string src))]
     713        [(port? src)    (set! port src)]
     714        [src            (set! port (current-input-port))])
    705715      (tm:date-reader newdate (string->list template-string) (string-length template-string) port)
    706716      (unless (date-compl?)

  • release/3/srfi-19/trunk/srfi-19-period.scm

    r12020 r12029  
    2525      time-period?
    2626      time-period-null?
    27       time-period=? time-period<? time-period>? time-period<=? time-period>=?
     27      time-period=?
     28      time-period<?
     29      time-period>?
     30      time-period<=?
     31      time-period>=?
    2832      time-period-type
    29       time-period-begin time-period-end time-period-last
     33      time-period-begin
     34      time-period-end
     35      time-period-last
    3036      time-period-length
    31       make-null-time-period make-time-period copy-time-period
    32       time-period-contains/period? time-period-contains/time?
    33       time-period-contains/date? time-period-contains?
    34       time-period-intersects? time-period-intersection
    35       time-period-union time-period-span
    36       time-period-shift time-period-shift!
    37       time-period-preceding time-period-succeeding) ) )
     37      make-null-time-period
     38      make-time-period
     39      copy-time-period
     40      time-period-contains/period?
     41      time-period-contains/time?
     42      time-period-contains/date?
     43      time-period-contains?
     44      time-period-intersects?
     45      time-period-intersection
     46      time-period-union
     47      time-period-span
     48      time-period-shift
     49      time-period-shift!
     50      time-period-preceding
     51      time-period-succeeding) ) )
    3852
    3953(use srfi-8
    … …  
    4660;;; Time Period
    4761
    48 (define-record-type time-period
     62(define-record-type/unsafe-inline-unchecked time-period
    4963  (%make-time-period beg end)
    50   time-period?
    51   (beg time-period-begin #;%set-time-period-begin!)
    52   (end time-period-end #;%set-time-period-end!) )
     64  %time-period?
     65  (beg %time-period-begin)
     66  (end %time-period-end) )
     67
     68(define-inline (%check-time-period loc obj)
     69  (##sys#check-structure obj 'time-period loc) )
    5370
    5471(define-record-printer (time-period per out)
    55   (fprintf out "#,(time-period ~A ~A)"
    56     (time-period-begin per) (time-period-end per)) )
     72  (fprintf out "#,(time-period ~A ~A)" (%time-period-begin per) (%time-period-end per)) )
    5773
    5874(define-reader-ctor 'time-period %make-time-period)
    5975
    60 (define (tm:time-period-check obj loc)
    61   (unless (time-period? obj)
    62     (error loc "invalid time-period" obj)) )
    63 
    64 (define (tm:time-period-binop-check obj1 obj2 loc)
    65   (tm:time-period-check obj1 loc)
    66   (tm:time-period-check obj2 loc) )
     76(define (tm:time-period-binop-check loc obj1 obj2)
     77  (%check-time-period loc obj1)
     78  (%check-time-period loc obj2) )
    6779
    6880(define (tm:time-period-type per)
    69    (time-type (time-period-begin per)) )
     81   (%time-type (%time-period-begin per)) )
    7082
    7183(define (tm:time-period-null? per)
    72   (tm:time<=? (time-period-end per) (time-period-begin per)) )
     84  (tm:time<=? (%time-period-end per) (%time-period-begin per)) )
    7385
    7486(define (tm:as-empty-time-period per)
    7587  (%make-time-period
    76     (tm:as-empty-time (time-period-begin per))
    77     (tm:as-empty-time (time-period-end per))) )
    78 
    79 (define (tm:ensure-compatible-time t1 t2 loc)
    80   (let ([tt1 (time-type t1)]
    81         [tt2 (time-type t2)]
     88    (tm:as-empty-time (%time-period-begin per))
     89    (tm:as-empty-time (%time-period-end per))) )
     90
     91(define (tm:ensure-compatible-time loc t1 t2)
     92  (let ([tt1 (%time-type t1)]
     93        [tt2 (%time-type t2)]
    8294        [errtt
    8395          (lambda ()
    … …  
    8698      t2
    8799      (let ([ntime (tm:as-empty-time t1)])
    88         (switch tt1
    89           [time-tai
    90             (switch tt2
    91               [time-utc (tm:time-utc->time-tai t2 ntime)]
    92               [time-monotonic (tm:time-monotonic->time-tai t2 ntime)]
     100        (case tt1
     101          [(time-tai)
     102            (case tt2
     103              [(time-utc)      (tm:time-utc->time-tai t2 ntime)]
     104              [(time-monotonic) (tm:time-monotonic->time-tai t2 ntime)]
    93105              [else
    94106                (errtt)])]
    95           [time-utc
    96             (switch tt2
    97               [time-tai (tm:time-tai->time-utc t2 ntime)]
    98               [time-monotonic (tm:time-monotonic->time-utc t2 ntime)]
     107          [(time-utc)
     108            (case tt2
     109              [(time-tai)      (tm:time-tai->time-utc t2 ntime)]
     110              [(time-monotonic) (tm:time-monotonic->time-utc t2 ntime)]
    99111              [else
    100112                (errtt)])]
    101           [time-monotonic
    102             (switch tt2
    103               [time-utc (tm:time-utc->time-monotonic t2 ntime)]
    104               [time-tai (tm:time-tai->time-monotonic t2 ntime)]
     113          [(time-monotonic)
     114            (case tt2
     115              [(time-utc) (tm:time-utc->time-monotonic t2 ntime)]
     116              [(time-tai) (tm:time-tai->time-monotonic t2 ntime)]
    105117              [else
    106118                (errtt)])]
    … …  
    109121
    110122(define (tm:ensure-compatible-date tim dat loc)
    111   (switch (time-type tim)
    112     [time-utc (date->time-utc dat)]
    113     [time-tai (date->time-tai dat)]
    114     [time-monotonic (date->time-monotonic dat)]
    115     [else (error loc "incompatible clock-type" tim)]) )
     123  (case (%time-type tim)
     124    [(time-utc)       (date->time-utc dat)]
     125    [(time-tai)       (date->time-tai dat)]
     126    [(time-monotonic) (date->time-monotonic dat)]
     127    [else
     128      (error loc "incompatible clock type" tim)]) )
     129
     130#;
     131(define (tm:time-compare loc per1 per2)
     132  (tm:time-period-binop-check loc per1 per2)
     133  (tm:time-period-subtract per1 per2) )
     134
    116135
    117136(define (tm:time-period=? per1 per2)
    118   (and (tm:time=? (time-period-begin per1) (time-period-begin per2))
    119        (tm:time=? (time-period-end per1) (time-period-end per2))) )
     137  (and
     138    (tm:time=? (%time-period-begin per1) (%time-period-begin per2))
     139    (tm:time=? (%time-period-end per1) (%time-period-end per2))) )
    120140
    121141(define (tm:time-points-within? b1 e1 b2 e2)
    … …  
    123143  (and (tm:time<=? b1 b2) (tm:time<=? e2 e1)) )
    124144
    125 (define (tm:time-period-contains/period? per1 per2 loc)
     145(define (tm:time-period-contains/period? loc per1 per2)
    126146  (and
    127147    (not (tm:time-period-null? per1))
    … …  
    130150              per2
    131151              (%make-time-period
    132                 (tm:ensure-compatible-time
    133                   (time-period-begin per1) (time-period-begin per2)
    134                   loc)
    135                 (tm:ensure-compatible-time
    136                   (time-period-end per1) (time-period-end per2)
    137                   loc)))])
     152                (tm:ensure-compatible-time loc (%time-period-begin per1) (%time-period-begin per2))
     153                (tm:ensure-compatible-time loc (%time-period-end per1) (%time-period-end per2))))])
    138154      (tm:time-points-within?
    139         (time-period-begin per1) (time-period-end per1)
    140         (time-period-begin tper) (time-period-end tper)) ) ) )
    141 
    142 (define (tm:time-period-contains/time? per tim loc)
     155        (%time-period-begin per1) (%time-period-end per1)
     156        (%time-period-begin tper) (%time-period-end tper)) ) ) )
     157
     158(define (tm:time-period-contains/time? loc per tim)
    143159  (and
    144160    (not (tm:time-period-null? per))
    145     (let ([tpt (tm:ensure-compatible-time (time-period-begin per) tim loc)])
    146       (tm:time-points-within?
    147         (time-period-begin per) (time-period-end per)
    148         tpt tpt) ) ) )
    149 
    150 (define (tm:time-period-contains/date? per dat loc)
     161    (let ([tpt (tm:ensure-compatible-time loc (%time-period-begin per) tim)])
     162      (tm:time-points-within? (%time-period-begin per) (%time-period-end per) tpt tpt) ) ) )
     163
     164(define (tm:time-period-contains/date? loc per dat)
    151165  (tm:time-period-contains/time?
    152     per
    153     (tm:ensure-compatible-date (time-period-begin per) dat loc)
    154     loc) )
     166    loc per (tm:ensure-compatible-date loc (%time-period-begin per) dat)) )
    155167
    156168(define (tm:time-point-intersection b1 e1 b2 e2)
    … …  
    163175  (and
    164176    (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 b1 (time-period-begin per2) loc)]
    168             [e2 (tm:ensure-compatible-time e1 (time-period-end per2) loc)])
     177    (let ([b1 (%time-period-begin per1)]
     178          [e1 (%time-period-end per1)])
     179      (let ([b2 (tm:ensure-compatible-time loc b1 (%time-period-begin per2))]
     180            [e2 (tm:ensure-compatible-time loc e1 (%time-period-end per2))])
    169181        (tm:time-point-intersection b1 e1 b2 e2) ) ) ) )
    170182
    171183(define (tm:time-period-shift per-in dur per-out)
    172   (tm:add-duration (time-period-begin per-in) dur (time-period-begin per-out))
    173   (tm:add-duration (time-period-end per-in) dur (time-period-end per-out))
     184  (tm:add-duration (%time-period-begin per-in) dur (%time-period-begin per-out))
     185  (tm:add-duration (%time-period-end per-in) dur (%time-period-end per-out))
    174186  per-out )
    175187
    176188;;
    177189
    178 (define (make-null-time-period . clock-type)
    179   (tm:as-empty-time-period
    180     (tm:make-empty-time
    181       (optional clock-type (default-date-clock-type)))) )
    182 
    183 (define (make-time-period beg end . clock-type)
    184   (cond
    185     [(number? beg)
    186       (set! beg
    187         (seconds->time/type beg
    188           (optional clock-type (default-date-clock-type))))]
    189     [(date? beg)
    190       (set! beg
    191         (date->time beg
    192           (optional clock-type (default-date-clock-type))))])
    193   (tm:time-check beg 'make-time-period)
    194   (when (eq? time-duration (time-type beg))
    195     (error 'make-time-period "invalid time" beg))
    196   (cond
    197     [(number? end)
    198       (set! end (seconds->time/type end time-duration))]
    199     [(date? end)
    200       (set! end (tm:ensure-compatible-date beg end 'make-time-period))])
    201   (tm:time-check end 'make-time-period)
    202   (when (eq? time-duration (time-type end))
    203     (set! end (tm:add-duration beg end (tm:as-empty-time beg))))
    204   (%make-time-period
    205     beg
    206     (tm:ensure-compatible-time beg end 'make-time-period)) )
     190(define time-period? %time-period?)
     191
     192(define (time-period-begin prd)
     193  (%check-time-period 'time-period-begin prd)
     194  (%time-period-begin prd) )
     195
     196(define (time-period-end prd)
     197  (%check-time-period 'time-period-end prd)
     198  (%time-period-end prd) )
     199
     200(define (make-null-time-period . args)
     201  (let-optionals args ((timtyp (default-date-clock-type)))
     202    (tm:as-empty-time-period (tm:make-empty-time timtyp)) ) )
     203
     204(define (make-time-period beg end . args)
     205  (let-optionals args ((timtyp (default-date-clock-type)))
     206    (cond
     207      [(number? beg)
     208        (set! beg (seconds->time/type beg timtyp))]
     209      [(date? beg)
     210        (set! beg (date->time beg timtyp))])
     211    (%check-time 'make-time-period beg)
     212    (when (eq? 'time-duration (%time-type beg))
     213      (error 'make-time-period "invalid time" beg))
     214    (cond
     215      [(number? end)
     216        (set! end (seconds->time/type end 'time-duration))]
     217      [(date? end)
     218        (set! end (tm:ensure-compatible-date 'make-time-period beg end))])
     219    (%check-time 'make-time-period end)
     220    (when (eq? 'time-duration (%time-type end))
     221      (set! end (tm:add-duration beg end (tm:as-empty-time beg))))
     222    (%make-time-period
     223      beg
     224      (tm:ensure-compatible-time 'make-time-period beg end)) ) )
    207225
    208226(define (copy-time-period per)
    209   (tm:time-period-check per 'copy-time-period)
    210   (%make-time-period
    211     (copy-time (time-period-begin per))
    212     (copy-time (time-period-end per))) )
     227  (%check-time-period 'copy-time-period per)
     228  (%make-time-period (copy-time (%time-period-begin per)) (copy-time (%time-period-end per))) )
    213229
    214230(define (time-period-type per)
    215   (tm:time-period-check per 'time-period-type)
     231  (%check-time-period 'time-period-type per)
    216232  (tm:time-period-type per) )
    217233
    218234(define (time-period-null? per)
    219   (tm:time-period-check per 'time-period-null?)
     235  (%check-time-period 'time-period-null? per)
    220236  (tm:time-period-null? per) )
    221237
    222238(define (time-period=? per1 per2)
    223   (tm:time-period-binop-check per1 per2 'time-period=?)
     239  (tm:time-period-binop-check 'time-period=? per1 per2)
    224240  (tm:time-period=? per1 per2) )
    225241
    226242(define (time-period<? per1 per2)
    227   (tm:time-period-binop-check per1 per2 'time-period<?)
    228   (tm:time<? (time-period-end per1) (time-period-begin per2)) )
     243  (tm:time-period-binop-check 'time-period<? per1 per2)
     244  (tm:time<? (%time-period-end per1) (%time-period-begin per2)) )
    229245
    230246(define (time-period>? per1 per2)
    231   (tm:time-period-binop-check per1 per2 'time-period>?)
    232   (tm:time>? (time-period-begin per1) (time-period-end per2)) )
     247  (tm:time-period-binop-check 'time-period>? per1 per2)
     248  (tm:time>? (%time-period-begin per1) (%time-period-end per2)) )
    233249
    234250(define (time-period<=? per1 per2)
    235   (tm:time-period-binop-check per1 per2 'time-period<=?)
    236   (tm:time<=? (time-period-end per1) (time-period-begin per2)) )
     251  (tm:time-period-binop-check 'time-period<=? per1 per2)
     252  (tm:time<=? (%time-period-end per1) (%time-period-begin per2)) )
    237253
    238254(define (time-period>=? per1 per2)
    239   (tm:time-period-binop-check per1 per2 'time-period>=?)
    240   (tm:time>=? (time-period-begin per1) (time-period-end per2)) )
     255  (tm:time-period-binop-check 'time-period>=? per1 per2)
     256  (tm:time>=? (%time-period-begin per1) (%time-period-end per2)) )
    241257
    242258(define (time-period-preceding per1 per2)
    243   (tm:time-period-binop-check per1 per2 'time-period-preceding)
    244   (and (tm:time<=? (time-period-begin per1) (time-period-begin per2))
    245        (make-time-period (time-period-begin per1) (time-period-begin per2)) ) )
     259  (tm:time-period-binop-check 'time-period-preceding per1 per2)
     260  (and (tm:time<=? (%time-period-begin per1) (%time-period-begin per2))
     261       (make-time-period (%time-period-begin per1) (%time-period-begin per2)) ) )
    246262
    247263(define (time-period-succeeding per1 per2)
    248   (tm:time-period-binop-check per1 per2 'time-period-succeeding)
    249   (and (tm:time>=? (time-period-end per1) (time-period-end per2))
    250        (make-time-period (time-period-end per2) (time-period-end per1)) ) )
     264  (tm:time-period-binop-check 'time-period-succeeding per1 per2)
     265  (and (tm:time>=? (%time-period-end per1) (%time-period-end per2))
     266       (make-time-period (%time-period-end per2) (%time-period-end per1)) ) )
    251267
    252268(define (time-period-last per)
    253   (tm:time-period-check per 'time-period-last)
    254   (let ([end (time-period-end per)])
     269  (%check-time-period 'time-period-last per)
     270  (let ([end (%time-period-end per)])
    255271    (tm:subtract-duration end ONE-NANOSECOND-DURATION (tm:as-empty-time end)) ) )
    256272
    257273(define (time-period-length per)
    258   (tm:time-period-check per 'time-period-length)
     274  (%check-time-period 'time-period-length per)
    259275  (let ([dur (tm:make-empty-time time-duration)])
    260276    (if (tm:time-period-null? per)
    261277      dur
    262278      (tm:time-difference
    263         (time-period-begin per) (time-period-end per) dur)) ) )
     279        (%time-period-begin per) (%time-period-end per) dur)) ) )
    264280
    265281(define (time-period-contains/period? per1 per2)
    266   (tm:time-period-check per1 'time-period-contains/period?)
    267   (tm:time-period-check per2 'time-period-contains/period?)
    268   (tm:time-period-contains/period? per1 per2 'time-period-contains/period?) )
     282  (%check-time-period 'time-period-contains/period? per1)
     283  (%check-time-period 'time-period-contains/period? per2)
     284  (tm:time-period-contains/period? 'time-period-contains/period? per1 per2) )
    269285
    270286(define (time-period-contains/time? per tim)
    271   (tm:time-period-check per 'time-period-contains/time?)
    272   (tm:time-check tim 'time-period-contains/time?)
    273   (tm:time-period-contains/time? per tim 'time-period-contains/time?) )
     287  (%check-time-period 'time-period-contains/time? per)
     288  (%check-time 'time-period-contains/time? tim)
     289  (tm:time-period-contains/time? 'time-period-contains/time? per tim) )
    274290
    275291(define (time-period-contains/date? per dat)
    276   (tm:time-period-check per 'time-period-contains/date?)
     292  (%check-time-period 'time-period-contains/date? per)
    277293  (tm:check-date 'time-period-contains/date? dat)
    278   (tm:time-period-contains/date? per dat 'time-period-contains/date?) )
     294  (tm:time-period-contains/date? 'time-period-contains/date? per dat) )
    279295
    280296(define (time-period-contains? per obj)
    281   (tm:time-period-check per 'time-period-contains?)
     297  (%check-time-period 'time-period-contains? per)
    282298  (cond
    283299    [(time-period? obj)
    284       (tm:time-period-contains/period? per obj 'time-period-contains?)]
     300      (tm:time-period-contains/period? 'time-period-contains? per obj)]
    285301    [(time? obj)
    286       (tm:time-period-contains/time? per obj 'time-period-contains?)]
     302      (tm:time-period-contains/time? 'time-period-contains? per obj)]
    287303    [(date? obj)
    288       (tm:time-period-contains/date? per obj 'time-period-contains?)]
     304      (tm:time-period-contains/date? 'time-period-contains? per obj)]
    289305    [else
    290306      (error 'time-period-contains? "invalid time object" obj)]) )
    291307
    292308(define (time-period-intersects? per1 per2)
    293   (tm:time-period-check per1 'time-period-intersects?)
    294   (tm:time-period-check per2 'time-period-intersects?)
    295   (receive [bi ei]
    296       (tm:time-period-intersection-values per1 per2 'time-period-intersects?)
     309  (%check-time-period 'time-period-intersects? per1)
     310  (%check-time-period 'time-period-intersects? per2)
     311  (receive [bi ei] (tm:time-period-intersection-values 'time-period-intersects? per1 per2)
    297312    (tm:time<=? bi ei) ) )
    298313
    299314(define (time-period-intersection per1 per2)
    300   (tm:time-period-check per1 'time-period-intersection)
    301   (tm:time-period-check per2 'time-period-intersection)
    302   (receive [bi ei]
    303       (tm:time-period-intersection-values per1 per2 'time-period-intersection)
     315  (%check-time-period 'time-period-intersection per1)
     316  (%check-time-period 'time-period-intersection per2)
     317  (receive [bi ei] (tm:time-period-intersection-values 'time-period-intersection per1 per2)
    304318    (and (tm:time<=? bi ei)
    305319         (%make-time-period bi ei)) ) )
    306320
    307321(define (time-period-union per1 per2)
    308   (tm:time-period-check per1 'time-period-union)
    309   (tm:time-period-check per2 'time-period-union)
    310   (let ([b1 (time-period-begin per1)]
    311         [e1 (time-period-end per1)])
    312       (let ([b2 (tm:ensure-compatible-time b1 (time-period-begin per2)
    313                                             'time-period-union)]
    314             [e2 (tm:ensure-compatible-time e1 (time-period-end per2)
    315                                             'time-period-union)])
    316         (receive [bi ei]
    317             (tm:time-point-intersection b1 e1 b2 e2)
     322  (%check-time-period 'time-period-union per1)
     323  (%check-time-period 'time-period-union per2)
     324  (let ([b1 (%time-period-begin per1)]
     325        [e1 (%time-period-end per1)])
     326      (let ([b2 (tm:ensure-compatible-time 'time-period-union b1 (time-period-begin per2))]
     327            [e2 (tm:ensure-compatible-time 'time-period-union e1 (time-period-end per2))])
     328        (receive [bi ei] (tm:time-point-intersection b1 e1 b2 e2)
    318329          (and (tm:time<=? bi ei)
    319                (receive [bu eu]
    320                    (tm:time-point-union-values b1 e1 b2 e2)
     330               (receive [bu eu] (tm:time-point-union-values b1 e1 b2 e2)
    321331                 (%make-time-period bu eu))) ) ) ) )
    322332
    323333(define (time-period-span per1 per2)
    324   (tm:time-period-check per1 'time-period-span)
    325   (tm:time-period-check per2 'time-period-span)
    326   (let ([b1 (time-period-begin per1)]
    327         [e1 (time-period-end per1)])
     334  (%check-time-period 'time-period-span per1)
     335  (%check-time-period 'time-period-span per2)
     336  (let ([b1 (%time-period-begin per1)]
     337        [e1 (%time-period-end per1)])
    328338    (receive [bu eu]
    329339        (tm:time-point-union-values
    330340          b1 e1
    331           (tm:ensure-compatible-time b1 (time-period-begin per2)
    332                                      'time-period-span)
    333           (tm:ensure-compatible-time e1 (time-period-end per2)
    334                                      'time-period-span))
     341          (tm:ensure-compatible-time 'time-period-span b1 (%time-period-begin per2))
     342          (tm:ensure-compatible-time 'time-period-span e1 (%time-period-end per2)))
    335343      (%make-time-period bu eu) ) ) )
    336344
    337345(define (time-period-shift per dur)
    338   (tm:time-period-check per 'time-period-shift)
    339   (tm:time-check dur 'time-period-shift)
    340   (tm:duration-check dur 'time-period-shift)
     346  (%check-time-period 'time-period-shift per)
     347  (%check-time 'time-period-shift dur)
     348  (tm:duration-check 'time-period-shift dur)
    341349  (tm:time-period-shift per dur (tm:as-empty-time-period per)) )
    342350
    343351(define (time-period-shift! per dur)
    344   (tm:time-period-check per 'time-period-shift!)
    345   (tm:time-check dur 'time-period-shift!)
    346   (tm:duration-check dur 'time-period-shift!)
     352  (%check-time-period 'time-period-shift! per)
     353  (%check-time 'time-period-shift! dur)
     354  (tm:duration-check 'time-period-shift! dur)
    347355  (tm:time-period-shift per dur per) )

  • release/3/srfi-19/trunk/tests/basic-test.scm

    r10022 r12029  
    252252(define-s19-test! "milliseconds->time [2.6.1 was using NS/S for conversion!]"
    253253  (lambda ()
    254     (let ([tm (milliseconds->time 10000)])
    255       (and (= 10 (time-second tm))
    256            (= 0 (time-nanosecond tm))))))
     254    (let ([tim (milliseconds->time 10000)])
     255      (and (= 10 (time-second tim))
     256           (= 0 (time-nanosecond tim))))))
    257257
    258258(define-s19-test! "Only one minute [2.6.1 current-date w/o tz-locale was doing dst conversion!]"
Note: See TracChangeset for help on using the changeset viewer.