Changeset 15643 in project


Ignore:
Timestamp:
08/29/09 19:27:42 (10 years ago)
Author:
kon
Message:

Save. Bug in posix parse. Rmvd string const globals. Made 'locale' a "full export" module.

Location:
release/4/locale/trunk
Files:
1 added
1 deleted
8 edited

Legend:

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

    r15641 r15643  
    88(module locale-builtin (;export
    99  ;
    10   UNKNOWN-LOCAL-TZ-NAME
    11   BUILTIN-SOURCE
     10  builtin-source-name builtin-source-name?
     11  unknown-timezone-name unknown-timezone-name?
    1212  ;
    1313  use-builtin-timezone
     
    2626;;; When no environment info use Plan B
    2727
    28 (define BUILTIN-SOURCE "BUILTIN")
    29 (define UNKNOWN-LOCAL-TZ-NAME "XXXX")
     28;FIXME use immutable core string
     29
     30(define-constant BUILTIN-SOURCE "BUILTIN")
     31(define (builtin-source-name) BUILTIN-SOURCE)
     32(define (builtin-source-name? x) (equal? BUILTIN-SOURCE x))
     33
     34(define-constant UNKNOWN-LOCAL-TZ-NAME "XXXX")
     35(define (unknown-timezone-name) UNKNOWN-LOCAL-TZ-NAME)
     36(define (unknown-timezone-name? x) (equal? UNKNOWN-LOCAL-TZ-NAME x))
    3037
    3138;; Builtin Timezone
     
    6774(define (use-builtin-locale)
    6875  (set-locale-category!
    69    'messages 
     76   'messages
    7077   (posix-locale-string->locale-components (make-builtin-locale-string) BUILTIN-SOURCE)) )
    7178
  • release/4/locale/trunk/locale-categories.scm

    r15641 r15643  
    1212  locale-category-ref
    1313  set-locale-category!)
    14  
     14
    1515  (import chicken scheme)
    1616  (require-extension #;srfi-9
    17                      miscmacros lookup-table
    18                      locale-components locale-errors)
     17                     miscmacros lookup-table type-checks type-errors
     18                     locale-components)
    1919
    2020  (declare
     
    2222    (inline)
    2323    (no-procedure-checks) )
    24 
    25 ;;
    26 
    27 (define (check-symbol loc obj)
    28   (unless (symbol? obj)
    29     (locale-type-error loc "symbol" obj) ) )
    3024
    3125;;;
     
    3630  (tbl locale-dictionary-table) )
    3731
    38 (define (make-locale-dictionary)
    39   (%make-locale-dictionary (make-dict)) )
     32(define (make-locale-dictionary) (%make-locale-dictionary (make-dict)))
    4033
    41 (define (check-locale-dictionary loc obj)
    42   (unless (locale-dictionary? obj)
    43     (locale-type-error loc "locale-dictionary" obj) ) )
     34(define-check+error-type locale-dictionary)
     35
    4436;;
    4537
     
    4941  (let ((tbl (locale-dictionary-table rec)))
    5042    (cond ((not val) (dict-delete! tbl key))
    51           (else 
     43          (else
    5244           (check-locale-components 'set-locale-dictionary-category! val)
    5345           (dict-set! tbl key val) ) ) ) )
     
    6860    (cond ((locale-dictionary? obj) obj)
    6961          (else
    70            (warning 'current-locale-dictionary (make-locale-type-error-message "locale-dictionary") obj)
     62           (warning 'current-locale-dictionary (make-error-type-message "locale-dictionary") obj)
    7163           (current-locale-dictionary) ) ) ) )
    7264
  • release/4/locale/trunk/locale-components.scm

    r15641 r15643  
    4141  (import chicken scheme)
    4242  (require-extension srfi-1
    43                      locale-errors)
    44  
     43                     type-checks type-errors)
     44
    4545  (declare
    4646    (fixnum)
     
    9898             (*locale-component-exists? obj 'source)) )
    9999
    100 (define (check-locale-components loc obj)
    101   (unless (locale-components? obj)
    102     (locale-type-error loc "a locale-components object" obj) ) )
     100(define-check+error-type locale-components)
    103101
    104102(define (locale-component-exists? lc what)
     
    140138  (o timezone-dst-rule-mwd-offset) )
    141139
    142 (define (check-timezone-dst-rule-mwd loc r)
    143   (unless (timezone-dst-rule-mwd? r)
    144     (locale-type-error loc "timezone-dst-rule-mwd" r) ) )
     140(define-check+error-type timezone-dst-rule-mwd)
     141(define-error-type timezone-dst-rule-julian "timezone-dst-rule-julian")
     142(define-error-type timezone-dst-rule "timezone-dst-rule")
    145143
    146144(define (timezone-dst-rule-julian? r)
     
    151149        ((timezone-dst-rule-julian-leap? r) (timezone-dst-rule-julian-leap-day r))
    152150        (else
    153          (locale-type-error 'timezone-dst-rule-offset "timezone-dst-rule-julian" r) ) ) )
     151         (error-timezone-dst-rule-julian 'timezone-dst-rule-julian r) ) ) )
    154152
    155153(define (timezone-dst-rule-month r)
     
    170168        ((timezone-dst-rule-mwd? r) (timezone-dst-rule-mwd-offset r))
    171169        (else
    172          (locale-type-error 'timezone-dst-rule-offset "timezone-dst-rule" r) ) ) )
     170         (error-timezone-dst-rule 'timezone-dst-rule-offset r) ) ) )
    173171
    174172;;; Timezone Components
     
    181179             (eq? 'timezone (*locale-component-ref obj 'tag #f))) )
    182180
    183 (define (check-timezone-components loc obj)
    184   (unless (timezone-components? obj)
    185     (locale-type-error loc "a timezone-components object" obj) ) )
     181(define-check+error-type timezone-components)
    186182
    187183(define (timezone-component-ref tz what . def)
  • release/4/locale/trunk/locale-posix.scm

    r15641 r15643  
    6868
    6969(define parse-posix-literal-timezone
    70         (let ((name-re (regexp "^([A-Za-z]+)|<([^>]+)>"))
     70        (let ((name-re (regexp "^([A-Za-z]+)" #;"^([A-Za-z]+)|<([^>]+)>"))
    7171                                (offset-re (regexp "^(\\+|-)?([0-9]+)(:[0-9]+)?(:[0-9]+)?"))
    7272                                ; For compatibility with System V Release 3.1, a semicolon (`;') may be
     
    105105            (parse-timecomp
    106106              (lambda (numstr) (parse-delmcomp numstr ":")) )
     107            (parse-optional-timecomp  ; an offset component is optional
     108              (lambda (numstr) (if numstr (parse-timecomp numstr) 0)) )
    107109            (parse-daterulecomp
    108110              (lambda (numstr) (parse-delmcomp numstr ".")) )
     
    110112              (lambda (sgnstr hms-lst)
    111113                (and-let* ((hr (parse-number (car hms-lst)))
    112                            (mn (parse-timecomp (cadr hms-lst)))
    113                            (sc (parse-timecomp (caddr hms-lst))) )
     114                           (mn (parse-optional-timecomp (cadr hms-lst)))
     115                           (sc (parse-optional-timecomp (caddr hms-lst))) )
    114116                  (let ((secs (+ (* hr SEC/HR) (* mn SEC/MIN) sc)))
    115                     (if (string=? sgnstr "-") (- secs) secs)) ) ) )
     117                    (if (and sgnstr (string=? sgnstr "-")) (- secs) secs)) ) ) )
    116118            (decode-dst-rule
    117119              (lambda (rulstr dat-lst off)
     
    144146                ; DST section is optional
    145147                (let ((n-m (next-match name-re)))
    146                   (if (not n-m) #t
     148                  (or (not n-m)
    147149                      ; Offset is optional & defaults to 1hr
    148150                      (let* ((o-m (next-match offset-re))
  • release/4/locale/trunk/locale.meta

    r15641 r15643  
    1111  "tests"
    1212        "locale.scm"
     13        "locale-current.scm"
    1314        "locale-categories.scm"
    1415        "locale-components.scm"
     
    1617        "locale-timezone.scm"
    1718        "locale-builtin.scm"
    18         "locale-errors.scm"
    1919  "locale.setup") )
  • release/4/locale/trunk/locale.scm

    r15641 r15643  
    77
    88(module locale (;export
     9  ; locale-timezone
     10  local-timezone
     11  local-timezone-offset
     12  with-tzset
     13  ; locale-builtin
     14  builtin-source-name builtin-source-name?
     15  unknown-timezone-name unknown-timezone-name?
     16  use-builtin-timezone
     17  use-builtin-locale
     18  use-builtin-language
     19  ; locale-posix
     20  seconds->h:m:s-string
     21  make-posix-timezone
     22  posix-timezone-string->timezone-components
     23  posix-locale-string->locale-components
     24  gnu-language-string->locale-components
     25  posix-load-timezone
     26  posix-load-locale
     27  gnu-load-locale
     28  ; locale-components
     29  make-locale-components
     30  locale-components?
     31  locale-component-ref
     32  locale-component-exists?
     33  set-locale-component!
     34  update-locale-components!
     35  make-timezone-components
     36  timezone-components?
     37  set-timezone-component!
     38  timezone-component-ref
     39  update-timezone-components!
     40  make-timezone-dst-rule-julian-leap
     41  make-timezone-dst-rule-julian-noleap
     42  make-timezone-dst-rule-mwd
     43  timezone-dst-rule-julian?
     44  timezone-dst-rule-julian-leap?
     45  timezone-dst-rule-julian-noleap?
     46  timezone-dst-rule-mwd?
     47  timezone-dst-rule-julian
     48  timezone-dst-rule-day
     49  timezone-dst-rule-month
     50  timezone-dst-rule-week
     51  timezone-dst-rule-offset
     52  ; locale-categories
     53  make-locale-dictionary
     54  locale-dictionary?
     55  set-locale-dictionary-category!
     56  locale-dictionary-category
     57  current-locale-dictionary
     58  locale-category-ref
     59  set-locale-category!
     60  ; locale-current
    961  current-timezone
    1062  current-locale
     
    1365
    1466  (import chicken scheme)
    15   (require-extension posix
    16                      locale-builtin locale-posix locale-components locale-categories locale-errors)
    17 
    18   (declare
    19     (usual-integrations)
    20     (fixnum)
    21     (inline)
    22     (no-procedure-checks) )
    23 
    24 ;;;
    25 
    26 (define-inline (%current-dstflag) (vector-ref (seconds->local-time (current-seconds)) 8))
    27 
    28 (define-inline (%locale-category+component-ref catnam cmpnam)
    29   (and-let* ((lc (locale-category-ref catnam))) (locale-component-ref lc cmpnam)) )
    30 
    31 ;;; Parameters (Well, parameter-like)
    32 
    33 ;;
    34 
    35 (define (current-timezone . args)
    36   (if (null? args) (%locale-category+component-ref 'timezone 'name)
    37       (let-optionals args ((obj #f) (src "USER"))
    38         (cond ((not obj)
    39                (set-locale-category! 'timezone #f) )
    40               ((string? obj)
    41                (set-locale-category!
    42                 'timezone
    43                 (posix-timezone-string->timezone-components obj src)) )
    44               ((timezone-components? obj)
    45                (set-locale-category! 'timezone obj) )
    46               (else
    47                (warning 'current-timezone (make-locale-type-error-message "string, #f or timezone-components") obj)
    48                (current-timezone) ) ) ) ) )
    49 
    50 ;; A'la MzScheme
    51 ;; Treat locale as messages category
    52 
    53 (define (current-locale . args)
    54   (if (null? args) (%locale-category+component-ref 'messages 'name)
    55       (let-optionals args ((obj #f) (src "USER"))
    56         (cond ((not obj)
    57                (set-locale-category! 'messages #f) )
    58               ((string? obj)
    59                (set-locale-category!
    60                 'messages
    61                 (posix-locale-string->locale-components obj src)) )
    62               ((and (not (timezone-components? obj)) (locale-components? obj))
    63                (set-locale-category! 'messages obj) )
    64               (else
    65                (warning 'current-locale (make-locale-type-error-message "string, #f or locale-components") obj)
    66                (current-locale) ) ) ) ) )
    67 
    68 ;;
    69 
    70 (define (current-timezone-components) (locale-category-ref 'timezone))
    71 
    72 (define (current-locale-components) (locale-category-ref 'messages))
    73 
    74 ;;;
    75 ;;; Module Init
    76 ;;;
    77 
    78 ;; Use posix locale system, for now
    79 
    80 (posix-load-timezone)
    81 (posix-load-locale)
    82 (gnu-load-locale)
    83 
    84 ;; Need the current-timezone-components, and unless we
    85 ;; have a current-timezone need to fake one from system
    86 ;; time info.
    87 
    88 (unless (current-timezone) (use-builtin-timezone))
    89 
    90 (unless (current-locale) (use-builtin-locale))
    91 
    92 (unless (locale-category-ref 'language) (use-builtin-language))
    93 
    94 ;; Chicken platform
    95 
    96 (set-timezone-component! (current-timezone-components) 'dst? (%current-dstflag))
     67  (require-extension locale-timezone locale-builtin locale-posix locale-components locale-categories locale-current)
    9768
    9869) ;module locale
  • release/4/locale/trunk/locale.setup

    r15641 r15643  
    55(verify-extension-name "locale")
    66
    7 (setup-shared-extension-module 'locale-errors (extension-version "0.0.0"))
    87(setup-shared-extension-module 'locale-components (extension-version "0.0.0"))
    98(setup-shared-extension-module 'locale-categories (extension-version "0.0.0"))
     
    1110(setup-shared-extension-module 'locale-timezone (extension-version "0.0.0"))
    1211(setup-shared-extension-module 'locale-builtin (extension-version "0.0.0"))
     12(setup-shared-extension-module 'locale-current (extension-version "0.0.0"))
    1313(setup-shared-extension-module 'locale (extension-version "0.0.0"))
  • release/4/locale/trunk/tests/run.scm

    r15641 r15643  
    11;;;; locale-test.scm
    22
    3 (use testbase testbase-output-compact)
     3(use test)
    44(use locale posix)
    55
    6 (define-test locale-test "Locale"
     6(test-group "Locale"
    77
    8         (test/case "Posix Timezone" (
    9                 [tz0 (make-timezone-components "PST+8:00" "TEST")]
    10                 [tz1 (make-timezone-components "PST+8:00PDT+7:00:00" '("POSIX" "TZ"))]
    11                 [tz2 (make-timezone-components "PST+8:00PDT7,J23/12:34,34/1:00:01" "TEST")] )
     8        (test-group "Posix Timezone"
    129
    13                 (expect-set! tz0
    14                   (update-timezone-components! tz0
    15                     'std-name "PST" 'std-offset (* 8 60 60)))
    16                 (expect-set! tz1
    17                   (update-timezone-components! tz1
    18         'std-name "PST" 'std-offset (* 8 60 60)
    19         'dst-name "PDT" 'dst-offset (* 7 60 60)
    20         'dst-start (make-timezone-dst-rule-mwd 4 1 0 3600)
    21         'dst-end (make-timezone-dst-rule-mwd 10 5 0 3600)))
    22                 (expect-set! tz2
    23                   (update-timezone-components! tz2
    24         'std-name "PST" 'std-offset (* 8 60 60)
    25         'dst-name "PDT" 'dst-offset (* 7 60 60)
    26         'dst-start (make-timezone-dst-rule-julian-noleap 23 (+ (* 12 60 60) (* 34 60)))
    27         'dst-end (make-timezone-dst-rule-julian-leap 34 (+ (* 1 60 60) 1))))
     10          (let ((tz0 (make-timezone-components "PST+8:00" "TEST"))
     11          (tz1 (make-timezone-components "PST+8:00PDT+7:00:00" '("POSIX" "TZ")))
     12          (tz2 (make-timezone-components "PST+8:00PDT7,J23/12:34,34/1:00:01" "TEST")) )
    2813
    29                 (expect-false "F1" (posix-timezone-string->timezone-components ":foo,bar,baz"))
    30                 (expect-false "F2" (posix-timezone-string->timezone-components "23,foo"))
    31                 (expect-false "F3" (posix-timezone-string->timezone-components "foo/23"))
    32                 (expect-false "F4" (posix-timezone-string->timezone-components "foo-23bar/23"))
    33                 (expect-false "F5" (posix-timezone-string->timezone-components "foo-23bar-22/23"))
     14      (set! tz0
     15        (update-timezone-components! tz0
     16          'std-name "PST" 'std-offset (* 8 60 60)))
     17      (set! tz1
     18        (update-timezone-components! tz1
     19          'std-name "PST" 'std-offset (* 8 60 60)
     20          'dst-name "PDT" 'dst-offset (* 7 60 60)
     21          'dst-start (make-timezone-dst-rule-mwd 4 1 0 3600)
     22          'dst-end (make-timezone-dst-rule-mwd 10 5 0 3600)))
     23      (set! tz2
     24        (update-timezone-components! tz2
     25          'std-name "PST" 'std-offset (* 8 60 60)
     26          'dst-name "PDT" 'dst-offset (* 7 60 60)
     27          'dst-start (make-timezone-dst-rule-julian-noleap 23 (+ (* 12 60 60) (* 34 60)))
     28          'dst-end (make-timezone-dst-rule-julian-leap 34 (+ (* 1 60 60) 1))))
    3429
    35                 (expect-equal "S1" tz0
    36                         (posix-timezone-string->timezone-components "PST+8:00" "TEST"))
    37                 (expect-equal "S2" tz1
    38                         (posix-timezone-string->timezone-components "PST+8:00PDT+7:00:00" '("POSIX" "TZ")))
    39                 (expect-equal "S3" tz2
    40                         (posix-timezone-string->timezone-components "PST+8:00PDT7,J23/12:34,34/1:00:01" "TEST"))
     30      (test-assert "F1" (not (posix-timezone-string->timezone-components ":foo,bar,baz")))
     31      (test-assert "F2" (not (posix-timezone-string->timezone-components "23,foo")))
     32      (test-assert "F3" (not (posix-timezone-string->timezone-components "foo/23")))
     33      (test-assert "F4" (not (posix-timezone-string->timezone-components "foo-23bar/23")))
     34      (test-assert "F5" (not (posix-timezone-string->timezone-components "foo-23bar-22/23")))
    4135
    42                 (side-effect (setenv "TZ" "PST+8:00PDT+7:00:00"))
    43                 (side-effect (posix-load-timezone))
    44                 (expect-equal "S4" tz1 (current-timezone-components))
     36      (test "S1" tz0
     37        (posix-timezone-string->timezone-components "PST+8:00" "TEST"))
     38      (test "S2" tz1
     39        (posix-timezone-string->timezone-components "PST+8:00PDT+7:00:00" '("POSIX" "TZ")))
     40      (test "S3" tz2
     41        (posix-timezone-string->timezone-components "PST+8:00PDT7,J23/12:34,34/1:00:01" "TEST"))
     42
     43      (setenv "TZ" "PST+8:00PDT+7:00:00")
     44      (posix-load-timezone)
     45      (test "S4" tz1 (current-timezone-components)) )
    4546        )
    4647
    47         (test/case "Posix Locale" (
    48                 [lc0 (make-locale-components "en_US" '("POSIX" "LANG"))]
    49                 [lc1 (make-locale-components "en-Latn_US.UTF8@foo,bar,baz" "TEST")] )
     48        (test-group "Posix Locale"
    5049
    51                 (expect-set! lc0
    52                   (update-locale-components! lc0
    53         'language "en"
    54         'region "US"))
    55                 (expect-set! lc1
    56                   (update-locale-components! lc1
    57         'language "en"
    58         'script "Latn"
    59         'region "US"
    60         'codeset "UTF8"
    61         'modifier "foo,bar,baz"))
     50          (let ((lc0 (make-locale-components "en_US" '("POSIX" "LANG")))
     51          (lc1 (make-locale-components "en-Latn_US.UTF8@foo,bar,baz" "TEST")) )
    6252
    63                 (expect-false "F1" (posix-locale-string->locale-components "/foo,bar,baz" "TEST"))
    64                 (expect-false "F2" (posix-locale-string->locale-components "23,bar,baz" "TEST"))
    65                 (expect-false "F3" (posix-locale-string->locale-components "foo-bar_1" "TEST"))
     53      (set! lc0
     54        (update-locale-components! lc0
     55          'language "en"
     56          'region "US"))
     57      (set! lc1
     58        (update-locale-components! lc1
     59          'language "en"
     60          'script "Latn"
     61          'region "US"
     62          'codeset "UTF8"
     63          'modifier "foo,bar,baz"))
    6664
    67                 (expect-equal "S1" lc0 (posix-locale-string->locale-components "en_US" '("POSIX" "LANG")))
    68                 (expect-equal "S2" lc1 (posix-locale-string->locale-components "en-Latn_US.UTF8@foo,bar,baz" "TEST"))
     65      (test-assert "F1" (not (posix-locale-string->locale-components "/foo,bar,baz" "TEST")))
     66      (test-assert "F2" (not (posix-locale-string->locale-components "23,bar,baz" "TEST")))
     67      (test-assert "F3" (not (posix-locale-string->locale-components "foo-bar_1" "TEST")))
    6968
    70                 (side-effect (setenv "LANG" "en_US"))
    71                 (side-effect (posix-load-locale))
    72                 (expect-equal "S3" lc0 (current-locale-components))
    73                 (expect-equal "S4" lc0 (locale-category-ref 'monetary))
     69      (test "S1" lc0 (posix-locale-string->locale-components "en_US" '("POSIX" "LANG")))
     70      (test "S2" lc1 (posix-locale-string->locale-components "en-Latn_US.UTF8@foo,bar,baz" "TEST"))
     71
     72      (setenv "LANG" "en_US")
     73      (posix-load-locale)
     74      (test "S3" lc0 (current-locale-components))
     75      (test "S4" lc0 (locale-category-ref 'monetary)) )
    7476        )
    7577
    7678  #;
    77         (test/case "Local Timezone" ()
     79        (test-group "Local Timezone"
    7880          (with-tzset "" (lambda () ))
    7981        )
    8082)
    81 
    82 (test::styler-set! locale-test test::output-style-compact)
    83 (run-test "Locale Tests")
Note: See TracChangeset for help on using the changeset viewer.