Changeset 35403 in project


Ignore:
Timestamp:
04/21/18 20:52:02 (5 weeks ago)
Author:
kon
Message:

delay locale-setup until 1st need, add current-second-dst?, test has dst flag now

Location:
release/4/locale/trunk
Files:
8 edited

Legend:

Unmodified
Added
Removed
  • release/4/locale/trunk/locale-builtin.scm

    r35363 r35403  
    3030
    3131(define-constant BUILTIN-SOURCE "BUILTIN")
    32 (define (builtin-source-name) BUILTIN-SOURCE)
    33 (define (builtin-source-name? x) (equal? BUILTIN-SOURCE x))
     32
     33(define (builtin-source-name)
     34  BUILTIN-SOURCE )
     35
     36(define (builtin-source-name? x)
     37  (equal? BUILTIN-SOURCE x) )
    3438
    3539(define-constant UNKNOWN-LOCAL-TZ-NAME "XXXX")
    36 (define (unknown-timezone-name) UNKNOWN-LOCAL-TZ-NAME)
    37 (define (unknown-timezone-name? x) (equal? UNKNOWN-LOCAL-TZ-NAME x))
     40
     41(define (unknown-timezone-name)
     42  UNKNOWN-LOCAL-TZ-NAME )
     43
     44(define (unknown-timezone-name? x)
     45  (equal? UNKNOWN-LOCAL-TZ-NAME x) )
    3846
    3947;; Builtin Timezone
     
    4856(define (make-builtin-timezone)
    4957  ; Need local timezone info
    50   (let ((tv (current-local-time)))
    51     (let ((tzn (local-timezone-name tv)
    52                #; ;Not until Posix bug fixed
    53                (local-timezone-abbreviation))
    54           (tzo (vector-ref tv 9))
    55           (dst? (vector-ref tv 8)) )
    56       ; Since the tzo reflects the dst status need to fake the one not in effect.
    57       (if dst?
    58           (make-posix-timezone UNKNOWN-LOCAL-TZ-NAME (+ tzo DEFAULT-DST-OFFSET) tzn tzo)
    59           (make-posix-timezone tzn tzo UNKNOWN-LOCAL-TZ-NAME (- tzo DEFAULT-DST-OFFSET)) ) ) ) )
     58  (let* (
     59    (tv (current-local-time))
     60    (tzn (local-timezone-name tv)
     61          #; ;Not until Posix bug fixed
     62          (local-timezone-abbreviation))
     63    (tzo (vector-ref tv 9))
     64    (dst? (vector-ref tv 8)) )
     65    ; Since the tzo reflects the dst status need to fake the one not in effect.
     66    (if dst?
     67      (make-posix-timezone UNKNOWN-LOCAL-TZ-NAME (+ tzo DEFAULT-DST-OFFSET) tzn tzo)
     68      (make-posix-timezone tzn tzo UNKNOWN-LOCAL-TZ-NAME (- tzo DEFAULT-DST-OFFSET)) ) ) )
    6069
    6170(define (use-builtin-timezone)
    6271  (set-locale-category!
    63    'timezone
    64    (posix-timezone-string->timezone-components (make-builtin-timezone) BUILTIN-SOURCE)) )
     72    'timezone
     73    (posix-timezone-string->timezone-components (make-builtin-timezone) BUILTIN-SOURCE)) )
    6574
    6675;; Builtin Locale
     
    7483(define (use-builtin-locale)
    7584  (set-locale-category!
    76    'current
    77    (posix-locale-string->locale-components (make-builtin-locale-string) BUILTIN-SOURCE)) )
     85    'current
     86    (posix-locale-string->locale-components (make-builtin-locale-string) BUILTIN-SOURCE)) )
    7887
    7988;; Builtin Language List
    8089
    8190(define (use-builtin-language)
    82   (and-let* ((msglc (locale-category-ref 'current)))
    83     (let ((lc (make-locale-components (locale-component-ref msglc 'name) BUILTIN-SOURCE 'language)))
     91  (and-let* (
     92    (msglc (locale-category-ref 'current)) )
     93    (let (
     94      (lc
     95        (make-locale-components
     96          (locale-component-ref msglc 'name)
     97          BUILTIN-SOURCE
     98          'language)) )
    8499      (update-locale-components! lc 'locales (list msglc))
    85100      (set-locale-category! 'language lc) ) ) )
  • release/4/locale/trunk/locale-categories.scm

    r35363 r35403  
    3131  (tbl locale-dictionary-table) )
    3232
    33 (define (make-locale-dictionary) (%make-locale-dictionary (make-dict)))
     33(define (make-locale-dictionary)
     34  (%make-locale-dictionary (make-dict)) )
    3435
    3536(define-check+error-type locale-dictionary)
     
    3839
    3940(define (set-locale-dictionary-category! rec key val)
    40   (check-locale-dictionary 'set-locale-dictionary-category! rec)
    4141  (check-symbol 'set-locale-dictionary-category! key)
    42   (let ((tbl (locale-dictionary-table rec)))
     42  (let (
     43    (tbl
     44      (locale-dictionary-table
     45        (check-locale-dictionary 'set-locale-dictionary-category! rec))) )
    4346    (cond
    4447      ((not val)
     
    6063
    6164(define-parameter current-locale-dictionary (make-locale-dictionary)
    62   (lambda (obj)
     65  (lambda (x)
    6366    (cond
    64       ((locale-dictionary? obj)
    65         obj)
     67      ((locale-dictionary? x)
     68        x )
    6669      (else
    67         (warning 'current-locale-dictionary (make-error-type-message "locale-dictionary") obj)
     70        (warning 'current-locale-dictionary (make-error-type-message "locale-dictionary") x)
    6871        (current-locale-dictionary) ) ) ) )
    6972
  • release/4/locale/trunk/locale-components.scm

    r35363 r35403  
    6868(import scheme chicken)
    6969(use
    70   (only srfi-1 last-pair every alist-cons fold)
     70  (only srfi-1 last-pair every alist-cons)
    7171  type-checks type-errors)
    7272
    7373;;;
     74
     75;;fx-utils
     76
     77(: fxnegative? (fixnum --> boolean))
     78;
     79(define (fxnegative? n)
     80  (fx> 0 n) )
     81
     82(: fxabs (fixnum --> fixnum))
     83;
     84(define (fxabs n)
     85  (if (fxnegative? n) (fxneg n) n) )
    7486
    7587;;
     
    92104(define-inline (*locale-component-ref loc lc what def)
    93105  (let ((cell (assq what lc)))
    94     (if cell (cdr cell)
     106    (if cell
     107      (cdr cell)
    95108      def ) ) )
    96109
     
    99112(define (*set-locale-component! loc lc what value checker)
    100113  (checker loc what value)
    101   (if (null? lc) (alist-cons what value lc)
     114  (if (null? lc)
     115    (alist-cons what value lc)
    102116    (let ((cell (assq what lc)))
    103117      (cond
    104         (cell (set-cdr! cell value))
    105         (else (set-cdr! (last-pair lc) (list (cons what value)))))
     118        (cell
     119          (set-cdr! cell value))
     120        (else
     121          (set-cdr! (last-pair lc) (list (cons what value)))))
    106122      lc ) ) )
     123
     124#;
     125(define (*delete-locale-component! loc lc what)
     126  (check-symbol loc what 'key)
     127  (if (null? lc)
     128    lc
     129    () ) )
    107130
    108131(define (*update-locale-components! loc lc kvs checker)
    109132  (let loop ((kvs kvs))
    110133    (cond
    111       ((null? kvs) lc)
     134      ((null? kvs)
     135        lc )
    112136      (else
    113137        (set! lc (*set-locale-component! loc lc (car kvs) (cadr kvs) checker))
     
    115139
    116140(define (*locale-components=? a b)
    117   (or (eq? a b)
    118       (and (fx= (length a) (length b))
    119            (fold
    120              (lambda (elma flg)
    121                (and flg
    122                     (and-let* ((elmb (assq (car elma) b)))
    123                       (equal? (cdr elma) (cdr elmb)) ) ) )
    124              #t
    125              a) ) ) )
     141  (or
     142    (eq? a b)
     143    (and
     144      (fx= (length a) (length b))
     145      (foldl
     146        (lambda (flg elma)
     147          (and
     148            flg
     149            (and-let* (
     150              (elmb (assq (car elma) b)) )
     151              (equal? (cdr elma) (cdr elmb)) ) ) )
     152        #t
     153        a) ) ) )
    126154
    127155;;; Locale Components
     
    169197
    170198(define (make-locale-components nam . args)
    171   (let-optionals args ((src #f) (tag 'locale))
     199  (let-optionals args (
     200    (src #f)
     201    (tag 'locale))
    172202    (*make-locale-components 'make-locale-components nam src tag) ) )
    173203
    174204(define (locale-components? obj)
    175   (and (pair? obj)
    176        (*locale-component-exists? 'locale-components? obj 'tag)
    177        (*locale-component-exists? 'locale-components? obj 'name)
    178        (*locale-component-exists? 'locale-components? obj 'source)) )
     205  (and
     206    (pair? obj)
     207    (*locale-component-exists? 'locale-components? obj 'tag)
     208    (*locale-component-exists? 'locale-components? obj 'name)
     209    (*locale-component-exists? 'locale-components? obj 'source)) )
    179210
    180211(define-check+error-type locale-components)
    181212
    182213(define (locale-components=? a b)
    183   (check-locale-components 'locale-components=? a)
    184   (check-locale-components 'locale-components=? b)
    185   (*locale-components=? a b) )
     214  (*locale-components=?
     215    (check-locale-components 'locale-components=? a)
     216    (check-locale-components 'locale-components=? b)) )
    186217
    187218(define (locale-component-exists? lc what)
    188   (check-locale-components 'locale-component-exists? lc)
    189   (*locale-component-exists? 'locale-component-exists? lc what) )
     219  (*locale-component-exists? 'locale-component-exists?
     220    (check-locale-components 'locale-component-exists? lc)
     221    what) )
    190222
    191223(define (locale-component-ref lc what . def)
    192   (check-locale-components 'locale-component-ref lc)
    193   (*locale-component-ref 'locale-component-ref lc what (optional def #f)) )
     224  (*locale-component-ref 'locale-component-ref
     225    (check-locale-components 'locale-component-ref lc)
     226    what (optional def #f)) )
    194227
    195228(define (set-locale-component! lc what value)
    196   (check-locale-components 'set-locale-component! lc)
    197   (*set-locale-component! 'set-locale-component! lc what value check-locale-component) )
     229  (*set-locale-component! 'set-locale-component!
     230    (check-locale-components 'set-locale-component! lc)
     231    what value check-locale-component) )
     232
     233#;
     234(define (delete-locale-component! lc what)
     235  (*delete-locale-component! 'delete-locale-component!
     236    (check-locale-components 'delete-locale-component! lc)
     237    what check-locale-component) )
    198238
    199239(define (update-locale-components! lc . args)
    200   (check-locale-components 'update-locale-components! lc)
    201   (*update-locale-components! 'update-locale-components! lc args check-locale-component) )
     240  (*update-locale-components! 'update-locale-components!
     241    (check-locale-components 'update-locale-components! lc)
     242    args check-locale-component) )
    202243
    203244;;; Timezone Daylight Saving Time Rule
     
    207248(define-constant SEC/DY 86400)
    208249(define (timezone-offset? obj)
    209   (and (fixnum? obj) (let ((atzo (abs obj))) (and (fx<= 0 atzo) (fx< atzo SEC/DY)))) )
     250  (and
     251    (fixnum? obj)
     252    (let (
     253      (atzo (fxabs obj)) )
     254      (and (fx<= 0 atzo) (fx< atzo SEC/DY)))) )
    210255
    211256(define-check+error-type timezone-offset)
     
    223268  (o timezone-dst-rule-julian-noleap-offset) )
    224269
    225 (define (timezone-dst-rule-julian-noleap-day? obj) (and (fixnum? obj) (<= 1 obj 365)))
     270(define (timezone-dst-rule-julian-noleap-day? obj)
     271  (and (fixnum? obj) (<= 1 obj 365)) )
    226272
    227273(define-check+error-type timezone-dst-rule-julian-noleap-day)
    228274
    229275(define (make-timezone-dst-rule-julian-noleap j o)
     276  (%make-timezone-dst-rule-julian-noleap
    230277  (check-timezone-dst-rule-julian-noleap-day 'make-timezone-dst-rule-julian-noleap j)
    231   (check-timezone-offset 'make-timezone-dst-rule-julian-noleap o)
    232   (%make-timezone-dst-rule-julian-noleap j o) )
     278  (check-timezone-offset 'make-timezone-dst-rule-julian-noleap o)) )
    233279
    234280;;
     
    243289  (o timezone-dst-rule-julian-leap-offset) )
    244290
    245 (define (timezone-dst-rule-julian-leap-day? obj) (and (fixnum? obj) (<= 0 obj 365)))
     291(define (timezone-dst-rule-julian-leap-day? obj)
     292  (and (fixnum? obj) (<= 0 obj 365)) )
    246293
    247294(define-check+error-type timezone-dst-rule-julian-leap-day)
    248295
    249296(define (make-timezone-dst-rule-julian-leap j o)
     297  (%make-timezone-dst-rule-julian-leap
    250298  (check-timezone-dst-rule-julian-leap-day 'make-timezone-dst-rule-julian-leap j)
    251   (check-timezone-offset 'make-timezone-dst-rule-julian-leap o)
    252   (%make-timezone-dst-rule-julian-leap j o) )
    253 
    254 ;;
    255 
    256 (define (timezone-dst-rule-julian? r) (or (timezone-dst-rule-julian-noleap? r) (timezone-dst-rule-julian-leap? r)))
     299  (check-timezone-offset 'make-timezone-dst-rule-julian-leap o)) )
     300
     301;;
     302
     303(define (timezone-dst-rule-julian? r)
     304  (or (timezone-dst-rule-julian-noleap? r) (timezone-dst-rule-julian-leap? r)) )
    257305
    258306(define-error-type timezone-dst-rule-julian)
     
    260308(define (timezone-dst-rule-julian r)
    261309  (cond
    262     ((timezone-dst-rule-julian-noleap? r) (timezone-dst-rule-julian-noleap-day r))
    263     ((timezone-dst-rule-julian-leap? r) (timezone-dst-rule-julian-leap-day r))
     310    ((timezone-dst-rule-julian-noleap? r)
     311      (timezone-dst-rule-julian-noleap-day r))
     312    ((timezone-dst-rule-julian-leap? r)
     313      (timezone-dst-rule-julian-leap-day r))
    264314    (else
    265315      (error-timezone-dst-rule-julian 'timezone-dst-rule-julian r) ) ) )
     
    280330  (o timezone-dst-rule-mwd-offset) )
    281331
    282 (define (timezone-dst-rule-mwd-day? obj) (and (fixnum? obj) (<= 0 obj 6)))
    283 (define (timezone-dst-rule-mwd-week? obj) (and (fixnum? obj) (<= 1 obj 5)))
    284 (define (timezone-dst-rule-mwd-month? obj) (and (fixnum? obj) (<= 1 obj 12)))
     332(define (timezone-dst-rule-mwd-day? obj)
     333  (and (fixnum? obj) (<= 0 obj 6)) )
     334
     335(define (timezone-dst-rule-mwd-week? obj)
     336  (and (fixnum? obj) (<= 1 obj 5)) )
     337
     338(define (timezone-dst-rule-mwd-month? obj)
     339  (and (fixnum? obj) (<= 1 obj 12)) )
    285340
    286341(define-check+error-type timezone-dst-rule-mwd-day)
     
    291346
    292347(define (make-timezone-dst-rule-mwd m w d o)
    293   (check-timezone-dst-rule-mwd-month 'make-timezone-dst-rule-mwd m)
    294   (check-timezone-dst-rule-mwd-week 'make-timezone-dst-rule-mwd w)
    295   (check-timezone-dst-rule-mwd-day 'make-timezone-dst-rule-mwd d)
    296   (check-timezone-offset 'make-timezone-dst-rule-mwd o)
    297   (%make-timezone-dst-rule-mwd m w d o) )
     348  (%make-timezone-dst-rule-mwd
     349    (check-timezone-dst-rule-mwd-month 'make-timezone-dst-rule-mwd m)
     350    (check-timezone-dst-rule-mwd-week 'make-timezone-dst-rule-mwd w)
     351    (check-timezone-dst-rule-mwd-day 'make-timezone-dst-rule-mwd d)
     352    (check-timezone-offset 'make-timezone-dst-rule-mwd o)) )
    298353
    299354(define (timezone-dst-rule-month r)
    300   (check-timezone-dst-rule-mwd 'timezone-dst-rule-month r)
    301   (timezone-dst-rule-mwd-month r) )
     355  (timezone-dst-rule-mwd-month
     356    (check-timezone-dst-rule-mwd 'timezone-dst-rule-month r)) )
    302357
    303358(define (timezone-dst-rule-week r)
    304   (check-timezone-dst-rule-mwd 'timezone-dst-rule-week r)
    305   (timezone-dst-rule-mwd-week r) )
     359  (timezone-dst-rule-mwd-week
     360    (check-timezone-dst-rule-mwd 'timezone-dst-rule-week r)) )
    306361
    307362(define (timezone-dst-rule-day r)
    308   (check-timezone-dst-rule-mwd 'timezone-dst-rule-day r)
    309   (timezone-dst-rule-mwd-day r) )
     363  (timezone-dst-rule-mwd-day
     364    (check-timezone-dst-rule-mwd 'timezone-dst-rule-day r)) )
    310365
    311366;;
    312367
    313368(define (timezone-dst-rule? obj)
    314   (or (timezone-dst-rule-julian-noleap? obj)
    315       (timezone-dst-rule-julian-leap? obj)
    316       (timezone-dst-rule-mwd? obj) ) )
     369  (or
     370    (timezone-dst-rule-julian-noleap? obj)
     371    (timezone-dst-rule-julian-leap? obj)
     372    (timezone-dst-rule-mwd? obj) ) )
    317373
    318374(define-error-type timezone-dst-rule)
     
    320376(define (timezone-dst-rule-offset r)
    321377  (cond
    322     ((timezone-dst-rule-julian-noleap? r) (timezone-dst-rule-julian-noleap-offset r))
    323     ((timezone-dst-rule-julian-leap? r) (timezone-dst-rule-julian-leap-offset r))
    324     ((timezone-dst-rule-mwd? r) (timezone-dst-rule-mwd-offset r))
     378    ((timezone-dst-rule-julian-noleap? r)
     379      (timezone-dst-rule-julian-noleap-offset r))
     380    ((timezone-dst-rule-julian-leap? r)
     381      (timezone-dst-rule-julian-leap-offset r))
     382    ((timezone-dst-rule-mwd? r)
     383      (timezone-dst-rule-mwd-offset r))
    325384    (else
    326385      (error-timezone-dst-rule 'timezone-dst-rule-offset r) ) ) )
  • release/4/locale/trunk/locale-current.scm

    r35363 r35403  
    1515  current-timezone-components
    1616  current-locale-components
     17  current-second-dst?
     18  ;
    1719  locale-setup)
    1820
     
    2830;;;
    2931
    30 (define-inline (current-dstflag)
    31   (vector-ref (seconds->local-time (current-seconds)) 8) )
     32(define *setup?* #f)
     33
     34(define-inline (ensure-setup)
     35  (unless *setup?*
     36    (set! *setup?* #t)
     37    (locale-setup)) )
    3238
    3339(define-inline (locale-category+component-ref catnam cmpnam)
    34   (and-let* ((lc (locale-category-ref catnam))) (locale-component-ref lc cmpnam)) )
     40  (and-let* (
     41    (lc (locale-category-ref catnam)) )
     42    (locale-component-ref lc cmpnam)) )
    3543
    3644(define-inline (language-components? obj)
     
    4250
    4351(define (current-timezone . args)
    44   (if (null? args) (locale-category+component-ref 'timezone 'name)
     52  (ensure-setup)
     53  (if (null? args)
     54    (locale-category+component-ref 'timezone 'name)
    4555    (let-optionals args ((obj #f) (src "USER"))
    4656      (cond
     
    6171
    6272(define (current-locale . args)
    63   (if (null? args) (locale-category+component-ref 'current 'name)
     73  (ensure-setup)
     74  (if (null? args)
     75    (locale-category+component-ref 'current 'name)
    6476    (let-optionals args ((obj #f) (src "USER"))
    6577      (cond
     
    7890;;
    7991
    80 (define (current-timezone-components) (locale-category-ref 'timezone))
    81 (define (current-locale-components) (locale-category-ref 'current))
     92(define (current-timezone-components)
     93  (ensure-setup)
     94  (locale-category-ref 'timezone) )
     95
     96(define (current-locale-components)
     97  (ensure-setup)
     98  (locale-category-ref 'current) )
     99
     100(define (current-second-dst?)
     101  (vector-ref (seconds->local-time (current-seconds)) 8) )
    82102
    83103;;
     
    86106  ;Native locale system 1st
    87107  ;FIXME platform locale system here
     108  ;
    88109  ;Posix locale system 2nd
    89110  (unless (current-timezone) (posix-load-timezone))
    90111  (unless (current-locale) (posix-load-locale))
     112  ;
     113  ;GNU locale system extension
    91114  (unless (locale-category-ref 'language)
    92115    ;GNU says only obey when locale specified
    93116    (when (current-locale) (gnu-load-locale)) )
     117  ;
    94118  ;Builtin (faked) locale system last
    95119  (unless (current-timezone) (use-builtin-timezone))
    96120  (unless (current-locale) (use-builtin-locale))
     121  ;
     122  ;Utility check
     123  (unless (current-timezone-components) (warning "cannot determine a timezone"))
     124  (unless (current-locale-components) (warning "cannot determine a locale"))
     125  ;
    97126  ;Chicken platform extensions
    98127  (when (current-timezone-components)
    99     (set-timezone-component! (current-timezone-components) 'dst? (current-dstflag)) ) )
    100 
    101 ;;;
    102 ;;; Module Init
    103 ;;;
    104 
    105 (locale-setup)
    106 (unless (current-timezone-components) (warning "cannot determine a timezone") )
    107 (unless (current-locale-components) (warning "cannot determine a locale") )
     128    (set-timezone-component! (current-timezone-components) 'dst? (current-second-dst?))) )
    108129
    109130) ;module locale
  • release/4/locale/trunk/locale-posix.scm

    r35363 r35403  
    3434;;;
    3535
     36;;fx-utils
     37
     38(: fxnegative? (fixnum --> boolean))
     39;
     40(define (fxnegative? n)
     41  (fx> 0 n) )
     42
     43(: fxabs (fixnum --> fixnum))
     44;
     45(define (fxabs n)
     46  (if (fxnegative? n) (fxneg n) n) )
     47
     48;;
     49
     50(define-type locale-components list)
     51
     52;;
     53
    3654(define-constant SEC/HR   3600)
    3755(define-constant SEC/MIN  60)
     
    4058
    4159(define (nonnull-getenv varnam)
    42   (let ((str (get-environment-variable varnam)))
    43     (and (string? str) (not (string-null? str))
    44          str ) ) )
     60  (let (
     61    (str (get-environment-variable varnam)) )
     62    (and
     63      (string? str) (not (string-null? str))
     64      str ) ) )
    4565
    4666;;; Utility
    4767
    4868(define (seconds->h:m:s-string secs)
    49   (let* ((asecs (abs secs))
    50          (rsecs (remainder asecs SEC/HR)) )
    51     (conc (if (negative? secs) #\- #\+) (quotient asecs SEC/HR)
    52           #\: (quotient rsecs SEC/MIN)
    53           #\: (remainder rsecs SEC/MIN)) ) )
     69  (let* (
     70    (asecs (fxabs secs))
     71    (rsecs (fxmod asecs SEC/HR)) )
     72    (conc
     73      (if (fxnegative? secs) #\- #\+) (fx/ asecs SEC/HR)
     74      #\: (fx/ rsecs SEC/MIN)
     75      #\: (fxmod rsecs SEC/MIN)) ) )
    5476
    5577(define (make-posix-timezone dst-tzn dst-off std-tzn std-off)
    56   (string-append dst-tzn (seconds->h:m:s-string dst-off) std-tzn (seconds->h:m:s-string std-off)) )
     78  (string-append
     79    dst-tzn (seconds->h:m:s-string dst-off)
     80    std-tzn (seconds->h:m:s-string std-off)) )
    5781
    5882;;; Timezone
     
    6892
    6993(define parse-posix-literal-timezone
    70   (let ((name-re (regexp "(^[^<:][^0-9,+-]+)|^<([^>]+)>"))
    71         (offset-re (regexp "^(\\+|-)?([0-9]+)(:[0-9]+)?(:[0-9]+)?"))
    72         ;For compatibility with System V Release 3.1, a semicolon (`;') may be
    73         ;used to separate the rule from the rest of the specification.
    74         ;Allow it to separate the "to DST" & "from DST" segments since no harm, no foul.
    75         (date-re (regexp "^[;,]([JM])?([0-9]+)(\\.[0-9]+)?(\\.[0-9]+)?"))
    76         (time-re (regexp "^/([0-9]+)(:[0-9]+)?(:[0-9]+)?"))
    77         (+0200hrs+ (* 2 SEC/HR)) )
     94  (let (
     95    (name-re (regexp "(^[^<:][^0-9,+-]+)|^<([^>]+)>"))
     96    (offset-re (regexp "^(\\+|-)?([0-9]+)(:[0-9]+)?(:[0-9]+)?"))
     97    ;For compatibility with System V Release 3.1, a semicolon (`;') may be
     98    ;used to separate the rule from the rest of the specification.
     99    ;Allow it to separate the "to DST" & "from DST" segments since no harm, no foul.
     100    (date-re (regexp "^[;,]([JM])?([0-9]+)(\\.[0-9]+)?(\\.[0-9]+)?"))
     101    (time-re (regexp "^/([0-9]+)(:[0-9]+)?(:[0-9]+)?"))
     102    (+0200hrs+ (fx* 2 SEC/HR)) )
     103    ;
    78104    (lambda (tz str)
    79       (let ((strpos 0)
    80             (strend (string-length str)) )
     105      (let (
     106        (strpos 0)
     107        (strend (string-length str)) )
     108        ;
    81109        (letrec (
    82             (fail
    83               (lambda (msg)
    84                 (error 'parse-posix-literal-timezone msg str) ) )
    85             (next-match
    86               (lambda (re)
    87                 (and-let* ((ml (string-search re str strpos)))
    88                   (set! strpos (+ strpos (string-length (car ml))))
    89                   ml ) ) )
    90             (all-parsed
    91               (lambda ()
    92                 (or (<= strend strpos)
    93                     (fail "bad timezone format") ) ) )
    94             (parse-number
    95               (lambda (numstr)
     110          ;
     111          (fail
     112            (lambda (msg)
     113              (error 'parse-posix-literal-timezone msg str) ) )
     114          ;
     115          (next-match
     116            (lambda (re)
     117              (and-let* (
     118                (ml (string-search re str strpos)) )
     119                (set! strpos (fx+ strpos (string-length (car ml))))
     120                ml ) ) )
     121          ;
     122          (all-parsed
     123            (lambda ()
     124              (or
     125                (<= strend strpos)
     126                (fail "bad timezone format") ) ) )
     127          ;
     128          (parse-number
     129            (lambda (numstr)
     130              (cond
     131                ((not numstr)
     132                  0 )
     133                ((char-numeric? (string-ref numstr 0))
     134                  (string->number numstr) )
     135                (else
     136                  (fail "bad timezone number") ) ) ) )
     137          ;
     138          (parse-delmcomp
     139            (lambda (numstr delm)
     140              (parse-number
     141                (if (not (and numstr (string-prefix? delm numstr)))
     142                  numstr
     143                  (string-trim numstr (string-ref delm 0)) ) ) ) )
     144          ;
     145          (parse-timecomp
     146            (lambda (numstr)
     147              (parse-delmcomp numstr ":")) )
     148          ;
     149          (parse-daterulecomp
     150            (lambda (numstr)
     151              (parse-delmcomp numstr ".")) )
     152          ;
     153          (hms->offset
     154            (lambda (sgnstr hms-lst)
     155              (and-let* (
     156                (hr (parse-number (car hms-lst)))
     157                (mn (parse-timecomp (cadr hms-lst)))
     158                (sc (parse-timecomp (caddr hms-lst))) )
     159                (let (
     160                  (secs (fx+ (fx* hr SEC/HR) (fx+ (fx* mn SEC/MIN) sc))) )
     161                  (if (and sgnstr (string=? sgnstr "-"))
     162                    (fxneg secs)
     163                    secs)) ) ) )
     164          ;
     165          (decode-dst-rule
     166            (lambda (rulstr dat-lst off)
     167              ;Must begin w/ a valid integer. Interpreted later.
     168              (and-let* (
     169                (n1 (parse-number (car dat-lst))) )
    96170                (cond
    97                   ((not numstr) 0 )
    98                   ((char-numeric? (string-ref numstr 0)) (string->number numstr) )
     171                  ((not rulstr) ;Julian Leap rule
     172                    (make-timezone-dst-rule-julian-leap n1 off) )
     173                  ;select rule kind & interpret rest of match
    99174                  (else
    100                     (fail "bad timezone number") ) ) ) )
    101             (parse-delmcomp
    102               (lambda (numstr delm)
    103                 (parse-number
    104                   (if (not (and numstr (string-prefix? delm numstr))) numstr
    105                       (string-trim numstr (string-ref delm 0)) ) ) ) )
    106             (parse-timecomp
    107               (lambda (numstr)
    108                 (parse-delmcomp numstr ":")) )
    109             (parse-daterulecomp
    110               (lambda (numstr)
    111                 (parse-delmcomp numstr ".")) )
    112             (hms->offset
    113               (lambda (sgnstr hms-lst)
    114                 (and-let* ((hr (parse-number (car hms-lst)))
    115                            (mn (parse-timecomp (cadr hms-lst)))
    116                            (sc (parse-timecomp (caddr hms-lst))) )
    117                   (let ((secs (+ (* hr SEC/HR) (* mn SEC/MIN) sc)))
    118                     (if (and sgnstr (string=? sgnstr "-")) (- secs) secs)) ) ) )
    119             (decode-dst-rule
    120               (lambda (rulstr dat-lst off)
    121                 ;Must begin w/ a valid integer. Interpreted later.
    122                 (and-let* ((n1 (parse-number (car dat-lst))))
    123                   (cond ((not rulstr) ;Julian Leap rule
    124                           (make-timezone-dst-rule-julian-leap n1 off) )
    125                       ; select rule kind & interpret rest of match
     175                    (case (string-ref rulstr 0)
     176                      ((#\J)  ;Julian No-Leap rule
     177                        (make-timezone-dst-rule-julian-noleap n1 off) )
     178                      ((#\M)  ;Date
     179                        (and-let* (
     180                          (n (parse-daterulecomp (cadr dat-lst)))
     181                          (d (parse-daterulecomp (caddr dat-lst))) )
     182                          (make-timezone-dst-rule-mwd n1 n d off) ) )
    126183                      (else
    127                         (case (string-ref rulstr 0)
    128                           ((#\J)  ; Julian No-Leap rule
    129                             (make-timezone-dst-rule-julian-noleap n1 off) )
    130                           ((#\M)  ; Date
    131                             (and-let* ((n (parse-daterulecomp (cadr dat-lst)))
    132                                        (d (parse-daterulecomp (caddr dat-lst))) )
    133                               (make-timezone-dst-rule-mwd n1 n d off) ) )
    134                           (else
    135                             (fail "unknown timezone DST rule type") ) ) ) ) ) ) )
    136             (parse-dst-rule
    137               (lambda (key)
    138                 (and-let* ((d-m (next-match date-re)))
    139                   ;Time component is optional & defaults to 02:00:00
    140                   (let* ((t-m (next-match time-re))
    141                          (off (if t-m (hms->offset #f (cdr t-m)) +0200hrs+)) )
    142                     (set-timezone-component! tz key (decode-dst-rule (cadr d-m) (cddr d-m) off))
    143                     #t ) ) ) )
    144             (dst-parse
    145               (lambda ()
    146                 ;DST section is optional
    147                 (let ((n-m (next-match name-re)))
    148                   (or (not n-m)
    149                       ; Offset is optional & defaults to 1hr
    150                       (let* ((o-m (next-match offset-re))
    151                              (off (if o-m (hms->offset (cadr o-m) (cddr o-m))
    152                                       (- (timezone-component-ref tz 'std-offset) SEC/HR)
    153                                       #; ;XXX What does "ahead" mean?
    154                                       (+ (timezone-component-ref tz 'std-offset) SEC/HR) ) ) )
    155                         (set-timezone-component! tz 'dst-name (cadr n-m))
    156                         (set-timezone-component! tz 'dst-offset off)
    157                         ; Rule, if present, must be complete
    158                         (if (parse-dst-rule 'dst-start) (parse-dst-rule 'dst-end)
    159                             #t ) ) ) ) ) )
    160             (std-parse
    161               (lambda ()
    162                 ; Must have name & offset components
    163                 (let ((n-m (next-match name-re)))
    164                   (cond
    165                     ((not n-m) (fail "bad timezone STD name") )
    166                     (else
    167                       (let ((o-m (next-match offset-re)))
    168                         (cond
    169                           ((not o-m) (fail "bad timezone STD offset") )
    170                           (else
    171                             (set-timezone-component! tz 'std-name (cadr n-m))
    172                             (set-timezone-component! tz 'std-offset (hms->offset (cadr o-m) (cddr o-m)))
    173                             #t ) ) ) ) ) ) ) ) )
    174           ; Walk the match set
     184                        (fail "unknown timezone DST rule type") ) ) ) ) ) ) )
     185          ;
     186          (parse-dst-rule
     187            (lambda (key)
     188              (and-let* (
     189                (d-m (next-match date-re)) )
     190                ;Time component is optional & defaults to 02:00:00
     191                (let* (
     192                  (t-m
     193                    (next-match time-re))
     194                  (off
     195                    (if t-m
     196                      (hms->offset #f (cdr t-m))
     197                      +0200hrs+)) )
     198                  (set-timezone-component!
     199                    tz
     200                    key (decode-dst-rule (cadr d-m) (cddr d-m) off))
     201                  #t ) ) ) )
     202          ;
     203          (dst-parse
     204            (lambda ()
     205              ;DST section is optional
     206              (let (
     207                (n-m (next-match name-re)) )
     208                (or
     209                  (not n-m)
     210                  ;Offset is optional & defaults to 1hr
     211                  (let* (
     212                    (o-m (next-match offset-re))
     213                    (off
     214                      (if o-m
     215                        (hms->offset (cadr o-m) (cddr o-m))
     216                        (fx- (timezone-component-ref tz 'std-offset) SEC/HR)
     217                        #; ;XXX What does "ahead" mean?
     218                        (fx+ (timezone-component-ref tz 'std-offset) SEC/HR))) )
     219                    (set-timezone-component! tz 'dst-name (cadr n-m))
     220                    (set-timezone-component! tz 'dst-offset off)
     221                    ;Rule, if present, must be complete
     222                    (if (parse-dst-rule 'dst-start)
     223                      (parse-dst-rule 'dst-end)
     224                      #t ) ) ) ) ) )
     225          ;
     226          (std-parse
     227            (lambda ()
     228              ;Must have name & offset components
     229              (let (
     230                (n-m (next-match name-re)) )
     231                (cond
     232                  ((not n-m)
     233                    (fail "bad timezone STD name") )
     234                  (else
     235                    (let (
     236                      (o-m (next-match offset-re)) )
     237                      (cond
     238                        ((not o-m)
     239                          (fail "bad timezone STD offset") )
     240                        (else
     241                          (set-timezone-component! tz 'std-name (cadr n-m))
     242                          (set-timezone-component! tz 'std-offset (hms->offset (cadr o-m) (cddr o-m)))
     243                          #t ) ) ) ) ) ) ) ) )
     244          ;
     245          ;walk the match set
    175246          (cond
    176             ((string-null? str) (fail "empty timezone") )
     247            ((string-null? str)
     248              (fail "empty timezone") )
    177249            (else
    178               (and (std-parse)   ; Required
    179                    (dst-parse)   ; Optional
    180                    (all-parsed)  ; Must have successfully scanned entire string
    181                    ;then valid timezone info
    182                    tz ) ) ) ) ) ) ) )
     250              (and
     251                (std-parse)   ;required
     252                (dst-parse)   ;optional
     253                (all-parsed)  ;must have successfully scanned entire string
     254                ;then valid timezone info
     255                tz ) ) ) ) ) ) ) )
    183256
    184257;;
     
    197270(define (parse-posix-pathname-timezone tz str)
    198271  (let ((pn (if (string-prefix? "/" str) str (make-pathname *system-timezone-directory* str))))
    199     (if (file-exists? pn) (parse-posix-tzfile tz pn)
    200         #f ) ) )
     272    (if (file-exists? pn)
     273      (parse-posix-tzfile tz pn)
     274      #f ) ) )
    201275|#
    202276
     
    205279  #f
    206280  #; ;NOT YET
    207   (or (parse-posix-pathname-timezone tz (substring str 1))
    208       (begin
    209         (warning "cannot understand Posix implementation-defined timezone" str)
    210         #f ) ) )
     281  (or
     282    (parse-posix-pathname-timezone tz (substring str 1))
     283    (begin
     284      (warning "cannot understand Posix implementation-defined timezone" str)
     285      #f ) ) )
    211286
    212287;;
    213288
    214289(define (posix-timezone-string->timezone-components str . src)
    215   (let ((tz (make-timezone-components str (optional src "POSIX"))))
     290  (let (
     291    (tz (make-timezone-components str (optional src "POSIX"))) )
    216292    (cond
    217293      ((and (string? str) (string-prefix? ":" str))
     
    238314;; modifier:
    239315
     316(define-constant POSIX-LOCALE-REGEX
     317  "([a-zA-Z]+)(-[a-zA-Z]+)?(_[a-zA-Z]+)?(-[a-zA-Z0-9]+)?(\\.[^@]+)?(@.+)?")
     318
     319(: parse-posix-literal-locale (locale-components string -> (or boolean locale-components)))
     320;
    240321(define parse-posix-literal-locale
    241   (let ((locale-re (regexp "([a-zA-Z]+)(-[a-zA-Z]+)?(_[a-zA-Z]+)?(-[a-zA-Z0-9]+)?(\\.[^@]+)?(@.+)?")))
     322  (let (
     323    (locale-re (regexp POSIX-LOCALE-REGEX)) )
    242324    (lambda (lc str)
    243       (let ((matched-len 0))
    244         (and-let* ((r (string-match locale-re str)))
    245           (let ((language (cadr r))
    246                 (script (caddr r))
    247                 (country (cadddr r))
    248                 (subdivision (car (cddddr r)))
    249                 (codeset (cadr (cddddr r)))
    250                 (modifier (caddr (cddddr r)))
    251                 (inc-matched-len
    252                   (lambda (v)
    253                     (set! matched-len (+ matched-len (string-length v))) ) ) )
     325      (let (
     326        (matched-len 0) )
     327        (and-let* (
     328          (r (string-match locale-re str)) )
     329          (let (
     330            (language (cadr r))
     331            (script (caddr r))
     332            (country (cadddr r))
     333            (subdivision (car (cddddr r)))
     334            (codeset (cadr (cddddr r)))
     335            (modifier (caddr (cddddr r)))
     336            (inc-matched-len
     337              (lambda (v)
     338                (set! matched-len (fx+ matched-len (string-length v))) ) ) )
    254339            (when language
    255340              (inc-matched-len language)
     
    275360                (string-append
    276361                  (or (locale-component-ref lc 'country) "")
    277                   (let ((str (locale-component-ref lc 'subdivision)))
     362                  (let (
     363                    (str (locale-component-ref lc 'subdivision)) )
    278364                    (if str (string-append "-" str) "")))) )
    279365            ;Must be at the end of string
    280             (and (= matched-len (string-length str))
    281                  lc ) ) ) ) ) ) )
     366            (and
     367              (fx= matched-len (string-length str))
     368              lc ) ) ) ) ) ) )
    282369
    283370;;
     
    295382
    296383(define (parse-posix-pathname-locale lc str)
    297   (let ((pn (if (string-prefix? "/" str) str (make-pathname *system-locale-directory* str))))
    298     (if (file-exists? pn) (parse-posix-localefile lc pn)
    299         #f ) ) )
     384  (let (
     385    (pn
     386      (if (string-prefix? "/" str)
     387        str
     388        (make-pathname *system-locale-directory* str))) )
     389    (if (file-exists? pn)
     390      (parse-posix-localefile lc pn)
     391      #f ) ) )
    300392|#
    301393
     
    303395
    304396(define (posix-locale-string->locale-components str . args)
    305   (let-optionals args ((src "POSIX") (tag 'locale))
    306     (let ((lc (make-locale-components str src tag)))
     397  (let-optionals args (
     398    (src "POSIX")
     399    (tag 'locale) )
     400    (let (
     401      (lc (make-locale-components str src tag)) )
    307402      (cond
    308403        ((or (not (string? str)) (string-null? str))
     
    332427(define (set-posix-locale-categories func)
    333428  (for-each
    334    (lambda (cell)
    335      (let ((cat (cdr cell)))
    336        (cond ((func (car cell) cat) => (cut set-locale-category! cat <>))) ) )
     429    (lambda (cell)
     430      (let (
     431        (cat (cdr cell)) )
     432        (cond
     433          ((func (car cell) cat)
     434            => (cut set-locale-category! cat <>))) ) )
    337435   *posix-locale-category-names*) )
    338436
     
    340438
    341439(define (gnu-language-string->locale-components str . args)
    342   (and (string? str)
    343        (not (string-null? str))
    344        (let-optionals args ((src "GNU") (tag 'language))
    345          (let ((lc (make-locale-components str src tag)))
    346            (update-locale-components! lc 'locales
    347              ;Keep in priority order
    348              (reverse!
    349                (fold
    350                  ;May not have a 'country or 'region. Should use locale's?
    351                  (lambda (str ls)
    352                    ;Ignore when no parse
    353                    (let ((lc (posix-locale-string->locale-components str src)))
    354                      (if lc (cons lc ls) ls) ) )
    355                  '()
    356                  (string-split str ":")))) ) ) ) )
     440  (and
     441    (string? str)
     442    (not (string-null? str))
     443    (let-optionals args (
     444      (src "GNU")
     445      (tag 'language) )
     446      (let (
     447        (lc (make-locale-components str src tag)) )
     448        (update-locale-components! lc 'locales
     449          ;Keep in priority order
     450          (reverse!
     451            (fold
     452              ;May not have a 'country or 'region. Should use locale's?
     453              (lambda (str ls)
     454              ;Ignore when no parse
     455              (let ((lc (posix-locale-string->locale-components str src)))
     456              (if lc (cons lc ls) ls) ) )
     457              '()
     458              (string-split str ":")))) ) ) ) )
    357459
    358460;;;
     
    361463
    362464(define (posix-load-timezone)
    363   (and-let* ((str (nonnull-getenv "TZ")))
    364     (set-locale-category! 'timezone
    365      (posix-timezone-string->timezone-components str (list "POSIX" "TZ"))) ) )
     465  (and-let* (
     466    (str (nonnull-getenv "TZ")) )
     467    (set-locale-category!
     468      'timezone
     469      (posix-timezone-string->timezone-components
     470        str
     471        (list "POSIX" "TZ"))) ) )
    366472
    367473;; Create all local category values from the environment
    368474
    369475(define (posix-load-locale)
    370   (let ((str (nonnull-getenv "LC_ALL")))
     476  (let (
     477    (str (nonnull-getenv "LC_ALL")) )
    371478    (if str
    372         ;then LC_ALL overrides
    373         (let ((lc (posix-locale-string->locale-components str '("POSIX" "LC_ALL"))))
    374           (set-locale-category! 'current lc)
    375           (set-posix-locale-categories (lambda (e c) lc)) )
    376         ;else set individually, w/ LANG as default
    377         (let ((str (nonnull-getenv "LANG")))
    378           (if str
    379               (let ((lc (posix-locale-string->locale-components str '("POSIX" "LANG"))))
    380                 (set-locale-category! 'current lc)
    381                 (set-posix-locale-categories
    382                  (lambda (e c)
    383                    (cond
    384                      ((nonnull-getenv e)
    385                        => (cut posix-locale-string->locale-components <> `("POSIX" ,e)))
    386                      (else lc)))) ) ) ) ) ) )
     479      ;then LC_ALL overrides
     480      (let (
     481        (lc (posix-locale-string->locale-components str '("POSIX" "LC_ALL"))) )
     482        (set-locale-category! 'current lc)
     483        (set-posix-locale-categories (lambda (e c) lc)) )
     484      ;else set individually, w/ LANG as default
     485      (let (
     486        (str (nonnull-getenv "LANG")) )
     487        (when str
     488          (let (
     489            (lc (posix-locale-string->locale-components str '("POSIX" "LANG"))) )
     490            (set-locale-category! 'current lc)
     491            (set-posix-locale-categories
     492              (lambda (e c)
     493                (cond
     494                  ((nonnull-getenv e)
     495                    => (cut posix-locale-string->locale-components <> `("POSIX" ,e)))
     496                  (else
     497                    lc)))) ) ) ) ) ) )
    387498
    388499;; GNU LANGUAGE (PATH-sytle list of LANG)
    389500
    390501(define (gnu-load-locale)
    391   (and-let* ((str (nonnull-getenv "LANGUAGE")))
    392     (let ((lc (gnu-language-string->locale-components str '("GNU" "LANGUAGE") 'language)))
     502  (and-let* (
     503    (str (nonnull-getenv "LANGUAGE")) )
     504    (let (
     505      (lc (gnu-language-string->locale-components str '("GNU" "LANGUAGE") 'language)) )
    393506      (set-locale-category! 'language lc) ) ) )
    394507
  • release/4/locale/trunk/locale.scm

    r35363 r35403  
    9696  current-timezone-components
    9797  current-locale-components
     98  current-second-dst?
    9899  locale-setup)
    99100
  • release/4/locale/trunk/locale.setup

    r35363 r35403  
    1 ;;;; locale.setup  -*- Hen -*-
     1;;;; locale.setup
    22
    33(use setup-helper-mod)
     
    55(verify-extension-name "locale")
    66
    7 (setup-shared-extension-module 'locale-components (extension-version "0.7.0")
     7(setup-shared-extension-module 'locale-components (extension-version "1.0.0")
     8  #:inline? #t
     9  #:types? #t
    810  #:compile-options '(
    911    -disable-interrupts
    1012    -fixnum-arithmetic
    11     -optimize-level 3
     13    -optimize-level 3 -debug-level 1
    1214    -no-procedure-checks))
    1315
    14 (setup-shared-extension-module 'locale-categories (extension-version "0.7.0")
     16(setup-shared-extension-module 'locale-categories (extension-version "1.0.0")
     17  #:inline? #t
     18  #:types? #t
    1519  #:compile-options '(
    1620    -fixnum-arithmetic
    17     -optimize-level 3
     21    -optimize-level 3 -debug-level 1
    1822    -no-procedure-checks))
    1923
    20 (setup-shared-extension-module 'locale-posix (extension-version "0.7.0")
     24(setup-shared-extension-module 'locale-posix (extension-version "1.0.0")
     25  #:inline? #t
     26  #:types? #t
     27  #:compile-options '(
     28    -optimize-level 3 -debug-level 1
     29    -no-procedure-checks))
     30
     31(setup-shared-extension-module 'locale-timezone (extension-version "1.0.0")
     32  #:inline? #t
     33  #:types? #t
    2134  #:compile-options '(
    2235    -fixnum-arithmetic
    23     -optimize-level 3
     36    -optimize-level 3 -debug-level 1
    2437    -no-procedure-checks))
    2538
    26 (setup-shared-extension-module 'locale-timezone (extension-version "0.7.0")
     39(setup-shared-extension-module 'locale-builtin (extension-version "1.0.0")
     40  #:inline? #t
     41  #:types? #t
    2742  #:compile-options '(
    2843    -fixnum-arithmetic
    29     -optimize-level 3
     44    -optimize-level 3 -debug-level 1
    3045    -no-procedure-checks))
    3146
    32 (setup-shared-extension-module 'locale-builtin (extension-version "0.7.0")
     47(setup-shared-extension-module 'locale-current (extension-version "1.0.0")
     48  #:inline? #t
     49  #:types? #t
    3350  #:compile-options '(
    3451    -fixnum-arithmetic
    35     -optimize-level 3
     52    -optimize-level 3 -debug-level 1
    3653    -no-procedure-checks))
    3754
    38 (setup-shared-extension-module 'locale-current (extension-version "0.7.0")
    39   #:compile-options '(
    40     -fixnum-arithmetic
    41     -optimize-level 3
    42     -no-procedure-checks))
    43 
    44 (setup-shared-extension-module 'locale (extension-version "0.7.0"))
     55(setup-shared-extension-module 'locale (extension-version "1.0.0"))
  • release/4/locale/trunk/tests/locale-test.scm

    r35363 r35403  
    3333  #; ;FIXME need to test locale-timezone
    3434        (test-group "Local Timezone"
    35        
     35
    3636          (test "TZN (fail)" "" (local-timezone (seconds->local-time (current-seconds))))
    3737          (test "TZO (fail)" -1 (local-timezone-offset (seconds->local-time (current-seconds))))
    38        
     38
    3939          #;(with-tzset "" (lambda () ))
    4040        )
     
    4747    ; cannot have a name composed of digits
    4848    (test-error "T2" (posix-timezone-string->timezone-components "23,foo"))
    49  
     49
    5050    ; this is actually legal!
    5151    (test-assert "T3" (posix-timezone-string->timezone-components "foo/23"))
     
    8888      (setenv "TZ" "PST+8:00PDT+7:00:00,M4.1.0,M10.5")
    8989      (posix-load-timezone)
    90       (test "TS4" tz1 (current-timezone-components)) )
     90      (let ((tzc (current-timezone-components)))
     91        (when (locale-component-exists? tzc 'dst?)
     92          (set-timezone-component! tz1 'dst? (locale-component-ref tzc 'dst?)))
     93        (test "TS4" tz1 tzc) ) )
    9194        )
    9295
Note: See TracChangeset for help on using the changeset viewer.