Changeset 15915 in project


Ignore:
Timestamp:
09/16/09 07:25:16 (10 years ago)
Author:
Kon Lovett
Message:

Use of scheme only in locale-timezone. Note about posix 'local-timezone-abbreviation' bug.

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

Legend:

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

    r15643 r15915  
    1515  use-builtin-language)
    1616
    17   (import chicken scheme)
    18   (require-extension posix
    19                      locale-posix locale-components locale-categories locale-timezone)
     17  (import scheme chicken
     18          (only posix seconds->local-time local-timezone-abbreviation)
     19          locale-posix
     20          locale-components
     21          locale-categories
     22          locale-timezone)
     23
     24  (require-library posix locale-posix locale-components locale-categories locale-timezone)
    2025
    2126  (declare
    2227    (fixnum)
    2328    (inline)
     29    (local)
    2430    (no-procedure-checks) )
    2531
     
    4551(define (current-local-time) (seconds->local-time (current-seconds)))
    4652
    47 (define (local-timezone-name tv)
    48   (local-timezone (+ (vector-ref tv 5) 1900) (vector-ref tv 4) (vector-ref tv 2)) )
     53(define (local-timezone-name tv) (local-timezone tv))
    4954
    5055(define (make-builtin-timezone)
    5156  ; Need local timezone info
    5257  (let ((tv (current-local-time)))
    53     (let ((tzn (local-timezone-name tv))
     58    (let ((tzn (local-timezone-name tv)
     59               #; ;Not until Posix bug fixed
     60               (local-timezone-abbreviation))
    5461          (tzo (vector-ref tv 9))
    5562          (dst? (vector-ref tv 8)) )
  • release/4/locale/trunk/locale-categories.scm

    r15643 r15915  
    1313  set-locale-category!)
    1414
    15   (import chicken scheme)
    16   (require-extension #;srfi-9
    17                      miscmacros lookup-table type-checks type-errors
    18                      locale-components)
     15  (import scheme chicken
     16          #;srfi-9
     17          (only miscmacros define-parameter)
     18          lookup-table
     19          type-checks
     20          type-errors
     21          locale-components)
     22
     23  (require-library #;srfi-9 miscmacros lookup-table type-checks type-errors locale-components)
    1924
    2025  (declare
    2126    (fixnum)
    2227    (inline)
     28    (local)
    2329    (no-procedure-checks) )
    2430
  • release/4/locale/trunk/locale-components.scm

    r15737 r15915  
    55;;
    66;; - Components predicates are not fool-proof.
    7 ;;
    8 ;; - Argument checking is minimal!
    97;;
    108;; - Used selectors for *-components since it is assumed extra elements will be needed by
     
    6361  timezone-dst-rule-offset)
    6462
    65   (import chicken scheme)
    66   (require-extension srfi-1
    67                      type-checks type-errors)
     63  (import scheme chicken
     64          (only srfi-1 last-pair every alist-cons)
     65          type-checks type-errors)
     66
     67  (require-library srfi-1 type-checks type-errors)
    6868
    6969  (declare
    7070    (fixnum)
    7171    (inline)
     72    (local)
    7273    (no-procedure-checks)
    7374    (disable-interrupts) )
  • release/4/locale/trunk/locale-current.scm

    r15682 r15915  
    1212  current-locale-components)
    1313
    14   (import chicken scheme)
    15   (require-extension posix
    16                      type-checks type-errors
    17                      locale-builtin locale-posix locale-components locale-categories)
     14  (import scheme chicken
     15          (only posix seconds->local-time)
     16          (only type-errors make-error-type-message)
     17          locale-builtin locale-posix locale-components locale-categories)
     18
     19  (require-library posix type-errors locale-builtin locale-posix locale-components locale-categories)
    1820
    1921  (declare
    20     (usual-integrations)
    2122    (fixnum)
    2223    (inline)
     24    (local)
    2325    (no-procedure-checks) )
    2426
  • release/4/locale/trunk/locale-posix.scm

    r15682 r15915  
    149149                      (let* ((o-m (next-match offset-re))
    150150                             (off (if o-m (hms->offset (cadr o-m) (cddr o-m))
    151                                       ;XXX What does "ahead" mean?
     151                                      (- (timezone-component-ref tz 'std-offset) SEC/HR)
     152                                      #; ;XXX What does "ahead" mean?
    152153                                      (+ (timezone-component-ref tz 'std-offset) SEC/HR) ) ) )
    153154                        (set-timezone-component! tz 'dst-name (cadr n-m))
  • release/4/locale/trunk/locale-timezone.scm

    r15641 r15915  
    77  with-tzset)
    88
    9   (import chicken scheme)
    10   (require-extension posix)
     9  (import scheme chicken foreign
     10          (only posix time->string seconds->local-time local-time->seconds setenv)
     11          (only type-checks check-fixnum)
     12          (only type-errors error-keyword error-argument-type))
     13
     14  (require-library posix type-checks type-errors)
    1115
    1216  (declare
    1317    (inline)
     18    (local)
    1419    (fixnum)
    1520    (no-procedure-checks)
    16     (run-time-macros)
    1721    (bound-to-procedure
    1822      ##sys#error-hook) )
    1923
    20 #>
    21 #include <stdlib.h>
    22 #include <string.h>
    23 #include <stdio.h>
    24 #include <time.h>
     24;;;
    2525
    26 #ifdef _WIN32
    27 static struct tm *
    28 localtime_r( const time_t *clock, struct tm *result )
    29 {
    30   if (!clock || !result) return NULL;
    31   memcpy( result, localtime( clock ), sizeof( *result ) );
    32   return result;
    33 }
    34 #endif
     26(define-syntax check-fixnums
     27  (syntax-rules ()
     28    ((_ loc nam0 ...)
     29      (for-each
     30        (lambda (x) (check-fixnum loc (car x) (cadr x)))
     31        (list (list nam0 'nam0) ...)) ) ) )
    3532
    36 static char *
    37 get_tz( int yr, int mo, int dy, int hr, int mn, int sc, int as_offset )
    38 {
    39   struct tm tm;
    40   time_t t;
     33(define-syntax check-closed-interval
     34  (syntax-rules (<=)
     35    ((_ loc (<= low0 nam0 hgh0) ...)
     36      (for-each
     37        (lambda (x)
     38          (unless (<= (caddr x) (car x) (cadddr x))
     39            (error loc
     40              (string-append "bad argument " (symbol->string (cadr x)) " type - out of range")
     41              (car x) (caddr x) (cadddr x)) ) )
     42        (list (list nam0 'nam0 low0 hgh0) ...)) ) ) )
    4143
    42   const int size = 31 + 1;
    43   char *buf = malloc( size * sizeof( char ) );
     44(define (error-minimum-argument-count loc argcnt cnt)
     45  (##sys#error-hook (foreign-value "C_BAD_MINIMUM_ARGUMENT_COUNT_ERROR" int) loc argcnt cnt) )
    4446
    45   memset( &tm, 0, sizeof tm );
    46   tm.tm_hour = hr;
    47   tm.tm_min = mn;
    48   tm.tm_sec = sc;
    49   tm.tm_year = yr - 1900;
    50   tm.tm_mon = mo;
    51   tm.tm_mday = dy;
     47(define (error-argument-count loc argcnt cnt)
     48  (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_COUNT_ERROR" int) loc argcnt cnt) )
    5249
    53   t = mktime( &tm );
    54   strftime( buf, size, (as_offset ? "%z" : "%Z"), localtime_r( &t, &tm ) );
     50(define (check-minimum-argument-count loc actargc minargc)
     51  (unless (<= minargc actargc)
     52    (error-minimum-argument-count loc actargc minargc)) )
    5553
    56   return buf;
    57 }
    58 <#
     54(define (check-argument-count loc actargc maxargc)
     55  (unless (<= actargc maxargc)
     56    (error-argument-count loc actargc maxargc)) )
    5957
    6058;;;
    6159
    62 (define get-tz (foreign-lambda c-string* "get_tz" int int int int int int bool))
     60(define (get-tz yr mo dy hr mn sc off? dst?)
     61  (let ((tv (vector sc mn hr dy mo (- yr 1900) 0 0 dst? 0)))
     62    (time->string (seconds->local-time (local-time->seconds tv)) (if off? "%z" "%Z")) ) )
    6363
    64 ; #!required tm | hr mo dy #!optional (hr 12) (mn 0) (sc 0) #!key offset?
     64; #!required tv | yr mo dy #!optional (hr 12) (mn 0) (sc 0) #!key offset? dst?
    6565(define (*local-timezone loc . args)
    6666
    67   (let ((arglen (length args))
    68         (yr #f) (mo #f) (dy #f) (hr #f) (mn #f) (sc #f) (offset? #f))
     67  (let ((argcnt (length args))
     68        (yr #f) (mo #f) (dy #f) (hr #f) (mn #f) (sc #f) (offset? #f) (dst? #f))
     69
     70    (define (kwdarg kwd rest)
     71      (cond ((eq? #:offset? kwd) (set! offset? (cadr rest)) )
     72           ((eq? #:dst? kwd) (set! dst? (cadr rest)) )
     73           (else (error-argument-type loc "keyword #:offset? or #:dst?" kwd) ) ) )
    6974
    7075    ; DSSSL lambda list parsing behavior as I wish it was
    71     (unless (<= 1 arglen) (##sys#error-hook 2 loc arglen 1))
     76    (check-minimum-argument-count loc argcnt 1)
    7277    (if (vector? (car args))
    73         (let ((tm (car args)))
    74           (when (< (vector-length tm) 10) (error loc "time vector too short" tm))
    75           (set! yr (+ (vector-ref tm 5) 1900))
    76           (set! mo (vector-ref tm 4))
    77           (set! dy (vector-ref tm 3))
    78           (set! hr (vector-ref tm 2))
    79           (set! mn (vector-ref tm 1))
    80           (set! sc (vector-ref tm 0))
    81           (let ((args (cdr args)))
    82             (if (= 3 arglen)
    83                 (let ((arg (car args)))
    84                   (if (eq? #:offset? arg) (set! offset? (cadr args))
    85                       (if (keyword? arg) (error loc "unknown keyword argument" arg)
    86                           (##sys#error-hook 1 loc arglen 3) ) ) )
    87                 (unless (= 1 arglen) (##sys#error-hook 1 loc arglen 3)) ) ) )
     78        (let ((tv (car args)))
     79          (when (< (vector-length tv) 10)
     80            (error-argument-type loc tv "ten element vector") )
     81          (set! dst? (vector-ref tv 8))
     82          (set! yr (+ (vector-ref tv 5) 1900))
     83          (set! mo (vector-ref tv 4))
     84          (set! dy (vector-ref tv 3))
     85          (set! hr (vector-ref tv 2))
     86          (set! mn (vector-ref tv 1))
     87          (set! sc (vector-ref tv 0))
     88          (let loop ((args (cdr args)))
     89            (unless (null? args)
     90              (let ((arg (car args)))
     91                (cond ((keyword? arg)
     92                       (kwdarg arg args)
     93                       (loop (cddr args)) )
     94                      (else
     95                        (error-keyword loc arg) ) ) ) ) ) )
    8896        (begin
    89           (unless (<= 3 arglen) (##sys#error-hook 2 loc arglen 3))
     97          (check-minimum-argument-count loc argcnt 3)
    9098          (set! yr (car args))
    9199          (set! mo (cadr args))
     
    96104                (let ((arg (car args)))
    97105                  (cond ((keyword? arg)
    98                          (if (eq? #:offset? arg) (set! offset? (cadr args))
    99                              (error loc "unknown keyword argument" arg) )
     106                         (kwdarg arg args)
    100107                         (loop (cddr args)) )
    101108                        ((and hr mn sc)
    102                          (##sys#error-hook 1 loc arglen 8) )
     109                         (error-argument-count loc argcnt 8) )
    103110                        (else
    104111                         (if hr (if mn (set! sc arg) (set! mn arg)) (set! hr arg))
    105112                         (loop (cdr args)) ) ) ) ) ) ) )
    106113
    107     (unless (and (fixnum? yr) (fixnum? mo) (fixnum? dy) (fixnum? hr) (fixnum? mn) (fixnum? sc))
    108       (apply error loc "bad argument type - expected fixnum" args) )
    109     (unless (and (<= 0 sc 60) (<= 0 mn 59) (<= 0 hr 23) (<= 1 dy 31) (<= 0 mn 11))
    110       (apply error loc "bad argument type - out of range" args) )
     114    (check-fixnums loc yr mo dy hr mn sc)
     115    (check-closed-interval loc (<= 0 sc 60) (<= 0 mn 59) (<= 0 hr 23) (<= 1 dy 31) (<= 0 mo 11))
    111116
    112     (get-tz yr mo dy hr mn sc offset?) ) )
     117    (get-tz yr mo dy hr mn sc offset? dst?) ) )
    113118
    114119;;;
     
    118123;; format (e.g. "-0500").
    119124
    120 (define (local-timezone . args) (apply *local-timezone 'local-timezone args))
     125(define (local-timezone . args)
     126  (apply *local-timezone 'local-timezone (append args '(#:offset? #f))) )
    121127
    122128;; Return the timezone offset as seconds where positive is east of UTC &
     
    124130
    125131(define (local-timezone-offset . args)
    126   (let* ((tzo (apply 'local-timezone-offset *local-timezone args))
    127          (1stch (string-ref tzo 0))
    128          (neg? (char=? #\- 1stch))
    129          (start (if (or neg? (char=? #\+ 1stch)) 1 0))
    130          (end (+ start 2))
    131          (secs (+ (* (string->number (substring tzo start end)) 3600)
    132                   (* (string->number (substring tzo end (+ end 2))) 60))) )
    133     (if neg? (- secs) secs) ) )
     132  (cond-expand
     133    ((or windows linux freebsd netbsd openbsd macosx solaris sunos)
     134      (let* ((tzo (apply *local-timezone 'local-timezone-offset (append args '(#:offset? #t))))
     135             (1stch (string-ref tzo 0))
     136             (neg? (char=? #\- 1stch))
     137             (start (if (or neg? (char=? #\+ 1stch)) 1 0))
     138             (end (+ start 2))
     139             (secs (+ (* (string->number (substring tzo start end)) 3600)
     140                      (* (string->number (substring tzo end (+ end 2))) 60))) )
     141        (if neg? (- secs) secs) ) )
     142    (else
     143      (error 'local-timezone-offset "operation unsupported" (software-version)) ) ) )
    134144
    135145;;
  • release/4/locale/trunk/tests/run.scm

    r15682 r15915  
    55
    66(test-group "Locale"
     7
     8        (test-group "Local Timezone"
     9       
     10          (test "TZN (fail)" "" (local-timezone (seconds->local-time (current-seconds))))
     11          (test "TZO (fail)" -1 (local-timezone-offset (seconds->local-time (current-seconds))))
     12       
     13          #;(with-tzset "" (lambda () ))
     14        )
    715
    816        (test-group "Posix Timezone"
     
    5159        (posix-timezone-string->timezone-components "PST+8:00PDT7,J23/12:34,34/1:00:01" "TEST"))
    5260
     61      ;; This screws up any further testing of TZ related info
    5362      (setenv "TZ" "PST+8:00PDT+7:00:00,M4.1.0,M10.5")
    5463      (posix-load-timezone)
     
    8594      (test "LS4" lc0 (locale-category-ref 'monetary)) )
    8695        )
    87 
    88   #;
    89         (test-group "Local Timezone"
    90           (with-tzset "" (lambda () ))
    91         )
    9296)
Note: See TracChangeset for help on using the changeset viewer.