Changeset 12073 in project


Ignore:
Timestamp:
10/01/08 07:34:11 (12 years ago)
Author:
Kon Lovett
Message:

Faster date compare & internal record field access.

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

Legend:

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

    r12029 r12073  
    4949;; return fixnums when possible.
    5050
    51 ;; ##sys#number?
    52 ;; returns #t for fixnum or flonum
     51;; ##sys#integer?
     52;; returns #t for integer fixnum or flonum
    5353
    5454;; ##sys#double->number
     
    7272  #;
    7373  (if (inexact-integer? x) (->fixnum x) x) )
    74 
    75 ;;
    76 
    77 (define-inline (tm:days-before-first-week date day-of-week-starting-week)
    78   (fxmod
    79     (fx- day-of-week-starting-week (tm:week-day 1 1 (date-year date)))
    80     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

    r12029 r12073  
    107107    (bound-to-procedure
    108108      ##sys#slot
    109       seconds->time)
     109      seconds->time
     110      tm:date->julian-day)
    110111    (export
    111112      ;; SRFI-19 extensions
     
    121122      time->srfi-18-time
    122123      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
    130124      time-max
    131125      time-min
     
    170164      time->julian-day
    171165      time->modified-julian-day
    172       leap-year?
    173       date-leap-year?
     166      date-compare
     167      time-compare
    174168      ;; SRFI-19
    175169      time-tai
     
    186180      time-resolution
    187181      make-time time?
    188       time-type 
     182      time-type
    189183      time-nanosecond
    190184      time-second
    191       set-time-type! 
     185      set-time-type!
    192186      set-time-nanosecond!
    193187      set-time-second!
     
    204198      subtract-duration
    205199      subtract-duration!
    206       make-date date?
     200      make-date
     201      date?
    207202      date-nanosecond
    208203      date-second
     
    213208      date-year
    214209      date-zone-offset
     210      leap-year? ; Actually part of SRFI 19 but not in original document
    215211      date-year-day
    216212      date-week-day
     
    257253      tm:date-nanosecond-set!
    258254      tm:date-second-set!
    259       tm:date-wday-set!
    260       tm:date-yday-set!
    261255      tm:date-year-set!
    262256      tm:date-zone-offset-set!
    263       tm:make-date
    264       tm:vali-date
     257      tm:make-incomplete-date
     258      tm:check-date
     259      tm:check-exploded-date
     260      tm:time-type
    265261      tm:check-time
    266262      tm:make-empty-time
     
    273269      tm:time-tai->time-utc
    274270      tm:week-day
    275       tm:check-date
     271      tm:days-before-first-week
    276272      tm:subtract-duration
    277273      tm:add-duration
     
    286282      tm:time-difference) ) )
    287283
    288 (use srfi-8 srfi-9 posix
    289      numbers locale)
     284(use srfi-6 srfi-8 srfi-9 posix
     285     numbers locale
     286     misc-extn-record)
    290287
    291288(register-feature! 'srfi-19)
     
    505502    (error loc "invalid time type" obj)) )
    506503
    507 ;;
    508 ;; NOTE - record type "time" is defined in "srfi-19-common"
    509 ;;
    510 
    511 ;;
     504;; There are 3 kinds of time record procedures:
     505;; %...   - generated (these are inline!)
     506;; tm:... - argument processing then %...
     507;; ...    - argument checking then tm:...
     508
     509(define-record-type/unsafe-inline-unchecked time
     510  (%make-time timtyp ns sec)
     511  %time?
     512  (timtyp %time-type        %set-time-type!)
     513  (ns     %time-nanosecond  %set-time-nanosecond!)
     514  (sec    %time-second      %set-time-second!) )
     515
     516(define-inline (%check-time loc obj)
     517  (##sys#check-structure obj 'time loc) )
     518
     519;;
     520
     521(define tm:time-type %time-type)
    512522
    513523(define (tm:make-time timtyp ns sec)
     
    578588  (tm:check-time-has-type loc obj1 (%time-type obj2)) )
    579589
    580 (define (tm:time-aritmetic-check tim dur loc)
     590(define (tm:time-aritmetic-check loc tim dur)
    581591  (%check-time loc tim)
    582592  (tm:check-duration dur loc) )
    583593
    584 ;;
    585 
    586 (define (tm:nanoseconds->time-values ns)
    587   ??? (values (abs (remainder ns NS/S)) (quotient ns NS/S)) )
     594;; Rem & Quo of nanoseconds per second
     595
     596(define (tm:split-nanoseconds nanos)
     597  (values (abs (remainder nanos NS/S)) (quotient nanos NS/S)) )
    588598
    589599;; Time CTOR
     
    595605(define (make-duration
    596606          #!key
    597           (dys 0)
     607          (days 0)
    598608          (hours 0) (minutes 0) (seconds 0)
    599609          (milliseconds 0) (microseconds 0) (nanoseconds 0))
    600   (receive [ns sec]
    601       (tm:nanoseconds->time-values (+ (* milliseconds NS/MS) (* microseconds NS/MuS) nanoseconds))
    602     (make-time
    603       'time-duration
    604       ns
    605       (+ (* dys SEC/DY) (* hours SEC/HR) (* minutes SEC/MIN) seconds sec)) ) )
     610  (let ([nanos (+ (* milliseconds NS/MS) (* microseconds NS/MuS) nanoseconds)]
     611        [secs (+ (* days SEC/DY) (* hours SEC/HR) (* minutes SEC/MIN) seconds)])
     612    (receive [ns sec] (tm:split-nanoseconds nanos)
     613      (make-time 'time-duration ns (+ secs sec)) ) ) )
    606614
    607615(define (copy-time tim)
     
    658666  (let-optionals args ((timtyp 'time-duration))
    659667    (tm:check-time-type 'nanoseconds->time timtyp)
    660     (receive [ns sec] (tm:nanoseconds->time-values ns)
     668    (receive [ns sec] (tm:split-nanoseconds ns)
    661669      (tm:make-time timtyp ns sec) ) ) )
    662670
     
    749757;; Time Comparison
    750758
     759(define (tm:time-compare tim1 tim2)
     760  (let ([dif (- (%time-second tim1) (%time-second tim2))])
     761    (if (not (zero? dif))
     762      dif
     763      (fx- (%time-nanosecond tim1) (%time-nanosecond tim2)) ) ) )
     764
    751765(define (tm:time=? tim1 tim2)
    752766  (and (= (%time-second tim1) (%time-second tim2))
    753        (= (%time-nanosecond tim1) (%time-nanosecond tim2))) )
     767       (fx= (%time-nanosecond tim1) (%time-nanosecond tim2))) )
    754768
    755769(define (tm:time<? tim1 tim2)
    756770  (or (< (%time-second tim1) (%time-second tim2))
    757771      (and (= (%time-second tim1) (%time-second tim2))
    758            (< (%time-nanosecond tim1) (%time-nanosecond tim2)))) )
     772           (fx< (%time-nanosecond tim1) (%time-nanosecond tim2)))) )
    759773
    760774(define (tm:time<=? tim1 tim2)
    761775  (or (< (%time-second tim1) (%time-second tim2))
    762776      (and (= (%time-second tim1) (%time-second tim2))
    763            (<= (%time-nanosecond tim1) (%time-nanosecond tim2)))) )
     777           (fx<= (%time-nanosecond tim1) (%time-nanosecond tim2)))) )
    764778
    765779(define (tm:time>? tim1 tim2)
    766780  (or (> (%time-second tim1) (%time-second tim2))
    767781      (and (= (%time-second tim1) (%time-second tim2))
    768            (> (%time-nanosecond tim1) (%time-nanosecond tim2)))) )
     782           (fx> (%time-nanosecond tim1) (%time-nanosecond tim2)))) )
    769783
    770784(define (tm:time>=? tim1 tim2)
    771785  (or (> (%time-second tim1) (%time-second tim2))
    772786      (and (= (%time-second tim1) (%time-second tim2))
    773            (>= (%time-nanosecond tim1) (%time-nanosecond tim2)))) )
     787           (fx>= (%time-nanosecond tim1) (%time-nanosecond tim2)))) )
    774788
    775789(define (tm:time-max tim . rest)
     
    787801        (loop (if (tm:time>? acc tim) tim acc) (cdr lst)))) ) )
    788802
    789 ;;
     803(define (time-compare tim1 tim2)
     804  (tm:time-compare-check 'time-compare tim1 tim2)
     805  (let ([dif (tm:time-compare tim1 tim2)])
     806    (cond
     807      [(negative? dif)  -1]
     808      [(positive? dif)  1]
     809      [else             0] ) ) )
    790810
    791811(define (time=? tim1 tim2)
     
    825845      (tm:set-time-second! tim3 0)
    826846      (tm:set-time-nanosecond! tim3 0))
    827     (receive [ns sec]
    828         (tm:nanoseconds->time-values (- (time->nanoseconds tim1) (time->nanoseconds tim2)))
     847    (receive [ns sec] (tm:split-nanoseconds (- (time->nanoseconds tim1) (time->nanoseconds tim2)))
    829848      (tm:set-time-second! tim3 sec)
    830849      (tm:set-time-nanosecond! tim3 ns)))
     
    853872
    854873(define (tm:divide-duration dur1 num dur3)
    855   (receive [ns sec]
    856       (tm:nanoseconds->time-values (/ (time->nanoseconds dur1) num))
     874  (receive [ns sec] (tm:split-nanoseconds (/ (time->nanoseconds dur1) num))
    857875    (tm:set-time-nanosecond! dur3 ns)
    858876    (tm:set-time-second! dur3 sec)
     
    860878
    861879(define (tm:multiply-duration dur1 num dur3)
    862   (receive [ns sec]
    863       (tm:nanoseconds->time-values (* (time->nanoseconds dur1) num))
     880  (receive [ns sec] (tm:split-nanoseconds (* (time->nanoseconds dur1) num))
    864881    (tm:set-time-nanosecond! dur3 ns)
    865882    (tm:set-time-second! dur3 sec)
     
    889906
    890907(define (add-duration! tim dur)
    891   (tm:time-aritmetic-check 'add-duration! tim dur 'add-duration!)
     908  (tm:time-aritmetic-check 'add-duration! tim dur)
    892909  (tm:add-duration tim dur tim) )
    893910
     
    10611078(define (check-timezone-locale loc obj)
    10621079  (unless (timezone-locale? obj)
    1063     (error loc "invalid timezone locale" obj) )
     1080    (error loc "invalid timezone locale" obj) ) )
    10641081
    10651082(define make-posix-timezone
     
    11121129      (if (timezone-locale? obj)
    11131130        obj
    1114         (local-timezone-locale)))))
     1131        (local-timezone-locale)))) )
    11151132
    11161133(define utc-timezone-locale
     
    11201137      (if (timezone-locale? obj)
    11211138        obj
    1122         (utc-timezone-locale)))))
     1139        (utc-timezone-locale)))) )
    11231140
    11241141;; Returns #f or a valid tz-name
     
    11321149                  (if (%timezone-locale-dst? tzi) 'dst-name 'std-name))])
    11331150      ; TZ may not be set
    1134       (and (not (eq? tzn UNKNOWN-LOCAL-TZ-NAME)) tzn) ) ) )
     1151      (and (not (eq? UNKNOWN-LOCAL-TZ-NAME tzn))
     1152           tzn) ) ) )
    11351153
    11361154;;
     
    11501168(define (timezone-locale-dst? . args)
    11511169  (let-optionals args ((tzi (local-timezone-locale)))
    1152     (check-timezone-locale 'timezone-locale-offset tzij)
     1170    (check-timezone-locale 'timezone-locale-offset tzi)
    11531171    (%timezone-locale-dst? tzi) ) )
    11541172
     
    11561174
    11571175(define-record-type/unsafe-inline-unchecked date
    1158   (%make-date ns sec mn hr dy mn yr tzo tzn dstf wdy ydy jdy)
     1176  (%make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)
    11591177  %date?
    11601178  (ns     %date-nanosecond  %date-nanosecond-set!)
    11611179  (sec    %date-second      %date-second-set!)
    1162   (mn     %date-minute      %date-minute-set!)
     1180  (min    %date-minute      %date-minute-set!)
    11631181  (hr     %date-hour        %date-hour-set!)
    11641182  (dy     %date-day         %date-day-set!)
     
    11711189  (wdy    %date-wday        %date-wday-set!)
    11721190  (ydy    %date-yday        %date-yday-set!)
    1173   (jdy  %date-jday          %date-jday-set!) )
     1191  (jdy    %date-jday        %date-jday-set!) )
    11741192
    11751193;;
     
    11801198;;
    11811199
    1182 (define (tm:date-nanosecond-set! date x)
    1183   (%date-nanosecond-set! date (->fixnum x)) )
    1184 
    1185 (define (tm:date-second-set! date x)
    1186   (%date-second-set! date (->fixnum x)) )
    1187 
    1188 (define (tm:date-minute-set! date x)
    1189   (%date-minute-set! date (->fixnum x)) )
    1190 
    1191 (define (tm:date-hour-set! date x)
    1192   (%date-hour-set! date (->fixnum x)) )
    1193 
    1194 (define (tm:date-day-set! date x)
    1195   (%date-day-set! date (->fixnum x)) )
    1196 
    1197 (define (tm:date-month-set! date x)
    1198   (%date-month-set! date (->fixnum x)) )
    1199 
    1200 (define (tm:date-year-set! date x)
    1201   (%date-year-set! date (->fixnum x)) )
    1202 
    1203 (define (tm:date-zone-offset-set! date x)
    1204   (%date-zone-offset-set! date (->fixnum x)) )
     1200(define (tm:date-nanosecond-set! dat x)
     1201  (%date-nanosecond-set! dat (->fixnum x)) )
     1202
     1203(define (tm:date-second-set! dat x)
     1204  (%date-second-set! dat (->fixnum x)) )
     1205
     1206(define (tm:date-minute-set! dat x)
     1207  (%date-minute-set! dat (->fixnum x)) )
     1208
     1209(define (tm:date-hour-set! dat x)
     1210  (%date-hour-set! dat (->fixnum x)) )
     1211
     1212(define (tm:date-day-set! dat x)
     1213  (%date-day-set! dat (->fixnum x)) )
     1214
     1215(define (tm:date-month-set! dat x)
     1216  (%date-month-set! dat (->fixnum x)) )
     1217
     1218(define (tm:date-year-set! dat x)
     1219  (%date-year-set! dat (->fixnum x)) )
     1220
     1221(define (tm:date-zone-offset-set! dat x)
     1222  (%date-zone-offset-set! dat (->fixnum x)) )
    12051223
    12061224;; Leap Year Test
     
    12191237;; Days per Month
    12201238
    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))
     1239(define tm:dys/mn '#(0 31 28 31 30 31 30 31 31 30 31 30 31))
     1240
     1241(define tm:leap-year-dys/mn '#(0 31 29 31 30 31 30 31 31 30 31 30 31))
     1242
     1243(define (tm:days-in-month mn yr)
     1244  (vector-ref (if (tm:leap-year? yr) tm:leap-year-dys/mn tm:dys/mn) mn) )
    12241245
    12251246(define tm:cumulative-month-days '#(0 0 31 59 90 120 151 181 212 243 273 304 334))
    12261247
     1248;; Returns an invalid date record (for use by 'scan-date')
     1249
     1250(define (tm:make-incomplete-date)
     1251  (%make-date
     1252    0
     1253    0 0 0
     1254    #f #f #f
     1255    (timezone-locale-offset) (timezone-locale-name) (timezone-locale-dst?)
     1256    #f #f #f) )
     1257
    12271258;; Internal Date CTOR
    12281259
    1229 (define (tm:make-date nanosecond second minute hour day month year
    1230                       zone-offset zone-name dstf
    1231                       wday yday jday)
     1260(define (tm:make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)
    12321261  (%make-date
    1233     (->fixnum nanosecond)
    1234     (->fixnum second) (->fixnum minute) (->fixnum hour)
    1235     (->fixnum day) (->fixnum month) (->fixnum year)
    1236     (->fixnum zone-offset) zone-name dstf
    1237     wday yday jday) )
     1262    (->fixnum ns)
     1263    (->fixnum sec) (->fixnum min) (->fixnum hr)
     1264    (->fixnum dy) (->fixnum mn) (->fixnum yr)
     1265    (->fixnum tzo) tzn dstf
     1266    wdy ydy jdy) )
    12381267
    12391268;; Parameter Checking
     
    12521281
    12531282(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) ) )
    1259 
    1260 (define (tm:vali-date loc ns sec min hr dy mn yr tzo tzn)
     1283  ; Days in [1 28/29/30/31] - depending on month & year
     1284  (unless (and (fixnum? dy) (fx<= 1 dy) (fx<= dy (tm:days-in-month mn yr)))
     1285    (error loc "invalid day" dy) ) )
     1286
     1287(define (tm:check-exploded-date loc ns sec min hr dy mn yr tzo tzn)
    12611288  ; Same as time object
    12621289  (tm:check-time-nanoseconds loc ns)
     
    12751302  (tm:check-day loc dy mn yr)
    12761303  ; Timezone offset in (-SEC/DY +SEC/DY)
    1277   (unless (and (fixnum? tzo)
    1278                (let ([atzo (abs tzo)]) (and (<= 0 atzo) (< atzo SEC/DY))))
     1304  (unless (and (fixnum? tzo) (let ([atzo (fxabs tzo)]) (and (fx<= 0 atzo) (fx< atzo SEC/DY))))
    12791305    (error loc "invalid timezone offset" tzo))
    12801306  ;
    12811307  (unless (or (not tzn) (string? tzn))
    1282     (error loc "invalid timezone name" tzn))
    1283   #t )
     1308    (error loc "invalid timezone name" tzn)) )
    12841309
    12851310;; Date Syntax
     
    12981323  (lambda (ns sec min hr dy mn yr tzo . rest)
    12991324    (let-optionals rest ([tzn #f] [dstf #f] [wdy #f] [ydy #f] [jdy #f])
    1300       ($make-date
    1301         ns
    1302         sec min hr
    1303         dy mn yr
    1304         tzo
    1305         tzn dstf
    1306         wdy ydy jdy))))
     1325      (tm:make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy))))
    13071326
    13081327;; Date CTOR
    13091328
    1310 (define (make-date nsec sec min hr dy mn yr tzo . rest)
     1329(define (make-date ns sec min hr dy mn yr tzo . rest)
    13111330  (let-optionals rest ([tzn #f] [dstf (void)])
    13121331    (if (timezone-locale? tzo)
     
    13181337      (when (eq? (void) dstf)
    13191338        (set! dstf #f)))
    1320     (tm:vali-date 'make-date nsec sec min hr dy mn yr tzo tzn)
    1321     ($make-date nsec sec min hr dy mn yr tzo tzn dstf #f #f #f) ) )
    1322 
    1323 (define (copy-date date)
     1339    (tm:check-exploded-date 'make-date ns sec min hr dy mn yr tzo tzn)
     1340    (tm:make-date ns sec min hr dy mn yr tzo tzn dstf #f #f #f) ) )
     1341
     1342(define (copy-date dat)
    13241343  (%make-date
    1325     (%date-nanosecond date)
    1326     (%date-second date) (%date-minute date) (%date-hour date)
    1327     (%date-day date) (%date-month date) (%date-year date)
    1328     (%date-zone-offset date)
    1329     (%date-zone-name date) (%date-dst? date)
    1330     (%date-wday date) (%date-yday date) (%date-jday date)) )
     1344    (%date-nanosecond dat)
     1345    (%date-second dat) (%date-minute dat) (%date-hour dat)
     1346    (%date-day dat) (%date-month dat) (%date-year dat)
     1347    (%date-zone-offset dat)
     1348    (%date-zone-name dat) (%date-dst? dat)
     1349    (%date-wday dat) (%date-yday dat) (%date-jday dat)) )
    13311350
    13321351;; Converts a seconds value, may be fractional, into a date type.
     
    13471366           [tzo (timezone-locale-offset tzi)]
    13481367           [tv (seconds->utc-time (+ isec tzo))])
    1349       ($make-date
     1368      (tm:make-date
    13501369        (round (* (- fsec isec) NS/S))
    13511370        (vector-ref tv 0) (vector-ref tv 1) (vector-ref tv 2)
    13521371        (vector-ref tv 3) (fx+ 1 (vector-ref tv 4)) (fx+ 1900 (vector-ref tv 5))
    1353         tzo
    1354         (timezone-locale-name tzi) (timezone-locale-dst? tzi)
     1372        tzo (timezone-locale-name tzi) (timezone-locale-dst? tzi)
    13551373        (vector-ref tv 6) (fx+ 1 (vector-ref tv 7)) #f) ) ) )
    13561374
     
    13661384(define (date-nanosecond dat)
    13671385        (%check-date 'date-nanosecond dat)
    1368         (%date-nanosecond date-nanosecond) )
     1386        (%date-nanosecond dat) )
    13691387
    13701388(define (date-second dat)
    13711389        (%check-date 'date-second dat)
    1372         (%date-second date-second) )
     1390        (%date-second dat) )
    13731391
    13741392(define (date-minute dat)
    13751393        (%check-date 'date-minute dat)
    1376         (%date-minute date-minute) )
     1394        (%date-minute dat) )
    13771395
    13781396(define (date-hour dat)
    13791397        (%check-date 'date-hour dat)
    1380         (%date-hour date-hour) )
     1398        (%date-hour dat) )
    13811399
    13821400(define (date-day dat)
    13831401        (%check-date 'date-day dat)
    1384         (%date-day date-day) )
     1402        (%date-day dat) )
    13851403
    13861404(define (date-month dat)
    13871405        (%check-date 'date-month dat)
    1388         (%date-month date-month) )
     1406        (%date-month dat) )
    13891407
    13901408(define (date-year dat)
    13911409        (%check-date 'date-year dat)
    1392         (%date-year date-year) )
     1410        (%date-year dat) )
     1411
     1412(define (date-dst? dat)
     1413        (%check-date 'date-dst? dat)
     1414        (%date-dst? dat) )
    13931415
    13941416(define (date-zone-offset dat)
    13951417        (%check-date 'date-zone-offset dat)
    1396         (%date-zone-offset date-zone-offset) )
    1397 
     1418        (%date-zone-offset dat) )
     1419
     1420(define (date-zone-name dat)
     1421        (%check-date 'date-zone-name dat)
     1422        (%date-zone-name dat) )
    13981423
    13991424;; Date Comparison
    14001425
    1401 (define (*date-compare/fields loc x y)
    1402   (%check-date loc x)
    1403   (%check-date loc y)
    1404   (if (not (fx= (%date-zone-offset x) (%date-zone-offset y)))
    1405     (error loc "cannot compare dates from different time-zones" x y)
    1406     (let ((dif (fx- (%date-year x) (%date-year y))))
     1426(define (tm:date-compare loc dat1 dat2)
     1427  (%check-date loc dat1)
     1428  (%check-date loc dat2)
     1429  (if (not (fx= (%date-zone-offset dat1) (%date-zone-offset dat2)))
     1430    (error loc "cannot compare dates from different time-zones" dat1 dat2)
     1431    (let ([dif (fx- (%date-year dat1) (%date-year dat2))])
    14071432      (if (not (fx= 0 dif))
    14081433        dif
    1409         (let ((dif (fx- (%date-year x) (%date-year y))))
     1434        (let ([dif (fx- (%date-year dat1) (%date-year dat2))])
    14101435          (if (not (fx= 0 dif))
    14111436            dif
    1412             (let ((dif (fx- (%date-month x) (%date-month y))))
     1437            (let ([dif (fx- (%date-month dat1) (%date-month dat2))])
    14131438              (if (not (fx= 0 dif))
    14141439                dif
    1415                 (let ((dif (fx- (%date-hour x) (%date-hour y))))
     1440                (let ([dif (fx- (%date-hour dat1) (%date-hour dat2))])
    14161441                  (if (not (fx= 0 dif))
    14171442                    dif
    1418                     (let ((dif (fx- (%date-minute x) (%date-minute y))))
     1443                    (let ([dif (fx- (%date-minute dat1) (%date-minute dat2))])
    14191444                      (if (not (fx= 0 dif))
    14201445                        dif
    1421                         (let ((dif (fx- (%date-second x) (%date-second y))))
     1446                        (let ([dif (fx- (%date-second dat1) (%date-second dat2))])
    14221447                          (if (not (fx= 0 dif))
    14231448                            dif
    1424                             (fx- (%date-nanosecond x) (%date-nanosecond y)) ) ) ) ) ) ) ) ) ) ) ) ) ) )
    1425 
    1426 (define (date-compare/fields x y)
    1427   (*date-compare/fields 'date-compare/fields x y) )
    1428 
    1429 (define (date=?/fields dat1 dat2)
    1430   (fx= 0 (*date-compare/fields 'date=?/fields dat1 dat2)) )
    1431 
    1432 (define (date<?/fields dat1 dat2)
    1433   (fx< 0 (*date-compare/fields 'date<?/fields dat1 dat2)) )
    1434 
    1435 (define (date<=?/fields dat1 dat2)
    1436   (fx<= 0 (*date-compare/fields 'date<=?/fields dat1 dat2)) )
    1437 
    1438 (define (date>?/fields dat1 dat2)
    1439   (fx> 0 (*date-compare/fields 'date>?/fields dat1 dat2)) )
    1440 
    1441 (define (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) )
     1449                            (fx- (%date-nanosecond dat1) (%date-nanosecond dat2)) ) ) ) ) ) ) ) ) ) ) ) ) ) )
     1450
     1451(define (date-compare dat1 dat2)
     1452  (let ([dif (tm:date-compare 'date-compare dat1 dat2)])
     1453    (cond
     1454      [(fx< dif 0)  -1]
     1455      [(fx> dif 0)  1]
     1456      [else         0] ) ) )
    14531457
    14541458(define (date=? dat1 dat2)
    1455   (= 0 (*date-compare 'date=? x y)) )
     1459  (fx= 0 (tm:date-compare 'date=? dat1 dat2)) )
    14561460
    14571461(define (date<? dat1 dat2)
    1458   (< 0 (*date-compare 'date=<? x y)) )
     1462  (fx< 0 (tm:date-compare 'date<? dat1 dat2)) )
     1463
     1464(define (date<=? dat1 dat2)
     1465  (fx<= 0 (tm:date-compare 'date<=? dat1 dat2)) )
    14591466
    14601467(define (date>? dat1 dat2)
    1461   (> 0 (*date-compare 'date>? x y)) )
    1462 
    1463 (define (date<=? dat1 dat2)
    1464   (<= 0 (*date-compare 'date<=? x y)) )
     1468  (fx> 0 (tm:date-compare 'date>? dat1 dat2)) )
    14651469
    14661470(define (date>=? dat1 dat2)
    1467   (>= 0 (*date-compare 'date>=? x y)) )
     1471  (fx>= 0 (tm:date-compare 'date>=? dat1 dat2)) )
    14681472
    14691473;; Date Arithmetic
     
    14881492    (time->date (tm:subtract-duration tim dur (tm:as-empty-time tim))) ) )
    14891493
    1490 ;; Date/Time Conversion
     1494;; Time to Date
     1495
     1496;; Gives the seconds/day/month/year
     1497
     1498(define (tm:decode-julian-day-number jdn)
     1499  (let* ([dys (->fixnum (truncate jdn))]
     1500         [a (fx+ dys 32044)]
     1501         [b (fx/ (fx+ (fx* 4 a) 3) 146097)]
     1502         [c (fx- a (fx/ (fx* 146097 b) 4))]
     1503         [d (fx/ (fx+ (fx* 4 c) 3) 1461)]
     1504         [e (fx- c (fx/ (fx* 1461 d) 4))]
     1505         [m (fx/ (fx+ (fx* 5 e) 2) 153)]
     1506         [y (fx+ (fx* 100 b) (fx+ d (fx- (fx/ m 10) 4800)))])
     1507    (values ; seconds day month year
     1508      (->fixnum (floor (* (- jdn dys) SEC/DY)))
     1509      (fx+ (fx- e (fx/ (fx+ (fx* 153 m) 2) 5)) 1)
     1510      (fx- (fx+ m 3) (fx* (fx/ m 10) MN/YR))
     1511      (if (fx<= y 0) (fx- y 1) y)) ) )
     1512
     1513;; Gives the Julian day number - rounds up to the nearest day
     1514
     1515(define (tm:seconds->julian-day-number sec tzo)
     1516  (+ TAI-EPOCH-IN-JD
     1517     ; Round to day boundary
     1518     (/ (+ sec tzo SEC/DY/2) SEC/DY)) )
     1519
     1520;; Is the time object one second before a leap second?
     1521
     1522(define (tm:tai-before-leap-second? tim)
     1523  (let ([sec (%time-second tim)])
     1524    (let loop ([lst tm:second-before-leap-second-table])
     1525      (and (not (null? lst))
     1526           (or (= sec (car lst))
     1527               (loop (cdr lst)) ) ) ) ) )
     1528
     1529(define (tm:time->date loc tim tzi)
     1530  ; The tz-info is caller's rest parameter
     1531  (let ([tzo (optional tzi (local-timezone-locale))]
     1532        [tzn #f]
     1533        [dstf #f])
     1534      (when (timezone-locale? tzo)
     1535        (set! dstf (timezone-locale-dst? tzo))
     1536        (set! tzn (timezone-locale-name tzo))
     1537        (set! tzo (timezone-locale-offset tzo)))
     1538      (unless (fixnum? tzo)
     1539        (error loc "invalid timezone offset" tzo) )
     1540      (receive [secs dy mn yr]
     1541          (tm:decode-julian-day-number (tm:seconds->julian-day-number (%time-second tim) tzo))
     1542        (let ([hr (fx/ secs SEC/HR)]
     1543              [rsecs (fxmod secs SEC/HR)])
     1544          (let ([min (fx/ rsecs SEC/MIN)]
     1545                [sec (fxmod rsecs SEC/MIN)])
     1546            (tm:make-date (%time-nanosecond tim) sec min hr dy mn yr tzo tzn dstf #f #f #f) ) ) ) ) )
     1547
     1548(define (tm:time-tai->date loc tim tzi)
     1549  (let ([tm-utc (tm:time-tai->time-utc tim (tm:as-empty-time tim))])
     1550    (if (tm:tai-before-leap-second? tim)
     1551      ; then time is *right* before the leap, we need to pretend to subtract a second ...
     1552      (let ([dat (tm:time->date loc (tm:subtract-duration tm-utc ONE-SECOND-DURATION tm-utc) tzi)])
     1553        (%date-second-set! dat SEC/MIN) ; Note full minute!
     1554        dat )
     1555      (tm:time->date loc tm-utc tzi) ) ) )
     1556
     1557(define (time-tai->date tim . tzi)
     1558  (tm:check-time-and-type 'time-tai->date tim 'time-tai)
     1559  (tm:time-tai->date 'time-tai->date tim tzi) )
     1560
     1561(define (time-utc->date tim . tzi)
     1562  (tm:check-time-and-type 'time-utc->date tim 'time-utc)
     1563  (tm:time->date 'time-utc->date tim tzi) )
     1564
     1565(define (time-monotonic->date tim . tzi)
     1566  (tm:check-time-and-type 'time-monotonic->date tim 'time-monotonic)
     1567  (tm:time->date 'time-monotonic->date tim tzi) )
     1568
     1569(define (time->date tim . tzi)
     1570  (%check-time 'time->date tim)
     1571  (case (%time-type tim)
     1572    [(time-monotonic) (tm:time->date 'time->date tim tzi)]
     1573    [(time-utc)       (tm:time->date 'time->date tim tzi)]
     1574    [(time-tai)       (tm:time-tai->date 'time->date tim tzi)]
     1575    [else ; This shouldn't happen
     1576      (error 'time->date "invalid clock type" tim)]) )
     1577
     1578;; Date to Time
    14911579
    14921580;; Gives the Julian day number - Gregorian proleptic calendar
     
    15051593      -32045) ) )
    15061594
    1507 ;; Gives the seconds/day/month/year
    1508 
    1509 (define (tm:decode-julian-day-number jdn)
    1510   (let* ([dys (inexact->exact (truncate jdn))]
    1511          [a (fx+ dys 32044)]
    1512          [b (fx/ (fx+ (fx* 4 a) 3) 146097)]
    1513          [c (fx- a (fx/ (fx* 146097 b) 4))]
    1514          [d (fx/ (fx+ (fx* 4 c) 3) 1461)]
    1515          [e (fx- c (fx/ (fx* 1461 d) 4))]
    1516          [m (fx/ (fx+ (fx* 5 e) 2) 153)]
    1517          [y (fx+ (fx* 100 b) (fx+ d (fx- (fx/ m 10) 4800)))])
    1518     (values ; seconds day month year
    1519       (->fixnum (floor (* (- jdn dys) SEC/DY)))
    1520       (fx+ (fx- e (fx/ (fx+ (fx* 153 m) 2) 5)) 1)
    1521       (fx- (fx+ m 3) (fx* (fx/ m 10) MN/YR))
    1522       (if (fx<= y 0) (fx- y 1) y)) ) )
    1523 
    1524 ;; Gives the Julian day number - rounds up to the nearest day
    1525 
    1526 (define (tm:seconds->julian-day-number sec tzo)
    1527   (+ TAI-EPOCH-IN-JD
    1528      ; Round to day boundary
    1529      (/ (+ sec tzo SEC/DY/2) SEC/DY)) )
    1530 
    1531 ;; Is the time object one second before a leap second?
    1532 
    1533 (define (tm:tai-before-leap-second? tim)
    1534   (let ([sec (%time-second tim)])
    1535     (let loop ([lst tm:second-before-leap-second-table])
    1536       (and (not (null? lst))
    1537            (or (= sec (car lst))
    1538                (loop (cdr lst)) ) ) ) ) )
    1539 
    1540 ;; Time to Date
    1541 
    1542 (define (tm:time->date loc tim tzi timtyp)
    1543   ; Validate time type for caller
    1544   (tm:check-time-and-type loc tim timtyp)
    1545   ; The tz-info is caller's rest parameter
    1546   (let ([tzo (optional tzi (local-timezone-locale))]
    1547         [tzn #f]
    1548         [dstf #f])
    1549       (when (timezone-locale? tzo)
    1550         (set! dstf (timezone-locale-dst? tzo))
    1551         (set! tzn (timezone-locale-name tzo))
    1552         (set! tzo (timezone-locale-offset tzo)))
    1553       (unless (fixnum? tzo)
    1554         (error loc "invalid timezone offset" tzo) )
    1555       (receive [secs day month year]
    1556           (tm:decode-julian-day-number (tm:seconds->julian-day-number (%time-second tim) tzo))
    1557         (let* ([hours (fx/ secs SEC/HR)]
    1558                [rsecs (fxmod secs SEC/HR)]
    1559                [minutes (fx/ rsecs SEC/MIN)]
    1560                [seconds (fxmod rsecs SEC/MIN)])
    1561           ($make-date
    1562             (%time-nanosecond tim)
    1563             seconds minutes hours
    1564             day month year
    1565             tzo
    1566             tzn dstf
    1567             #f #f #f) ) ) ) )
    1568 
    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
    1575               (tm:time->date
    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)
    1592   (case (%time-type time)
    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)
     1595(define (tm:date->time-utc loc dat)
    16011596  (let ([ns (%date-nanosecond dat)]
    16021597        [sec (%date-second dat)]
     
    16071602        [yr (%date-year dat)]
    16081603        [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)))) ) ) )
     1604    (let ([jdys (- (tm:encode-julian-day-number dy mn yr) TAI-EPOCH-IN-JD)]
     1605          [secs (fx+ (fx+ (fx* hr SEC/HR) (fx+ (fx* min SEC/MIN) sec)) (fxneg tzo))])
     1606      (tm:make-time 'time-utc ns (+ (* (- jdys ONE-HALF) SEC/DY) secs)) ) ) )
     1607
     1608(define (tm:date->time-tai loc dat)
     1609  (let* ([tm-utc (tm:date->time-utc loc dat)]
     1610         [tm-tai (tm:time-utc->time-tai tm-utc tm-utc)])
     1611    (if (fx= 60 (%date-second dat))
     1612      (tm:subtract-duration tm-tai ONE-SECOND-DURATION tm-tai)
     1613      tm-tai ) ) )
     1614
     1615(define (tm:date->time-monotonic loc dat)
     1616  (let ([tim-utc (tm:date->time-utc loc dat)])
     1617    (tm:time-utc->time-monotonic tim-utc tim-utc) ) )
     1618
     1619(define (date->time-utc dat)
     1620  (%check-date 'date->time-utc dat)
     1621  (tm:date->time-utc 'date->time-utc dat) )
    16151622
    16161623(define (date->time-tai dat)
    16171624  (%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))) )
     1625  (tm:date->time-tai 'date->time-tai dat) )
    16221626
    16231627(define (date->time-monotonic dat)
    1624   (time-utc->time-monotonic! (date->time-utc dat)) )
     1628  (%check-date 'date->time-monotonic dat)
     1629  (tm:date->time-monotonic 'date->time-monotonic dat) )
    16251630
    16261631(define (date->time dat . timtyp)
    16271632  (%check-date 'date->time dat)
    16281633  (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)]
     1634    [(time-monotonic) (tm:date->time-monotonic  'date->time dat)]
     1635    [(time-utc)       (tm:date->time-utc 'date->time dat)]
     1636    [(time-tai)       (tm:date->time-tai 'date->time dat)]
    16321637    [else
    16331638      (error 'date->time "invalid clock type" timtyp)]) )
    16341639
    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)
     1640;; Leap Year
     1641
     1642(define (leap-year? dat)
    16441643  (%check-date 'date-leap-year? dat)
    16451644  (tm:leap-year? (%date-year dat)) )
    16461645
    1647 ;;
     1646;; Day of Year
    16481647
    16491648(define (tm:year-day dy mn yr)
     
    16531652      yrdy ) ) )
    16541653
    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 
    16631654(define (date-year-day dat)
    16641655  (%check-date 'date-year-day dat)
    1665   (or (date-yday dat)
     1656  (or (%date-yday dat)
    16661657      (let ([yrdy (tm:year-day (%date-day dat) (%date-month dat) (%date-year dat))])
    16671658        (%date-yday-set! dat yrdy)
    16681659        yrdy ) ) )
     1660
     1661;; Week Day
    16691662
    16701663;; Using Gregorian Calendar (from Calendar FAQ)
     
    16741667         [y (fx- yr a)]
    16751668         [m (fx- (fx+ mn (fx* a MN/YR)) 2)])
    1676     (modulo
    1677       (fx+ dy
    1678            (fx+ y
    1679                 (fx+ (fx/ y 4)
    1680                      (fx- (fx+ (fx/ y 400) (fx/ (fx* m DY/MN) MN/YR))
    1681                           (fx/ y 100)))))
     1669    (fxmod
     1670      (fx+ (fx+ dy y) (fx+ (fx- (fx/ y 4) (fx/ y 100)) (fx+ (fx/ y 400) (fx/ (fx* m DY/MN) MN/YR))))
    16821671      DY/WK) ) )
    16831672
    1684 ;;
     1673(define (tm:days-before-first-week dat day-of-week-starting-week)
     1674  (fxmod
     1675    (fx- day-of-week-starting-week (tm:week-day 1 1 (%date-year dat)))
     1676    DY/WK) )
    16851677
    16861678(define (date-week-day dat)
     
    16941686  (%check-date 'date-week-number dat)
    16951687  (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))
    1697          DY/WK) ) )
    1698 
    1699 ;; tm:julian-day
     1688    (fx/
     1689      (fx- (date-year-day dat) (tm:days-before-first-week dat day-of-week-starting-week))
     1690      DY/WK) ) )
     1691
     1692;; Julian-day Operations
     1693
     1694;; Date to Julian-day
    17001695
    17011696; Does the nanoseconds value contribute anything to the julian day?
    17021697; The range is < 1 second here (but not in the reference).
    17031698
    1704 (define (tm:julian-day nanosecond second minute hour day month year tzo)
    1705   (+ (- (tm:encode-julian-day-number day month year) ONE-HALF)
    1706      (/ (+ (fx+ (fx+ (fx* hour SEC/HR) (fx+ (fx* minute SEC/MIN) second)) (fxneg tzo))
    1707            (/ nanosecond NS/S))
    1708         SEC/DY)) )
     1699(define (tm:julian-day ns sec min hr dy mn yr tzo)
     1700  (+
     1701    (- (tm:encode-julian-day-number dy mn yr) ONE-HALF)
     1702    (/
     1703      (+ (fx+ (fx+ (fx* hr SEC/HR) (fx+ (fx* min SEC/MIN) sec)) (fxneg tzo)) (/ ns NS/S))
     1704      SEC/DY)) )
    17091705
    17101706#; ; inexact version
    1711 (define (tm:julian-day nanosecond second minute hour day month year tzo)
    1712   (fp+ (fp- (exact->inexact (tm:encode-julian-day-number day month year)) iONE-HALF)
    1713        (fp/ (fp+ (exact->inexact
    1714                   (fx+ (fx+ (fx* hour SEC/HR) (fx+ (fx* minute SEC/MIN) second)) (fxneg tzo)))
    1715                  (fp/ (exact->inexact nanosecond) iNS/S))
    1716             iSEC/DY)) )
    1717 
    1718 ;;
    1719 
    1720 (define (date->julian-day dat)
    1721   (%check-date 'date->julian-day dat)
    1722   (or (date-jday dat)
     1707(define (tm:julian-day ns sec min hr dy mn yr tzo)
     1708  (fp+
     1709    (fp- (exact->inexact (tm:encode-julian-day-number dy mn yr)) iONE-HALF)
     1710    (fp/
     1711      (fp+
     1712        (exact->inexact (fx+ (fx+ (fx* hr SEC/HR) (fx+ (fx* min SEC/MIN) sec)) (fxneg tzo)))
     1713        (fp/ (exact->inexact ns) iNS/S))
     1714      iSEC/DY)) )
     1715
     1716(define (tm:date->julian-day loc dat)
     1717  (%check-date loc dat)
     1718  (or (%date-jday dat)
    17231719      (let ([jdn
    17241720              (tm:julian-day
     
    17301726        jdn ) ) )
    17311727
     1728(define (date->julian-day dat)
     1729  (tm:date->julian-day 'date->julian-day dat) )
     1730
    17321731(define (date->modified-julian-day dat)
    1733   (- (date->julian-day dat) TAI-EPOCH-IN-MODIFIED-JD) )
     1732  (- (tm:date->julian-day 'date->modified-julian-day dat) TAI-EPOCH-IN-MODIFIED-JD) )
    17341733
    17351734;; Time to Julian-day
     
    17381737  (+ TAI-EPOCH-IN-JD (/ (+ sec (/ ns NS/S)) SEC/DY)) )
    17391738
     1739(define-inline (%time-tai->julian-day tim)
     1740  (let ([sec (%time-second tim)])
     1741    (tm:seconds->julian-day (%time-nanosecond tim) (- sec (tm:leap-second-delta sec))) ) )
     1742
    17401743(define (tm:time-utc->julian-day tim)
    17411744  (tm:seconds->julian-day (%time-nanosecond tim) (%time-second tim)) )
    17421745
    17431746(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))) ) )
     1747  (%time-tai->julian-day tim) )
     1748
     1749(define (tm:time-monotonic->julian-day tim)
     1750  (%time-tai->julian-day tim) )
    17461751
    17471752(define (time-utc->julian-day tim)
    1748   (tm:check-time-and-type'time-utc->julian-day tim 'time-utc)
     1753  (tm:check-time-and-type 'time-utc->julian-day tim 'time-utc)
    17491754  (tm:time-utc->julian-day tim) )
    17501755
     
    17551760(define (time-monotonic->julian-day tim)
    17561761  (tm:check-time-and-type 'time-monotonic->julian-day tim 'time-monotonic)
    1757   (tm:time-tai->julian-day tim) )
     1762  (tm:time-monotonic->julian-day tim) )
    17581763
    17591764(define (time->julian-day tim)
    17601765  (%check-time 'time->julian-day tim)
    17611766  (case (%time-type tim)
    1762     [(time-monotonic) (tm:time-tai->julian-day tim)]
     1767    [(time-monotonic) (tm:time-monotonic->julian-day tim)]
    17631768    [(time-utc)       (tm:time-utc->julian-day tim)]
    17641769    [(time-tai)       (tm:time-tai->julian-day tim)]
     
    17661771      (error 'time->julian-day "invalid clock type" tim)]) )
    17671772
    1768 ;; Time to Modified-julian-day
    1769 
    17701773(define (tm:time-utc->modified-julian-day tim)
    17711774  (- (tm:time-utc->julian-day tim) TAI-EPOCH-IN-MODIFIED-JD) )
     
    17731776(define (tm:time-tai->modified-julian-day tim)
    17741777  (- (tm:time-tai->julian-day tim) TAI-EPOCH-IN-MODIFIED-JD) )
     1778
     1779(define (tm:time-monotonic->modified-julian-day tim)
     1780  (- (tm:time-monotonic->julian-day tim) TAI-EPOCH-IN-MODIFIED-JD) )
    17751781
    17761782(define (time-utc->modified-julian-day tim)
     
    17841790(define (time-monotonic->modified-julian-day tim)
    17851791  (tm:check-time-and-type 'time-monotonic->modified-julian-day tim 'time-monotonic)
    1786   (tm:time-tai->modified-julian-day tim) )
     1792  (tm:time-monotonic->modified-julian-day tim) )
    17871793
    17881794(define (time->modified-julian-day tim)
    17891795  (%check-time 'time->modified-julian-day tim)
    17901796  (case (%time-type tim)
    1791     [(time-monotonic) (tm:time-tai->modified-julian-day tim)]
     1797    [(time-monotonic) (tm:time-monotonic->modified-julian-day tim)]
    17921798    [(time-utc)       (tm:time-utc->modified-julian-day tim)]
    17931799    [(time-tai)       (tm:time-tai->modified-julian-day tim)]
     
    17981804
    17991805(define (julian-day->time-utc jdn)
    1800   (let ([ns (* (- jdn TAI-EPOCH-IN-JD) SEC/DY NS/S)])
    1801     (tm:make-time 'time-utc (abs (remainder ns NS/S)) (floor (/ ns NS/S))) ) )
     1806  (receive [ns sec] (tm:split-nanoseconds (* (- jdn TAI-EPOCH-IN-JD) SEC/DY NS/S))
     1807    (tm:make-time 'time-utc ns sec) ) )
    18021808
    18031809(define (julian-day->time-tai jdn)
     
    18101816  (apply time-utc->date (julian-day->time-utc jdn) tzi) )
    18111817
    1812 ;; Modified-julian-day to Time
    1813 
    18141818(define (modified-julian-day->time-utc mjdn)
    18151819  (julian-day->time-utc (+ mjdn TAI-EPOCH-IN-MODIFIED-JD)) )
  • release/3/srfi-19/trunk/srfi-19-eggdoc.scm

    r11875 r12073  
    227227        (subsubsection "Time Comparison"
    228228
     229          (procedure "(time-compare TIME1 TIME2)"
     230            (p "Returns -1, 0, or 1.") )
     231
    229232          (procedure "(time-max TIME1 [TIME2 ...])"
    230233            (p "Returns the maximum time object from " (tt "TIME1 TIME2 ...") "."))
     
    273276
    274277        (subsubsection "Date Comparison"
     278
     279          (procedure "(date-compare DATE1 DATE2)"
     280            (p "Returns -1, 0, or 1.") )
    275281
    276282          (procedure "(date=? DATE1 DATE2)"
     
    534540
    535541  (history
     542    (version "2.7.0" "Replaced date comparison w/ a field by field algorithm. Removed local-timezone-info, local-timezone-name, local-timezone-offset, and local-timezone-dst?.")
    536543    (version "2.6.11" "Printing of \"xxx.0\" => "xxx". More use of fixnum ops in srfi-19-io.")
    537544    (version "2.6.10" "Dropped :optional.")
  • release/3/srfi-19/trunk/srfi-19-io.scm

    r12029 r12073  
    159159(define (tm:locale-find-string str vec)
    160160  (let loop ([idx (fx- (vector-length vec) 1)])
    161     (and (fx<= 0 idx)
    162          (or (and (string=? str (item@ (vector-ref vec idx))) idx)
     161    (and (fx< 0 idx)
     162         (or (and (string=? str (item@ (vector-ref vec idx)))
     163                  idx)
    163164             (loop (fx- idx 1))) ) ) )
    164165
     
    689690(define (scan-date src template-string)
    690691  (let ([port #f]
    691         [newdate
    692           (tm:make-date
    693             0 0 0 0 #f #f #f
    694             (local-timezone-offset) (local-timezone-name) (local-timezone-dst?)
    695             #f #f #f)])
     692        [newdate (tm:make-incomplete-date)])
    696693    (let ([date-compl?
    697694            (lambda ()
     
    700697                   (date-day newdate) (date-month newdate) (date-year newdate)
    701698                   (date-zone-offset newdate)))]
    702           [date-ok?
     699          [date-ok
    703700            (lambda ()
    704               (tm:vali-date
     701              (tm:check-exploded-date
    705702                'scan-date
    706703                (date-nanosecond newdate)
     
    716713      (unless (date-compl?)
    717714        (error 'scan-date "bad date template: date read incomplete" template-string newdate))
    718       (and (date-ok?) newdate) ) ) )
     715      (date-ok)
     716      newdate ) ) )
    719717
    720718(define (string->date src . template-string)
    721   (scan-date src (optional template-string (item@ LOCALE-DATE-TIME-FORMAT))))
     719  (scan-date src (optional template-string (item@ LOCALE-DATE-TIME-FORMAT))) )
  • release/3/srfi-19/trunk/srfi-19-period.scm

    r12029 r12073  
    5252
    5353(use srfi-8
    54     srfi-19-core)
     54    srfi-19-core
     55    misc-extn-record)
    5556
    5657;;;
     
    7980
    8081(define (tm:time-period-type per)
    81    (%time-type (%time-period-begin per)) )
     82   (tm:time-type (%time-period-begin per)) )
    8283
    8384(define (tm:time-period-null? per)
     
    9091
    9192(define (tm:ensure-compatible-time loc t1 t2)
    92   (let ([tt1 (%time-type t1)]
    93         [tt2 (%time-type t2)]
    94         [errtt
    95           (lambda ()
    96             (error loc "incompatible clock-types" t1 t2))])
     93  (let ([tt1 (tm:time-type t1)]
     94        [tt2 (tm:time-type t2)]
     95        [errtt (lambda () (error loc "incompatible clock-types" t1 t2))])
    9796    (if (eq? tt1 tt2)
    9897      t2
     
    121120
    122121(define (tm:ensure-compatible-date tim dat loc)
    123   (case (%time-type tim)
     122  (case (tm:time-type tim)
    124123    [(time-utc)       (date->time-utc dat)]
    125124    [(time-tai)       (date->time-tai dat)]
     
    129128
    130129#;
    131 (define (tm:time-compare loc per1 per2)
     130(define (tm:time-period-compare loc per1 per2)
    132131  (tm:time-period-binop-check loc per1 per2)
    133132  (tm:time-period-subtract per1 per2) )
    134 
    135133
    136134(define (tm:time-period=? per1 per2)
     
    199197
    200198(define (make-null-time-period . args)
    201   (let-optionals args ((timtyp (default-date-clock-type)))
     199  (let-optionals args ([timtyp (default-date-clock-type)])
    202200    (tm:as-empty-time-period (tm:make-empty-time timtyp)) ) )
    203201
    204202(define (make-time-period beg end . args)
    205   (let-optionals args ((timtyp (default-date-clock-type)))
     203  (let-optionals args ([timtyp (default-date-clock-type)])
    206204    (cond
    207205      [(number? beg)
     
    209207      [(date? beg)
    210208        (set! beg (date->time beg timtyp))])
    211     (%check-time 'make-time-period beg)
    212     (when (eq? 'time-duration (%time-type beg))
     209    (tm:check-time 'make-time-period beg)
     210    (when (eq? 'time-duration (tm:time-type beg))
    213211      (error 'make-time-period "invalid time" beg))
    214212    (cond
     
    217215      [(date? end)
    218216        (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))
     217    (tm:check-time 'make-time-period end)
     218    (when (eq? 'time-duration (tm:time-type end))
    221219      (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)) ) )
     220    (%make-time-period beg (tm:ensure-compatible-time 'make-time-period beg end)) ) )
    225221
    226222(define (copy-time-period per)
     
    276272    (if (tm:time-period-null? per)
    277273      dur
    278       (tm:time-difference
    279         (%time-period-begin per) (%time-period-end per) dur)) ) )
     274      (tm:time-difference (%time-period-begin per) (%time-period-end per) dur)) ) )
    280275
    281276(define (time-period-contains/period? per1 per2)
     
    286281(define (time-period-contains/time? per tim)
    287282  (%check-time-period 'time-period-contains/time? per)
    288   (%check-time 'time-period-contains/time? tim)
     283  (tm:check-time 'time-period-contains/time? tim)
    289284  (tm:time-period-contains/time? 'time-period-contains/time? per tim) )
    290285
     
    324319  (let ([b1 (%time-period-begin per1)]
    325320        [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)
    329           (and (tm:time<=? bi ei)
    330                (receive [bu eu] (tm:time-point-union-values b1 e1 b2 e2)
    331                  (%make-time-period bu eu))) ) ) ) )
     321    (let ([b2 (tm:ensure-compatible-time 'time-period-union b1 (time-period-begin per2))]
     322          [e2 (tm:ensure-compatible-time 'time-period-union e1 (time-period-end per2))])
     323      (receive [bi ei] (tm:time-point-intersection b1 e1 b2 e2)
     324        (and (tm:time<=? bi ei)
     325             (receive [bu eu] (tm:time-point-union-values b1 e1 b2 e2)
     326               (%make-time-period bu eu) ) ) ) ) ) )
    332327
    333328(define (time-period-span per1 per2)
     
    336331  (let ([b1 (%time-period-begin per1)]
    337332        [e1 (%time-period-end per1)])
    338     (receive [bu eu]
    339         (tm:time-point-union-values
    340           b1 e1
    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)))
    343       (%make-time-period bu eu) ) ) )
     333    (let ([b2 (tm:ensure-compatible-time 'time-period-span b1 (%time-period-begin per2))]
     334          [e2 (tm:ensure-compatible-time 'time-period-span e1 (%time-period-end per2))])
     335    (receive [bu eu] (tm:time-point-union-values b1 e1 b2 e2)
     336      (%make-time-period bu eu) ) ) ) )
    344337
    345338(define (time-period-shift per dur)
    346339  (%check-time-period 'time-period-shift per)
    347   (%check-time 'time-period-shift dur)
    348   (tm:duration-check 'time-period-shift dur)
     340  (tm:check-duration 'time-period-shift dur)
    349341  (tm:time-period-shift per dur (tm:as-empty-time-period per)) )
    350342
    351343(define (time-period-shift! per dur)
    352344  (%check-time-period 'time-period-shift! per)
    353   (%check-time 'time-period-shift! dur)
    354   (tm:duration-check 'time-period-shift! dur)
     345  (tm:check-duration 'time-period-shift! dur)
    355346  (tm:time-period-shift per dur per) )
  • release/3/srfi-19/trunk/srfi-19.html

    r11875 r12073  
    276276<div class="subsubsection">
    277277<h5>Time Comparison</h5>
     278<dt class="definition"><strong>procedure:</strong> (time-compare TIME1 TIME2)</dt>
     279<dd>
     280<p>Returns -1, 0, or 1.</p></dd>
    278281<dt class="definition"><strong>procedure:</strong> (time-max TIME1 [TIME2 ...])</dt>
    279282<dd>
     
    313316<div class="subsubsection">
    314317<h5>Date Comparison</h5>
     318<dt class="definition"><strong>procedure:</strong> (date-compare DATE1 DATE2)</dt>
     319<dd>
     320<p>Returns -1, 0, or 1.</p></dd>
    315321<dt class="definition"><strong>procedure:</strong> (date=? DATE1 DATE2)</dt>
    316322<dd>
     
    484490<h3>Version</h3>
    485491<ul>
    486 <li>2.6.11 Printing of &quot;xxx.0&quot; =&gt; xxx. More use of fixnum ops in srfi-19-10.</li>
     492<li>2.7.0 Replaced date comparison w/ a field by field algorithm. Removed local-timezone-info, local-timezone-name, local-timezone-offset, and local-timezone-dst?.</li>
     493<li>2.6.11 Printing of &quot;xxx.0&quot; =&gt; xxx. More use of fixnum ops in srfi-19-io.</li>
    487494<li>2.6.10 Dropped :optional.</li>
    488495<li>2.6.9 Needs Chicken 2.610 for MacOS X &amp; Windows.</li>
  • release/3/srfi-19/trunk/srfi-19.setup

    r10022 r12073  
    55
    66(required-extension-version
     7  'misc-extn              "3.2.0"
    78  'srfi-29                "1.5"
    89  'miscmacros             "2.4"
  • release/3/srfi-19/trunk/tests/basic-test.scm

    r12029 r12073  
    219219(define-s19-test! "string->date conversions"
    220220  (lambda ()
    221     (equal? (make-date 0 53 4 0 19 10 2006 (local-timezone-info))
     221    (equal? (make-date 0 53 4 0 19 10 2006 (local-timezone-locale))
    222222            (string->date "2006/10/19 00:04:53" "~Y/~m/~d ~H:~M:~S"))))
    223223
Note: See TracChangeset for help on using the changeset viewer.