Changeset 34327 in project


Ignore:
Timestamp:
08/24/17 05:00:59 (3 months ago)
Author:
kon
Message:

fold check-*, SEC/YR, no rec variants,

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

Legend:

Unmodified
Added
Removed
  • release/4/srfi-19/trunk/chicken-primitive-object-inlines.scm

    r19907 r34327  
    384384(define-inline (%bytevector=? bv1 bv2)
    385385  (let ((n (%bytevector-length bv1)))
    386     (and (%fx= n (%bytevector-length bv2))
    387          (%fx= 0 (##core#inline "C_string_compare" bv1 bv2 n)) ) ) )
     386    (and
     387      (%fx= n (%bytevector-length bv2))
     388      (%fx= 0 (##core#inline "C_string_compare" bv1 bv2 n)) ) ) )
    388389
    389390(define-inline (%bytevector-ref bv i) (%byteblock-ref bv i))
     
    439440         (d (%fx- l1 l2))
    440441         (r (%string-compare/length s1 s2 (if (%fxpositive? d) l2 l1))) )
    441     (if (%fxzero? r) d
    442         r ) ) )
     442    (if (%fxzero? r)
     443      d
     444      r ) ) )
    443445
    444446(define-inline (%string=? s1 s2) (%fxzero? (%string-compare s1 s2)))
     
    455457         (d (%fx- l1 l2))
    456458         (r (%string-ci-compare/length s1 s2 (if (%fxpositive? d) l2 l1))) )
    457     (if (%fxzero? r) d
    458         r ) ) )
     459    (if (%fxzero? r)
     460      d
     461      r ) ) )
    459462
    460463(define-inline (%string-ci=? s1 s2) (%fxzero? (%string-ci-compare s1 s2)))
     
    538541(define-inline (%wordblock-set!/immediate wb i v) (##core#inline "C_i_set_i_slot" wb i v))
    539542(define-inline (%wordblock-set! wb i v)
    540   (if (%immediate? v) (%wordblock-set!/immediate wb i v)
    541       (%wordblock-set!/mutate wb i v) ) )
     543  (if (%immediate? v)
     544    (%wordblock-set!/immediate wb i v)
     545    (%wordblock-set!/mutate wb i v) ) )
    542546
    543547;; Generic-vector (wordblock)
     
    617621  ;(assert (and (proper-list? ls0) (exact? i0) (<= 0 i0 (sub1 (length ls0)))))
    618622  (let loop ((ls ls0) (i i0))
    619     (cond ((%null? ls)  '() )
    620                 ((%fx= 0 i)   (%car ls) )
    621                 (else         (loop (%cdr ls) (%fx- i 1)) ) ) ) )
     623    (cond
     624      ((%null? ls)  '() )
     625      ((%fx= 0 i)   (%car ls) )
     626      (else         (loop (%cdr ls) (%fx- i 1)) ) ) ) )
    622627
    623628(define-inline (%list-pair-ref ls0 i0)
    624629  ;(assert (and (proper-list? ls0) (exact? i0) (<= 0 i0 (sub1 (length ls0)))))
    625630  (let loop ((ls ls0) (i i0))
    626     (cond ((%null? ls)  '() )
    627                 ((%fx= 0 i)   ls )
    628                 (else         (loop (%cdr ls) (%fx- i 1)) ) ) ) )
     631    (cond
     632      ((%null? ls)  '() )
     633      ((%fx= 0 i)   ls )
     634      (else         (loop (%cdr ls) (%fx- i 1)) ) ) ) )
    629635
    630636(define-inline (%last-pair ls0)
     
    636642  ;(assert (proper-list? ls0))
    637643  (let copy-rest ((ls ls0))
    638     (if (%null? ls) '()
    639         (%cons (%car ls) (copy-rest (%cdr ls))) ) ) )
     644    (if (%null? ls)
     645      '()
     646      (%cons (%car ls) (copy-rest (%cdr ls))) ) ) )
    640647
    641648(define-inline (%append! . lss)
    642649  ;(assert (and (proper-list? lss) (for-each (cut proper-list? <>) lss)))
    643   (let ((lss (let position-at-first-pair ((lss lss))
    644                (cond ((%null? lss)        '() )
    645                      ((%null? (%car lss))  (position-at-first-pair (%cdr lss)) )
    646                      (else                 lss ) ) ) ) )
    647     (if (%null? lss) '()
    648         (let ((ls0 (%car lss)))
    649           ;(assert (pair? ls0))
    650           (let append!-rest ((lss (%cdr lss)) (pls ls0))
    651             (if (%null? lss) ls0
    652                 (let ((ls (%car lss)))
    653                   (cond ((%null? ls)
    654                          (append!-rest (%cdr lss) pls) )
    655                         (else
    656                          (%set-cdr!/mutate (%last-pair pls) ls)
    657                          (append!-rest (%cdr lss) ls) ) ) ) ) ) ) ) ) )
     650  (let ((lss
     651          (let position-at-first-pair ((lss lss))
     652            (cond
     653              ((%null? lss)        '() )
     654              ((%null? (%car lss))  (position-at-first-pair (%cdr lss)) )
     655              (else                 lss ) ) ) ) )
     656    (if (%null? lss)
     657      '()
     658      (let ((ls0 (%car lss)))
     659        ;(assert (pair? ls0))
     660        (let append!-rest ((lss (%cdr lss)) (pls ls0))
     661          (if (%null? lss)
     662            ls0
     663            (let ((ls (%car lss)))
     664              (cond
     665                ((%null? ls)
     666                 (append!-rest (%cdr lss) pls) )
     667                (else
     668                  (%set-cdr!/mutate (%last-pair pls) ls)
     669                  (append!-rest (%cdr lss) ls) ) ) ) ) ) ) ) ) )
    658670
    659671(define-inline (%delq! x ls0)
    660672  ;(assert (proper-list? ls0))
    661673  (let find-elm ((ls ls0) (ppr #f))
    662     (cond ((%null? ls)
    663            ls0 )
    664                 ((%eq? x (%car ls))
    665                  (cond (ppr
    666                         (%set-cdr! ppr (%cdr ls))
    667                         ls0 )
    668                        (else
    669                         (%cdr ls) ) ) )
    670                 (else
    671                  (find-elm (%cdr ls) ls) ) ) ) )
     674    (cond
     675      ((%null? ls)
     676        ls0 )
     677      ((%eq? x (%car ls))
     678        (cond
     679          (ppr
     680            (%set-cdr! ppr (%cdr ls))
     681            ls0 )
     682          (else
     683            (%cdr ls) ) ) )
     684      (else
     685        (find-elm (%cdr ls) ls) ) ) ) )
    672686
    673687(define-inline (%list-fold/1 func init ls0)
    674688  ;(assert (and (proper-list? ls0) (procedure? func)))
    675689  (let loop ((ls ls0) (acc init))
    676     (if (%null? ls) acc
    677         (loop (%cdr ls) (func (%car ls) acc)) ) ) )
     690    (if (%null? ls)
     691      acc
     692      (loop (%cdr ls) (func (%car ls) acc)) ) ) )
    678693
    679694(define-inline (%list-map/1 func ls0)
    680695  ;(assert (and (proper-list? ls0) (procedure? func)))
    681696  (let loop ((ls ls0))
    682     (if (%null? ls) '()
    683         (%cons (func (%car ls)) (loop (%cdr ls))) ) ) )
     697    (if (%null? ls)
     698      '()
     699      (%cons (func (%car ls)) (loop (%cdr ls))) ) ) )
    684700
    685701(define-inline (%list-for-each/1 proc ls0)
     
    694710(define-inline (%list . objs)
    695711  (let loop ((objs objs))
    696     (if (%null? objs) '()
    697         (%cons (%car objs) (loop (%cdr objs)) ) ) ) )
     712    (if (%null? objs)
     713      '()
     714      (%cons (%car objs) (loop (%cdr objs)) ) ) ) )
    698715
    699716(define-inline (%make-list n e)
    700717  (let loop ((n n) (ls '()))
    701     (if (%fxzero? n) ls
    702         (loop (%fxsub1 n) (%cons e ls)) ) ) )
     718    (if (%fxzero? n)
     719      ls
     720      (loop (%fxsub1 n) (%cons e ls)) ) ) )
    703721
    704722(define-inline (%list-take ls0 n)
    705723  (let loop ((ls ls0) (n n))
    706     (if (%fxzero? n) '()
    707         (%cons (%car ls) (loop (%cdr ls) (%fxsub1 n))) ) ) )
     724    (if (%fxzero? n)
     725      '()
     726      (%cons (%car ls) (loop (%cdr ls) (%fxsub1 n))) ) ) )
    708727
    709728(define-inline (%list-drop ls0 n)
    710729  (let loop ((ls ls0) (n n))
    711     (if (%fxzero? n) ls
    712         (loop (%cdr ls) (%fxsub1 n)) ) ) )
     730    (if (%fxzero? n)
     731      ls
     732      (loop (%cdr ls) (%fxsub1 n)) ) ) )
    713733
    714734(define-inline (%list-any/1 pred? ls)
    715735  (let loop ((ls ls))
    716     (and (not (%null? ls))
    717          (or (pred? (%car ls))
    718             (loop (%cdr ls)) ) ) ) )
     736    (and
     737      (not (%null? ls))
     738      (or (pred? (%car ls)) (loop (%cdr ls)) ) ) ) )
    719739
    720740(define-inline (%list-every/1 pred? ls)
    721741  (let loop ((ls ls) (last #t))
    722     (if (%null? ls) last
    723         (let ((this (pred? (%car ls))))
    724           (and this
    725               (loop (%cdr ls) this)) ) ) ) )
     742    (if (%null? ls)
     743      last
     744      (let ((this (pred? (%car ls))))
     745        (and this (loop (%cdr ls) this)) ) ) ) )
    726746
    727747(define-inline (%list-length ls0)
    728748  (let loop ((ls ls0) (n 0))
    729     (if (%null? ls) n
    730         (loop (%cdr ls) (%fxadd1 n)) ) ) )
     749    (if (%null? ls)
     750      n
     751      (loop (%cdr ls) (%fxadd1 n)) ) ) )
    731752
    732753(define-inline (%list-find pred? ls)
    733754  (let loop ((ls ls))
    734     (and (not (%null? ls))
    735          (or (let ((elm (%car ls))) (and (pred? elm) elm))
    736              (loop (%cdr ls)) ) ) ) )
     755    (and
     756      (not (%null? ls))
     757      (or
     758        (let ((elm (%car ls))) (and (pred? elm) elm))
     759        (loop (%cdr ls)) ) ) ) )
    737760
    738761(define-inline (%alist-ref key al #!optional (test eqv?) def)
    739762  (let loop ((al al))
    740     (cond ((%null? al) def )
    741           ((test key (%caar al)) (%cdar al) )
    742           (else (loop (%cdr al)) ) ) ) )
     763    (cond
     764      ((%null? al) def )
     765      ((test key (%caar al)) (%cdar al) )
     766      (else (loop (%cdr al)) ) ) ) )
    743767
    744768(define-inline (%alist-update! key val al0 #!optional (test eqv?))
    745769  (let loop ((al al0))
    746     (cond ((%null? al) (%cons (%cons key val) al0) )
    747           ((test key (%caar al)) (%set-cdr! (%car al) val) al0 )
    748           (else (loop (%cdr al)) ) ) ) )
     770    (cond
     771      ((%null? al) (%cons (%cons key val) al0) )
     772      ((test key (%caar al)) (%set-cdr! (%car al) val) al0 )
     773      (else (loop (%cdr al)) ) ) ) )
    749774
    750775(define-inline (%alist-delete! key al0 #!optional (test equal?))
    751776  (let loop ((al al0) (prv #f))
    752     (cond ((%null? al) al0)
    753           ((test key (%caar al)) (if prv (begin (%set-cdr! prv (%cdr al)) al0) (%cdr al)) )
    754           (else (loop (%cdr al) al) ) ) ) )
     777    (cond
     778      ((%null? al) al0)
     779      ((test key (%caar al)) (if prv (begin (%set-cdr! prv (%cdr al)) al0) (%cdr al)) )
     780      (else (loop (%cdr al) al) ) ) ) )
    755781
    756782;; Structure (wordblock)
     
    905931(define-inline (%closure-decoration c test)
    906932  (let find-decor ((i (%fxsub1 (%closure-length c))))
    907     (and (%fxpositive? i)
    908          (let ((x (%closure-ref c i)))
    909            (if (test x) x
    910                (find-decor (%fxsub1 i)) ) ) ) ) )
     933    (and
     934      (%fxpositive? i)
     935      (let ((x (%closure-ref c i)))
     936        (if (test x)
     937          x
     938          (find-decor (%fxsub1 i)) ) ) ) ) )
    911939
    912940(define-inline (%closure-decorate! c test dcor)
    913941  (let ((l (%closure-length c)))
    914942    (let find-decor ((i (%fxsub l)))
    915       (cond ((%fxzero? i)
    916              (let ((nc (%make-closure (%fxadd1 l))))
    917                (%closure-copy nc c l)
    918                (##core#inline "C_copy_pointer" c nc)
    919                (dcor nc i) ) )
    920             (else
    921              (let ((x (%closure-ref c i)))
    922                (if (test x) (dcor c i)
    923                    (find-decor (%fxsub i)) ) ) ) ) ) ) )
     943      (cond
     944        ((%fxzero? i)
     945          (let ((nc (%make-closure (%fxadd1 l))))
     946            (%closure-copy nc c l)
     947            (##core#inline "C_copy_pointer" c nc)
     948            (dcor nc i) ) )
     949        (else
     950          (let ((x (%closure-ref c i)))
     951            (if (test x)
     952              (dcor c i)
     953              (find-decor (%fxsub i)) ) ) ) ) ) ) )
    924954
    925955(define-inline (%closure-lambda-info c)
  • release/4/srfi-19/trunk/srfi-19-common.scm

    r33841 r34327  
    1111(define-constant -NS/S  -1000000000)
    1212
     13(define-constant SEC/YR   31536000) ; seconds in a year
    1314(define-constant SEC/DY   86400)    ; seconds in a day
    1415(define-constant SEC/DY/2 43200)    ; seconds in a half day
  • release/4/srfi-19/trunk/srfi-19-core.scm

    r19907 r34327  
    33(module srfi-19-core
    44
    5   (;export             ;DEPRECATED
    6     ;; SRFI-19
    7     time-tai
    8     time-utc
    9     time-monotonic
    10     time-thread
    11     time-process
    12     time-duration
    13     time-gc
    14     current-date
    15     current-julian-day
    16     current-modified-julian-day
    17     current-time
    18     time-resolution
    19     make-time
    20     time?
    21     time-type
    22     time-nanosecond
    23     time-second
    24     set-time-type!
    25     set-time-nanosecond!
    26     set-time-second!
    27     copy-time
    28     time<=?
    29     time<?
    30     time=?
    31     time>=?
    32     time>?
    33     time-difference
    34     time-difference!
    35     add-duration
    36     add-duration!
    37     subtract-duration
    38     subtract-duration!
    39     make-date
    40     date?
    41     date-nanosecond
    42     date-second
    43     date-minute
    44     date-hour
    45     date-day
    46     date-month
    47     date-year
    48     date-zone-offset
    49     leap-year? ; Actually part of SRFI 19 but not in original document
    50     date-year-day
    51     date-week-day
    52     date-week-number
    53     date->julian-day
    54     date->modified-julian-day
    55     date->time-monotonic
    56     date->time-tai
    57     date->time-utc
    58     julian-day->date
    59     julian-day->time-monotonic
    60     julian-day->time-tai
    61     julian-day->time-utc
    62     modified-julian-day->date
    63     modified-julian-day->time-monotonic
    64     modified-julian-day->time-tai
    65     modified-julian-day->time-utc
    66     time-monotonic->date
    67     time-monotonic->julian-day
    68     time-monotonic->modified-julian-day
    69     time-monotonic->time-tai
    70     time-monotonic->time-tai!
    71     time-monotonic->time-utc
    72     time-monotonic->time-utc!
    73     time-tai->date
    74     time-tai->julian-day
    75     time-tai->modified-julian-day
    76     time-tai->time-monotonic
    77     time-tai->time-monotonic!
    78     time-tai->time-utc
    79     time-tai->time-utc!
    80     time-utc->date
    81     time-utc->julian-day
    82     time-utc->modified-julian-day
    83     time-utc->time-monotonic
    84     time-utc->time-monotonic!
    85     time-utc->time-tai
    86     time-utc->time-tai!
    87     ;; SRFI-19 extensions
    88     one-second-duration
    89     one-nanosecond-duration
    90     zero-time
    91     time-type?
    92     make-duration
    93     divide-duration
    94     divide-duration!
    95     multiply-duration
    96     multiply-duration!
    97     time->srfi-18-time
    98     srfi-18-time->time
    99     time-max
    100     time-min
    101     time-negative?
    102     time-positive?
    103     time-zero?
    104     time-abs
    105     time-abs!
    106     time-negate
    107     time-negate!
    108     seconds->time/type
    109     seconds->date/type
    110     time->nanoseconds
    111     nanoseconds->time
    112     nanoseconds->seconds
    113     read-leap-second-table
    114     time->milliseconds
    115     time->seconds
    116     milliseconds->time
    117     milliseconds->seconds
    118     time->date
    119     default-date-clock-type
    120     date-zone-name
    121     date-dst?
    122     copy-date
    123     date->time
    124     date-difference
    125     date-add-duration
    126     date-subtract-duration
    127     date=?
    128     date>?
    129     date<?
    130     date>=?
    131     date<=?
    132     date-max
    133     date-min
    134     time->julian-day
    135     time->modified-julian-day
    136     date-compare
    137     time-compare
    138     ;; SRFI-19 extensions
    139     timezone-name?
    140     timezone-info?
    141     local-timezone-locale
    142     utc-timezone-locale
    143     timezone-locale-name
    144     timezone-locale-offset
    145     timezone-locale-dst?)
     5(;export             ;DEPRECATED
     6  ;; SRFI-19
     7  time-tai
     8  time-utc
     9  time-monotonic
     10  time-thread
     11  time-process
     12  time-duration
     13  time-gc
     14  current-date
     15  current-julian-day
     16  current-modified-julian-day
     17  current-time
     18  time-resolution
     19  make-time
     20  time?
     21  time-type
     22  time-nanosecond
     23  time-second
     24  set-time-type!
     25  set-time-nanosecond!
     26  set-time-second!
     27  copy-time
     28  time<=?
     29  time<?
     30  time=?
     31  time>=?
     32  time>?
     33  time-difference
     34  time-difference!
     35  add-duration
     36  add-duration!
     37  subtract-duration
     38  subtract-duration!
     39  make-date
     40  date?
     41  date-nanosecond
     42  date-second
     43  date-minute
     44  date-hour
     45  date-day
     46  date-month
     47  date-year
     48  date-zone-offset
     49  leap-year? ; Actually part of SRFI 19 but not in original document
     50  date-year-day
     51  date-week-day
     52  date-week-number
     53  date->julian-day
     54  date->modified-julian-day
     55  date->time-monotonic
     56  date->time-tai
     57  date->time-utc
     58  julian-day->date
     59  julian-day->time-monotonic
     60  julian-day->time-tai
     61  julian-day->time-utc
     62  modified-julian-day->date
     63  modified-julian-day->time-monotonic
     64  modified-julian-day->time-tai
     65  modified-julian-day->time-utc
     66  time-monotonic->date
     67  time-monotonic->julian-day
     68  time-monotonic->modified-julian-day
     69  time-monotonic->time-tai
     70  time-monotonic->time-tai!
     71  time-monotonic->time-utc
     72  time-monotonic->time-utc!
     73  time-tai->date
     74  time-tai->julian-day
     75  time-tai->modified-julian-day
     76  time-tai->time-monotonic
     77  time-tai->time-monotonic!
     78  time-tai->time-utc
     79  time-tai->time-utc!
     80  time-utc->date
     81  time-utc->julian-day
     82  time-utc->modified-julian-day
     83  time-utc->time-monotonic
     84  time-utc->time-monotonic!
     85  time-utc->time-tai
     86  time-utc->time-tai!
     87  ;; SRFI-19 extensions
     88  one-second-duration
     89  one-nanosecond-duration
     90  zero-time
     91  time-type?
     92  make-duration
     93  divide-duration
     94  divide-duration!
     95  multiply-duration
     96  multiply-duration!
     97  time->srfi-18-time
     98  srfi-18-time->time
     99  time-max
     100  time-min
     101  time-negative?
     102  time-positive?
     103  time-zero?
     104  time-abs
     105  time-abs!
     106  time-negate
     107  time-negate!
     108  seconds->time/type
     109  seconds->date/type
     110  time->nanoseconds
     111  nanoseconds->time
     112  nanoseconds->seconds
     113  read-leap-second-table
     114  time->milliseconds
     115  time->seconds
     116  milliseconds->time
     117  milliseconds->seconds
     118  time->date
     119  default-date-clock-type
     120  date-zone-name
     121  date-dst?
     122  copy-date
     123  date->time
     124  date-difference
     125  date-add-duration
     126  date-subtract-duration
     127  date=?
     128  date>?
     129  date<?
     130  date>=?
     131  date<=?
     132  date-max
     133  date-min
     134  time->julian-day
     135  time->modified-julian-day
     136  date-compare
     137  time-compare
     138  ;; SRFI-19 extensions
     139  timezone-name?
     140  timezone-info?
     141  local-timezone-locale
     142  utc-timezone-locale
     143  timezone-locale-name
     144  timezone-locale-offset
     145  timezone-locale-dst?)
    146146
    147   (import scheme chicken srfi-19-timezone srfi-19-support srfi-19-time srfi-19-date)
     147(import scheme)
    148148
    149   (require-library srfi-19-timezone srfi-19-support srfi-19-time srfi-19-date)
     149(import chicken)
     150
     151(use srfi-19-timezone srfi-19-support srfi-19-time srfi-19-date)
    150152
    151153) ;module srfi-19-core
  • release/4/srfi-19/trunk/srfi-19-date.scm

    r33841 r34327  
    11;;;; srfi-19-date.scm
    22;;;; Chicken port, Kon Lovett, Dec '05
     3
     4;;Issues
     5;;
     6;; - use of check-* im or/and forms is problematic
    37
    48;; SRFI-19: Time Data Types and Procedures.
     
    3034(module srfi-19-date
    3135
    32   (;export
    33     ; SRFI-19
    34     current-date
    35     current-julian-day
    36     current-modified-julian-day
    37     make-date
    38     date-nanosecond
    39     date-second
    40     date-minute
    41     date-hour
    42     date-day
    43     date-month
    44     date-year
    45     date-zone-offset
    46     leap-year? ; Actually part of SRFI 19 but not in original document
    47     date-year-day
    48     days-in-month/year
    49     natural-year
    50     date-week-day
    51     date-week-number
    52     date->julian-day
    53     date->modified-julian-day
    54     date->time-monotonic
    55     date->time-tai
    56     date->time-utc
    57     julian-day->date
    58     julian-day->time-monotonic
    59     julian-day->time-tai
    60     julian-day->time-utc
    61     modified-julian-day->date
    62     modified-julian-day->time-monotonic
    63     modified-julian-day->time-tai
    64     modified-julian-day->time-utc
    65     time-monotonic->date
    66     time-monotonic->julian-day
    67     time-monotonic->modified-julian-day
    68     time-tai->date
    69     time-tai->julian-day
    70     time-tai->modified-julian-day
    71     time-utc->date
    72     time-utc->julian-day
    73     time-utc->modified-julian-day
    74     ; Extensions
    75     seconds->date
    76     read-leap-second-table
    77     time->date
    78     default-date-clock-type
    79     default-date-adjust-integer
    80     date-zone-name
    81     date-dst?
    82     copy-date
    83     date->time
    84     date-adjust
    85     date-difference
    86     date-add-duration
    87     date-subtract-duration
    88     date=?
    89     date>?
    90     date<?
    91     date>=?
    92     date<=?
    93     date-max
    94     date-min
    95     time->julian-day
    96     time->modified-julian-day
    97     date-compare
    98     ; DEPRECATED
    99     seconds->date/type)
    100 
    101   (import
    102     (except scheme
    103       zero? negative? positive? real?)
    104     chicken
    105     (only srfi-1 fold list-index)
    106     srfi-69
    107     #;srfi-8
    108     (only numbers
    109       zero? negative? positive? real?)
    110     miscmacros
    111     (only locale-components
    112       check-timezone-components timezone-components?)
    113     type-checks
    114     type-errors
    115     srfi-19-timezone
    116     srfi-19-support)
    117 
    118   (require-library
    119     #;srfi-8
    120     numbers miscmacros locale-components
    121    type-checks type-errors
    122    srfi-19-timezone srfi-19-support)
     36(;export
     37  ; SRFI-19
     38  current-date
     39  current-julian-day
     40  current-modified-julian-day
     41  make-date
     42  date-nanosecond
     43  date-second
     44  date-minute
     45  date-hour
     46  date-day
     47  date-month
     48  date-year
     49  date-zone-offset
     50  leap-year? ; Actually part of SRFI 19 but not in original document
     51  date-year-day
     52  days-in-month/year
     53  natural-year
     54  date-week-day
     55  date-week-number
     56  date->julian-day
     57  date->modified-julian-day
     58  date->time-monotonic
     59  date->time-tai
     60  date->time-utc
     61  julian-day->date
     62  julian-day->time-monotonic
     63  julian-day->time-tai
     64  julian-day->time-utc
     65  modified-julian-day->date
     66  modified-julian-day->time-monotonic
     67  modified-julian-day->time-tai
     68  modified-julian-day->time-utc
     69  time-monotonic->date
     70  time-monotonic->julian-day
     71  time-monotonic->modified-julian-day
     72  time-tai->date
     73  time-tai->julian-day
     74  time-tai->modified-julian-day
     75  time-utc->date
     76  time-utc->julian-day
     77  time-utc->modified-julian-day
     78  ; Extensions
     79  seconds->date
     80  read-leap-second-table
     81  time->date
     82  default-date-clock-type
     83  default-date-adjust-integer
     84  date-zone-name
     85  date-dst?
     86  copy-date
     87  date->time
     88  date-adjust
     89  date-difference
     90  date-add-duration
     91  date-subtract-duration
     92  date=?
     93  date>?
     94  date<?
     95  date>=?
     96  date<=?
     97  date-max
     98  date-min
     99  time->julian-day
     100  time->modified-julian-day
     101  date-compare
     102  ; DEPRECATED
     103  seconds->date/type)
     104
     105(import
     106  (except scheme
     107    zero? negative? positive? real?))
     108
     109(import chicken)
     110
     111(import
     112  (only srfi-1 fold list-index)
     113  srfi-69
     114  #;srfi-8)
     115(require-library
     116  srfi-1 srfi-69
     117  #;srfi-8)
     118
     119(import
     120  (only numbers
     121    zero? negative? positive? real?))
     122(require-library
     123  numbers)
     124
     125(import
     126  (only locale-components
     127    check-timezone-components timezone-components?))
     128(require-library
     129  locale-components)
     130
     131(use
     132  miscmacros
     133  type-checks type-errors
     134  srfi-19-timezone srfi-19-support)
    123135
    124136;;;
     
    136148
    137149(define (checked-tm:date->time loc dat tt)
    138   (check-clock-type loc tt)
    139150  (or
    140     (tm:date->time dat tt)
     151    (tm:date->time dat (check-clock-type loc tt))
    141152    (error-convert loc 'date 'time dat)) )
    142153
     
    144155
    145156(define (read-leap-second-table flnm)
    146   (check-string 'read-leap-second-table flnm) ;FIXME should be check-pathname
    147   (tm:read-leap-second-table flnm) )
     157  ;FIXME should be check-pathname
     158  (tm:read-leap-second-table (check-string 'read-leap-second-table flnm)) )
    148159
    149160;;; Date Object (Public Immutable)
     
    174185(define-parameter default-date-clock-type 'utc
    175186  (lambda (obj)
    176     (cond
    177       ((clock-type? obj) obj)
    178       (else
     187    (if (clock-type? obj)
     188      obj
     189      (begin
    179190        (warning-argument-type 'default-date-clock-type obj 'clock-type)
    180191        (default-date-clock-type) ) ) ) )
     
    182193(define-parameter default-date-adjust-integer tm:default-date-adjust-integer
    183194  (lambda (obj)
    184     (cond
    185       ((procedure? obj) obj)
    186       (else
     195    (if (procedure? obj)
     196      obj
     197      (begin
    187198        (warning-argument-type 'default-date-adjust-integer obj 'procedure)
    188199        (default-date-adjust-integer) ) ) ) )
     
    216227
    217228(define (seconds->date sec . tzi)
    218   (check-raw-seconds 'seconds->date sec)
    219229  (let ((tzc (checked-optional-timezone-info 'seconds->date (optional tzi #t))))
    220230    (check-timezone-components 'seconds->date tzc)
    221     (tm:seconds->date/type sec tzc) ) )
     231    (tm:seconds->date/type (check-raw-seconds 'seconds->date sec) tzc) ) )
    222232
    223233(define seconds->date/type seconds->date) ; DEPRECATED
     
    229239
    230240(define (date-nanosecond dat)
    231         (check-date 'date-nanosecond dat)
    232         (tm:date-nanosecond dat) )
     241        (tm:date-nanosecond (check-date 'date-nanosecond dat)) )
    233242
    234243(define (date-second dat)
    235         (check-date 'date-second dat)
    236         (tm:date-second dat) )
     244        (tm:date-second (check-date 'date-second dat)) )
    237245
    238246(define (date-minute dat)
    239         (check-date 'date-minute dat)
    240         (tm:date-minute dat) )
     247        (tm:date-minute (check-date 'date-minute dat)) )
    241248
    242249(define (date-hour dat)
    243         (check-date 'date-hour dat)
    244         (tm:date-hour dat) )
     250        (tm:date-hour (check-date 'date-hour dat)) )
    245251
    246252(define (date-day dat)
    247         (check-date 'date-day dat)
    248         (tm:date-day dat) )
     253        (tm:date-day (check-date 'date-day dat)) )
    249254
    250255(define (date-month dat)
    251         (check-date 'date-month dat)
    252         (tm:date-month dat) )
     256        (tm:date-month (check-date 'date-month dat)) )
    253257
    254258(define (date-year dat)
    255         (check-date 'date-year dat)
    256         (tm:date-year dat) )
     259        (tm:date-year (check-date 'date-year dat)) )
    257260
    258261(define (date-dst? dat)
    259         (check-date 'date-dst? dat)
    260         (tm:date-dst? dat) )
     262        (tm:date-dst? (check-date 'date-dst? dat)) )
    261263
    262264(define (date-zone-offset dat)
    263         (check-date 'date-zone-offset dat)
    264         (tm:date-zone-offset dat) )
     265        (tm:date-zone-offset (check-date 'date-zone-offset dat)) )
    265266
    266267(define (date-zone-name dat)
    267         (check-date 'date-zone-name dat)
    268         (tm:date-zone-name dat) )
     268        (tm:date-zone-name (check-date 'date-zone-name dat)) )
    269269
    270270;; Date Comparison
    271271
    272272(define (checked-date-compare loc dat1 dat2)
    273   (check-date loc dat1)
    274   (check-date loc dat2)
    275   (check-date-compatible-timezone-offsets loc dat1 dat2)
     273  (check-date-compatible-timezone-offsets loc (check-date loc dat1) (check-date loc dat2))
    276274  (tm:date-compare dat1 dat2) )
    277275
     
    303301  (fold
    304302    (lambda (dat acc)
    305       (check-date 'date-max dat)
    306       (check-date-compatible-timezone-offsets 'date-max acc dat)
     303      (check-date-compatible-timezone-offsets 'date-max acc (check-date 'date-max dat))
    307304      (if (fx> 0 (tm:date-compare acc dat)) dat acc) )
    308305    (check-date 'date-max dat1)
     
    312309  (fold
    313310    (lambda (dat acc)
    314       (check-date 'date-max dat)
    315       (check-date-compatible-timezone-offsets 'date-min acc dat)
     311      (check-date-compatible-timezone-offsets 'date-min acc (check-date 'date-max dat))
    316312      (if (fx< 0 (tm:date-compare acc dat)) dat acc) )
    317313    (check-date 'date-min dat1)
     
    321317
    322318(define (date-adjust dat amt key . args)
    323   (check-date 'date-adjust dat)
    324   (check-integer 'date-adjust amt)
    325319  (let-optionals args ((tt (default-date-clock-type)) )
    326320    ((date-adjuster-ref 'date-adjust key)
    327       dat
    328       ((default-date-adjust-integer) amt)
     321      (check-date 'date-adjust dat)
     322      ((default-date-adjust-integer) (check-integer 'date-adjust amt))
    329323      key
    330324      ;only used for duration conversion
     
    332326
    333327(define (date-difference dat1 dat2 . args)
    334   (check-date 'date-difference dat1)
    335   (check-date 'date-difference dat2)
    336328  (let-optionals args ((tt (default-date-clock-type)))
    337     (let ((tim1 (checked-tm:date->time 'date-difference dat1 tt))
    338           (tim2 (checked-tm:date->time 'date-difference dat2 tt)) )
     329    (let ((tim1 (checked-tm:date->time 'date-difference (check-date 'date-difference dat1) tt))
     330          (tim2 (checked-tm:date->time 'date-difference (check-date 'date-difference dat2) tt)) )
    339331      (tm:time-difference tim1 tim2 (tm:some-time 'duration)) ) ) )
    340332
    341333(define (date-add-duration dat dur . args)
    342   (check-date 'date-add-duration dat)
    343334  (check-duration 'date-add-duration dur)
    344335  (let-optionals args ((tt (default-date-clock-type)))
    345     (let ((tim (checked-tm:date->time 'date-add-duration dat tt)) )
     336    (let ((tim (checked-tm:date->time 'date-add-duration (check-date 'date-add-duration dat) tt)) )
    346337      (checked-tm:time->date 'date-add-duration
    347338        (tm:add-duration tim dur (tm:as-some-time tim))
     
    349340
    350341(define (date-subtract-duration dat dur . args)
    351   (check-date 'date-subtract-duration dat)
    352342  (check-duration 'date-subtract-duration dur)
    353343  (let-optionals args ((tt (default-date-clock-type)))
    354     (let ((tim (checked-tm:date->time 'date-subtract-duration dat tt)) )
     344    (let ((tim (checked-tm:date->time 'date-subtract-duration (check-date 'date-subtract-duration dat) tt)) )
    355345      (checked-tm:time->date 'date-subtract-duration
    356346        (tm:subtract-duration tim dur (tm:as-some-time tim))
     
    463453
    464454(define (time->date tim . tzi)
    465   (check-time 'time->date tim)
    466455  (checked-tm:time->date 'time->date
    467     tim
     456    (check-time 'time->date tim)
    468457    (checked-optional-timezone-info 'time->date (optional tzi #t))) )
    469458
     
    471460
    472461(define (date->time-utc dat)
    473   (check-date 'date->time-utc dat)
    474   (tm:date->time-utc dat) )
     462  (tm:date->time-utc (check-date 'date->time-utc dat)) )
    475463
    476464(define (date->time-tai dat)
    477   (check-date 'date->time-tai dat)
    478   (tm:date->time-tai dat) )
     465  (tm:date->time-tai (check-date 'date->time-tai dat)) )
    479466
    480467(define (date->time-monotonic dat)
    481   (check-date 'date->time-monotonic dat)
    482   (tm:date->time-monotonic dat) )
     468  (tm:date->time-monotonic (check-date 'date->time-monotonic dat)) )
    483469
    484470(define (date->time dat . args)
    485   (check-date 'date->time dat)
    486471  (let-optionals args ((tt (default-date-clock-type)))
    487     (checked-tm:date->time 'date->time dat tt) ) )
     472    (checked-tm:date->time 'date->time (check-date 'date->time dat) tt) ) )
    488473
    489474;; Given a 'two digit' number, find the year within 50 years +/-
    490475
    491476(define (natural-year n . tzi)
    492   (check-date-year 'natural-year n)
    493   (tm:natural-year n (checked-optional-timezone-info 'natural-year (optional tzi #t))) )
     477  (tm:natural-year (check-date-year 'natural-year n) (checked-optional-timezone-info 'natural-year (optional tzi #t))) )
    494478
    495479;; Leap Year
     
    505489
    506490(define (date-year-day dat)
    507   (check-date 'date-year-day dat)
    508   (tm:date-year-day dat) )
     491  (tm:date-year-day (check-date 'date-year-day dat)) )
    509492
    510493(define (days-in-month/year mn yr)
    511   (check-date-year 'days-in-month/year yr)
    512   (check-date-month 'days-in-month/year mn)
    513   (tm:days-in-month yr mn) )
     494  (tm:days-in-month (check-date-year 'days-in-month/year yr) (check-date-month 'days-in-month/year mn)) )
    514495
    515496;; Week Day
    516497
    517498(define (date-week-day dat)
    518   (check-date 'date-week-day dat)
    519   (tm:date-week-day dat) )
     499  (tm:date-week-day (check-date 'date-week-day dat)) )
    520500
    521501;;
    522502
    523503(define (date-week-number dat . args)
    524   (check-date 'date-week-number dat)
    525504  (let-optionals args ((1st-weekday 0))
    526     (check-week-day 'date-week-number 1st-weekday)
    527     (tm:date-week-number dat 1st-weekday) ) )
     505    (tm:date-week-number
     506      (check-date 'date-week-number dat)
     507      (check-week-day 'date-week-number 1st-weekday)) ) )
    528508
    529509;; Julian-day Operations
    530510
    531511(define (date->julian-day dat)
    532   (check-date 'date->julian-day dat)
    533   (tm:date->julian-day dat) )
     512  (tm:date->julian-day (check-date 'date->julian-day dat)) )
    534513
    535514(define (date->modified-julian-day dat)
    536   (check-date 'date->modified-julian-day dat)
    537   (tm:julian-day->modified-julian-day (tm:date->julian-day dat)) )
     515  (tm:julian-day->modified-julian-day
     516    (tm:date->julian-day
     517      (check-date 'date->modified-julian-day dat))) )
    538518
    539519;; Time to Julian-day
     
    552532
    553533(define (time->julian-day tim)
    554   (check-time 'time->julian-day tim)
    555534  (or
    556     (tm:time->julian-day tim)
     535    (tm:time->julian-day (check-time 'time->julian-day tim))
    557536    (error-convert 'time->julian-day 'time 'julian-day tim) ) )
    558537
     
    570549
    571550(define (time->modified-julian-day tim)
    572   (check-time 'time->modified-julian-day tim)
    573551  (or
    574     (tm:time->modified-julian-day tim)
     552    (tm:time->modified-julian-day (check-time 'time->modified-julian-day tim))
    575553    (error-convert 'time->modified-julian-day 'time 'modified-julian-day tim) ) )
    576554
     
    578556
    579557(define (julian-day->time-utc jdn)
    580   (check-julian-day 'julian-day->time-utc jdn)
    581   (tm:julian-day->time-utc jdn) )
     558  (tm:julian-day->time-utc (check-julian-day 'julian-day->time-utc jdn)) )
    582559
    583560(define (julian-day->time-tai jdn)
    584   (check-julian-day 'julian-day->time-tai jdn)
    585   (let ((tim (tm:julian-day->time-utc jdn)))
     561  (let ((tim (tm:julian-day->time-utc (check-julian-day 'julian-day->time-tai jdn))))
    586562    (tm:time-utc->time-tai tim tim) ) )
    587563
    588564(define (julian-day->time-monotonic jdn)
    589   (check-julian-day 'julian-day->time-monotonic jdn)
    590   (let ((tim (julian-day->time-utc jdn)))
     565  (let ((tim (julian-day->time-utc (check-julian-day 'julian-day->time-monotonic jdn))))
    591566    (tm:time-utc->time-monotonic tim tim) ) )
    592567
    593568(define (julian-day->date jdn . tzi)
    594   (check-julian-day 'julian-day->date jdn)
    595569  (tm:time-utc->date
    596     (tm:julian-day->time-utc jdn)
     570    (tm:julian-day->time-utc (check-julian-day 'julian-day->date jdn))
    597571    (checked-optional-timezone-info 'julian-day->date (optional tzi #t))) )
    598572
    599573(define (modified-julian-day->time-utc mjdn)
    600   (check-julian-day 'modified-julian-day->time-utc mjdn)
    601   (tm:julian-day->time-utc (tm:modified-julian-day->julian-day mjdn)) )
     574  (tm:julian-day->time-utc
     575    (tm:modified-julian-day->julian-day
     576      (check-julian-day 'modified-julian-day->time-utc mjdn))) )
    602577
    603578(define (modified-julian-day->time-tai mjdn)
    604   (check-julian-day 'modified-julian-day->time-tai mjdn)
    605   (let ((tim (tm:julian-day->time-utc (tm:modified-julian-day->julian-day mjdn))))
     579  (let ((tim
     580          (tm:julian-day->time-utc
     581            (tm:modified-julian-day->julian-day
     582              (check-julian-day 'modified-julian-day->time-tai mjdn)))))
    606583    (tm:time-utc->time-tai tim tim) ) )
    607584
    608585(define (modified-julian-day->time-monotonic mjdn)
    609   (check-julian-day 'modified-julian-day->time-monotonic mjdn)
    610   (let ((tim (tm:julian-day->time-utc (tm:modified-julian-day->julian-day mjdn))))
     586  (let ((tim
     587          (tm:julian-day->time-utc
     588            (tm:modified-julian-day->julian-day
     589              (check-julian-day 'modified-julian-day->time-monotonic mjdn)))))
    611590    (tm:time-utc->time-monotonic tim tim) ) )
    612591
    613592(define (modified-julian-day->date mjdn . tzi)
    614   (check-julian-day 'modified-julian-day->date mjdn)
    615593  (tm:time-utc->date
    616     (tm:julian-day->time-utc (tm:modified-julian-day->julian-day mjdn))
     594    (tm:julian-day->time-utc
     595      (tm:modified-julian-day->julian-day
     596        (check-julian-day 'modified-julian-day->date mjdn)))
    617597    (checked-optional-timezone-info 'modified-julian-day->date (optional tzi #t))) )
    618598
  • release/4/srfi-19/trunk/srfi-19-io.scm

    r28127 r34327  
    3030(module srfi-19-io
    3131
    32   (;export
    33     ;; SRFI-19
    34     date->string
    35     string->date
    36     ;; SRFI-19 extensions
    37     format-date
    38     scan-date)
    39 
    40   (import
    41     (except scheme
    42       + / > exact->inexact number->string)
    43     chicken
    44     #;srfi-6
    45     (only srfi-1 drop)
    46     (only srfi-13 string-pad)
    47     (only ports with-output-to-string)
    48     (only data-structures
    49       reverse-string-append alist-ref)
    50     (only numbers
    51       + / > exact->inexact number->string)
    52     srfi-29
    53     type-checks
    54     srfi-19-support
    55     srfi-19-timezone)
    56 
    57   (require-library
    58     srfi-1 #;srfi-6 srfi-13
    59     ports data-structures
    60     numbers srfi-29 type-checks
    61     srfi-19-support srfi-19-timezone)
     32(;export
     33  ;; SRFI-19
     34  date->string
     35  string->date
     36  ;; SRFI-19 extensions
     37  format-date
     38  scan-date)
     39
     40(import
     41  (except scheme
     42    + / > exact->inexact number->string))
     43
     44(import chicken)
     45
     46(import
     47  #;srfi-6
     48  (only srfi-1 drop)
     49  (only srfi-13 string-pad)
     50  (only ports with-output-to-string)
     51  (only data-structures
     52    reverse-string-append alist-ref))
     53(require-library
     54   #;srfi-6
     55  srfi-1 srfi-13
     56  ports data-structures)
     57
     58(import
     59  (only numbers
     60    + / > exact->inexact number->string))
     61(require-library
     62  numbers)
     63
     64(use
     65  srfi-29
     66  type-checks
     67  srfi-19-support
     68  srfi-19-timezone)
    6269
    6370;;;
     
    7380  (apply error
    7481    loc
    75     (if (string=? "" msg) "bad date template"
     82    (if (string=? "" msg)
     83      "bad date template"
    7684      (string-append "bad date template - " msg))
    7785    args) )
     
    114122(define (decimal-expansion frac prec)
    115123  (let loop ((n (- frac (round frac))) (p prec) (ls '()))
    116     (if (or (fx= 0 p) (zero? n)) (reverse-string-append ls)
     124    (if (or (fx= 0 p) (zero? n))
     125      (reverse-string-append ls)
    117126      (let* ((n*10 (* 10 n))
    118127             (rn*10 (round n*10)))
    119         (loop (- n*10 rn*10) (fx- p 1) (cons (number->string (inexact->exact rn*10)) ls)) ) ) ) )
     128        (loop
     129          (- n*10 rn*10)
     130          (fx- p 1)
     131          (cons (number->string (inexact->exact rn*10)) ls)) ) ) ) )
    120132
    121133;; Returns a string rep. of number N, of minimum LENGTH,
     
    128140         (len (string-length str)))
    129141    (define (trailing-dotzero?)
    130       (and (fx<= 2 len)
    131            (char=? #\. (string-ref str (fx- len 2)))
    132            (char=? #\0 (string-ref str (fx- len 1))) ) )
    133     (let ((str (if (not (trailing-dotzero?)) str
    134                    (substring str 0 (fx- len 2)) ) ) )
    135       (if (or (not pad-with) (fx> len length)) str
     142      (and
     143        (fx<= 2 len)
     144        (char=? #\. (string-ref str (fx- len 2)))
     145        (char=? #\0 (string-ref str (fx- len 1))) ) )
     146    (let ((str
     147            (if (not (trailing-dotzero?))
     148              str
     149              (substring str 0 (fx- len 2)) ) ) )
     150      (if (or (not pad-with) (fx> len length))
     151        str
    136152        (string-pad str length pad-with)) ) ) )
    137153
     
    148164(define (locale-find-string str vec)
    149165  (let loop ((idx (fx- (vector-length vec) 1)))
    150     (and (fx< 0 idx)
    151          (or (and (string=? str (item@ (vector-ref vec idx)))
    152                   idx)
    153              (loop (fx- idx 1))) ) ) )
     166    (and
     167      (fx< 0 idx)
     168      (or
     169        (and
     170          (string=? str (item@ (vector-ref vec idx)))
     171          idx)
     172        (loop (fx- idx 1))) ) ) )
    154173
    155174(define (locale-abbr-weekday->index str) (locale-find-string str LOCALE-ABRV-WEEKDAYS))
     
    169188
    170189(define (tz-printer offset port)
    171   (if (fx= 0 offset) (display "Z" port)
     190  (if (fx= 0 offset)
     191    (display "Z" port)
    172192    (let ((isneg (fx< offset 0)))
    173193      (display (if isneg #\- #\+) port)
     
    224244              (sec (tm:date-second date)))
    225245          (if (> ns NS/S) ;This shouldn't happen!
    226               (display (padding (+ sec 1) pad-with 2) port)
    227               (display (padding sec pad-with 2) port))
     246            (display (padding (+ sec 1) pad-with 2) port)
     247            (display (padding sec pad-with 2) port))
    228248          ;ns must be inexact for 'decimal-expansion'
    229249          (let ((f (decimal-expansion (/ (exact->inexact ns) NS/S) 6)))
     
    244264        (let ((hr (tm:date-hour date)))
    245265          (if (fx> hr 12)
    246               (display (padding (fx- hr 12) pad-with 2) port)
    247               (display (padding hr pad-with 2) port)))))
     266            (display (padding (fx- hr 12) pad-with 2) port)
     267            (display (padding hr pad-with 2) port)))))
    248268
    249269    (cons #\j
     
    292312        (let ((sec (tm:date-second date)))
    293313          (if (> (tm:date-nanosecond date) NS/S) ;This shouldn't happen!
    294               (display (padding (+ sec 1) pad-with 2) port)
    295               (display (padding sec pad-with 2) port)))))
     314            (display (padding (+ sec 1) pad-with 2) port)
     315            (display (padding sec pad-with 2) port)))))
    296316
    297317    (cons #\t
     
    307327        (let ((wkno (tm:date-week-number date 0)))
    308328          (if (fx> (tm:days-before-first-week date 0) 0)
    309               (display (padding (fx+ wkno 1) #\0 2) port)
    310               (display (padding wkno #\0 2) port)))))
     329            (display (padding (fx+ wkno 1) #\0 2) port)
     330            (display (padding wkno #\0 2) port)))))
    311331
    312332    (cons #\V
     
    322342        (let ((wkno (tm:date-week-number date 1)))
    323343          (if (fx> (tm:days-before-first-week date 1) 0)
    324               (display (padding (fx+ wkno 1) #\0 2) port)
    325               (display (padding wkno #\0 2) port)))))
     344            (display (padding (fx+ wkno 1) #\0 2) port)
     345            (display (padding wkno #\0 2) port)))))
    326346
    327347    (cons #\x
     
    379399  (define (form-it pad-with key)
    380400    (define (get-formatter)
    381       (or (alist-ref key tm:display-directives)
    382           (error-bad-date-format loc (list->string fmt-rem))) )
     401      (or
     402        (alist-ref key tm:display-directives)
     403        (error-bad-date-format loc (list->string fmt-rem))) )
    383404    ((get-formatter) date pad-with port)
    384405    ;account for conversion character
     
    467488
    468489(define (integer-reader upto port)
     490  (define (eoi? ch nchars)
     491    (or
     492      (eof-object? ch)
     493      (not (char-numeric? ch))
     494      (and upto (fx>= nchars upto))) )
    469495  (let loop ((accum 0) (nchars 0))
    470     (let ((ch (peek-char port)))
    471       (if (or (eof-object? ch)
    472               (not (char-numeric? ch))
    473               (and upto (fx>= nchars upto))) accum
    474         (loop (fx+ (fx* accum 10) (digit->int (read-char port))) (fx+ nchars 1))) ) ) )
     496    (if (eoi? (peek-char port) nchars)
     497      accum
     498      (loop
     499        (fx+ (fx* accum 10) (digit->int (read-char port)))
     500        (fx+ nchars 1))) ) )
    475501
    476502(define (make-integer-reader upto)
     
    511537      (error-bad-date-template 'string->date
    512538       "invalid time zone +/-" 'eof-object))
    513     (if (or (char=? ch #\Z) (char=? ch #\z)) 0
     539    (if (or (char=? ch #\Z) (char=? ch #\z))
     540      0
    514541      (begin
    515542        (cond
     
    637664      (list #\z
    638665        (lambda (c)
    639           (or (char=? c #\Z)
    640               (char=? c #\z)
    641               (char=? c #\+)
    642               (char=? c #\-)))
     666          (or
     667            (char=? c #\Z)
     668            (char=? c #\z)
     669            (char=? c #\+)
     670            (char=? c #\-)))
    643671        zone-reader
    644672        (lambda (val dat) (tm:date-zone-offset-set! dat val))) ) ) )
     
    650678             (let loop ((ch (peek-char port)))
    651679               (if (eof-object? ch)
    652                    (error-bad-date-template 'scan-date "" (list->string fmt-rem))
    653                    (unless (skipper ch)
    654                      (read-char port)
    655                      (loop (peek-char port))))))))
     680                 (error-bad-date-template 'scan-date "" (list->string fmt-rem))
     681                 (unless (skipper ch)
     682                   (read-char port)
     683                   (loop (peek-char port))))))))
    656684      (when (fx< 0 len-rem)
    657685        (let ((cur-ch (car fmt-rem)))
     
    685713        (newdate (tm:make-incomplete-date)))
    686714    (let ((date-complete?
    687            (lambda ()
    688              (and (tm:date-nanosecond newdate)
    689                   (tm:date-second newdate) (tm:date-minute newdate) (tm:date-hour newdate)
    690                   (tm:date-day newdate) (tm:date-month newdate) (tm:date-year newdate)
    691                   (tm:date-zone-offset newdate))))
     715            (lambda ()
     716              (and
     717                (tm:date-nanosecond newdate)
     718                (tm:date-second newdate) (tm:date-minute newdate) (tm:date-hour newdate)
     719                (tm:date-day newdate) (tm:date-month newdate) (tm:date-year newdate)
     720                (tm:date-zone-offset newdate))))
    692721          (date-ok
    693722           (lambda ()
  • release/4/srfi-19/trunk/srfi-19-period.scm

    r24175 r34327  
    1212(module srfi-19-period
    1313
    14   (;export
    15     time-period?
    16     check-time-period
    17     error-time-period
    18     ;time-period-null?
    19     time-period-compare
    20     time-period=?
    21     time-period<?
    22     time-period>?
    23     time-period<=?
    24     time-period>=?
    25     time-period-type
    26     time-period-begin
    27     time-period-end
    28     time-period-last
    29     time-period-length
    30     ;make-null-time-period
    31     make-time-period
    32     copy-time-period
    33     time-period-contains/period?
    34     time-period-contains/time?
    35     time-period-contains/date?
    36     time-period-contains?
    37     time-period-intersects?
    38     time-period-intersection
    39     time-period-union
    40     time-period-span
    41     time-period-shift
    42     time-period-shift!
    43     time-period-preceding
    44     time-period-succeeding)
    45 
    46   (import
    47     scheme
    48     chicken
    49     (only extras format)
    50     record-variants
    51     type-checks
    52     type-errors
    53     srfi-19-time
    54     srfi-19-date
    55     srfi-19-support)
    56 
    57   (require-library
    58     record-variants type-checks type-errors
    59     srfi-19-time srfi-19-date srfi-19-support)
     14(;export
     15  time-period?
     16  check-time-period
     17  error-time-period
     18  ;time-period-null?
     19  time-period-compare
     20  time-period=?
     21  time-period<?
     22  time-period>?
     23  time-period<=?
     24  time-period>=?
     25  time-period-type
     26  time-period-begin
     27  time-period-end
     28  time-period-last
     29  time-period-length
     30  ;make-null-time-period
     31  make-time-period
     32  copy-time-period
     33  time-period-contains/period?
     34  time-period-contains/time?
     35  time-period-contains/date?
     36  time-period-contains?
     37  time-period-intersects?
     38  time-period-intersection
     39  time-period-union
     40  time-period-span
     41  time-period-shift
     42  time-period-shift!
     43  time-period-preceding
     44  time-period-succeeding)
     45
     46(import scheme)
     47
     48(import chicken)
     49
     50(import (only extras format))
     51(require-library extras)
     52
     53(use
     54  type-checks
     55  type-errors
     56  srfi-19-time
     57  srfi-19-date
     58  srfi-19-support)
    6059
    6160;;;
    6261
    6362(include "srfi-19-common")
     63
     64(define (->boolean obj)
     65  (and obj #t) )
    6466
    6567;;;
     
    9395;;; Time Period
    9496
     97#; ;dependency
    9598(define-record-type-variant time-period (unchecked inline unsafe)
    9699  (%make-time-period beg end)
     
    99102  (end %time-period-end) )
    100103
     104(define-record-type time-period
     105  (%make-time-period beg end)
     106  %time-period?
     107  (beg %time-period-begin)
     108  (end %time-period-end) )
     109
    101110(define-check+error-type time-period %time-period?)
    102111
     
    130139        (tt2 (tm:time-type t2)))
    131140    (define (errtt) (error-incompatible-clock-types loc t1 t2))
    132     (if (eq? tt1 tt2) t2
     141    (if (eq? tt1 tt2)
     142      t2
    133143      (let ((ntime (tm:any-time)))
    134144        (case tt1
     
    155165
    156166(define (tm:ensure-compatible-time-period-begin loc per1 per2)
    157   (tm:ensure-compatible-time loc (%time-period-begin per1) (%time-period-begin per2)) )
     167  (tm:ensure-compatible-time loc
     168    (%time-period-begin per1)
     169    (%time-period-begin per2)) )
    158170
    159171(define (tm:ensure-compatible-time-period-end loc per1 per2)
    160   (tm:ensure-compatible-time loc (%time-period-end per1) (%time-period-end per2)) )
     172  (tm:ensure-compatible-time loc
     173    (%time-period-end per1)
     174      (%time-period-end per2)) )
    161175
    162176(define (tm:ensure-compatible-date loc tim dat)
    163   (or (tm:date->time dat (tm:time-type tim))
    164       (error-incompatible-clock-type loc tim)) )
     177  (or
     178    (tm:date->time dat (tm:time-type tim))
     179    (error-incompatible-clock-type loc tim)) )
    165180
    166181(define (tm:time-period-type=? per1 per2)
     
    172187
    173188(define (tm:time-period-contains/period? loc per1 per2)
    174   (let ((tper (if (tm:time-period-type=? per1 per2) per2
    175                 (%make-time-period
    176                   (tm:ensure-compatible-time-period-begin loc per1 per2)
    177                   (tm:ensure-compatible-time-period-end loc per1 per2)) ) ) )
     189  (let ((tper
     190          (if (tm:time-period-type=? per1 per2)
     191            per2
     192            (%make-time-period
     193              (tm:ensure-compatible-time-period-begin loc per1 per2)
     194              (tm:ensure-compatible-time-period-end loc per1 per2)) ) ) )
    178195    (tm:time-point-within?
    179196     (%time-period-begin per1) (%time-period-end per1)
     
    196213(define (tm:time-period-subtract per1 per2)
    197214  (let ((diff (- (%time-period-begin per1) (%time-period-begin per2))))
    198     (if (zero? diff) (- (%time-period-end per1) (%time-period-end per2))
    199         diff ) ) )
     215    (if (zero? diff)
     216      (- (%time-period-end per1) (%time-period-end per2))
     217      diff ) ) )
    200218
    201219;;
     
    215233    (check-clock-type 'make-time-period tt)
    216234    ;
    217     (cond ((real? beg)  (set! beg (tm:seconds->time beg tt)) )
    218           ((date? beg)  (set! beg (tm:date->time beg tt)) ) )
     235    (cond
     236      ((real? beg)  (set! beg (tm:seconds->time beg tt)) )
     237      ((date? beg)  (set! beg (tm:date->time beg tt)) ) )
    219238    (check-time 'make-time-period beg 'begin)
    220239    (when (tm:time-has-type? (tm:time-type beg) 'duration)
    221240      (error-clock-type 'make-time-period beg 'begin))
    222241    ;
    223     (cond ((real? end)  (set! end (tm:seconds->time end 'duration)) )
    224           ((date? end)  (set! end (tm:ensure-compatible-date 'make-time-period beg end)) ) )
     242    (cond
     243      ((real? end)  (set! end (tm:seconds->time end 'duration)) )
     244      ((date? end)  (set! end (tm:ensure-compatible-date 'make-time-period beg end)) ) )
    225245    (check-time 'make-time-period end 'end)
    226246    (when (tm:time-has-type? (tm:time-type end) 'duration)
     
    241261
    242262(define (time-period-type per)
    243   (check-time-period 'time-period-type per)
    244   (tm:time-period-type per) )
    245 
    246 (define (time-period-begin prd)
    247   (check-time-period 'time-period-begin prd)
    248   (%time-period-begin prd) )
    249 
    250 (define (time-period-end prd)
    251   (check-time-period 'time-period-end prd)
    252   (%time-period-end prd) )
     263  (tm:time-period-type (check-time-period 'time-period-type per)) )
     264
     265(define (time-period-begin per)
     266  (%time-period-begin (check-time-period 'time-period-begin per)) )
     267
     268(define (time-period-end per)
     269  (%time-period-end (check-time-period 'time-period-end per)) )
    253270
    254271(define (time-period-compare per1 per2)
     
    289306(define (time-period-preceding per1 per2)
    290307  (check-time-period-binop 'time-period-preceding per1 per2)
    291   (and (tm:time<=? (%time-period-begin per1) (%time-period-begin per2))
    292        (make-time-period (%time-period-begin per1) (%time-period-begin per2)) ) )
     308  (and
     309    (tm:time<=? (%time-period-begin per1) (%time-period-begin per2))
     310    (make-time-period (%time-period-begin per1) (%time-period-begin per2)) ) )
    293311
    294312(define (time-period-succeeding per1 per2)
    295313  (check-time-period-binop 'time-period-succeeding per1 per2)
    296   (and (tm:time>=? (%time-period-end per1) (%time-period-end per2))
    297        (make-time-period (%time-period-end per2) (%time-period-end per1)) ) )
     314  (and
     315    (tm:time>=? (%time-period-end per1) (%time-period-end per2))
     316    (make-time-period (%time-period-end per2) (%time-period-end per1)) ) )
    298317
    299318(define (time-period-last per)
     
    307326    (tm:time-difference (%time-period-begin per) (%time-period-end per) dur)
    308327    #; ;BAD IDEA
    309     (if (tm:time-period-null? per) dur
     328    (if (tm:time-period-null? per)
     329      dur
    310330      (tm:time-difference (%time-period-begin per) (%time-period-end per) dur)) ) )
    311331
    312332(define (time-period-contains/period? per1 per2)
    313   (check-time-period 'time-period-contains/period? per1)
    314   (check-time-period 'time-period-contains/period? per2)
    315   (tm:time-period-contains/period? 'time-period-contains/period? per1 per2) )
     333  (tm:time-period-contains/period? 'time-period-contains/period?
     334    (check-time-period 'time-period-contains/period? per1)
     335    (check-time-period 'time-period-contains/period? per2)) )
    316336
    317337(define (time-period-contains/time? per tim)
    318   (check-time-period 'time-period-contains/time? per)
    319   (check-time 'time-period-contains/time? tim)
    320   (tm:time-period-contains/time? 'time-period-contains/time? per tim) )
     338  (tm:time-period-contains/time? 'time-period-contains/time?
     339    (check-time-period 'time-period-contains/time? per)
     340    (check-time 'time-period-contains/time? tim)) )
    321341
    322342(define (time-period-contains/date? per dat)
    323   (check-time-period 'time-period-contains/date? per)
    324   (check-date 'time-period-contains/date? dat)
    325   (tm:time-period-contains/date? 'time-period-contains/date? per dat) )
     343  (tm:time-period-contains/date? 'time-period-contains/date?
     344    (check-time-period 'time-period-contains/date? per)
     345    (check-date 'time-period-contains/date? dat)) )
    326346
    327347(define (time-period-contains? per obj)
     
    339359;#f when no intersection (inverted period)
    340360(define (time-period-intersects? per1 per2)
    341   (and (time-period-intersection per1 per2)
    342        #t) )
     361  (->boolean (time-period-intersection per1 per2)) )
    343362
    344363;#f when no overlap
  • release/4/srfi-19/trunk/srfi-19-support.scm

    r34116 r34327  
    5959(module srfi-19-support
    6060
    61   (;export
    62     ;
    63     time?
    64     time-type?
    65     time-seconds?
    66     time-nanoseconds?
    67     clock-type?
    68     date?
    69     date-nanoseconds?
    70     date-seconds?
    71     date-minutes?
    72     date-hours?
    73     date-day?
    74     date-month?
    75     date-year?
    76     week-day?
    77     julian-day?
    78     time-record-printer-format
    79     date-record-printer-format
    80     ;
    81     check-time
    82     check-time-type
    83     check-time-seconds
    84     check-time-nanoseconds
    85     check-raw-seconds
    86     check-raw-milliseconds
    87     check-time-has-type
    88     check-time-and-type
    89     check-duration
    90     check-time-elements
    91     #;check-times
    92     check-time-binop
    93     check-time-compare
    94     check-time-aritmetic
    95     check-clock-type
    96     check-date
    97     check-date-nanoseconds
    98     check-date-seconds
    99     check-date-minutes
    100     check-date-hours
    101     check-date-day
    102     check-date-month
    103     check-date-year
    104     check-date-elements
    105     check-date-compatible-timezone-offsets
    106     check-week-day
    107     check-julian-day
    108     ;
    109     error-time
    110     error-time-type
    111     error-time-seconds
    112     error-time-nanoseconds
    113     error-incompatible-time-types
    114     error-clock-type
    115     error-convert
    116     error-date
    117     error-date-nanoseconds
    118     error-date-seconds
    119     error-date-minutes
    120     error-date-hours
    121     error-date-day
    122     error-date-month
    123     error-date-year
    124     error-date-compatible-timezone
    125     error-week-day
    126     error-julian-day
    127     ;
    128     tm:read-tai-utc-data
    129     tm:calc-second-before-leap-second-table
    130     tm:read-leap-second-table
    131     (tm:any-time %make-time)
    132     (tm:some-time %make-time)
    133     (tm:as-some-time %time-type %make-time)
    134     (tm:time-type %time-type)
    135     (tm:time-nanosecond %time-second)
    136     (tm:time-second %time-nanosecond)
    137     (tm:time-type-set! %time-type-set!)
    138     (tm:time-nanosecond-set! %time-nanosecond-set!)
    139     (tm:time-second-set! %time-second-set!)
    140     tm:make-time
    141     (tm:copy-time %make-time)
    142     (tm:time-has-type? %time-type)
    143     tm:nanoseconds->time-values
    144     tm:time->nanoseconds
    145     tm:time->milliseconds
    146     tm:nanoseconds->seconds
    147     tm:milliseconds->seconds
    148     tm:time->seconds
    149     tm:duration-elements->time-values
    150     tm:milliseconds->time-values
    151     tm:seconds->time-values
    152     tm:seconds->time
    153     (tm:current-time-values tm:current-nanoseconds)
    154     tm:current-time-utc
    155     (tm:current-time-tai leap-second-delta)
    156     tm:current-time-monotonic
    157     (tm:current-time-thread current-thread-milliseconds)
    158     (tm:current-time-process current-process-milliseconds)
    159     (tm:current-time-gc current-gc-milliseconds total-gc-milliseconds)
    160     tm:time-resolution
    161     tm:time-compare
    162     tm:time=?
    163     tm:time<?
    164     tm:time<=?
    165     tm:time>?
    166     tm:time>=?
    167     tm:time-max
    168     tm:time-min
    169     tm:time-difference
    170     tm:add-duration
    171     tm:subtract-duration
    172     tm:divide-duration
    173     tm:multiply-duration
    174     tm:time-abs
    175     tm:time-negate
    176     tm:time-zero? tm:time-positive? tm:time-negative?
    177     (tm:time-tai->time-utc leap-second-neg-delta)
    178     tm:time-tai->time-monotonic
    179     tm:time-utc->time-tai
    180     tm:time-utc->time-monotonic
    181     tm:time-monotonic->time-tai
    182     tm:time-monotonic->time-utc
    183     tm:leap-year?
    184     (tm:leap-day? +leap-year-dys/mn+)
    185     (tm:days-in-month +leap-year-dys/mn+ +year-dys/mn+)
    186     (tm:date-nanosecond %date-nanosecond)
    187     (tm:date-second %date-second)
    188     (tm:date-minute %date-minute)
    189     (tm:date-hour %date-hour)
    190     (tm:date-day %date-day)
    191     (tm:date-month %date-month)
    192     (tm:date-year %date-year)
    193     (tm:date-zone-offset %date-zone-offset)
    194     (tm:date-zone-name %date-zone-name)
    195     (tm:date-dst? %date-dst?)
    196     tm:date-wday
    197     tm:date-yday
    198     tm:date-jday
    199     (tm:date-timezone-info %make-date-timezone-info)
    200     (tm:date-nanosecond-set! %date-nanosecond-set!)
    201     (tm:date-second-set! %date-second-set!)
    202     (tm:date-minute-set! %date-minute-set!)
    203     (tm:date-hour-set! %date-hour-set!)
    204     (tm:date-day-set! %date-day-set!)
    205     (tm:date-month-set! %date-month-set!)
    206     (tm:date-year-set! %date-year-set!)
    207     (tm:date-zone-offset-set! %date-zone-offset-set!)
    208     (tm:make-incomplete-date %make-date)
    209     (tm:make-date %make-date)
    210     (tm:copy-date %date-nanosecond %date-second %date-minute %date-hour
    211       %date-day %date-month %date-year
    212       %date-zone-offset %date-zone-name
    213       %date-jday %date-yday %date-wday
    214       %make-date)
    215     tm:seconds->date/type
    216     tm:current-date
    217     (tm:date-compare %date-nanosecond %date-second %date-minute %date-hour
    218       %date-day %date-month %date-year)
    219     tm:decode-julian-day-number
    220     tm:seconds->julian-day-number
    221     tm:tai-before-leap-second?
    222     tm:time-utc->date
    223     tm:time-tai->date
    224     tm:time->date
    225     tm:encode-julian-day-number
    226     tm:date->time-utc
    227     tm:date->time-tai
    228     tm:date->time-monotonic
    229     tm:date->time
    230     tm:natural-year
    231     tm:year-day
    232     tm:date-year-day
    233     tm:week-day
    234     tm:days-before-first-week
    235     tm:date-week-day
    236     tm:date-week-number
    237     tm:julian-day->modified-julian-day
    238     tm:julian-day
    239     (tm:date->julian-day %date-nanosecond %date-second %date-minute %date-hour
    240       %date-day %date-month %date-year
    241       %date-zone-offset
    242       %date-jday %date-jday-set!)
    243     tm:seconds->julian-day
    244     tm:time-utc->julian-day
    245     tm:time-tai->julian-day
    246     tm:time-monotonic->julian-day
    247     tm:time->julian-day
    248     tm:time-utc->modified-julian-day
    249     tm:time-tai->modified-julian-day
    250     tm:time-monotonic->modified-julian-day
    251     tm:time->modified-julian-day
    252     tm:julian-day->nanoseconds
    253     tm:julian-day->time-values
    254     tm:modified-julian-day->julian-day
    255     tm:julian-day->time-utc
    256     tm:default-date-adjust-integer)
    257 
    258   (import
    259     (except scheme
    260       + - * / remainder quotient
    261       abs round floor truncate
    262       real? integer? inexact? zero? negative? positive?
    263       = <= >= < >
    264       inexact->exact exact->inexact
    265       string->number)
    266     chicken
    267     (only srfi-1 fold)
    268     (only posix
    269       seconds->utc-time)
    270     (only extras
    271       format read-line)
    272     (only data-structures
    273       conc)
    274     (only ports
    275       with-input-from-port with-input-from-string)
    276     (only numbers
    277       + - * / remainder quotient
    278       abs round floor truncate
    279       real? integer? inexact? zero? negative? positive?
    280       = <= >= < >
    281       inexact->exact exact->inexact
    282       string->number)
    283     locale
    284     record-variants
    285     type-checks
    286     type-errors
    287     srfi-19-timezone)
    288 
    289   (require-library
    290     srfi-18 posix extras ports
    291     numbers locale record-variants type-checks type-errors
    292     srfi-19-timezone)
     61(;export
     62  ;
     63  time?
     64  time-type?
     65  time-seconds?
     66  time-nanoseconds?
     67  clock-type?
     68  date?
     69  date-nanoseconds?
     70  date-seconds?
     71  date-minutes?
     72  date-hours?
     73  date-day?
     74  date-month?
     75  date-year?
     76  week-day?
     77  julian-day?
     78  time-record-printer-format
     79  date-record-printer-format
     80  ;
     81  check-time
     82  check-time-type
     83  check-time-seconds
     84  check-time-nanoseconds
     85  check-raw-seconds
     86  check-raw-milliseconds
     87  check-time-has-type
     88  check-time-and-type
     89  check-duration
     90  check-time-elements
     91  #;check-times
     92  check-time-binop
     93  check-time-compare
     94  check-time-aritmetic
     95  check-clock-type
     96  check-date
     97  check-date-nanoseconds
     98  check-date-seconds
     99  check-date-minutes
     100  check-date-hours
     101  check-date-day
     102  check-date-month
     103  check-date-year
     104  check-date-elements
     105  check-date-compatible-timezone-offsets
     106  check-week-day
     107  check-julian-day
     108  ;
     109  error-time
     110  error-time-type
     111  error-time-seconds
     112  error-time-nanoseconds
     113  error-incompatible-time-types
     114  error-clock-type
     115  error-convert
     116  error-date
     117  error-date-nanoseconds
     118  error-date-seconds
     119  error-date-minutes
     120  error-date-hours
     121  error-date-day
     122  error-date-month
     123  error-date-year
     124  error-date-compatible-timezone
     125  error-week-day
     126  error-julian-day
     127  ;
     128  tm:read-tai-utc-data
     129  tm:calc-second-before-leap-second-table
     130  tm:read-leap-second-table
     131  (tm:any-time %make-time)
     132  (tm:some-time %make-time)
     133  (tm:as-some-time %time-type %make-time)
     134  (tm:time-type %time-type)
     135  (tm:time-nanosecond %time-second)
     136  (tm:time-second %time-nanosecond)
     137  (tm:time-type-set! %time-type-set!)
     138  (tm:time-nanosecond-set! %time-nanosecond-set!)
     139  (tm:time-second-set! %time-second-set!)
     140  tm:make-time
     141  (tm:copy-time %make-time)
     142  (tm:time-has-type? %time-type)
     143  tm:nanoseconds->time-values
     144  tm:time->nanoseconds
     145  tm:time->milliseconds
     146  tm:nanoseconds->seconds
     147  tm:milliseconds->seconds
     148  tm:time->seconds
     149  tm:duration-elements->time-values
     150  tm:milliseconds->time-values
     151  tm:seconds->time-values
     152  tm:seconds->time
     153  (tm:current-time-values tm:current-nanoseconds)
     154  tm:current-time-utc
     155  (tm:current-time-tai leap-second-delta)
     156  tm:current-time-monotonic
     157  (tm:current-time-thread current-thread-milliseconds)
     158  (tm:current-time-process current-process-milliseconds)
     159  (tm:current-time-gc current-gc-milliseconds total-gc-milliseconds)
     160  tm:time-resolution
     161  tm:time-compare
     162  tm:time=?
     163  tm:time<?
     164  tm:time<=?
     165  tm:time>?
     166  tm:time>=?
     167  tm:time-max
     168  tm:time-min
     169  tm:time-difference
     170  tm:add-duration
     171  tm:subtract-duration
     172  tm:divide-duration
     173  tm:multiply-duration
     174  tm:time-abs
     175  tm:time-negate
     176  tm:time-zero? tm:time-positive? tm:time-negative?
     177  (tm:time-tai->time-utc leap-second-neg-delta)
     178  tm:time-tai->time-monotonic
     179  tm:time-utc->time-tai
     180  tm:time-utc->time-monotonic
     181  tm:time-monotonic->time-tai
     182  tm:time-monotonic->time-utc
     183  tm:leap-year?
     184  (tm:leap-day? +leap-year-dys/mn+)
     185  (tm:days-in-month +leap-year-dys/mn+ +year-dys/mn+)
     186  (tm:date-nanosecond %date-nanosecond)
     187  (tm:date-second %date-second)
     188  (tm:date-minute %date-minute)
     189  (tm:date-hour %date-hour)
     190  (tm:date-day %date-day)
     191  (tm:date-month %date-month)
     192  (tm:date-year %date-year)
     193  (tm:date-zone-offset %date-zone-offset)
     194  (tm:date-zone-name %date-zone-name)
     195  (tm:date-dst? %date-dst?)
     196  tm:date-wday
     197  tm:date-yday
     198  tm:date-jday
     199  (tm:date-timezone-info %make-date-timezone-info)
     200  (tm:date-nanosecond-set! %date-nanosecond-set!)
     201  (tm:date-second-set! %date-second-set!)
     202  (tm:date-minute-set! %date-minute-set!)
     203  (tm:date-hour-set! %date-hour-set!)
     204  (tm:date-day-set! %date-day-set!)
     205  (tm:date-month-set! %date-month-set!)
     206  (tm:date-year-set! %date-year-set!)
     207  (tm:date-zone-offset-set! %date-zone-offset-set!)
     208  (tm:make-incomplete-date %make-date)
     209  (tm:make-date %make-date)
     210  (tm:copy-date %date-nanosecond %date-second %date-minute %date-hour
     211    %date-day %date-month %date-year
     212    %date-zone-offset %date-zone-name
     213    %date-jday %date-yday %date-wday
     214    %make-date)
     215  tm:seconds->date/type
     216  tm:current-date
     217  (tm:date-compare %date-nanosecond %date-second %date-minute %date-hour
     218    %date-day %date-month %date-year)
     219  tm:decode-julian-day-number
     220  tm:seconds->julian-day-number
     221  tm:tai-before-leap-second?
     222  tm:time-utc->date
     223  tm:time-tai->date
     224  tm:time->date
     225  tm:encode-julian-day-number
     226  tm:date->time-utc
     227  tm:date->time-tai
     228  tm:date->time-monotonic
     229  tm:date->time
     230  tm:natural-year
     231  tm:year-day
     232  tm:date-year-day
     233  tm:week-day
     234  tm:days-before-first-week
     235  tm:date-week-day
     236  tm:date-week-number
     237  tm:julian-day->modified-julian-day
     238  tm:julian-day
     239  (tm:date->julian-day %date-nanosecond %date-second %date-minute %date-hour
     240    %date-day %date-month %date-year
     241    %date-zone-offset
     242    %date-jday %date-jday-set!)
     243  tm:seconds->julian-day
     244  tm:time-utc->julian-day
     245  tm:time-tai->julian-day
     246  tm:time-monotonic->julian-day
     247  tm:time->julian-day
     248  tm:time-utc->modified-julian-day
     249  tm:time-tai->modified-julian-day
     250  tm:time-monotonic->modified-julian-day
     251  tm:time->modified-julian-day
     252  tm:julian-day->nanoseconds
     253  tm:julian-day->time-values
     254  tm:modified-julian-day->julian-day
     255  tm:julian-day->time-utc
     256  tm:default-date-adjust-integer)
     257
     258(import
     259  (except scheme
     260    + - * / remainder quotient
     261    abs round floor truncate
     262    real? integer? inexact? zero? negative? positive?
     263    = <= >= < >
     264    inexact->exact exact->inexact
     265    string->number))
     266
     267(import chicken)
     268
     269(import
     270  (only srfi-1 fold)
     271  (only posix
     272    seconds->utc-time)
     273  (only extras
     274    format read-line)
     275  (only data-structures
     276    conc)
     277  (only ports
     278    with-input-from-port with-input-from-string))
     279(require-library
     280  srfi-1 posix extras data-structures ports
     281  srfi-18)
     282
     283(import
     284  (only numbers
     285    + - * / remainder quotient
     286    abs round floor truncate
     287    real? integer? inexact? zero? negative? positive?
     288    = <= >= < >
     289    inexact->exact exact->inexact
     290    string->number))
     291(require-library
     292  numbers)
     293
     294(use
     295  locale
     296  record-variants
     297  type-checks
     298  type-errors
     299  srfi-19-timezone)
    293300
    294301;;;
     
    379386;; Number of seconds after epoch of first leap year
    380387
    381 (define LEAP-START
    382   (fx*
    383     (fx- FIRST-LEAP-YEAR TAI-EPOCH-YEAR)
    384     (fx* DY/YR SEC/DY)) )
     388(define LEAP-START (fx* (fx- FIRST-LEAP-YEAR TAI-EPOCH-YEAR) SEC/YR))
    385389
    386390;; A table of leap seconds
     
    417421    (78796800 . 11)
    418422    (63072000 . 10)
    419     #;(-60480000 . 4.21317)   ; Before 1972
     423    #;(-60480000 . 4.21317)   ;Before 1972
    420424    #;(-126230400 . 4.31317)
    421425    #;(-136771200 . 3.84013)
     
    572576#; ;UNUSED
    573577(define (normalize-time ns sec min hr)
    574   (let*-values (((ns ns-sec) (normalize-nanoseconds ns))
    575                 ((sec sec-min) (normalize-timeval (+ sec ns-sec) SEC/MIN))
    576                 ((min min-hr) (normalize-timeval (+ min sec-min) MIN/HR))
    577                 ((hr hr-dy) (normalize-timeval (+ hr min-hr) HR/DY)) )
    578         (values ns sec min hr (+ dy hr-dy)) ) )
     578  (let*-values (
     579      ((ns ns-sec)    (normalize-nanoseconds ns))
     580      ((sec sec-min)  (normalize-timeval (+ sec ns-sec) SEC/MIN))
     581      ((min min-hr)   (normalize-timeval (+ min sec-min) MIN/HR))
     582      ((hr hr-dy)     (normalize-timeval (+ hr min-hr) HR/DY)) )
     583    (values ns sec min hr (+ dy hr-dy)) ) )
    579584
    580585;;
     
    836841  (check-time-has-type loc tim tt) )
    837842
    838 (define (check-duration loc obj) (check-time-and-type loc obj 'duration))
     843(define (check-duration loc obj)
     844  (check-time-and-type loc obj 'duration) )
    839845
    840846(define (check-time-elements loc obj1 obj2 obj3)
     
    10521058                  (let ((timin ?timin)
    10531059                        (timout ?timout))
    1054         #;(%time-type-set! timin 'tai) ; fool converter (unnecessary)
     1060        #;(%time-type-set! timin 'tai) ;fool converter (unnecessary)
    10551061        (tm:time-tai->time-utc timin timout) ) ) ) )
    10561062
     
    10991105;;
    11001106
    1101 #;
     1107#; ;dependency
    11021108(define-record-type-variant date (unchecked inline unsafe)
    11031109  (%make-date ns sec min hr dy mn yr tzo tzn dstf wdy ydy jdy)
     
    11771183          (fx< obj NS/S)) ) ) ) )
    11781184
    1179 ; Seconds in [0 SEC/MIN] ; SEC/MIN legal due to leap second
     1185; Seconds in [0 SEC/MIN] ;SEC/MIN legal due to leap second
    11801186(define-syntax date-seconds?
    11811187        (syntax-rules ()
     
    14101416
    14111417;Belongs in srfi-19-timezone
    1412 
    1413 #;
     1418;but won't fit since needs srfi-19-support (%date-*)
     1419
     1420#; ;dependency
    14141421(define-record-type-variant date-timezone-info (unchecked inline unsafe)
    14151422  (%make-date-timezone-info n o d)
     
    15251532         (m (quotient (+ (* 5 e) 2) 153))
    15261533         (y (+ (* 100 b) d -4800 (quotient m 10))))
    1527     (values ; seconds date month year
     1534    (values ;seconds date month year
    15281535     (* (- jdn days) tm:sid)
    15291536     (+ e (- (quotient (+ (* 153 m) 2) 5)) 1)
     
    15401547         (m (fx/ (fx+ (fx* 5 e) 2) 153))
    15411548         (y (fx+ (fx* 100 b) (fx+ d (fx- (fx/ m 10) JDYR)))) )
    1542     (values ; seconds date month year
     1549    (values ;seconds date month year
    15431550      (number->genint (floor (* (- jdn dys) SEC/DY)))
    15441551      (fx+ (fx- e (fx/ (fx+ (fx* 153 m) 2) 5)) 1)
     
    15931600    (if (not (tm:tai-before-leap-second? tim))
    15941601      (tm:time-utc->date tm-utc tzi)
    1595       ; else time is *right* before the leap, we need to pretend to subtract a second ...
     1602      ;else time is *right* before the leap, we need to pretend to subtract a second ...
    15961603      (let ((dat (tm:time-utc->date (tm:subtract-duration tm-utc ONE-SECOND-DURATION tm-utc) tzi)))
    1597         (%date-second-set! dat SEC/MIN) ; Note full minute!
     1604        (%date-second-set! dat SEC/MIN) ;Note full minute!
    15981605        dat ) ) ) )
    15991606
     
    16121619  (let* ((a (fx/ (fx- 14 mn) MN/YR))
    16131620         (b (fx- (fx+ yr JDYR) a))
    1614          (y (if (fx< yr 0) (fx+ b 1) b)) ; BCE?
     1621         (y (if (fx< yr 0) (fx+ b 1) b)) ;BCE?
    16151622         (m (fx- (fx+ mn (fx* a MN/YR)) 3)))
    1616     (+
    1617       dy
    1618      (fx/ (fx+ (fx* 153 m) 2) 5)
    1619      (fx* y DY/YR)
    1620      (fx/ y 4)
    1621      (fx/ y -100)
    1622      (fx/ y 400)
    1623      -32045) ) )
     1623    (+ dy
     1624      (fx/ (fx+ (fx* 153 m) 2) 5)
     1625      (fx* y DY/YR)
     1626      (fx/ y 4)
     1627      (fx/ y -100)
     1628      (fx/ y 400)
     1629      -32045) ) )
    16241630
    16251631(define (tm:date->time-utc dat)
     
    16331639        (tzo (%date-zone-offset dat)) )
    16341640    (let ((jdys
    1635             (-
    1636               (tm:encode-julian-day-number dy mn yr)
    1637               TAI-EPOCH-IN-JD))
     1641            (- (tm:encode-julian-day-number dy mn yr) TAI-EPOCH-IN-JD))
    16381642          (secs
    16391643            (fx+
     
    16671671
    16681672(define (tm:natural-year n tzi)
     1673  ;propagate the error
    16691674  (if (or (fx< n 0) (fx>= n 100))
    16701675    n
    1671     (let* ((current-year (%date-year (tm:current-date tzi)) )
    1672            (current-century (fx* (fx/ current-year 100) 100) )
    1673            (X (fx- (fx+ current-century n) current-year) ) )
     1676    (let* (
     1677        (current-year     (%date-year (tm:current-date tzi)) )
     1678        (current-century  (fx* (fx/ current-year 100) 100) )
     1679        (X                (fx- (fx+ current-century n) current-year) ) )
    16741680      (if (fx<= X 50)
    16751681        (fx+ current-century n)
     
    17671773    (+ (- jdn ONE-HALF) (/ timsecs SEC/DY)) ) )
    17681774
    1769 #; ; inexact version
     1775#; ;inexact version
    17701776(define (tm:julian-day ns sec min hr dy mn yr tzo)
    17711777  (let ((time-seconds
     
    17921798          (%date-jday dat)
    17931799          (let ((jdn
    1794                  (tm:julian-day
    1795                   (%date-nanosecond dat)
    1796                   (%date-second dat) (%date-minute dat) (%date-hour dat)
    1797                   (%date-day dat) (%date-month dat) (%date-year dat)
    1798                   (%date-zone-offset dat))))
     1800                  (tm:julian-day
     1801                    (%date-nanosecond dat)
     1802                    (%date-second dat) (%date-minute dat) (%date-hour dat)
     1803                    (%date-day dat) (%date-month dat) (%date-year dat)
     1804                    (%date-zone-offset dat))))
    17991805            (%date-jday-set! dat jdn)
    18001806            jdn ) ) ) ) ) )
     
    18181824(define (tm:time->julian-day tim)
    18191825  (case (%time-type tim)
    1820     ((utc)       (tm:time-utc->julian-day tim))
    1821     ((tai)       (tm:time-tai->julian-day tim))
    1822     ((monotonic) (tm:time-monotonic->julian-day tim))
    1823     (else        #f)) )
     1826    ((utc)        (tm:time-utc->julian-day tim))
     1827    ((tai)        (tm:time-tai->julian-day tim))
     1828    ((monotonic)  (tm:time-monotonic->julian-day tim))
     1829    (else         #f)) )
    18241830
    18251831(define (tm:time-utc->modified-julian-day tim)
     
    18341840(define (tm:time->modified-julian-day tim)
    18351841  (case (%time-type tim)
    1836     ((utc)       (tm:time-utc->modified-julian-day tim))
    1837     ((tai)       (tm:time-tai->modified-julian-day tim))
    1838     ((monotonic) (tm:time-monotonic->modified-julian-day tim))
    1839     (else        #f)) )
     1842    ((utc)        (tm:time-utc->modified-julian-day tim))
     1843    ((tai)        (tm:time-tai->modified-julian-day tim))
     1844    ((monotonic)  (tm:time-monotonic->modified-julian-day tim))
     1845    (else         #f)) )
    18401846
    18411847;; Julian-day to Time
  • release/4/srfi-19/trunk/srfi-19-time.scm

    r20423 r34327  
    3030(module srfi-19-time
    3131
    32   (;export
    33     ; SRFI-19
    34     time-tai
    35     time-utc
    36     time-monotonic
    37     time-thread
    38     time-process
    39     time-duration
    40     time-gc
    41     current-time
    42     time-resolution
    43     make-time
    44     time-type
    45     time-nanosecond
    46     time-second
    47     set-time-type!
    48     set-time-nanosecond!
    49     set-time-second!
    50     copy-time
    51     time<=?
    52     time<?
    53     time=?
    54     time>=?
    55     time>?
    56     time-difference
    57     time-difference!
    58     add-duration
    59     add-duration!
    60     subtract-duration
    61     subtract-duration!
    62     time-monotonic->time-tai
    63     time-monotonic->time-tai!
    64     time-monotonic->time-utc
    65     time-monotonic->time-utc!
    66     time-tai->time-monotonic
    67     time-tai->time-monotonic!
    68     time-tai->time-utc
    69     time-tai->time-utc!
    70     time-utc->time-monotonic
    71     time-utc->time-monotonic!
    72     time-utc->time-tai
    73     time-utc->time-tai!
    74     ; Extensions
    75     one-second-duration
    76     one-nanosecond-duration
    77     zero-time
    78     make-duration
    79     divide-duration
    80     divide-duration!
    81     multiply-duration
    82     multiply-duration!
    83     time->srfi-18-time
    84     srfi-18-time->time
    85     time-max
    86     time-min
    87     time-negative?
    88     time-positive?
    89     time-zero?
    90     time-abs
    91     time-abs!
    92     time-negate
    93     time-negate!
    94     seconds->time
    95     nanoseconds->time
    96     nanoseconds->seconds
    97     milliseconds->time
    98     milliseconds->seconds
    99     time->nanoseconds
    100     time->milliseconds
    101     time->seconds
    102     time-compare
    103     ; DEPRECATED
    104     seconds->time/type)
    105 
    106   (import
    107     (except scheme
    108       zero? negative? positive? real?)
    109     chicken
    110     #;srfi-8
    111     (prefix
    112       (only srfi-18
    113         seconds->time time->seconds)
    114       srfi-18:)
    115     (only numbers
    116       zero? negative? positive? real?)
    117     miscmacros
    118     type-checks
    119     type-errors
    120     srfi-19-support)
    121 
    122   (require-library
    123     #;srfi-8 srfi-18 numbers miscmacros
    124    type-checks type-errors
    125    srfi-19-support)
     32(;export
     33  ; SRFI-19
     34  time-tai
     35  time-utc
     36  time-monotonic
     37  time-thread
     38  time-process
     39  time-duration
     40  time-gc
     41  current-time
     42  time-resolution
     43  make-time
     44  time-type
     45  time-nanosecond
     46  time-second
     47  set-time-type!
     48  set-time-nanosecond!
     49  set-time-second!
     50  copy-time
     51  time<=?
     52  time<?
     53  time=?
     54  time>=?
     55  time>?
     56  time-difference
     57  time-difference!
     58  add-duration
     59  add-duration!
     60  subtract-duration
     61  subtract-duration!
     62  time-monotonic->time-tai
     63  time-monotonic->time-tai!
     64  time-monotonic->time-utc
     65  time-monotonic->time-utc!
     66  time-tai->time-monotonic
     67  time-tai->time-monotonic!
     68  time-tai->time-utc
     69  time-tai->time-utc!
     70  time-utc->time-monotonic
     71  time-utc->time-monotonic!
     72  time-utc->time-tai
     73  time-utc->time-tai!
     74  ; Extensions
     75  one-second-duration
     76  one-nanosecond-duration
     77  zero-time
     78  make-duration
     79  divide-duration
     80  divide-duration!
     81  multiply-duration
     82  multiply-duration!
     83  time->srfi-18-time
     84  srfi-18-time->time
     85  time-max
     86  time-min
     87  time-negative?
     88  time-positive?
     89  time-zero?
     90  time-abs
     91  time-abs!
     92  time-negate
     93  time-negate!
     94  seconds->time
     95  nanoseconds->time
     96  nanoseconds->seconds
     97  milliseconds->time
     98  milliseconds->seconds
     99  time->nanoseconds
     100  time->milliseconds
     101  time->seconds
     102  time-compare
     103  ; DEPRECATED
     104  seconds->time/type)
     105
     106(import
     107  (except scheme
     108    zero? negative? positive? real?))
     109
     110(import chicken)
     111
     112(import
     113  #;srfi-8
     114  (prefix
     115    (only srfi-18 seconds->time time->seconds)
     116    srfi-18:))
     117(require-library
     118  #;srfi-8
     119  srfi-18)
     120
     121(import
     122  (only numbers
     123    zero? negative? positive? real?))
     124(require-library
     125  numbers)
     126
     127(use
     128  miscmacros
     129  type-checks
     130  type-errors
     131  srfi-19-support)
    126132
    127133;;;
     
    165171
    166172(define (copy-time tim)
    167   (check-time 'copy-time tim)
    168   (tm:copy-time tim) )
     173  (tm:copy-time (check-time 'copy-time tim)) )
    169174
    170175;; Time record-type operations
    171176
    172177(define (time-type tim)
    173   (check-time 'time-type tim)
    174   (tm:time-type tim) )
     178  (tm:time-type (check-time 'time-type tim)) )
    175179
    176180(define (time-nanosecond tim)
    177   (check-time 'time-nanosecond tim)
    178   (tm:time-nanosecond tim) )
     181  (tm:time-nanosecond (check-time 'time-nanosecond tim)) )
    179182
    180183(define (time-second tim)
    181   (check-time 'time-second tim)
    182   (tm:time-second tim) )
     184  (tm:time-second (check-time 'time-second tim)) )
    183185
    184186(define (set-time-type! tim tt)
    185   (check-time 'set-time-type! tim)
    186   (check-time-type 'set-time-type! tt)
    187   (tm:time-type-set! tim tt) )
     187  (tm:time-type-set!
     188    (check-time 'set-time-type! tim)
     189    (check-time-type 'set-time-type! tt)) )
    188190
    189191(define (set-time-nanosecond! tim ns)
    190   (check-time 'set-time-nanosecond! tim)
    191   (check-time-nanoseconds 'set-time-nanosecond! ns)
    192   (tm:time-nanosecond-set! tim ns) )
     192  (tm:time-nanosecond-set!
     193    (check-time 'set-time-nanosecond! tim)
     194    (check-time-nanoseconds 'set-time-nanosecond! ns)) )
    193195
    194196(define (set-time-second! tim sec)
    195   (check-time 'set-time-second! tim)
    196   (check-time-seconds 'set-time-second! sec)
    197   (tm:time-second-set! tim sec) )
     197  (tm:time-second-set!
     198    (check-time 'set-time-second! tim)
     199    (check-time-seconds 'set-time-second! sec)) )
    198200
    199201;; Seconds Conversion
     
    201203(define (nanoseconds->time ns . args)
    202204  (let-optionals args ((tt 'duration))
    203     (receive (ns sec)
    204         (tm:nanoseconds->time-values ns)
     205    (receive (ns sec) (tm:nanoseconds->time-values ns)
    205206      (check-time-elements 'nanoseconds->time tt ns sec)
    206207      (tm:make-time tt ns sec) ) ) )
    207208
    208209(define (nanoseconds->seconds ns)
    209   (check-real 'nanoseconds->seconds ns)
    210   (tm:nanoseconds->seconds ns) )
     210  (tm:nanoseconds->seconds (check-real 'nanoseconds->seconds ns)) )
    211211
    212212(define (milliseconds->time ms . args)
    213213  (check-raw-milliseconds 'milliseconds->time ms)
    214214  (let-optionals args ((tt 'duration))
    215     (receive (ns sec)
    216         (tm:milliseconds->time-values ms)
     215    (receive (ns sec) (tm:milliseconds->time-values ms)
    217216      (check-time-elements 'milliseconds->time tt ns sec)
    218217      (tm:make-time tt ns sec) ) ) )
     
    226225
    227226(define (seconds->time sec . args)
    228   (check-raw-seconds 'seconds->time sec)
    229227  (let-optionals args ((tt 'duration))
    230     (check-time-type 'seconds->time tt)
    231     (tm:seconds->time sec tt) ) )
     228    (tm:seconds->time
     229      (check-raw-seconds 'seconds->time sec)
     230      (check-time-type 'seconds->time tt)) ) )
    232231
    233232(define seconds->time/type seconds->time) ; DEPRECATED
    234233
    235234(define (time->nanoseconds tim)
    236   (check-time 'time->nanoseconds tim)
    237   (tm:time->nanoseconds tim) )
     235  (tm:time->nanoseconds (check-time 'time->nanoseconds tim)) )
    238236
    239237(define (time->milliseconds tim)
    240   (check-time 'time->milliseconds tim)
    241   (tm:time->milliseconds tim) )
     238  (tm:time->milliseconds (check-time 'time->milliseconds tim)) )
    242239
    243240(define (time->seconds tim)
    244   (check-time 'time->seconds tim)
    245   (tm:time->seconds tim) )
     241  (tm:time->seconds (check-time 'time->seconds tim)) )
    246242
    247243;; Current time routines
     
    265261(define (time-resolution . args)
    266262  (let-optionals args ((tt 'utc))
    267     (check-time-type 'time-resolution tt)
    268     (tm:time-resolution tt) ) )
     263    (tm:time-resolution (check-time-type 'time-resolution tt)) ) )
    269264
    270265;; SRFI-18 Routines
     
    274269
    275270(define (time->srfi-18-time tim)
    276   (check-time 'time->srfi-18-time tim)
    277   (srfi-18:seconds->time (tm:time->seconds tim)) )
     271  (srfi-18:seconds->time
     272    (tm:time->seconds
     273      (check-time 'time->srfi-18-time tim))) )
    278274
    279275;; Time Comparison
     
    282278  (check-time-compare 'time-compare tim1 tim2)
    283279  (let ((dif (tm:time-compare tim1 tim2)))
    284     (cond ((negative? dif)  -1)
    285           ((positive? dif)  1)
    286           (else             0) ) ) )
     280    (cond
     281      ((negative? dif)  -1)
     282      ((positive? dif)  1)
     283      (else             0) ) ) )
    287284
    288285(define (time=? tim1 tim2)
     
    307304
    308305(define (time-max tim1 . rest)
    309   (check-time 'time-max tim1)
    310   (let ((tt (tm:time-type tim1)))
     306  (let ((tt (tm:time-type (check-time 'time-max tim1))))
    311307    (let loop ((acc tim1) (ls rest))
    312       (if (null? ls) acc
    313           (let ((tim (car ls)))
    314             (check-time-and-type 'time-max tim tt)
    315             (loop (tm:time-max acc tim) (cdr ls)) ) ) ) ) )
     308      (if (null? ls)
     309        acc
     310        (let ((tim (car ls)))
     311          (check-time-and-type 'time-max tim tt)
     312          (loop (tm:time-max acc tim) (cdr ls)) ) ) ) ) )
    316313
    317314(define (time-min tim1 . rest)
    318   (check-time 'time-min tim1)
    319   (let ((tt (tm:time-type tim1)))
     315  (let ((tt (tm:time-type (check-time 'time-min tim1))))
    320316    (let loop ((acc tim1) (ls rest))
    321       (if (null? ls) acc
    322           (let ((tim (car ls)))
    323             (check-time-and-type 'time-min tim tt)
    324             (loop (tm:time-min acc tim) (cdr ls)) ) ) ) ) )
     317      (if (null? ls)
     318        acc
     319        (let ((tim (car ls)))
     320          (check-time-and-type 'time-min tim tt)
     321          (loop (tm:time-min acc tim) (cdr ls)) ) ) ) ) )
    325322
    326323;; Time Arithmetic
     
    387384
    388385(define (time-negative? tim)
    389   (check-time 'time-negative? tim)
    390386  ;nanoseconds irrelevant
    391   (negative? (tm:time-second tim)) )
     387  (negative? (tm:time-second (check-time 'time-negative? tim))) )
    392388
    393389(define (time-positive? tim)
    394   (check-time 'time-positive? tim)
    395390  ;nanoseconds irrelevant
    396   (positive? (tm:time-second tim)) )
     391  (positive? (tm:time-second (check-time 'time-positive? tim))) )
    397392
    398393(define (time-zero? tim)
    399394  (check-time 'time-zero? tim)
    400   (and (zero? (tm:time-nanosecond tim))
    401        (zero? (tm:time-second tim))) )
     395  (and
     396    (zero? (tm:time-nanosecond tim))
     397    (zero? (tm:time-second tim))) )
    402398
    403399;; Time Type Conversion
  • release/4/srfi-19/trunk/srfi-19-timezone.scm

    r22600 r34327  
    1 ;;;; srfi-19-timezone.scm
     1;;;;srfi-19-timezone.scm
    22
    33(module srfi-19-timezone
    44
    5   (;export
    6     local-timezone-locale
    7     utc-timezone-locale
    8     #;make-timezone-locale
    9     timezone-locale-name
    10     timezone-locale-offset
    11     timezone-locale-dst?
    12     timezone-name?
    13     check-timezone-name
    14     timezone-info?
    15     error-timezone-name
    16     check-timezone-info
    17     error-timezone-info
    18     checked-optional-timezone-info)
     5(;export
     6  local-timezone-locale
     7  utc-timezone-locale
     8  #;make-timezone-locale
     9  timezone-locale-name
     10  timezone-locale-offset
     11  timezone-locale-dst?
     12  timezone-name?
     13  check-timezone-name
     14  timezone-info?
     15  error-timezone-name
     16  check-timezone-info
     17  error-timezone-info
     18  checked-optional-timezone-info)
    1919
    20   (import scheme chicken)
     20(import scheme)
    2121
    22   (use miscmacros locale type-checks type-errors)
     22(import chicken)
    2323
    24 ;;; Timezone Locale Object (Public Immutable, but not enforced)
     24(use miscmacros locale type-checks type-errors)
     25
     26;;;Timezone Locale Object (Public Immutable, but not enforced)
    2527
    2628(define-inline (make-utc-timezone)
     
    3537(define-parameter local-timezone-locale (current-timezone-components)
    3638  (lambda (obj)
    37     (cond ((timezone-components? obj) obj)
    38           (else
    39            (warning-argument-type 'local-timezone-locale obj 'timezone-components)
    40            (local-timezone-locale) ) ) ) )
     39    (cond
     40      ((timezone-components? obj)
     41        obj )
     42      (else
     43        (warning-argument-type 'local-timezone-locale obj 'timezone-components)
     44        (local-timezone-locale) ) ) ) )
    4145
    4246(define-parameter utc-timezone-locale (make-utc-timezone)
    4347  (lambda (obj)
    44     (cond ((timezone-components? obj) obj)
    45           (else
    46            (warning-argument-type 'utc-timezone-locale obj 'timezone-components)
    47            (utc-timezone-locale) ) ) ) )
     48    (cond
     49      ((timezone-components? obj)
     50        obj )
     51      (else
     52        (warning-argument-type 'utc-timezone-locale obj 'timezone-components)
     53        (utc-timezone-locale) ) ) ) )
    4854
    4955;;
    5056
    51 #; ;Unusued
     57#;;Unusued
    5258(define (make-timezone-locale nam off dst?)
    5359  (update-timezone-components! (make-timezone-components #f "SRFI 19")
     
    6066    (check-timezone-components 'timezone-locale-name tzc)
    6167    (let ((tzn (timezone-components-ref/dst? tzc 'dst-name 'std-name)))
    62       ; TZ may not be set
    63       (and (not (unknown-timezone-name? tzn))
    64            tzn ) ) ) )
     68      ;TZ may not be set
     69      (and
     70        (not (unknown-timezone-name? tzn))
     71        tzn ) ) ) )
    6572
    6673(define (timezone-locale-offset . tzc)
     
    6875    (check-timezone-components 'timezone-locale-offset tzc)
    6976    (let ((tzo (timezone-components-ref/dst? tzc 'dst-offset 'std-offset)))
    70       ; TZ may not be set but if it is then convert to ISO 8601
     77      ;TZ may not be set but if it is then convert to ISO 8601
    7178      (if tzo (- tzo)
    7279          0 ) ) ) )
     
    8895
    8996(define (checked-optional-timezone-info loc tzi)
    90   (cond ((not tzi)                    (utc-timezone-locale))
    91         ((boolean? tzi)               (local-timezone-locale))
    92         ((timezone-components? tzi)   tzi)
    93         ((fixnum? tzi)                tzi)
    94         (else
    95           (error-timezone-info loc tzi)) ) )
     97  (cond
     98    ((not tzi)                    (utc-timezone-locale))
     99    ((boolean? tzi)               (local-timezone-locale))
     100    ((timezone-components? tzi)   tzi)
     101    ((fixnum? tzi)                tzi)
     102    (else
     103      (error-timezone-info loc tzi)) ) )
    96104
    97105) ;module srfi-19-timezone
  • release/4/srfi-19/trunk/srfi-19.meta

    r26689 r34327  
    1313        (locale "0.6.6")
    1414        (srfi-29 "2.1.3")
    15         (check-errors "1.12.2")
    16         (record-variants "0.5"))
     15        (check-errors "1.12.2"))
    1716 (test-depends numbers format)
    1817 (files "srfi-19.scm" "srfi-19-common.scm" "srfi-19-io.scm" "tai-utc.dat" "srfi-19-time.scm" "TODO" "srfi-19-timezone.scm" "srfi-19.release-info" "it/srfi-19" "chicken-primitive-object-inlines.scm" "srfi-19.setup" "en/srfi-19" "srfi-19-core.scm" "de/srfi-19" "srfi-19-period.scm" "es/srfi-19" "srfi-19.meta" "srfi-19-date.scm" "nl/srfi-19" "srfi-19-support.scm" "tests/run.scm" "pt/br/srfi-19") )
  • release/4/srfi-19/trunk/srfi-19.scm

    r33841 r34327  
    11;;;; srfi-19.scm
    22
    3 (module srfi-19 (;export
     3(module srfi-19
     4
     5(;export
    46  ;; SRFI-19
    57  time-tai
     
    153155  seconds->date/type)
    154156
    155   (import scheme chicken
    156           srfi-19-timezone srfi-19-support srfi-19-time srfi-19-date srfi-19-io)
     157(import scheme)
    157158
    158   (require-library srfi-19-timezone srfi-19-support srfi-19-time srfi-19-date srfi-19-io)
     159(import chicken)
     160
     161(use srfi-19-timezone srfi-19-support srfi-19-time srfi-19-date srfi-19-io)
    159162
    160163) ;module srfi-19
  • release/4/srfi-19/trunk/srfi-19.setup

    r34116 r34327  
    1212(install-srfi-29-bundle 'srfi-19 'pt 'br)
    1313
    14 (setup-shared-extension-module 'srfi-19-timezone (extension-version "3.4.2")
     14(setup-shared-extension-module 'srfi-19-timezone (extension-version "3.4.3")
    1515        #:inline? #t
    1616        #:types? #t
    1717  #:compile-options '(-fixnum-arithmetic -optimize-level 3 -no-procedure-checks))
    1818
    19 (setup-shared-extension-module 'srfi-19-support (extension-version "3.4.2")
     19(setup-shared-extension-module 'srfi-19-support (extension-version "3.4.3")
    2020        #:inline? #t
    2121        #:types? #t
     
    2424    -no-procedure-checks -no-bound-checks -no-argc-checks))
    2525
    26 (setup-shared-extension-module 'srfi-19-time (extension-version "3.4.2")
     26(setup-shared-extension-module 'srfi-19-time (extension-version "3.4.3")
    2727        #:inline? #t
    2828        #:types? #t
    2929  #:compile-options '(-optimize-level 3 -no-procedure-checks))
    3030
    31 (setup-shared-extension-module 'srfi-19-date (extension-version "3.4.2")
     31(setup-shared-extension-module 'srfi-19-date (extension-version "3.4.3")
    3232        #:inline? #t
    3333        #:types? #t
    3434  #:compile-options '(-optimize-level 3 -no-procedure-checks))
    3535
    36 (setup-shared-extension-module 'srfi-19-io (extension-version "3.4.2")
     36(setup-shared-extension-module 'srfi-19-io (extension-version "3.4.3")
    3737        #:inline? #t
    3838        #:types? #t
    3939  #:compile-options '(-optimize-level 3 -no-procedure-checks))
    4040
    41 (setup-shared-extension-module 'srfi-19-period (extension-version "3.4.2")
     41(setup-shared-extension-module 'srfi-19-period (extension-version "3.4.3")
    4242        #:inline? #t
    4343        #:types? #t
    4444  #:compile-options '(-optimize-level 3 -no-procedure-checks))
    4545
    46 (setup-shared-extension-module 'srfi-19-core (extension-version "3.4.2")
     46(setup-shared-extension-module 'srfi-19-core (extension-version "3.4.3")
    4747        #:inline? #t
    4848        #:types? #t
    4949  #:compile-options '(-optimize-level 3 -no-procedure-checks))
    5050
    51 (setup-shared-extension-module 'srfi-19 (extension-version "3.4.2")
     51(setup-shared-extension-module 'srfi-19 (extension-version "3.4.3")
    5252        #:inline? #t
    5353        #:types? #t
  • release/4/srfi-19/trunk/tests/run.scm

    r33884 r34327  
    446446; Time Period
    447447
     448(use srfi-19-period)
     449
    448450;;
    449451
Note: See TracChangeset for help on using the changeset viewer.