Changeset 15788 in project


Ignore:
Timestamp:
09/08/09 05:31:02 (10 years ago)
Author:
Kon Lovett
Message:

Save.

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

Legend:

Unmodified
Added
Removed
  • release/4/srfi-19/trunk/srfi-19-core.scm

    r15754 r15788  
    11;;;; srfi-19.scm
    22
    3 (module srfi-19-core (;export
     3(module srfi-19-core (;export             ;DEPRECATED
    44  ;; SRFI-19
    55  time-tai
     
    144144
    145145  (import scheme chicken srfi-19-timezone srfi-19-support srfi-19-time srfi-19-date)
    146  
     146
    147147  (require-library srfi-19-timezone srfi-19-support srfi-19-time srfi-19-date)
    148148
  • release/4/srfi-19/trunk/srfi-19-date.scm

    r15755 r15788  
    7171  time-utc->modified-julian-day
    7272  ; Extensions
    73   seconds->date/type
     73  seconds->date seconds->date/type
    7474  read-leap-second-table
    7575  time->date
     
    132132(define (make-date ns sec min hr dy mn yr tzo . args)
    133133  (let-optionals args ((tzn #f) (dstf (void)))
    134     (cond ((timezone-components? tzo)
    135            ; Supplied parameters override
    136            (set! dstf (if (eq? (void) dstf) (timezone-locale-dst? tzo) dstf))
    137            (set! tzn (or tzn (timezone-locale-name tzo)))
    138            (set! tzo (timezone-locale-offset tzo)) )
    139           (else
    140            (when (eq? (void) dstf) (set! dstf #f)) ) )
     134    (let ((no-dstf (eq? (void) dstf)))
     135      (cond ((timezone-components? tzo)
     136             ; Supplied parameters override
     137             (set! dstf (if no-dstf (timezone-locale-dst? tzo) dstf))
     138             (set! tzn (or tzn (timezone-locale-name tzo)))
     139             (set! tzo (timezone-locale-offset tzo)) )
     140            (else
     141             (when no-dstf (set! dstf #f)) ) ) )
    141142    (check-date-elements 'make-date ns sec min hr dy mn yr tzo tzn)
    142143    (tm:make-date ns sec min hr dy mn yr tzo tzn dstf #f #f #f) ) )
     
    151152;; the optional 2nd argument. The default is #f.
    152153
    153 (define (seconds->date/type sec . tzi)
     154(define (seconds->date sec . tzi)
    154155  (check-raw-seconds 'seconds->date/type sec)
    155156  (let ((tzc (checked-optional-timezone-info 'seconds->date/type (optional tzi #t))))
    156157    (check-timezone-components 'seconds->date/type tzc)
    157158    (tm:seconds->date/type sec tzc) ) )
     159
     160(define seconds->date/type seconds->date)
    158161
    159162(define (current-date . tzi)
     
    259262    (let ((tim1 (tm:date->time dat1 tt))
    260263          (tim2 (tm:date->time dat2 tt)) )
    261       (unless tim1 (error-clock-type 'date-difference dat1))
    262       (unless tim2 (error-clock-type 'date-difference dat2))
     264      (unless tim1 (error-convert 'date-difference 'date 'time dat1))
     265      (unless tim2 (error-convert 'date-difference 'date 'time dat2))
    263266      (tm:time-difference tim1 tim2 (tm:some-time 'duration)) ) ) )
     267
     268(define (tm:time->date/tzi loc tim tzi)
     269  (let ((dat (tm:time->date tim)))
     270    (cond (dat
     271            (tm:date-timezone-info-set! dat tzi)
     272            dat )
     273          (else
     274            (error-convert loc 'time 'date tim) ) ) ) )
    264275
    265276(define (date-add-duration dat dur . args)
     
    267278  (check-duration 'date-add-duration dur)
    268279  (let-optionals args ((tt (default-date-clock-type)))
    269     (let ((tim (tm:date->time dat tt)))
    270       (unless tim (error-clock-type 'date-add-duration dat))
    271       (time->date (tm:add-duration tim dur (tm:as-some-time tim))) ) ) )
     280    (let ((tim (tm:date->time dat tt)) )
     281      (unless tim (error-convert 'date-add-duration 'date 'time dat))
     282      (tm:time->date/tzi 'date-add-duration
     283                         (tm:add-duration tim dur (tm:as-some-time tim))
     284                         (tm:date-timezone-info dat)) ) ) )
    272285
    273286(define (date-subtract-duration dat dur . args)
     
    275288  (check-duration 'date-subtract-duration dur)
    276289  (let-optionals args ((tt (default-date-clock-type)))
    277     (let ((tim (tm:date->time dat tt)))
    278       (unless tim (error-clock-type 'date-subtract-duration dat))
    279       (time->date (tm:subtract-duration tim dur (tm:as-some-time tim))) ) ) )
     290    (let ((tim (tm:date->time dat tt)) )
     291      (unless tim (error-convert 'date-subtract-duration 'date 'time dat))
     292      (tm:time->date/tzi 'date-subtract-duration
     293                         (tm:subtract-duration tim dur (tm:as-some-time tim))
     294                         (tm:date-timezone-info dat)) ) ) )
    280295
    281296;; Time to Date
     
    297312  (or (tm:time->date tim (checked-optional-timezone-info 'time->date (optional tzi #t)))
    298313      ; This shouldn't happen
    299       (error-clock-type 'time->date tim)) )
     314      (error-convert 'time->date 'time 'date tim)) )
    300315
    301316;; Date to Time
     
    352367(define (date-week-number dat . args)
    353368  (check-date 'date-week-number dat)
    354   (let ((day-of-week-starting-week (optional args 0)))
    355     (check-week-day 'date-week-number day-of-week-starting-week)
    356     (tm:date-week-number dat day-of-week-starting-week) ) )
     369  (let-optionals args ((1st-weekday 0))
     370    (check-week-day 'date-week-number 1st-weekday)
     371    (tm:date-week-number dat 1st-weekday) ) )
    357372
    358373;; Julian-day Operations
     
    383398  (check-time 'time->julian-day tim)
    384399  (or (tm:time->julian-day tim)
    385       (error-clock-type 'time->julian-day tim) ) )
     400      (error-convert 'time->julian-day 'time 'julian-day tim) ) )
    386401
    387402(define (time-utc->modified-julian-day tim)
     
    400415  (check-time 'time->modified-julian-day tim)
    401416  (or (tm:time->modified-julian-day tim)
    402       (error-clock-type 'time->modified-julian-day tim) ) )
     417      (error-convert 'time->modified-julian-day 'time 'modified-julian-day tim) ) )
    403418
    404419;; Julian-day to Time
  • release/4/srfi-19/trunk/srfi-19-io.scm

    r15776 r15788  
    3636  scan-date)
    3737
    38   (import (except scheme / number->string)
     38  (import (except scheme + / > exact->inexact number->string)
    3939          chicken
    40           #;srfi-1
     40          (only srfi-1 reverse!)
    4141          #;srfi-6
    4242          (only srfi-13 string-pad)
    4343          (only ports with-output-to-string)
    4444          (only data-structures noop)
    45           (only numbers / number->string)
     45          (only numbers + / > exact->inexact number->string)
    4646          srfi-29
    47           #;srfi-19-core
    4847          srfi-19-support)
    4948
    50   (require-library srfi-1 #;srfi-6 srfi-13 ports data-structures srfi-29 locale numbers
    51                    #;srfi-19-core srfi-19-support)
     49  (require-library srfi-1 #;srfi-6 srfi-13 ports data-structures
     50                   numbers srfi-29 locale srfi-19-support)
    5251
    5352;;;
     
    7473(define LOCALE-ABRV-WEEKDAYS '#(sun mon tue wed thu fri sat))
    7574(define LOCALE-LONG-WEEKDAYS '#(sunday monday tuesday wednesday thursday friday saturday))
     75
    7676(define LOCALE-ABRV-MONTHS '#(#f jan feb mar apr may jun jul aug sep oct nov dec))
    7777(define LOCALE-LONG-MONTHS '#(#f january february march april may june july august september october november december))
     
    100100;; portion of a number, limited by a specified precision
    101101
    102 (define (decimal-expansion r prec)
    103   (cond-expand
    104     (chicken
    105       (parameterize ((flonum-print-precision prec)) (number->string r)) )
    106     (else
    107       (let loop ((num (- r (round r)))
    108                  (p prec)
    109                  (ls '()))
    110         (if (or (fx= 0 p) (zero? num)) (apply string-append (reverse! ls))
    111             (let* ((num-times-10 (* 10 num))
    112                    (round-num-times-10 (round num-times-10)))
    113               (loop (- num-times-10 round-num-times-10)
    114                     (fx- p 1)
    115                     (cons (number->string (inexact->exact round-num-times-10)) ls)) ) ) ) ) ) )
     102(define (decimal-expansion frac prec)
     103  (let loop ((n (- frac (round frac))) (p prec) (ls '()))
     104    (if (or (fx= 0 p) (zero? n)) (apply string-append (reverse! ls))
     105        (let* ((n*10 (* 10 n))
     106               (rn*10 (round n*10)))
     107          (loop (- n*10 rn*10) (fx- p 1) (cons (number->string (inexact->exact rn*10)) ls)) ) ) ) )
    116108
    117109;; Returns a string rep. of number N, of minimum LENGTH,
     
    121113
    122114(define (padding n pad-with length)
    123   (define (trailing-dotzero? str len)
    124     (and (fx>= len 2)
    125          (char=? #\. (string-ref str (fx- len 2)))
    126          (char=? #\0 (string-ref str (fx- len 1))) ) )
    127115  (let* ((str (number->string n))
    128116         (len (string-length str)))
    129     (let ((str
    130            (if (not (trailing-dotzero? str len)) str
    131                (substring str 0 (fx- len 2)) ) ) )
     117    (define (trailing-dotzero?)
     118      (and (fx<= 2 len)
     119           (char=? #\. (string-ref str (fx- len 2)))
     120           (char=? #\0 (string-ref str (fx- len 1))) ) )
     121    (let ((str (if (not (trailing-dotzero?)) str
     122                   (substring str 0 (fx- len 2)) ) ) )
    132123      (if (or (not pad-with) (fx> len length)) str
    133124          (string-pad str length pad-with)) ) ) )
     
    220211        (let ((ns (tm:date-nanosecond date))
    221212              (sec (tm:date-second date)))
    222           (let ((f (decimal-expansion (/ ns NS/S) 6)))
     213          (if (> ns NS/S) ; This shouldn't happen!
     214              (display (padding (+ sec 1) pad-with 2) port)
     215              (display (padding sec pad-with 2) port))
     216          ; ns must be inexact for 'decimal-expansion'
     217          (let ((f (decimal-expansion (/ (exact->inexact ns) NS/S) 6)))
    223218            (when (fx< 0 (string-length f))
    224219              (display (item@ LOCALE-NUMBER-SEPARATOR) port)
     
    284279      (lambda (date pad-with port)
    285280        (let ((sec (tm:date-second date)))
    286           (display (padding sec pad-with 2) port))))
     281          (if (> (tm:date-nanosecond date) NS/S) ; This shouldn't happen!
     282              (display (padding (+ sec 1) pad-with 2) port)
     283              (display (padding sec pad-with 2) port)))))
    287284
    288285    (cons #\t
  • release/4/srfi-19/trunk/srfi-19-period.scm

    r15751 r15788  
    4040          type-checks
    4141          type-errors
    42           srfi-19-core
     42          srfi-19-time
     43          srfi-19-date
    4344          srfi-19-support)
    4445
    45   (require-library #;srfi-8 srfi-9-ext type-checks type-errors srfi-19-core srfi-19-support)
     46  (require-library #;srfi-8 srfi-9-ext type-checks type-errors
     47                   srfi-19-time srfi-19-date srfi-19-support)
    4648
    4749;;;
  • release/4/srfi-19/trunk/srfi-19-support.scm

    r15776 r15788  
    112112  error-incompatible-time-types
    113113  error-clock-type
     114  error-convert
    114115  error-date
    115116  error-date-nanoseconds
     
    193194  tm:date-yday
    194195  tm:date-jday
     196  tm:date-timezone-info
    195197  tm:date-nanosecond-set!
    196198  tm:date-second-set!
     
    201203  tm:date-year-set!
    202204  tm:date-zone-offset-set!
     205  tm:date-timezone-info-set!
    203206  tm:make-incomplete-date
    204207  tm:make-date
     
    257260          (only posix seconds->utc-time)
    258261          (only extras format read-line)
     262          (only data-structures conc)
    259263          (only ports with-input-from-port with-input-from-string)
    260264          (only numbers + - * / remainder quotient
     
    789793;;; Date Object (Public Immutable)
    790794
    791 ;;
    792 
    793 (define (clock-type? obj) (memq obj '(monotonic tai utc)))
    794 
    795795;; Leap Year Test
    796796
     
    828828  (tzo    *date-zone-offset *date-zone-offset-set!)
    829829  ;; non-srfi extn
    830   (tzn    *date-zone-name)
    831   (dstf   *date-dst?)
     830  (tzn    *date-zone-name   *date-zone-name-set!)
     831  (dstf   *date-dst?        *date-dst-set!)
    832832  (wdy    *date-wday        *date-wday-set!)
    833833  (ydy    *date-yday        *date-yday-set!)
     
    875875(define-check+error-type date-minutes)
    876876(define-check+error-type date-hours)
    877 (define-check+error-type date-day)
     877(define-error-type date-day)
     878(define (check-date-day loc obj mn yr) (unless (date-day? obj mn yr) (error-date-day loc obj)))
    878879(define-check+error-type date-month)
    879880(define-check+error-type date-year)
     
    901902;;
    902903
     904(define (clock-type? obj) (memq obj '(monotonic tai utc)))
     905
    903906(define-check+error-type clock-type)
     907
     908(define (error-convert loc obj srcnam dstnam)
     909  (signal-type-error loc (conc "cannot convert " srcnam " to " dstnam) obj) )
     910
    904911(define-check+error-type date)
    905912
     
    928935(define (tm:date-year-set! dat x) (*date-year-set! dat (gennum->?fixnum x)))
    929936(define (tm:date-zone-offset-set! dat x) (*date-zone-offset-set! dat (gennum->?fixnum x)))
     937
     938(define (tm:date-timezone-info dat)
     939  (list (*date-zone-name dat) (*date-zone-offset dat) (*date-dst? dat)) )
     940
     941(define (tm:date-timezone-info-set! dat tzi)
     942  (*date-zone-name-set! dat (car tzi))
     943  (*date-zone-offset-set! dat (cadr tzi))
     944  (*date-dst-set! dat (caddr tzi)) )
    930945
    931946;; Returns an invalid date record (for use by 'scan-date')
     
    10421057#; ;Original
    10431058(define (tm:time-utc->date tim tzi)
    1044   ; The tz-info is caller's rest parameter
    10451059  (let ((tzo tzi)
    10461060        (tzn #f)
     
    10591073
    10601074(define (tm:time-utc->date tim tzi)
    1061   ; The tz-info is caller's rest parameter
    10621075  (let ((tzo tzi)
    10631076        (tzn #f)
     
    12181231      (tm:cache-date-week-day dat) ) )
    12191232
    1220 (define (tm:days-before-first-week dat day-of-week-starting-week)
    1221   (fxmod (fx- day-of-week-starting-week (tm:week-day 1 1 (*date-year dat))) DY/WK) )
    1222 
    1223 (define (tm:date-week-number dat day-of-week-starting-week)
    1224   (fx/ (fx- (tm:date-year-day dat) (tm:days-before-first-week dat day-of-week-starting-week))
     1233(define (tm:days-before-first-week dat 1st-weekday)
     1234  (fxmod (fx- 1st-weekday (tm:week-day 1 1 (*date-year dat))) DY/WK) )
     1235
     1236(define (tm:date-week-number dat 1st-weekday)
     1237  (fx/ (fx- (tm:date-year-day dat) (tm:days-before-first-week dat 1st-weekday))
    12251238        DY/WK) )
    12261239
  • release/4/srfi-19/trunk/srfi-19-time.scm

    r15755 r15788  
    9090  time-negate
    9191  time-negate!
    92   seconds->time/type
    93   time->nanoseconds
     92  seconds->time seconds->time/type
    9493  nanoseconds->time
    9594  nanoseconds->seconds
     95  milliseconds->time
     96  milliseconds->seconds
     97  time->nanoseconds
    9698  time->milliseconds
    9799  time->seconds
    98   milliseconds->time
    99   milliseconds->seconds
    100100  time-compare)
    101101
     
    158158  (tm:copy-time tim) )
    159159
    160 ;; Converts a seconds value, may be fractional, into a time type.
    161 ;; The type of time default is time-duration.
    162 
    163 (define (seconds->time/type sec . args)
    164   (check-raw-seconds 'seconds->time/type sec)
    165   (let-optionals args ((tt 'duration))
    166     (check-time-type 'seconds->time/type tt)
    167     (tm:seconds->time sec tt) ) )
    168 
    169160;; Time record-type operations
    170161
     
    220211  (check-raw-milliseconds 'milliseconds->seconds ms)
    221212  (tm:milliseconds->seconds ms) )
     213
     214;; Converts a seconds value, may be fractional, into a time type.
     215;; The type of time default is time-duration.
     216
     217(define (seconds->time sec . args)
     218  (check-raw-seconds 'seconds->time/type sec)
     219  (let-optionals args ((tt 'duration))
     220    (check-time-type 'seconds->time/type tt)
     221    (tm:seconds->time sec tt) ) )
     222
     223(define seconds->time/type seconds->time)
    222224
    223225(define (time->nanoseconds tim)
     
    259261
    260262(define (srfi-18-time->time srfi-18-tim)
    261   (seconds->time/type (srfi-18:time->seconds srfi-18-tim) 'duration) )
     263  (seconds->time (srfi-18:time->seconds srfi-18-tim) 'duration) )
    262264
    263265(define (time->srfi-18-time tim)
  • release/4/srfi-19/trunk/srfi-19-timezone.scm

    r15754 r15788  
    1616
    1717  (import scheme chicken miscmacros locale type-checks type-errors)
    18  
     18
    1919  (require-library miscmacros locale type-checks type-errors)
    2020
  • release/4/srfi-19/trunk/srfi-19.scm

    r15754 r15788  
    150150
    151151  (import scheme chicken srfi-19-timezone srfi-19-support srfi-19-time srfi-19-date srfi-19-io)
    152  
     152
    153153  (require-library srfi-19-timezone srfi-19-support srfi-19-time srfi-19-date srfi-19-io)
    154154
  • release/4/srfi-19/trunk/srfi-19.setup

    r15776 r15788  
    2020
    2121(setup-shared-extension-module 'srfi-19-support (extension-version "3.0.0")
    22   #:compile-options '(-optimize-level 2 -debug-level 1) #;'(-optimize-level 4 -debug-level 0))
     22  #:compile-options '(-optimize-level 4 -debug-level 0))
    2323
    2424(setup-shared-extension-module 'srfi-19-time (extension-version "3.0.0")
Note: See TracChangeset for help on using the changeset viewer.