Changeset 38270 in project


Ignore:
Timestamp:
03/15/20 23:48:54 (3 weeks ago)
Author:
Kon Lovett
Message:

split tm: ns from -support (not exported but somehow still pollutes toplevel!), remove use of fx, add test gloss

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

Legend:

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

    r38153 r38270  
    106106(import (chicken base))
    107107(import (chicken type))
    108 (import (chicken fixnum))
    109108(import (only (chicken keyword) string->keyword))
    110109(import (only srfi-1 fold list-index))
     
    157156        `(,_begin
    158157          ,@(let loop ((args (cdr frm)) (ls '()))
    159               (if (null? args)
    160                 ls
     158              (if (null? args) ls
    161159                (let (
    162160                  (?key (car args))
     
    166164                  (loop ?rest (cons `(,_date-adjuster-set! ',?key ',?syns ,?hdlr) ls) ) ) ) ) ) ) ) ) )
    167165
    168 #;
    169 (define-syntax date-adjuster-create
    170   (syntax-rules ()
    171     ((date-adjuster-create "aux" (?key ?syns ?hdlr) ...)
    172       (begin
    173         (date-adjuster-set! ?key ?syns ?hdlr)
    174         (date-adjuster-create ...) ) )
    175     ((date-adjuster-create ?key ?syns ?hdlr ...)
    176       (date-adjuster-create "aux" (?key ?syns ?hdlr) ...) ) ) )
    177 
    178166;;
    179167
     
    181169(define-parameter default-date-clock-type 'utc
    182170  (lambda (obj)
    183     (if (clock-type? obj)
    184       obj
     171    (if (clock-type? obj) obj
    185172      (begin
    186173        (warning-argument-type 'default-date-clock-type obj 'clock-type)
     
    189176(define-parameter default-date-adjust-integer tm:default-date-adjust-integer
    190177  (lambda (obj)
    191     (if (procedure? obj)
    192       obj
     178    (if (procedure? obj) obj
    193179      (begin
    194180        (warning-argument-type 'default-date-adjust-integer obj 'procedure)
     
    233219
    234220(define (date->seconds dat #!optional (tt (default-date-clock-type)))
    235   (let* (
    236     (dat
    237       (check-date 'date->seconds dat))
    238     (tim
    239       (case (check-clock-type 'date->seconds tt)
    240         ((utc)        (tm:date->time-utc dat))
    241         ((tai)        (tm:date->time-tai dat))
    242         ((monotonic)  (tm:date->time-monotonic dat)) ) ) )
    243     (tm:time-second tim) ) )
     221  (tm:time->seconds
     222    (tm:date->time
     223      (check-date 'date->seconds dat)
     224      (check-clock-type 'date->seconds tt))) )
    244225
    245226(define (current-date . tzi)
     
    291272  (let ((dif (checked-date-compare 'date-compare dat1 dat2)))
    292273    (cond
    293       ((fx> 0 dif)  -1)
    294       ((fx< 0 dif)  1)
    295       (else         0) ) ) )
     274      ((> 0 dif)  -1)
     275      ((< 0 dif)  1)
     276      (else       0) ) ) )
    296277
    297278(define (date=? dat1 dat2)
    298   (fx= 0 (checked-date-compare 'date=? dat1 dat2)) )
     279  (zero? (checked-date-compare 'date=? dat1 dat2)) )
    299280
    300281(define (date<? dat1 dat2)
    301   (fx> 0 (checked-date-compare 'date<? dat1 dat2)) )
     282  (positive? (checked-date-compare 'date<? dat1 dat2)) )
    302283
    303284(define (date<=? dat1 dat2)
    304   (fx>= 0 (checked-date-compare 'date<=? dat1 dat2)) )
     285  (>= 0 (checked-date-compare 'date<=? dat1 dat2)) )
    305286
    306287(define (date>? dat1 dat2)
    307   (fx< 0 (checked-date-compare 'date>? dat1 dat2)) )
     288  (negative? (checked-date-compare 'date>? dat1 dat2)) )
    308289
    309290(define (date>=? dat1 dat2)
    310   (fx<= 0 (checked-date-compare 'date>=? dat1 dat2)) )
     291  (<= 0 (checked-date-compare 'date>=? dat1 dat2)) )
    311292
    312293(define (date-max dat1 . rest)
     
    314295    (lambda (dat acc)
    315296      (check-date-compatible-timezone-offsets 'date-max acc (check-date 'date-max dat))
    316       (if (fx> 0 (tm:date-compare acc dat)) dat acc) )
     297      (if (positive? (tm:date-compare acc dat)) dat acc) )
    317298    (check-date 'date-max dat1)
    318299    rest) )
     
    322303    (lambda (dat acc)
    323304      (check-date-compatible-timezone-offsets 'date-min acc (check-date 'date-max dat))
    324       (if (fx< 0 (tm:date-compare acc dat)) dat acc) )
     305      (if (negative? (tm:date-compare acc dat)) dat acc) )
    325306    (check-date 'date-min dat1)
    326307    rest) )
     
    340321(define (date-difference dat1 dat2 . args)
    341322  (let-optionals args ((tt (default-date-clock-type)))
    342     (let ((tim1 (checked-tm:date->time 'date-difference (check-date 'date-difference dat1) tt))
    343           (tim2 (checked-tm:date->time 'date-difference (check-date 'date-difference dat2) tt)) )
     323    (let (
     324      (tim1
     325        (checked-tm:date->time 'date-difference
     326          (check-date 'date-difference dat1) tt))
     327      (tim2
     328        (checked-tm:date->time 'date-difference
     329          (check-date 'date-difference dat2) tt)) )
    344330      (tm:time-difference tim1 tim2 (tm:some-time 'duration)) ) ) )
    345331
     
    347333  (check-duration 'date-add-duration dur)
    348334  (let-optionals args ((tt (default-date-clock-type)))
    349     (let ((tim (checked-tm:date->time 'date-add-duration (check-date 'date-add-duration dat) tt)) )
     335    (let (
     336      (tim
     337        (checked-tm:date->time 'date-add-duration
     338          (check-date 'date-add-duration dat) tt)) )
    350339      (checked-tm:time->date 'date-add-duration
    351340        (tm:add-duration tim dur (tm:as-some-time tim))
     
    355344  (check-duration 'date-subtract-duration dur)
    356345  (let-optionals args ((tt (default-date-clock-type)))
    357     (let ((tim (checked-tm:date->time 'date-subtract-duration (check-date 'date-subtract-duration dat) tt)) )
     346    (let (
     347      (tim
     348        (checked-tm:date->time 'date-subtract-duration
     349          (check-date 'date-subtract-duration dat) tt)) )
    358350      (checked-tm:time->date 'date-subtract-duration
    359351        (tm:subtract-duration tim dur (tm:as-some-time tim))
     
    363355
    364356(define (date-adjuster-years dat amt key tt)
    365   (let ((yr (fx+ (tm:date-year dat) amt))
    366         (ndat (tm:copy-date dat)) )
     357  (let (
     358    (yr (+ (tm:date-year dat) amt))
     359    (ndat (tm:copy-date dat)) )
    367360    (tm:date-year-set! ndat yr)
    368     (when
    369         (and
    370           (tm:leap-day? (tm:date-day dat) (tm:date-month dat))
    371           (not (tm:leap-year? yr)))
     361    (when (and
     362            (tm:leap-day? (tm:date-day dat) (tm:date-month dat))
     363            (not (tm:leap-year? yr)))
    372364      (tm:date-day-set! ndat (tm:days-in-month (tm:date-month dat) yr)))
    373365    ndat ) )
    374366
    375367(define (date-adjuster-quarters dat amt key tt)
    376   (date-adjuster-months dat (fx* 3 amt) 'months tt) )
     368  (date-adjuster-months dat (* 3 amt) 'months tt) )
    377369
    378370(define (date-adjuster-months dat amt key tt)
    379371  (if (zero? amt)
    380372    (tm:copy-date dat)
    381     (let ((ndat (copy-date dat))
    382           (yrs (quotient amt 12))
    383           (mns (remainder amt 12)) )
     373    (let (
     374      (ndat (copy-date dat))
     375      (yrs (quotient amt 12))
     376      (mns (remainder amt 12)) )
    384377      (cond
    385378        ((positive? mns)
    386           (when (fx< 12 (fx+ (tm:date-month dat) mns))
     379          (when (< 12 (+ (tm:date-month dat) mns))
    387380            (tm:date-month-set! ndat 1)
    388             (set! mns (fx- mns (fx- 12 (tm:date-month dat))))
    389             (set! yrs (fx+ 1 yrs)) ) )
     381            (set! mns (- mns (- 12 (tm:date-month dat))))
     382            (set! yrs (+ 1 yrs)) ) )
    390383        (else ;(negative? amt)
    391           (when (fx> 1 (fx+ (tm:date-month dat) mns))
     384          (when (> 1 (+ (tm:date-month dat) mns))
    392385            (tm:date-month-set! ndat 12)
    393             (set! mns (fx+ mns (tm:date-month dat)))
    394             (set! yrs (fx- yrs 1)) ) ) )
    395       (tm:date-month-set! ndat (fx+ mns (tm:date-month ndat)))
    396       (tm:date-year-set! ndat (fx+ yrs (tm:date-year ndat)))
    397       (when (fx< (tm:days-in-month (tm:date-year ndat) (tm:date-month ndat)) (tm:date-day ndat))
     386            (set! mns (+ mns (tm:date-month dat)))
     387            (set! yrs (- yrs 1)) ) ) )
     388      (tm:date-month-set! ndat (+ mns (tm:date-month ndat)))
     389      (tm:date-year-set! ndat (+ yrs (tm:date-year ndat)))
     390      (when (< (tm:days-in-month (tm:date-year ndat) (tm:date-month ndat)) (tm:date-day ndat))
    398391        (tm:date-day-set! ndat (tm:days-in-month (tm:date-year ndat) (tm:date-month ndat))) )
    399392      ndat  ) ) )
    400393
    401394(define (date-adjuster-weeks dat amt key tt)
    402   (date-adjuster-duration dat (fx* amt 7) 'days tt) )
     395  (date-adjuster-duration dat (* amt 7) 'days tt) )
    403396
    404397(define (date-adjuster-duration dat amt key tt)
     
    650643
    651644(define (date-key< a b)
    652   (fx< 0 (date-key-compare a b)) )
     645  (negative? (date-key-compare a b)) )
    653646
    654647(define (date-key-compare a b)
  • release/5/srfi-19/trunk/srfi-19-io.scm

    r38153 r38270  
    4040(import scheme)
    4141(import (chicken base))
    42 (import (chicken fixnum))
    4342#;(import srfi-6)
    4443(import (only srfi-1 drop))
     
    7574(define LOCALE-NUMBER-SEPARATOR 'separator)
    7675
    77 (define LOCALE-ABRV-WEEKDAYS '#(#f sun mon tue wed thu fri sat))
    78 (define LOCALE-LONG-WEEKDAYS '#(#f sunday monday tuesday wednesday thursday friday saturday))
    79 
    80 (define LOCALE-ABRV-MONTHS '#(#f jan feb mar apr may jun jul aug sep oct nov dec))
    81 (define LOCALE-LONG-MONTHS '#(#f january february march april may-long june july august september october november december))
     76(define LOCALE-ABRV-WEEKDAYS #(#f sun mon tue wed thu fri sat))
     77(define LOCALE-LONG-WEEKDAYS #(#f sunday monday tuesday wednesday thursday friday saturday))
     78
     79(define LOCALE-ABRV-MONTHS #(#f jan feb mar apr may jun jul aug sep oct nov dec))
     80(define LOCALE-LONG-MONTHS #(#f january february march april may-long june july august september october november december))
    8281
    8382(define LOCALE-PM 'pm)
     
    101100(define (decimal-expansion frac prec)
    102101  (let loop ((n (- frac (round frac))) (p prec) (ls '()))
    103     (if (or (fx= 0 p) (zero? n))
     102    (if (or (zero? p) (zero? n))
    104103      (reverse-string-append ls)
    105104      (let* ((n*10 (* 10 n))
     
    107106        (loop
    108107          (- n*10 rn*10)
    109           (fx- p 1)
     108          (- p 1)
    110109          (cons (number->string (inexact->exact rn*10)) ls)) ) ) ) )
    111110
     
    120119    (define (trailing-dotzero?)
    121120      (and
    122         (fx<= 2 len)
    123         (char=? #\. (string-ref str (fx- len 2)))
    124         (char=? #\0 (string-ref str (fx- len 1))) ) )
     121        (<= 2 len)
     122        (char=? #\. (string-ref str (- len 2)))
     123        (char=? #\0 (string-ref str (- len 1))) ) )
    125124    (let ((str
    126125            (if (not (trailing-dotzero?))
    127126              str
    128               (substring str 0 (fx- len 2)) ) ) )
    129       (if (or (not pad-with) (fx> len length))
     127              (substring str 0 (- len 2)) ) ) )
     128      (if (or (not pad-with) (> len length))
    130129        str
    131130        (string-pad str length pad-with)) ) ) )
    132131
    133 (define fxtake-right-digits
    134   (let ((nth '#(0 10 100 1000 100000 1000000 10000000 100000000 1000000000)))
     132(define take-right-digits
     133  (let ((nth #(0 10 100 1000 100000 1000000 10000000 100000000 1000000000)))
    135134    (lambda (i n)
    136       (fxmod (fxabs i) (vector-ref nth n)) ) ) )
    137 
    138 (define (locale-abbr-weekday n) (item@ (vector-ref LOCALE-ABRV-WEEKDAYS (fx+ n 1))))
    139 (define (locale-long-weekday n) (item@ (vector-ref LOCALE-LONG-WEEKDAYS (fx+ n 1))))
     135      (modulo (abs i) (vector-ref nth n)) ) ) )
     136
     137(define (locale-abbr-weekday n) (item@ (vector-ref LOCALE-ABRV-WEEKDAYS (+ n 1))))
     138(define (locale-long-weekday n) (item@ (vector-ref LOCALE-LONG-WEEKDAYS (+ n 1))))
    140139(define (locale-abbr-month n) (item@ (vector-ref LOCALE-ABRV-MONTHS n)))
    141140(define (locale-long-month n) (item@ (vector-ref LOCALE-LONG-MONTHS n)))
    142141
    143142(define (locale-find-string str vec)
    144   (let loop ((idx (fx- (vector-length vec) 1)))
     143  (let loop ((idx (- (vector-length vec) 1)))
    145144    (and
    146       (fx< 0 idx)
     145      (positive? idx)
    147146      (or
    148147        (and
    149148          (string=? str (item@ (vector-ref vec idx)))
    150149          idx)
    151         (loop (fx- idx 1))) ) ) )
     150        (loop (- idx 1))) ) ) )
    152151
    153152(define (locale-abbr-weekday->index str) (locale-find-string str LOCALE-ABRV-WEEKDAYS))
     
    164163;; Again, locale specific.
    165164
    166 (define (locale-am/pm hr) (item@ (if (fx> hr 11) LOCALE-PM LOCALE-AM)))
     165(define (locale-am/pm hr) (item@ (if (> hr 11) LOCALE-PM LOCALE-AM)))
    167166
    168167(define (tz-printer offset port)
    169   (if (fx= 0 offset)
     168  (if (zero? offset)
    170169    (display "Z" port)
    171     (let ((isneg (fx< offset 0)))
     170    (let ((isneg (negative? offset)))
    172171      (display (if isneg #\- #\+) port)
    173       (let ((offset (if isneg (fxneg offset) offset)))
    174         (display (padding (fx/ offset SEC/HR) #\0 2) port)
    175         (display (padding (fx/ (fxmod offset SEC/HR) SEC/MIN) #\0 2) port) ) ) ) )
     172      (let ((offset (if isneg (- offset) offset)))
     173        (display (padding (quotient offset SEC/HR) #\0 2) port)
     174        (display (padding (quotient (modulo offset SEC/HR) SEC/MIN) #\0 2) port) ) ) ) )
    176175
    177176;; A table of output formatting directives.
     
    227226          ;ns must be inexact for 'decimal-expansion'
    228227          (let ((f (decimal-expansion (/ (exact->inexact ns) NS/S) 6)))
    229             (when (fx< 0 (string-length f))
     228            (when (positive? (string-length f))
    230229              (display (item@ LOCALE-NUMBER-SEPARATOR) port)
    231230              (display f port))))))
     
    242241      (lambda (date pad-with port)
    243242        (let ((hr (tm:date-hour date)))
    244           (if (fx> hr 12)
    245             (display (padding (fx- hr 12) pad-with 2) port)
     243          (if (> hr 12)
     244            (display (padding (- hr 12) pad-with 2) port)
    246245            (display (padding hr pad-with 2) port)))))
    247246
     
    257256      (lambda (date pad-with port)
    258257        (let ((hr (tm:date-hour date)))
    259           (display (padding (if (fx> hr 12) (fx- hr 12) hr) #\space 2) port))))
     258          (display (padding (if (> hr 12) (- hr 12) hr) #\space 2) port))))
    260259
    261260    (cons #\m
     
    305304      (lambda (date pad-with port)
    306305        (let ((wkno (tm:date-week-number date 0)))
    307           (if (fx> (tm:days-before-first-week date 0) 0)
    308             (display (padding (fx+ wkno 1) #\0 2) port)
     306          (if (positive? (tm:days-before-first-week date 0))
     307            (display (padding (+ wkno 1) #\0 2) port)
    309308            (display (padding wkno #\0 2) port)))))
    310309
     
    320319      (lambda (date pad-with port)
    321320        (let ((wkno (tm:date-week-number date 1)))
    322           (if (fx> (tm:days-before-first-week date 1) 0)
    323             (display (padding (fx+ wkno 1) #\0 2) port)
     321          (if (positive? (tm:days-before-first-week date 1))
     322            (display (padding (+ wkno 1) #\0 2) port)
    324323            (display (padding wkno #\0 2) port)))))
    325324
     
    334333    (cons #\y
    335334      (lambda (date pad-with port)
    336         (display (padding (fxtake-right-digits (tm:date-year date) 2) pad-with 2) port)))
     335        (display (padding (take-right-digits (tm:date-year date) 2) pad-with 2) port)))
    337336
    338337    (cons #\Y
     
    372371  ;Check enough format characters
    373372  (define (need-fmt-len amt)
    374     (when (fx< len-rem amt)
     373    (when (< len-rem amt)
    375374      (error-bad-date-format loc (list->string fmt-rem)) ) )
    376375
     
    384383    ;account for conversion character
    385384    (set! fmt-rem (cdr fmt-rem))
    386     (set! len-rem (fx- len-rem 1)) )
     385    (set! len-rem (- len-rem 1)) )
    387386
    388387  ;Conversion w/ padding override
     
    394393    ;must be done after the format
    395394    (set! fmt-rem (cdr fmt-rem))
    396     (set! len-rem (fx- len-rem 1)) )
     395    (set! len-rem (- len-rem 1)) )
    397396
    398397  ;Any formatting left to do?
    399   (when (fx< 0 len-rem)
     398  (when (positive? len-rem)
    400399    ;Decide what to do with it
    401400    (let ((1st-ch (car fmt-rem)))
     
    417416              (else                 (form-it #\0 2nd-ch) ) ) ) ) ) )
    418417    ;Remaining formatting
    419     (date-printer loc date (cdr fmt-rem) (fx- len-rem 1) port) ) )
     418    (date-printer loc date (cdr fmt-rem) (- len-rem 1) port) ) )
    420419
    421420(define (format-date dest fmtstr . r)
     
    471470      (eof-object? ch)
    472471      (not (char-numeric? ch))
    473       (and upto (fx>= nchars upto))) )
     472      (and upto (>= nchars upto))) )
    474473  (let loop ((accum 0) (nchars 0))
    475474    (if (eoi? (peek-char port) nchars)
    476475      accum
    477       (loop
    478         (fx+ (fx* accum 10) (digit->int (read-char port)))
    479         (fx+ nchars 1))) ) )
     476      (loop (+ (* accum 10) (digit->int (read-char port))) (+ nchars 1))) ) )
    480477
    481478(define (make-integer-reader upto)
     
    490487      (let ((ch (peek-char port)))
    491488        (cond
    492           ((fx>= nchars n)
     489          ((>= nchars n)
    493490            accum)
    494491          ((eof-object? ch)
     
    497494          ((char-numeric? ch)
    498495            (set! padding-ok #f)
    499             (loop (fx+ (fx* accum 10) (digit->int (read-char port))) (fx+ nchars 1)))
     496            (loop (+ (* accum 10) (digit->int (read-char port))) (+ nchars 1)))
    500497          (padding-ok
    501498            (read-char port)    ;consume padding
    502             (loop accum (fx+ nchars 1)))
     499            (loop accum (+ nchars 1)))
    503500          (else                ;padding where it shouldn't be
    504501            (error-bad-date-template 'string->date
     
    528525            (error-bad-date-template 'string->date
    529526             "invalid time zone number" 'eof-object))
    530           (set! offset (fx* (digit->int ch) (fx* 10 SEC/HR))))
     527          (set! offset (* (digit->int ch) (* 10 SEC/HR))))
    531528        ;non-existing values are considered zero
    532529        (let ((ch (read-char port)))
    533530          (unless (eof-object? ch)
    534             (set! offset (fx+ offset (fx* (digit->int ch) SEC/HR)))))
     531            (set! offset (+ offset (* (digit->int ch) SEC/HR)))))
    535532        (let ((ch (read-char port)))
    536533          (unless (eof-object? ch)
    537             (set! offset (fx+ offset (fx* (digit->int ch) 600)))))
     534            (set! offset (+ offset (* (digit->int ch) 600)))))
    538535        (let ((ch (read-char port)))
    539536          (unless (eof-object? ch)
    540             (set! offset (fx+ offset (fx* (digit->int ch) 60)))))
    541         (if is-pos offset (fxneg offset)))) ) )
     537            (set! offset (+ offset (* (digit->int ch) 60)))))
     538        (if is-pos offset (- offset)))) ) )
    542539
    543540;; Looking at a char, read the char string, run thru indexer, return index
     
    661658                   (read-char port)
    662659                   (loop (peek-char port))))))))
    663       (when (fx< 0 len-rem)
     660      (when (positive? len-rem)
    664661        (let ((cur-ch (car fmt-rem)))
    665662          (cond
     
    669666                          (not (char=? cur-ch port-char)))
    670667                  (error-bad-date-template 'scan-date "" (list->string fmt-rem))))
    671               (loop (cdr fmt-rem) (fx- len-rem 1)))
     668              (loop (cdr fmt-rem) (- len-rem 1)))
    672669            ;otherwise, it's an escape, we hope
    673             ((fx< len-rem 2)
     670            ((< len-rem 2)
    674671              (error-bad-date-template 'scan-date "" (list->string fmt-rem)))
    675672            (else
     
    686683                      (error-bad-date-template 'scan-date "" (list->string fmt-rem))
    687684                      (actor val date))))
    688                 (loop (cddr fmt-rem) (fx- len-rem 2))))) ) ) ) ) )
     685                (loop (cddr fmt-rem) (- len-rem 2))))) ) ) ) ) )
    689686
    690687(define (scan-date src fmtstr)
  • release/5/srfi-19/trunk/srfi-19-support.scm

    r38153 r38270  
    9999(import (chicken base))
    100100(import (chicken type))
    101 (import (chicken fixnum))
    102101(import (only srfi-1 fold))
    103102(import (only (chicken io) read-line))
     
    123122;;;arithmetic can be exported as syntax.
    124123
    125 ;; For storage savings since some aritmetic routines do not
    126 ;; return fixnums when possible.
    127 ;;
    128 ;; Number MUST be a fixnum or bignum
    129 
    130 (define-syntax number->genint
    131   (syntax-rules ()
    132     ((_ ?x)
    133       (let ((x ?x))
    134         (if (fixnum? x)
    135           x
    136           (inexact->exact (floor x)) ) ) ) ) )
    137 
    138124;;; Time Object
    139125
     
    183169
    184170(define (time-nanoseconds? obj)
    185   (and (fixnum? obj) (fx< -NS/S obj) (fx< obj NS/S)) )
     171  (and (fixnum? obj) (< -NS/S obj NS/S)) )
    186172
    187173;;
     
    194180;; Seconds Conversion
    195181
    196 (define (check-raw-seconds loc obj) (check-real loc obj 'seconds))
    197 
    198 (define (check-raw-milliseconds loc obj) (check-real loc obj 'milliseconds))
     182(define (check-raw-seconds loc obj)
     183  (check-real loc obj 'seconds) )
     184
     185(define (check-raw-milliseconds loc obj)
     186  (check-real loc obj 'milliseconds) )
    199187
    200188;; Specialized Time Parameter Checking
     
    275263
    276264; Nanoseconds in [0 NS/S-1]
    277 (define-syntax date-nanoseconds?
    278         (syntax-rules ()
    279                 ((_ ?obj)
    280                   (let ((obj ?obj))
    281         (and
    282           (fixnum? obj)
    283           (fx<= 0 obj)
    284           (fx< obj NS/S)) ) ) ) )
     265(define (date-nanoseconds? obj)
     266  (and (fixnum? obj) (<= 0 obj) (< obj NS/S)) )
    285267
    286268; Seconds in [0 SEC/MIN] ;SEC/MIN legal due to leap second
    287 (define-syntax date-seconds?
    288         (syntax-rules ()
    289                 ((_ ?obj)
    290                   (let ((obj ?obj))
    291         (and
    292           (fixnum? obj)
    293           (fx<= 0 obj)
    294           (fx<= obj SEC/MIN)) ) ) ) )
     269(define (date-seconds? obj)
     270  (and (fixnum? obj) (<= 0 obj SEC/MIN)) )
    295271
    296272; Minutes in [0 SEC/MIN-1]
    297 (define-syntax date-minutes?
    298         (syntax-rules ()
    299                 ((_ ?obj)
    300                   (let ((obj ?obj))
    301         (and
    302           (fixnum? obj)
    303           (fx<= 0 obj)
    304           (fx< obj SEC/MIN)) ) ) ) )
     273(define (date-minutes? obj)
     274  (and (fixnum? obj) (<= 0 obj) (< obj SEC/MIN)) )
    305275
    306276; Hours in [0 HR/DY-1]
    307 (define-syntax date-hours?
    308         (syntax-rules ()
    309                 ((_ ?obj)
    310                   (let ((obj ?obj))
    311         (and
    312           (fixnum? obj)
    313           (fx<= 0 obj)
    314           (fx< obj HR/DY)) ) ) ) )
     277(define (date-hours? obj)
     278  (and (fixnum? obj) (<= 0 obj) (< obj HR/DY)) )
    315279
    316280; Days in [1 28/29/30/31] - depending on month & year
    317 (define-syntax date-day?
    318         (syntax-rules ()
    319                 ((_ ?obj ?mn ?yr)
    320                   (let ((obj ?obj) (mn ?mn) (yr ?yr))
    321         (and
    322           (fixnum? obj)
    323           (fx<= 1 obj)
    324           (fx<= obj (tm:days-in-month yr mn))) ) ) ) )
     281(define (date-day? obj mn yr)
     282  (and (fixnum? obj) (<= 1 obj (tm:days-in-month yr mn))) )
    325283
    326284; Months in [1 MN/YR]
    327 (define-syntax date-month?
    328         (syntax-rules ()
    329                 ((_ ?obj)
    330                   (let ((obj ?obj))
    331         (and
    332           (fixnum? obj)
    333           (fx<= 1 obj)
    334           (fx<= obj MN/YR)) ) ) ) )
     285(define (date-month? obj)
     286  (and (fixnum? obj) (<= 1 obj MN/YR)) )
    335287
    336288; No year 0!
    337289(define (date-year? obj)
    338   (and
    339     (fixnum? obj)
    340     (not (fx= 0 obj))) )
     290  (and (fixnum? obj) (not (= 0 obj))) )
    341291
    342292;;
     
    368318
    369319(define (check-date-compatible-timezone-offsets loc dat1 dat2)
    370   (unless (fx= (%date-zone-offset dat1) (%date-zone-offset dat2))
     320  (unless (= (%date-zone-offset dat1) (%date-zone-offset dat2))
    371321    (error-date-compatible-timezone loc dat1 dat2) ) )
    372322
     
    390340
    391341(define (week-day? obj)
    392   (and (fixnum? obj) (fx<= 0 obj) (fx<= obj 6)) )
     342  (and (fixnum? obj) (<= 0 obj 6)) )
    393343
    394344(define-check+error-type week-day)
  • release/5/srfi-19/trunk/tests/srfi-19-test.scm

    r38130 r38270  
    22
    33(import test)
     4
     5(include "test-gloss.incl")
     6
     7;;;
    48
    59(test-begin "SRFI 19")
     
    7579  (test-assert "Time difference 2" (time=? t4 (time-difference t2 t1))) )
    7680
    77 (define (test-one-utc-tai-edge utc tai-diff tai-last-diff)
    78   (let* (;; right on the edge they should be the same
    79     (utc-basic (make-time time-utc 0 utc))
    80     (tai-basic (make-time time-tai 0 (+ utc tai-diff)))
    81     (utc->tai-basic (time-utc->time-tai utc-basic))
    82     (tai->utc-basic (time-tai->time-utc tai-basic))
    83     ;; a second before they should be the old diff
    84     (utc-basic-1 (make-time time-utc 0 (- utc 1)))
    85     (tai-basic-1 (make-time time-tai 0 (- (+ utc tai-last-diff) 1)))
    86     (utc->tai-basic-1 (time-utc->time-tai utc-basic-1))
    87     (tai->utc-basic-1 (time-tai->time-utc tai-basic-1))
    88     ;; a second later they should be the new diff
    89     (utc-basic+1 (make-time time-utc 0 (+ utc 1)))
    90     (tai-basic+1 (make-time time-tai 0 (+ (+ utc tai-diff) 1)))
    91     (utc->tai-basic+1 (time-utc->time-tai utc-basic+1))
    92     (tai->utc-basic+1 (time-tai->time-utc tai-basic+1))
    93     ;; ok, let's move the clock half a month or so plus half a second
    94     (shy (* 15 24 60 60))
    95     (hs (/ (expt 10 9) 2))
    96     ;; a second later they should be the new diff
    97     (utc-basic+2 (make-time time-utc hs (+ utc shy)))
    98     (tai-basic+2 (make-time time-tai hs (+ (+ utc tai-diff) shy)))
    99     (utc->tai-basic+2 (time-utc->time-tai utc-basic+2))
    100     (tai->utc-basic+2 (time-tai->time-utc tai-basic+2)))
    101     (and
    102       (time=? utc-basic tai->utc-basic)
    103       (time=? tai-basic utc->tai-basic)
    104       (time=? utc-basic-1 tai->utc-basic-1)
    105       (time=? tai-basic-1 utc->tai-basic-1)
    106       (time=? utc-basic+1 tai->utc-basic+1)
    107       (time=? tai-basic+1 utc->tai-basic+1)
    108       (time=? utc-basic+2 tai->utc-basic+2)
    109       (time=? tai-basic+2 utc->tai-basic+2))))
    110 
    111 (test-assert "TAI-UTC Conversions"
    112   (and
    113     (test-one-utc-tai-edge 915148800  32 31)
    114     (test-one-utc-tai-edge 867715200  31 30)
    115     (test-one-utc-tai-edge 820454400  30 29)
    116     (test-one-utc-tai-edge 773020800  29 28)
    117     (test-one-utc-tai-edge 741484800  28 27)
    118     (test-one-utc-tai-edge 709948800  27 26)
    119     (test-one-utc-tai-edge 662688000  26 25)
    120     (test-one-utc-tai-edge 631152000  25 24)
    121     (test-one-utc-tai-edge 567993600  24 23)
    122     (test-one-utc-tai-edge 489024000  23 22)
    123     (test-one-utc-tai-edge 425865600  22 21)
    124     (test-one-utc-tai-edge 394329600  21 20)
    125     (test-one-utc-tai-edge 362793600  20 19)
    126     (test-one-utc-tai-edge 315532800  19 18)
    127     (test-one-utc-tai-edge 283996800  18 17)
    128     (test-one-utc-tai-edge 252460800  17 16)
    129     (test-one-utc-tai-edge 220924800  16 15)
    130     (test-one-utc-tai-edge 189302400  15 14)
    131     (test-one-utc-tai-edge 157766400  14 13)
    132     (test-one-utc-tai-edge 126230400  13 12)
    133     (test-one-utc-tai-edge 94694400   12 11)
    134     (test-one-utc-tai-edge 78796800   11 10)
    135     (test-one-utc-tai-edge 63072000   10 0)
    136     (test-one-utc-tai-edge 0          0  0) ;; at the epoch
    137     (test-one-utc-tai-edge 10         0  0) ;; close to it ...
    138     (test-one-utc-tai-edge 1045789645 32 32) ;; about now ...
    139     ))
     81(define test-one-utc-tai-edge
     82  (let (
     83    (+cnt+ 0) )
     84    (define (idmsg)
     85      (set! +cnt+ (add1 +cnt+))
     86      (string-append "TAI-UTC Conversions" " " (number->string +cnt+)) )
     87    (lambda (utc tai-diff tai-last-diff)
     88      (let* (;; right on the edge they should be the same
     89        (utc-basic (make-time time-utc 0 utc))
     90        (tai-basic (make-time time-tai 0 (+ utc tai-diff)))
     91        (utc->tai-basic (time-utc->time-tai utc-basic))
     92        (tai->utc-basic (time-tai->time-utc tai-basic))
     93        ;; a second before they should be the old diff
     94        (utc-basic-1 (make-time time-utc 0 (- utc 1)))
     95        (tai-basic-1 (make-time time-tai 0 (- (+ utc tai-last-diff) 1)))
     96        (utc->tai-basic-1 (time-utc->time-tai utc-basic-1))
     97        (tai->utc-basic-1 (time-tai->time-utc tai-basic-1))
     98        ;; a second later they should be the new diff
     99        (utc-basic+1 (make-time time-utc 0 (+ utc 1)))
     100        (tai-basic+1 (make-time time-tai 0 (+ (+ utc tai-diff) 1)))
     101        (utc->tai-basic+1 (time-utc->time-tai utc-basic+1))
     102        (tai->utc-basic+1 (time-tai->time-utc tai-basic+1))
     103        ;; ok, let's move the clock half a month or so plus half a second
     104        (shy (* 15 24 60 60))
     105        (hs (/ (expt 10 9) 2))
     106        ;; a second later they should be the new diff
     107        (utc-basic+2 (make-time time-utc hs (+ utc shy)))
     108        (tai-basic+2 (make-time time-tai hs (+ (+ utc tai-diff) shy)))
     109        (utc->tai-basic+2 (time-utc->time-tai utc-basic+2))
     110        (tai->utc-basic+2 (time-tai->time-utc tai-basic+2)) )
     111        (test-assert (idmsg) (time=? utc-basic tai->utc-basic))
     112        (test-assert (idmsg) (time=? tai-basic utc->tai-basic))
     113        (test-assert (idmsg) (time=? utc-basic-1 tai->utc-basic-1))
     114        (test-assert (idmsg) (time=? tai-basic-1 utc->tai-basic-1))
     115        (test-assert (idmsg) (time=? utc-basic+1 tai->utc-basic+1))
     116        (test-assert (idmsg) (time=? tai-basic+1 utc->tai-basic+1))
     117        (test-assert (idmsg) (time=? utc-basic+2 tai->utc-basic+2))
     118        (test-assert (idmsg) (time=? tai-basic+2 utc->tai-basic+2)) ) ) ) )
     119
     120(test-one-utc-tai-edge 915148800  32 31)
     121(test-one-utc-tai-edge 867715200  31 30)
     122(test-one-utc-tai-edge 820454400  30 29)
     123(test-one-utc-tai-edge 773020800  29 28)
     124(test-one-utc-tai-edge 741484800  28 27)
     125(test-one-utc-tai-edge 709948800  27 26)
     126(test-one-utc-tai-edge 662688000  26 25)
     127(test-one-utc-tai-edge 631152000  25 24)
     128(test-one-utc-tai-edge 567993600  24 23)
     129(test-one-utc-tai-edge 489024000  23 22)
     130(test-one-utc-tai-edge 425865600  22 21)
     131(test-one-utc-tai-edge 394329600  21 20)
     132(test-one-utc-tai-edge 362793600  20 19)
     133(test-one-utc-tai-edge 315532800  19 18)
     134(test-one-utc-tai-edge 283996800  18 17)
     135(test-one-utc-tai-edge 252460800  17 16)
     136(test-one-utc-tai-edge 220924800  16 15)
     137(test-one-utc-tai-edge 189302400  15 14)
     138(test-one-utc-tai-edge 157766400  14 13)
     139(test-one-utc-tai-edge 126230400  13 12)
     140(test-one-utc-tai-edge 94694400   12 11)
     141(test-one-utc-tai-edge 78796800   11 10)
     142(test-one-utc-tai-edge 63072000   10 0)
     143(test-one-utc-tai-edge 0          0  0) ;; at the epoch
     144(test-one-utc-tai-edge 10         0  0) ;; close to it ...
     145(test-one-utc-tai-edge 1045789645 32 32) ;; about now ...
    140146
    141147(define (tm:date= d1 d2)
     
    149155    (= (date-zone-offset d1) (date-zone-offset d2))))
    150156
    151 (test-assert "TAI-Date Conversions"
    152   (and
    153     (tm:date=
    154       (time-tai->date (make-time time-tai 0 (+ 915148800 29)) 0)
    155       (make-date 0 58 59 23 31 12 1998 0))
    156     (tm:date=
    157       (time-tai->date (make-time time-tai 0 (+ 915148800 30)) 0)
    158       (make-date 0 59 59 23 31 12 1998 0))
    159     (tm:date=
    160       (time-tai->date (make-time time-tai 0 (+ 915148800 31)) 0)
    161       (make-date 0 60 59 23 31 12 1998 0))
    162     (tm:date=
    163       (time-tai->date (make-time time-tai 0 (+ 915148800 32)) 0)
    164       (make-date 0 0 0 0 1 1 1999 0))))
     157(define test-one-tai-date-edge
     158  (let (
     159    (+cnt+ 0) )
     160    (define (idmsg)
     161      (set! +cnt+ (add1 +cnt+))
     162      (string-append "TAI-Date Conversions" " " (number->string +cnt+)) )
     163    (lambda (tai-diff dat)
     164      (let* (
     165        (tai (make-time time-tai 0 (+ 915148800 tai-diff)))
     166        (tai-dat (time-tai->date tai 0)) )
     167        #;(glossf "tai-dat: ~S | dat: ~S" (date->string tai-dat) (date->string dat))
     168        (test-assert (idmsg) (tm:date= tai-dat dat)) ) ) ) )
     169
     170(test-one-tai-date-edge 29 (make-date 0 58 59 23 31 12 1998 0))
     171(test-one-tai-date-edge 30 (make-date 0 59 59 23 31 12 1998 0))
     172(test-one-tai-date-edge 31 (make-date 0 60 59 23 31 12 1998 0))
     173(test-one-tai-date-edge 32 (make-date 0 0 0 0 1 1 1999 0))
    165174
    166175(test-assert "Date-UTC Conversions"
     
    331340;BUG 121
    332341;Need "error" test
    333 #;(format-date #t "~Y")
    334 #;(format-date #t "")
    335 #;(format-date #t "~Y" (make-date 0 2 1 13 10 11 2009 0))
    336 #;(format-date "~~.~a.~A.~b.~B.~c.~d.~D.~e,~f,~h.~H" (make-date 1000 2 3 4 5 6 2007 -7200))
     342;(format-date #t "~Y")
     343;(format-date #t "")
     344
     345;(glossf "dat: ~S" (format-date #t "~Y" (make-date 0 2 1 13 10 11 2009 0)))
     346;(glossf "dat: ~S" (format-date "~~.~a.~A.~b.~B.~c.~d.~D.~e,~f,~h.~H" (make-date 1000 2 3 4 5 6 2007 -7200)))
    337347
    338348;Duplicate short & long month name keys (`may')
Note: See TracChangeset for help on using the changeset viewer.