Changeset 38283 in project


Ignore:
Timestamp:
03/16/20 20:12:26 (2 weeks ago)
Author:
Kon Lovett
Message:

inline struct sccessors, smaller binary

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

Legend:

Unmodified
Added
Removed
  • release/5/srfi-19/trunk/srfi-19-date.scm

    r38277 r38283  
    674674(define-record-printer (srfi-19-date dat out)
    675675  (format out (date-record-printer-format-string)
    676    (%date-nanosecond dat)
    677    (%date-second dat) (%date-minute dat) (%date-hour dat)
    678    (%date-day dat) (%date-month dat) (%date-year dat)
    679    (%date-zone-offset dat)
    680    (%date-zone-name dat) (%date-dst? dat)
    681    (%date-wday dat) (%date-yday dat) (%date-jday dat)) )
     676   (tm:date-nanosecond dat)
     677   (tm:date-second dat) (tm:date-minute dat) (tm:date-hour dat)
     678   (tm:date-day dat) (tm:date-month dat) (tm:date-year dat)
     679   (tm:date-zone-offset dat)
     680   (tm:date-zone-name dat) (tm:date-dst? dat)
     681   (tm:date-wday dat) (tm:date-yday dat) (tm:date-jday dat)) )
    682682
    683683(define-reader-ctor 'srfi-19-date
    684684  (lambda (ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)
    685     (%make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)))
     685    (tm:make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)))
    686686
    687687) ;module srfi-19-date
  • release/5/srfi-19/trunk/srfi-19-support.scm

    r38277 r38283  
    123123
    124124(define (time? obj)
    125   (%time? obj) )
     125  (tm:time? obj) )
    126126
    127127;; Time to Date
     
    140140;;
    141141
    142 (define-check+error-type time %time?)
     142(define-check+error-type time tm:time?)
    143143(define-check+error-type time-type)
    144144(define-check+error-type time-seconds)
     
    160160(define (check-time-has-type loc tim tt)
    161161  (unless (tm:time-has-type? tim tt)
    162     (error-incompatible-time-types loc (%time-type tim) tt) ) )
     162    (error-incompatible-time-types loc (tm:time-type tim) tt) ) )
    163163
    164164(define (check-time-and-type loc tim tt)
     
    183183(define (check-time-compare loc obj1 obj2)
    184184  (check-time-binop loc obj1 obj2)
    185   (check-time-has-type loc obj1 (%time-type obj2)) )
     185  (check-time-has-type loc obj1 (tm:time-type obj2)) )
    186186
    187187(define (check-time-aritmetic loc tim dur)
     
    192192
    193193(define (date? obj)
    194   (%date? obj) )
     194  (tm:date? obj) )
    195195
    196196;;
     
    252252
    253253(define (check-date-compatible-timezone-offsets loc dat1 dat2)
    254   (unless (= (%date-zone-offset dat1) (%date-zone-offset dat2))
     254  (unless (= (tm:date-zone-offset dat1) (tm:date-zone-offset dat2))
    255255    (error-date-compatible-timezone loc dat1 dat2) ) )
    256256
     
    264264  (signal-type-error loc (conc "cannot convert " srcnam " to " dstnam) obj) )
    265265
    266 (define-check+error-type date %date?)
     266(define-check+error-type date tm:date?)
    267267
    268268;; Date TZ information extract
    269269
    270270(define (date-timezone-info? obj)
    271   (%date-timezone-info? obj) )
     271  (tm:date-timezone-info? obj) )
    272272
    273273;; Week Day
  • release/5/srfi-19/trunk/srfi-19-time.scm

    r38277 r38283  
    462462(define-record-printer (srfi-19-time tim out)
    463463  (format out (time-record-printer-format-string)
    464     (%time-type tim)
    465     (%time-nanosecond tim)
    466     (%time-second tim)) )
     464    (tm:time-type tim)
     465    (tm:time-nanosecond tim)
     466    (tm:time-second tim)) )
    467467
    468468;SRFI-10
    469469(define-reader-ctor 'srfi-19-time
    470470  (lambda (tt ns sec)
    471     (%make-time tt ns sec)))
     471    (tm:make-time tt ns sec)))
    472472
    473473) ;module srfi-19-time
  • release/5/srfi-19/trunk/srfi-19-tm.scm

    r38277 r38283  
    6464
    6565(;export
    66   ;;Private
    67   ;
    68   %make-date-timezone-info
    69   %date-timezone-info?
    70   %date-timezone-info-name
    71   %date-timezone-info-offset
    72   %date-timezone-info-dst?
    73   ;
    74   %make-time
    75   %time?
    76   %time-type        %time-type-set!
    77   %time-nanosecond  %time-nanosecond-set!
    78   %time-second      %time-second-set!
    79   ;
    80   %make-date
    81   %date?
    82   %date-nanosecond  %date-nanosecond-set!
    83   %date-second      %date-second-set!
    84   %date-minute      %date-minute-set!
    85   %date-hour        %date-hour-set!
    86   %date-day         %date-day-set!
    87   %date-month       %date-month-set!
    88   %date-year        %date-year-set!
    89   %date-zone-offset %date-zone-offset-set!
    90   %date-zone-name   %date-zone-name-set!
    91   %date-dst?        %date-dst-set!
    92   %date-wday        %date-wday-set!
    93   %date-yday        %date-yday-set!
    94   %date-jday        %date-jday-set!
    95   ;
    9666  tm:read-tai-utc-data
    9767  tm:calc-second-before-leap-second-table
    9868  tm:read-leap-second-table
    99   (tm:any-time %make-time)
    100   (tm:some-time %make-time)
    101   (tm:as-some-time %time-type %make-time)
    102   (tm:time-type %time-type)
    103   (tm:time-nanosecond %time-second)
    104   (tm:time-second %time-nanosecond)
    105   (tm:time-type-set! %time-type-set!)
    106   (tm:time-nanosecond-set! %time-nanosecond-set!)
    107   (tm:time-second-set! %time-second-set!)
     69  tm:any-time
     70  tm:some-time
     71  tm:as-some-time
     72  tm:time-type
     73  tm:time-nanosecond
     74  tm:time-second
     75  tm:time-type-set!
     76  tm:time-nanosecond-set!
     77  tm:time-second-set!
     78  tm:time?
    10879  tm:make-time
    109   (tm:copy-time %make-time)
    110   (tm:time-has-type? %time-type)
     80  tm:copy-time
     81  tm:time-has-type?
    11182  tm:nanoseconds->time-values
    11283  tm:time->nanoseconds
     
    11990  tm:seconds->time-values
    12091  tm:seconds->time
    121   (tm:current-time-values tm:current-nanoseconds)
     92  tm:current-time-values
    12293  tm:current-time-utc
    123   (tm:current-time-tai leap-second-delta)
     94  tm:current-time-tai
    12495  tm:current-time-monotonic
    125   (tm:current-time-thread current-thread-milliseconds)
    126   (tm:current-time-process current-process-milliseconds)
    127   (tm:current-time-gc current-gc-milliseconds total-gc-milliseconds)
     96  tm:current-time-thread
     97  tm:current-time-process
     98  tm:current-time-gc
    12899  tm:time-resolution
    129100  tm:time-compare
     
    143114  tm:time-negate
    144115  tm:time-zero? tm:time-positive? tm:time-negative?
    145   (tm:time-tai->time-utc leap-second-neg-delta)
     116  tm:time-tai->time-utc
    146117  tm:time-tai->time-monotonic
    147118  tm:time-utc->time-tai
     
    152123  tm:leap-day?
    153124  tm:days-in-month
    154   (tm:date-nanosecond %date-nanosecond)
    155   (tm:date-second %date-second)
    156   (tm:date-minute %date-minute)
    157   (tm:date-hour %date-hour)
    158   (tm:date-day %date-day)
    159   (tm:date-month %date-month)
    160   (tm:date-year %date-year)
    161   (tm:date-zone-offset %date-zone-offset)
    162   (tm:date-zone-name %date-zone-name)
    163   (tm:date-dst? %date-dst?)
     125  tm:date-nanosecond
     126  tm:date-second
     127  tm:date-minute
     128  tm:date-hour
     129  tm:date-day
     130  tm:date-month
     131  tm:date-year
     132  tm:date-zone-offset
     133  tm:date-zone-name
     134  tm:date-dst?
    164135  tm:date-wday
    165136  tm:date-yday
    166137  tm:date-jday
    167   (tm:date-timezone-info %make-date-timezone-info)
    168   (tm:date-nanosecond-set! %date-nanosecond-set!)
    169   (tm:date-second-set! %date-second-set!)
    170   (tm:date-minute-set! %date-minute-set!)
    171   (tm:date-hour-set! %date-hour-set!)
    172   (tm:date-day-set! %date-day-set!)
    173   (tm:date-month-set! %date-month-set!)
    174   (tm:date-year-set! %date-year-set!)
    175   (tm:date-zone-offset-set! %date-zone-offset-set!)
    176   (tm:make-incomplete-date %make-date)
    177   (tm:make-date %make-date)
    178   (tm:copy-date %date-nanosecond %date-second %date-minute %date-hour
    179     %date-day %date-month %date-year
    180     %date-zone-offset %date-zone-name
    181     %date-jday %date-yday %date-wday
    182     %make-date)
     138  tm:date-timezone-info?
     139  tm:date-timezone-info
     140  tm:date-nanosecond-set!
     141  tm:date-second-set!
     142  tm:date-minute-set!
     143  tm:date-hour-set!
     144  tm:date-day-set!
     145  tm:date-month-set!
     146  tm:date-year-set!
     147  tm:date-zone-offset-set!
     148  tm:make-incomplete-date
     149  tm:date?
     150  tm:make-date
     151  tm:copy-date
    183152  tm:seconds->date/type
    184153  tm:current-date
    185   (tm:date-compare %date-nanosecond %date-second %date-minute %date-hour
    186     %date-day %date-month %date-year)
     154  tm:date-compare
    187155  tm:decode-julian-day-number
    188156  tm:seconds->julian-day-number
     
    205173  tm:julian-day->modified-julian-day
    206174  tm:julian-day
    207   (tm:date->julian-day %date-nanosecond %date-second %date-minute %date-hour
    208     %date-day %date-month %date-year
    209     %date-zone-offset
    210     %date-jday %date-jday-set!)
     175  tm:date->julian-day
    211176  tm:seconds->julian-day
    212177  tm:time-utc->julian-day
     
    247212(include "srfi-19-common")
    248213
    249 ;;;NOTE the use of syntax for inlining is an experiment. no procedure w/
    250 ;;;arithmetic can be exported as syntax.
    251 
    252 ;; For storage savings since some aritmetic routines do not
    253 ;; return fixnums when possible.
    254 ;;
    255 ;; Number MUST be a fixnum or bignum
    256 
     214;-> integer, exact!
    257215(define-syntax number->genint
    258216  (syntax-rules ()
     
    262220          (inexact->exact (floor x)) ) ) ) ) )
    263221
     222;-> integer, inexact or exact!
    264223(define-syntax number->integer
    265224  (syntax-rules ()
     
    292251
    293252;#: ;dependency
    294 (define-constant date-timezone-info 'date-timezone-info)
    295 (define-record-type-variant date-timezone-info (unchecked #;inline unsafe)
     253(define-constant date-timezone-info 'srfi-19-date#date-timezone-info)
     254(define-record-type-variant date-timezone-info (unchecked inline unsafe)
    296255  (%make-date-timezone-info n o d)
    297256  %date-timezone-info?
     
    506465;#| ;dependency
    507466(define-constant srfi-19-time 'srfi-19-time#srfi-19-time)
    508 (define-record-type-variant srfi-19-time (unchecked #;inline unsafe)
     467(define-record-type-variant srfi-19-time (unchecked inline unsafe)
    509468  (%make-time tt ns sec)
    510469  %time?
     
    550509;Used to create an output time record where all fields will be set later
    551510;
    552 (define-syntax tm:any-time
    553         (syntax-rules ()
    554                 ((tm:any-time)
    555       (%make-time #f #f #f) ) ) )
     511(define (tm:any-time)
     512  (%make-time #f #f #f) )
    556513
    557514;Used to create a time record where ns & sec fields will be set later
    558515;
    559 (define-syntax tm:some-time
    560         (syntax-rules ()
    561                 ((tm:some-time ?tt)
    562                   (%make-time ?tt #f #f) ) ) )
     516(define (tm:some-time tt)
     517  (%make-time tt #f #f) )
    563518
    564519;Used to create a time record where ns & sec fields will be set later
    565520;
    566 (define-syntax tm:as-some-time
    567         (syntax-rules ()
    568                 ((tm:as-some-time ?tim)
    569                   (%make-time (%time-type ?tim) #f #f) ) ) )
    570 
    571 ;;
    572 
    573 (define-syntax tm:time-type
    574         (syntax-rules ()
    575                 ((tm:time-type ?tim)
    576                   (%time-type ?tim) ) ) )
    577 
    578 (define-syntax tm:time-second
    579         (syntax-rules ()
    580                 ((tm:time-second ?tim)
    581                   (%time-second ?tim) ) ) )
    582 
    583 (define-syntax tm:time-nanosecond
    584         (syntax-rules ()
    585                 ((tm:time-nanosecond ?tim)
    586                   (%time-nanosecond ?tim) ) ) )
    587 
    588 (define-syntax tm:time-type-set!
    589         (syntax-rules ()
    590                 ((tm:time-type-set! ?tim ?typ)
    591                   (%time-type-set! ?tim ?typ) ) ) )
    592 
    593 (define-syntax tm:time-nanosecond-set!
    594         (syntax-rules ()
    595                 ((tm:time-nanosecond-set! ?tim ?ns)
    596                   (%time-nanosecond-set! ?tim (number->genint ?ns)) ) ) )
    597 
    598 (define-syntax tm:time-second-set!
    599         (syntax-rules ()
    600                 ((tm:time-second-set! ?tim ?sec)
    601                   (%time-second-set! ?tim (number->integer ?sec)) ) ) )
     521(define (tm:as-some-time tim)
     522  (%make-time (%time-type tim) #f #f) )
     523
     524;;
     525
     526(define (tm:time-type tim)
     527  (%time-type tim) )
     528
     529(define (tm:time-second tim)
     530  (%time-second tim) )
     531
     532(define (tm:time-nanosecond tim)
     533  (%time-nanosecond tim) )
     534
     535(define (tm:time-type-set! tim typ)
     536  (%time-type-set! tim typ) )
     537
     538(define (tm:time-nanosecond-set! tim ns)
     539  (%time-nanosecond-set! tim (number->integer ns)) )
     540
     541(define (tm:time-second-set! tim sec)
     542  (%time-second-set! tim (number->integer sec)) )
     543
     544(define (tm:time? obj)
     545  (%time? obj) )
    602546
    603547(define (tm:make-time tt ns sec)
    604548  (let-values (
    605549    ((ns ns-sec) (normalize-nanoseconds ns)) )
    606     (%make-time tt (number->genint ns) (number->integer (+ sec ns-sec))) ) )
    607 
    608 (define-syntax tm:copy-time
    609         (syntax-rules ()
    610                 ((tm:copy-time ?tim)
    611                   (let ((tim ?tim))
    612         (%make-time (%time-type tim) (%time-second tim) (%time-nanosecond tim)) ) ) ) )
    613 
    614 (define-syntax tm:time-has-type?
    615         (syntax-rules ()
    616                 ((tm:time-has-type? ?tim ?tt)
    617                   (eq? ?tt (%time-type ?tim)) ) ) )
     550    (%make-time tt (number->integer ns) (number->integer (+ sec ns-sec))) ) )
     551
     552(define (tm:copy-time tim)
     553  (%make-time (%time-type tim) (%time-second tim) (%time-nanosecond tim)) )
     554
     555(define (tm:time-has-type? tim tt)
     556  (eq? tt (%time-type tim)) )
    618557
    619558;; Rem & Quo of nanoseconds per second
     
    658597  (let* (
    659598    (isec (number->integer sec))
    660     (ns (number->genint (round (* (- sec isec) NS/S)))) )
     599    (ns (number->integer (round (* (- sec isec) NS/S)))) )
    661600    (values ns isec) ) )
    662601
    663602(define (tm:milliseconds->time-values ms)
    664603  (let (
    665     (ns (* (number->genint (remainder ms MS/S)) NS/MS))
     604    (ns (* (number->integer (remainder ms MS/S)) NS/MS))
    666605    (sec (quotient ms MS/S)) )
    667606    (values ns sec) ) )
     
    691630;Use the 'official' seconds & nanoseconds values
    692631;
    693 (define-syntax tm:current-time-values
    694         (syntax-rules ()
    695                 ((tm:current-time-values)
    696       (values (tm:current-nanoseconds) (current-seconds)) ) ) )
    697 
    698 (define-syntax tm:current-time-utc
    699         (syntax-rules ()
    700                 ((tm:current-time-utc)
    701                   (let-values (((ns sec) (tm:current-time-values)))
    702         (tm:make-time 'utc ns sec) ) ) ) )
    703 
    704 (define-syntax tm:current-time-tai
    705         (syntax-rules ()
    706                 ((tm:current-time-tai)
    707       (let-values (((ns sec) (tm:current-time-values)))
    708         (tm:make-time 'tai ns (+ sec (leap-second-delta sec))) ) ) ) )
    709 
    710 (define-syntax tm:current-time-monotonic
    711         (syntax-rules ()
    712                 ((tm:current-time-monotonic)
    713       (let ((tim (tm:current-time-tai)))
    714         ;time-monotonic is time-tai
    715         (%time-type-set! tim 'monotonic)
    716         tim ) ) ) )
    717 
    718 (define-syntax tm:current-time-thread
    719         (syntax-rules ()
    720                 ((tm:current-time-thread)
    721       (tm:milliseconds->time (current-thread-milliseconds) 'thread) ) ) )
    722 
    723 (define-syntax tm:current-time-process
    724         (syntax-rules ()
    725                 ((tm:current-time-process)
    726       (tm:milliseconds->time (current-process-milliseconds) 'process) ) ) )
    727 
    728 (define-syntax tm:current-time-gc
    729         (syntax-rules ()
    730                 ((tm:current-time-gc)
    731       (tm:milliseconds->time (total-gc-milliseconds) 'gc) ) ) )
     632(define (tm:current-time-values)
     633  (values (tm:current-nanoseconds) (current-seconds)) )
     634
     635(define (tm:current-time-utc)
     636  (let-values (((ns sec) (tm:current-time-values)))
     637    (tm:make-time 'utc ns sec) ) )
     638
     639(define (tm:current-time-tai)
     640  (let-values (((ns sec) (tm:current-time-values)))
     641    (tm:make-time 'tai ns (+ sec (leap-second-delta sec))) ) )
     642
     643(define (tm:current-time-monotonic)
     644  (let ((tim (tm:current-time-tai)))
     645    ;time-monotonic is time-tai
     646    (%time-type-set! tim 'monotonic)
     647    tim ) )
     648
     649(define (tm:current-time-thread)
     650  (tm:milliseconds->time (current-thread-milliseconds) 'thread) )
     651
     652(define (tm:current-time-process)
     653  (tm:milliseconds->time (current-process-milliseconds) 'process) )
     654
     655(define (tm:current-time-gc)
     656  (tm:milliseconds->time (total-gc-milliseconds) 'gc) )
    732657
    733658;; -- Time Resolution
     
    844769    timout ) )
    845770
    846 (define-syntax tm:time-abs
    847         (syntax-rules ()
    848                 ((tm:time-abs ?tim1 ?timout)
    849                   (let ((tim1 ?tim1) (timout ?timout))
    850         (tm:time-nanosecond-set! timout (abs (%time-nanosecond tim1)))
    851         (tm:time-second-set! timout (abs (%time-second tim1)))
    852         timout ) ) ) )
     771(define (tm:time-abs tim1 timout)
     772  (tm:time-nanosecond-set! timout (abs (%time-nanosecond tim1)))
     773  (tm:time-second-set! timout (abs (%time-second tim1)))
     774  timout )
    853775
    854776(define (tm:time-negate tim1 timout )
     
    945867;#| ;dependency
    946868(define-constant srfi-19-date 'srfi-19-date#srfi-19-date)
    947 (define-record-type-variant srfi-19-date (unchecked #;inline unsafe)
     869(define-record-type-variant srfi-19-date (unchecked inline unsafe)
    948870  (%make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)
    949871  %date?
     
    986908;;; Getters
    987909
    988 (define-syntax tm:date-nanosecond
    989         (syntax-rules ()
    990                 ((tm:date-nanosecond ?dat)
    991                   (%date-nanosecond ?dat) ) ) )
    992 
    993 (define-syntax tm:date-second
    994         (syntax-rules ()
    995                 ((tm:date-second ?dat)
    996                   (%date-second ?dat) ) ) )
    997 
    998 (define-syntax tm:date-minute
    999         (syntax-rules ()
    1000                 ((tm:date-minute ?dat)
    1001                   (%date-minute ?dat) ) ) )
    1002 
    1003 (define-syntax tm:date-hour
    1004         (syntax-rules ()
    1005                 ((tm:date-hour ?dat)
    1006                   (%date-hour ?dat) ) ) )
    1007 
    1008 (define-syntax tm:date-day
    1009         (syntax-rules ()
    1010                 ((tm:date-day ?dat)
    1011                   (%date-day ?dat) ) ) )
    1012 
    1013 (define-syntax tm:date-month
    1014         (syntax-rules ()
    1015                 ((tm:date-month ?dat)
    1016                   (%date-month ?dat) ) ) )
    1017 
    1018 (define-syntax tm:date-year
    1019         (syntax-rules ()
    1020                 ((tm:date-year ?dat)
    1021                   (%date-year ?dat) ) ) )
    1022 
    1023 (define-syntax tm:date-zone-offset
    1024         (syntax-rules ()
    1025                 ((tm:date-zone-offset ?dat)
    1026                   (%date-zone-offset ?dat) ) ) )
    1027 
    1028 (define-syntax tm:date-zone-name
    1029         (syntax-rules ()
    1030                 ((tm:date-zone-name ?dat)
    1031                   (%date-zone-name ?dat) ) ) )
    1032 
    1033 (define-syntax tm:date-dst?
    1034         (syntax-rules ()
    1035                 ((tm:date-dst? ?dat)
    1036                   (%date-dst? ?dat) ) ) )
    1037 
    1038 (define-syntax tm:date-wday
    1039         (syntax-rules ()
    1040                 ((tm:date-wday ?dat)
    1041                   (%date-wday ?dat) ) ) )
    1042 
    1043 (define-syntax tm:date-yday
    1044         (syntax-rules ()
    1045                 ((tm:date-yday ?dat)
    1046                   (%date-yday ?dat) ) ) )
    1047 
    1048 (define-syntax tm:date-jday
    1049         (syntax-rules ()
    1050                 ((tm:date-jday ?dat)
    1051                   (%date-jday ?dat) ) ) )
     910(define (tm:date-nanosecond dat)
     911  (%date-nanosecond dat) )
     912
     913(define (tm:date-second dat)
     914  (%date-second dat) )
     915
     916(define (tm:date-minute dat)
     917  (%date-minute dat) )
     918
     919(define (tm:date-hour dat)
     920  (%date-hour dat) )
     921
     922(define (tm:date-day dat)
     923  (%date-day dat) )
     924
     925(define (tm:date-month dat)
     926  (%date-month dat) )
     927
     928(define (tm:date-year dat)
     929  (%date-year dat) )
     930
     931(define (tm:date-zone-offset dat)
     932  (%date-zone-offset dat) )
     933
     934(define (tm:date-zone-name dat)
     935  (%date-zone-name dat) )
     936
     937(define (tm:date-dst? dat)
     938  (%date-dst? dat) )
     939
     940(define (tm:date-wday dat)
     941  (%date-wday dat) )
     942
     943(define (tm:date-yday dat)
     944  (%date-yday dat) )
     945
     946(define (tm:date-jday dat)
     947  (%date-jday dat) )
    1052948
    1053949;;; Setters
    1054950
    1055 (define-syntax tm:date-nanosecond-set!
    1056         (syntax-rules ()
    1057                 ((tm:date-nanosecond-set! ?dat ?x)
    1058                   (%date-nanosecond-set! ?dat (number->genint ?x)) ) ) )
    1059 
    1060 (define-syntax tm:date-second-set!
    1061         (syntax-rules ()
    1062                 ((tm:date-second-set! ?dat ?x)
    1063                   (%date-second-set! ?dat (number->genint ?x)) ) ) )
    1064 
    1065 (define-syntax tm:date-minute-set!
    1066         (syntax-rules ()
    1067                 ((tm:date-minute-set! ?dat ?x)
    1068                   (%date-minute-set! ?dat (number->genint ?x)) ) ) )
    1069 
    1070 (define-syntax tm:date-hour-set!
    1071         (syntax-rules ()
    1072                 ((tm:date-hour-set! ?dat ?x)
    1073                   (%date-hour-set! ?dat (number->genint ?x)) ) ) )
    1074 
    1075 (define-syntax tm:date-day-set!
    1076         (syntax-rules ()
    1077                 ((tm:date-day-set! ?dat ?x)
    1078                   (%date-day-set! ?dat (number->genint ?x)) ) ) )
    1079 
    1080 (define-syntax tm:date-month-set!
    1081         (syntax-rules ()
    1082                 ((tm:date-month-set! ?dat ?x)
    1083                   (%date-month-set! ?dat (number->genint ?x)) ) ) )
    1084 
    1085 (define-syntax tm:date-year-set!
    1086         (syntax-rules ()
    1087                 ((tm:date-year-set! ?dat ?x)
    1088                   (%date-year-set! ?dat (number->genint ?x)) ) ) )
    1089 
    1090 (define-syntax tm:date-zone-offset-set!
    1091         (syntax-rules ()
    1092                 ((tm:date-zone-offset-set! ?dat ?x)
    1093                   (%date-zone-offset-set! ?dat (number->genint ?x)) ) ) )
     951(define (tm:date-nanosecond-set! dat x)
     952  (%date-nanosecond-set! dat (number->integer x)) )
     953
     954(define (tm:date-second-set! dat x)
     955  (%date-second-set! dat (number->integer x)) )
     956
     957(define (tm:date-minute-set! dat x)
     958  (%date-minute-set! dat (number->integer x)) )
     959
     960(define (tm:date-hour-set! dat x)
     961  (%date-hour-set! dat (number->integer x)) )
     962
     963(define (tm:date-day-set! dat x)
     964  (%date-day-set! dat (number->integer x)) )
     965
     966(define (tm:date-month-set! dat x)
     967  (%date-month-set! dat (number->integer x)) )
     968
     969(define (tm:date-year-set! dat x)
     970  (%date-year-set! dat (number->integer x)) )
     971
     972(define (tm:date-zone-offset-set! dat x)
     973  (%date-zone-offset-set! dat (number->integer x)) )
    1094974
    1095975;; Date TZ information extract
    1096976
    1097 (define-syntax tm:date-timezone-info
    1098         (syntax-rules ()
    1099                 ((tm:date-timezone-info ?dat)
    1100                   (let ((dat ?dat))
    1101         (%make-date-timezone-info
    1102           (%date-zone-name dat) (%date-zone-offset dat) (%date-dst? dat)) ) ) ) )
     977(define (tm:date-timezone-info? obj)
     978  (%date-timezone-info? obj) )
     979
     980(define (tm:date-timezone-info dat)
     981  (%make-date-timezone-info
     982    (%date-zone-name dat) (%date-zone-offset dat) (%date-dst? dat)) )
     983
     984(define (tm:date? obj)
     985  (%date? obj) )
    1103986
    1104987;; Returns an invalid date record (for use by 'scan-date')
    1105988
    1106 (define-syntax tm:make-incomplete-date
    1107         (syntax-rules ()
    1108                 ((tm:make-incomplete-date)
    1109       (%make-date
    1110         0
    1111         0 0 0
    1112         #f #f #f
    1113         (timezone-locale-offset) (timezone-locale-name) (timezone-locale-dst?)
    1114         #f #f #f) ) ) )
     989(define (tm:make-incomplete-date)
     990  (%make-date
     991    0
     992    0 0 0
     993    #f #f #f
     994    (timezone-locale-offset) (timezone-locale-name) (timezone-locale-dst?)
     995    #f #f #f) )
    1115996
    1116997;; Internal Date CTOR
    1117998
    1118 (define-syntax tm:make-date
    1119         (syntax-rules ()
    1120                 ((tm:make-date ?ns ?sec ?min ?hr ?dy ?mn ?yr ?tzo ?tzn ?dstf ?wdy ?ydy ?jdy)
    1121                   (%make-date
    1122         (number->genint ?ns)
    1123         (number->genint ?sec) (number->genint ?min) (number->genint ?hr)
    1124         (number->genint ?dy) (number->genint ?mn) (number->genint ?yr)
    1125         (number->genint ?tzo) ?tzn ?dstf
    1126         ?wdy ?ydy ?jdy) ) ) )
    1127 
    1128 (define-syntax tm:copy-date
    1129         (syntax-rules ()
    1130                 ((tm:copy-date ?dat)
    1131                   (let ((dat ?dat))
    1132         (%make-date
    1133           (%date-nanosecond dat)
    1134           (%date-second dat) (%date-minute dat) (%date-hour dat)
    1135           (%date-day dat) (%date-month dat) (%date-year dat)
    1136           (%date-zone-offset dat)
    1137           (%date-zone-name dat) (%date-dst? dat)
    1138           (%date-wday dat) (%date-yday dat) (%date-jday dat)) ) ) ) )
     999(define (tm:make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)
     1000  (%make-date
     1001    (number->integer ns)
     1002    (number->integer sec) (number->integer min) (number->integer hr)
     1003    (number->integer dy) (number->integer mn) (number->integer yr)
     1004    (number->integer tzo) tzn dstf
     1005    wdy ydy jdy) )
     1006
     1007(define (tm:copy-date dat)
     1008  (%make-date
     1009    (%date-nanosecond dat)
     1010    (%date-second dat) (%date-minute dat) (%date-hour dat)
     1011    (%date-day dat) (%date-month dat) (%date-year dat)
     1012    (%date-zone-offset dat)
     1013    (%date-zone-name dat) (%date-dst? dat)
     1014    (%date-wday dat) (%date-yday dat) (%date-jday dat)) )
    11391015
    11401016(define (tm:seconds->date/type sec tzc)
     
    11421018    (isec (number->genint sec))
    11431019    (tzo (timezone-locale-offset tzc))
     1020    ;seconds->utc-time cannot accept inexact-integer
    11441021    (tv (seconds->utc-time (+ isec tzo))) )
    11451022    (tm:make-date
     
    11551032;; Date Comparison
    11561033
    1157 (define-syntax tm:date-compare
    1158         (syntax-rules ()
    1159                 ((tm:date-compare ?dat1 ?dat2)
    1160                   (let ((dat1 ?dat1) (dat2 ?dat2))
    1161         (let ((dif (- (%date-year dat1) (%date-year dat2))))
    1162           (if (not (zero? dif))
    1163             dif
    1164             (let ((dif (- (%date-month dat1) (%date-month dat2))))
    1165               (if (not (zero? dif))
    1166                 dif
    1167                 (let ((dif (- (%date-day dat1) (%date-day dat2))))
    1168                   (if (not (zero? dif))
    1169                     dif
    1170                     (let ((dif (- (%date-hour dat1) (%date-hour dat2))))
    1171                       (if (not (zero? dif))
    1172                         dif
    1173                         (let ((dif (- (%date-minute dat1) (%date-minute dat2))))
    1174                           (if (not (zero? dif))
    1175                             dif
    1176                             (let ((dif (- (%date-second dat1) (%date-second dat2))))
    1177                               (if (not (zero? dif))
    1178                                 dif
    1179                                 (- (%date-nanosecond dat1) (%date-nanosecond dat2)) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) )
     1034(define (tm:date-compare dat1 dat2)
     1035  (let ((dif (- (%date-year dat1) (%date-year dat2))))
     1036    (if (not (zero? dif))
     1037      dif
     1038      (let ((dif (- (%date-month dat1) (%date-month dat2))))
     1039        (if (not (zero? dif))
     1040          dif
     1041          (let ((dif (- (%date-day dat1) (%date-day dat2))))
     1042            (if (not (zero? dif))
     1043              dif
     1044              (let ((dif (- (%date-hour dat1) (%date-hour dat2))))
     1045                (if (not (zero? dif))
     1046                  dif
     1047                  (let ((dif (- (%date-minute dat1) (%date-minute dat2))))
     1048                    (if (not (zero? dif))
     1049                      dif
     1050                      (let ((dif (- (%date-second dat1) (%date-second dat2))))
     1051                        (if (not (zero? dif))
     1052                          dif
     1053                          (- (%date-nanosecond dat1) (%date-nanosecond dat2)) ) ) ) ) ) ) ) ) ) ) ) ) )
    11801054
    11811055;; Gives the seconds/day/month/year
     
    12131087          (loop (cdr ls)) ) ) ) ) )
    12141088
     1089(define (optional-tzinfo tzi)
     1090  (cond
     1091    ((%date-timezone-info? tzi)
     1092      (values
     1093        (%date-timezone-info-offset tzi)
     1094        (%date-timezone-info-name tzi)
     1095        (%date-timezone-info-dst? tzi)) )
     1096    ((timezone-components? tzi)
     1097      (values
     1098        (timezone-locale-offset tzi)
     1099        (timezone-locale-name tzi)
     1100        (timezone-locale-dst? tzi)) )
     1101    (else
     1102      ;assume an offset
     1103      (values tzi #f #f) ) ) )
     1104
    12151105(define (tm:time-utc->date tim tzi)
    1216   (let (
    1217     (tzo tzi) ;assume an offset
    1218     (tzn #f)
    1219     (dstf #f) )
    1220     (cond
    1221       ((%date-timezone-info? tzi)
    1222         (set! dstf (%date-timezone-info-dst? tzi))
    1223         (set! tzn (%date-timezone-info-name tzi))
    1224         (set! tzo (%date-timezone-info-offset tzi)) )
    1225       ((timezone-components? tzi)
    1226         (set! dstf (timezone-locale-dst? tzi))
    1227         (set! tzn (timezone-locale-name tzi))
    1228         (set! tzo (timezone-locale-offset tzi)) ) )
     1106  (let-values (
     1107    ((tzo tzn dstf) (optional-tzinfo tzi)) )
    12291108    (let-values (
    12301109      ((secs dy mn yr)
     
    14631342        (exact->inexact SEC/DY))) ) )
    14641343
    1465 (define-syntax tm:date->julian-day
    1466         (syntax-rules ()
    1467                 ((tm:date->julian-day ?dat)
    1468                   (let ((dat ?dat))
    1469         (or
    1470           (%date-jday dat)
    1471           (let (
    1472             (jdn
    1473               (tm:julian-day
    1474                 (%date-nanosecond dat)
    1475                 (%date-second dat) (%date-minute dat) (%date-hour dat)
    1476                 (%date-day dat) (%date-month dat) (%date-year dat)
    1477                 (%date-zone-offset dat))))
    1478             (%date-jday-set! dat jdn)
    1479             jdn ) ) ) ) ) )
     1344(define (tm:date->julian-day dat)
     1345  (or
     1346    (%date-jday dat)
     1347    (let (
     1348      (jdn
     1349        (tm:julian-day
     1350          (%date-nanosecond dat)
     1351          (%date-second dat) (%date-minute dat) (%date-hour dat)
     1352          (%date-day dat) (%date-month dat) (%date-year dat)
     1353          (%date-zone-offset dat))))
     1354      (%date-jday-set! dat jdn)
     1355      jdn ) ) )
    14801356
    14811357;; Time to Julian-day
Note: See TracChangeset for help on using the changeset viewer.