Changeset 35402 in project


Ignore:
Timestamp:
04/21/18 19:49:48 (6 months ago)
Author:
kon
Message:

fix date-adjust key synonym support

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

Legend:

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

    r34839 r35402  
    3535
    3636(;export
    37   ; SRFI-19
     37  ;SRFI-19
    3838  current-date
    3939  current-julian-day
     
    4848  date-year
    4949  date-zone-offset
    50   leap-year? ; Actually part of SRFI 19 but not in original document
     50  leap-year?          ;not in original document
    5151  date-year-day
    5252  days-in-month/year
     
    7676  time-utc->julian-day
    7777  time-utc->modified-julian-day
    78   ; Extensions
     78  ;Extensions
    7979  date-record-printer-format
    8080  seconds->date
     
    101101  time->modified-julian-day
    102102  date-compare
    103   ; DEPRECATED
     103  ;DEPRECATED
    104104  seconds->date/type)
    105105
     
    110110(import chicken)
    111111
    112 (import
    113   (only srfi-1 fold list-index)
    114   srfi-69
    115   #;srfi-8)
    116 (require-library
    117   srfi-1 srfi-69
    118   #;srfi-8)
    119 
    120 (import
     112(use
    121113  (only numbers
    122114    zero? negative? positive? real?))
    123 (require-library
    124   numbers)
    125 
    126 (import
     115
     116(use
     117  (only srfi-1
     118    fold list-index)
     119  (only srfi-69
     120    make-hash-table symbol-hash
     121    hash-table-exists? hash-table-ref/default hash-table-set!)
     122  #;srfi-8
    127123  (only locale-components
    128     check-timezone-components timezone-components?))
    129 (require-library
    130   locale-components)
    131 
    132 (use
     124    check-timezone-components timezone-components?)
    133125  miscmacros
    134126  type-checks type-errors
     
    209201      (cond
    210202        ((timezone-components? tzo)
    211           ; Supplied parameters override
     203          ;Supplied parameters override
    212204          (set! dstf (if no-dstf (timezone-locale-dst? tzo) dstf))
    213205          (set! tzn (or tzn (timezone-locale-name tzo)))
     
    232224    (tm:seconds->date/type (check-raw-seconds 'seconds->date sec) tzc) ) )
    233225
    234 (define seconds->date/type seconds->date) ; DEPRECATED
     226(define seconds->date/type seconds->date) ;DEPRECATED
    235227
    236228(define (current-date . tzi)
     
    318310
    319311(define (date-adjust dat amt key . args)
    320   (let-optionals args ((tt (default-date-clock-type)) )
    321     ((date-adjuster-ref 'date-adjust key)
    322       (check-date 'date-adjust dat)
    323       ((default-date-adjust-integer) (check-integer 'date-adjust amt))
    324       key
    325       ;only used for duration conversion
    326       tt) ) )
     312  (let-optionals args ((tt (default-date-clock-type)))
     313    (let-values (((key adjuster) (date-adjuster-ref 'date-adjust key)))
     314      (adjuster
     315        (check-date 'date-adjust dat)
     316        ((default-date-adjust-integer) (check-integer 'date-adjust amt))
     317        key
     318        ;only used for duration conversion
     319        tt) ) ) )
    327320
    328321(define (date-difference dat1 dat2 . args)
     
    411404;; Date Adjust Support
    412405
     406(define +date-adjust-synonym-map+ (make-hash-table eq? symbol-hash))
     407(define +date-adjuster-map+ (make-hash-table eq? symbol-hash))
     408
    413409(define (date-adjust-key? obj)
    414410  (hash-table-exists? +date-adjust-synonym-map+ obj) )
    415411
    416412(define (date-adjuster-ref loc key)
    417   (let ((key (hash-table-ref/default +date-adjust-synonym-map+ key 'UNKNOWN)))
    418     (hash-table-ref/default
    419       +date-adjuster-map+
     413  (let (
     414    (key (hash-table-ref/default +date-adjust-synonym-map+ key 'UNKNOWN)))
     415    (values
    420416      key
    421       (unknown-date-key-handler loc)) ) )
     417      (hash-table-ref/default +date-adjuster-map+ key (unknown-date-key-handler loc))) ) )
    422418
    423419(define (date-adjuster-set! key syns hdlr)
    424420  ;all are key
    425421  (hash-table-set! +date-adjust-synonym-map+ key key)
    426   (for-each
    427     (lambda (syn)
    428       (hash-table-set! +date-adjust-synonym-map+ syn key) )
    429     syns)
     422  (for-each (cut hash-table-set! +date-adjust-synonym-map+ <> key) syns)
    430423  ;adjuster for key
    431424  (hash-table-set! +date-adjuster-map+ key hdlr) )
    432 
    433 (define +date-adjust-synonym-map+ (make-hash-table eq? symbol-hash))
    434 (define +date-adjuster-map+ (make-hash-table eq? symbol-hash))
    435425
    436426(define date-key? date-adjust-key?)
     
    640630
    641631(define (date-key< a b)
    642   (< 0 (date-key-compare a b)) )
     632  (fx< 0 (date-key-compare a b)) )
    643633
    644634(define (date-key-compare a b)
  • release/4/srfi-19/trunk/srfi-19-io.scm

    r34327 r35402  
    4444(import chicken)
    4545
    46 (import
     46(use
     47  (only numbers
     48    + / > exact->inexact number->string))
     49
     50(use
    4751  #;srfi-6
    4852  (only srfi-1 drop)
     
    5054  (only ports with-output-to-string)
    5155  (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
     56    reverse-string-append alist-ref)
    6557  srfi-29
    6658  type-checks
     
    10597(define LOCALE-SHORT-DATE-FORMAT 'date)
    10698(define LOCALE-TIME-FORMAT 'time)
    107 
    108 ;; SRFI-29: Localization initialization
    109 
    110 (reset-locale-parameters)
    111 (load-best-available-bundle! (most-specific-bundle-specifier 'srfi-19))
    11299
    113100;; SRFI-29 Helper
     
    743730  (scan-date src (optional fmtstr (item@ LOCALE-DATE-TIME-FORMAT))) )
    744731
     732;;;
     733;;; Module Init
     734;;;
     735
     736;; SRFI-29: Localization initialization
     737
     738(reset-locale-parameters)
     739(load-best-available-bundle! (most-specific-bundle-specifier 'srfi-19))
     740
    745741) ;module srfi-19-io
  • release/4/srfi-19/trunk/srfi-19-support.scm

    r34839 r35402  
    267267(import chicken)
    268268
    269 (import
     269(use
     270  (only numbers
     271    + - * / remainder quotient
     272    abs round floor truncate
     273    real? integer? inexact? zero? negative? positive?
     274    = <= >= < >
     275    inexact->exact exact->inexact
     276    string->number))
     277
     278(use
    270279  (only srfi-1 fold)
    271280  (only posix
     
    276285    conc)
    277286  (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
     287    with-input-from-port with-input-from-string)
    295288  locale
    296289  record-variants
     
    440433
    441434(define (tm:read-tai-utc-data flnm)
    442 
     435  ;
    443436  (define (convert-jd jd)
    444437    (* (- (inexact->exact jd) TAI-EPOCH-IN-JD) SEC/DY))
    445 
     438  ;
    446439  (define (convert-sec sec)
    447440    (inexact->exact sec))
    448 
     441  ;
    449442  (define (read-data)
    450443    (let loop ((ls '()))
     
    459452                (if (< year FIRST-LEAP-YEAR) ls
    460453                (cons (cons (convert-jd jd) (convert-sec secs)) ls))) ) ) ) ) ) )
    461 
     454  ;
    462455  (with-input-from-port (open-input-file flnm) read-data) )
    463456
     
    747740          milliseconds microseconds nanoseconds)
    748741        (let ((nanos (+ (* milliseconds NS/MS) (* microseconds NS/MuS) nanoseconds))
    749           (secs (+ (* days SEC/DY) (* hours SEC/HR) (* minutes SEC/MIN) seconds)) )
     742        (secs (+ (* days SEC/DY) (* hours SEC/HR) (* minutes SEC/MIN) seconds)) )
    750743    (let-values (((ns-ns ns-secs)
    751744                  (normalize-nanoseconds (+ nanos (* (- secs (floor secs)) NS/S)))))
     
    928921(define (tm:add-duration tim1 dur timout)
    929922        (let-values (((ns sec)
    930                   (tm:nanoseconds->time-values
    931                     (+ (%time-nanosecond tim1) (%time-nanosecond dur)))) )
     923                (tm:nanoseconds->time-values
     924                  (+ (%time-nanosecond tim1) (%time-nanosecond dur)))) )
    932925    (let ((secs (+ (%time-second tim1) (%time-second dur) sec)))
    933926      (cond
     
    943936(define (tm:subtract-duration tim1 dur timout)
    944937  (let-values (((ns sec)
    945                     (tm:nanoseconds->time-values
    946                       (- (%time-nanosecond tim1) (%time-nanosecond dur)))) )
     938                (tm:nanoseconds->time-values
     939                  (- (%time-nanosecond tim1) (%time-nanosecond dur)))) )
    947940    #;(assert (zero? sec)) ;Since ns >= 0 the `sec' should be zero!
    948941    (let ((secs (- (%time-second tim1) (%time-second dur) sec)))
     
    10821075                  (let ((yr ?yr))
    10831076        (and
    1084           #; ;Not officially adopted!
     1077          #; ;!NOT Officially Adopted!
    10851078          (not (fx= (fxmod yr 4000) 0))
    10861079          (or
     
    15371530;; Gives the seconds/day/month/year
    15381531
    1539 #; ;Original
     1532#; ;original
    15401533(define (tm:decode-julian-day-number jdn)
    15411534  (let* ((days (floor jdn))
     
    15521545     (+ m 3 (* -12 (quotient m 10)))
    15531546     (if (>= 0 y) (- y 1) y)) ) )
    1554 
    15551547(define (tm:decode-julian-day-number jdn)
    15561548  (let* ((dys (number->genint (floor jdn)))
     
    15981590          (set! tzo (timezone-locale-offset tzi)) ) )
    15991591    (let-values (((secs dy mn yr)
    1600                     (tm:decode-julian-day-number
    1601                       (tm:seconds->julian-day-number (%time-second tim) tzo))) )
     1592                  (tm:decode-julian-day-number
     1593                    (tm:seconds->julian-day-number (%time-second tim) tzo))) )
    16021594      (let ((hr (fx/ secs SEC/HR))
    16031595            (rem (fxmod secs SEC/HR)))
     
    16531645        (yr (%date-year dat))
    16541646        (tzo (%date-zone-offset dat)) )
    1655     (let ((jdys
    1656             (- (tm:encode-julian-day-number dy mn yr) TAI-EPOCH-IN-JD))
     1647    (let ((jdys (- (tm:encode-julian-day-number dy mn yr) TAI-EPOCH-IN-JD))
    16571648          (secs
    16581649            (fx+
     
    17871778            (/ ns NS/S))) )
    17881779    (+ (- jdn ONE-HALF) (/ timsecs SEC/DY)) ) )
    1789 
    17901780#; ;inexact version
    17911781(define (tm:julian-day ns sec min hr dy mn yr tzo)
  • release/4/srfi-19/trunk/srfi-19-timezone.scm

    r34327 r35402  
    2727
    2828(define-inline (make-utc-timezone)
    29   (let ((tz (make-timezone-components "UTC0" (builtin-source-name))))
    30     (update-timezone-components! tz 'std-name "UTC" 'std-offset 0) ) )
     29  (let ((tzc (make-timezone-components "UTC0" (builtin-source-name))))
     30    (update-timezone-components! tzc 'std-name "UTC" 'std-offset 0) ) )
    3131
    3232(define-inline (timezone-components-ref/dst? tzc a b)
     
    3535;;
    3636
    37 (define-parameter local-timezone-locale (current-timezone-components)
    38   (lambda (obj)
     37(define-parameter local-timezone-locale #f
     38  (lambda (x)
    3939    (cond
    40       ((timezone-components? obj)
    41         obj )
     40      ((or (not x) (timezone-components? x))
     41        x )
    4242      (else
    43         (warning-argument-type 'local-timezone-locale obj 'timezone-components)
     43        (warning-argument-type 'local-timezone-locale x 'timezone-components)
    4444        (local-timezone-locale) ) ) ) )
    4545
    4646(define-parameter utc-timezone-locale (make-utc-timezone)
    47   (lambda (obj)
     47  (lambda (x)
    4848    (cond
    49       ((timezone-components? obj)
    50         obj )
     49      ((timezone-components? x)
     50        x )
    5151      (else
    52         (warning-argument-type 'utc-timezone-locale obj 'timezone-components)
     52        (warning-argument-type 'utc-timezone-locale x 'timezone-components)
    5353        (utc-timezone-locale) ) ) ) )
     54
     55;;
     56
     57(define (local-timezone-locale*)
     58  (or
     59    (local-timezone-locale)
     60    (begin
     61      (locale-setup)
     62      (local-timezone-locale (current-timezone-components))
     63      (local-timezone-locale) ) ) )
    5464
    5565;;
     
    6373
    6474(define (timezone-locale-name . tzc)
    65   (let ((tzc (optional tzc (local-timezone-locale))))
     75  (let ((tzc (optional tzc (local-timezone-locale*))))
    6676    (check-timezone-components 'timezone-locale-name tzc)
    6777    (let ((tzn (timezone-components-ref/dst? tzc 'dst-name 'std-name)))
     
    7282
    7383(define (timezone-locale-offset . tzc)
    74   (let ((tzc (optional tzc (local-timezone-locale))))
     84  (let ((tzc (optional tzc (local-timezone-locale*))))
    7585    (check-timezone-components 'timezone-locale-offset tzc)
    7686    (let ((tzo (timezone-components-ref/dst? tzc 'dst-offset 'std-offset)))
     
    8090
    8191(define (timezone-locale-dst? . tzc)
    82   (let ((tzc (optional tzc (local-timezone-locale))))
     92  (let ((tzc (optional tzc (local-timezone-locale*))))
    8393    (check-timezone-components 'timezone-locale-offset tzc)
    8494    (timezone-component-ref tzc 'dst?) ) )
     
    97107  (cond
    98108    ((not tzi)                    (utc-timezone-locale))
    99     ((boolean? tzi)               (local-timezone-locale))
     109    ((boolean? tzi)               (local-timezone-locale*))
    100110    ((timezone-components? tzi)   tzi)
    101111    ((fixnum? tzi)                tzi)
  • release/4/srfi-19/trunk/srfi-19.setup

    r34839 r35402  
    1212(install-srfi-29-bundle 'srfi-19 'pt 'br)
    1313
    14 (setup-shared-extension-module 'srfi-19-timezone (extension-version "3.5.0")
     14(setup-shared-extension-module 'srfi-19-timezone (extension-version "3.6.0")
    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.5.0")
     19(setup-shared-extension-module 'srfi-19-support (extension-version "3.6.0")
    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.5.0")
     26(setup-shared-extension-module 'srfi-19-time (extension-version "3.6.0")
    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.5.0")
     31(setup-shared-extension-module 'srfi-19-date (extension-version "3.6.0")
    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.5.0")
     36(setup-shared-extension-module 'srfi-19-io (extension-version "3.6.0")
    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.5.0")
     41(setup-shared-extension-module 'srfi-19-period (extension-version "3.6.0")
    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.5.0")
     46(setup-shared-extension-module 'srfi-19-core (extension-version "3.6.0")
    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.5.0")
     51(setup-shared-extension-module 'srfi-19 (extension-version "3.6.0")
    5252        #:inline? #t
    5353        #:types? #t
Note: See TracChangeset for help on using the changeset viewer.