source: project/release/3/locale/trunk/locale-parameters.scm @ 13852

Last change on this file since 13852 was 13852, checked in by Kon Lovett, 12 years ago

Added errors file.

File size: 3.7 KB
Line 
1;;;; locale-parameters.scm
2;;;; Kon Lovett, May '06
3
4;;ISSUES
5;;
6;; - Only Posix for now.
7
8(declare
9  (usual-integrations)
10  (fixnum)
11  (inline)
12  (no-procedure-checks)
13  (export
14    current-locale-dictionary
15    current-timezone
16    current-locale
17    current-timezone-components
18    current-locale-components) )
19
20(require-extension miscmacros locale-categories locale-components locale-errors)
21
22;;
23
24(define (check-string-or-false loc obj)
25  (unless (or (not obj) (string? obj))
26    (type-error loc "string or #f" obj) ) )
27
28;;
29
30(define-parameter current-locale-dictionary (make-locale-dictionary)
31  (lambda (obj)
32    (cond ((locale-dictionary? obj)
33            obj)
34          (else
35            (warning 'current-locale-dictionary (make-type-error-message "a locale-dictionary") obj)
36            (current-locale-dictionary) ) ) ) )
37
38;;
39
40(define (current-timezone . args)
41  (cond ((null? args)
42          (and-let* ((lc (locale-category-ref 'timezone)))
43            (locale-component-ref lc 'name) ) )
44        (else
45          (let-optionals args ((str #f) (src "USER"))
46            (check-string-or-false 'current-timezone str)
47            (let ((lc (and str (posix-timezone-string->locale-components str src))))
48              (set-locale-category! 'timezone lc) ) ) ) ) )
49
50;; A'la MzScheme
51;; Treat locale as messages category
52
53(define (current-locale . args)
54  (cond ((null? args)
55          (and-let* ((lc (locale-category-ref 'messages)))
56            (locale-component-ref lc 'name) ) )
57        (else
58          (let-optionals args ((str #f) (src "USER"))
59            (check-string-or-false 'current-locale str)
60            (let ((lc (and str (posix-locale-string->locale-components str src))))
61              (set-locale-category! 'messages lc) ) ) ) ) )
62
63;;;
64
65(define (current-timezone-components) (locale-category-ref 'timezone))
66
67(define (current-locale-components) (locale-category-ref 'messages))
68
69;;
70
71#;
72(define current-timezone-components
73        (let ((cached-timezone #f)
74                                (cached-components (default-timezone-components)))
75                (lambda args
76                  (cond ((null? args)
77              (let ((timezone (current-timezone)))
78                (unless (equal? cached-timezone timezone)
79                  (unless (and timezone
80                               (and-let* (((string? timezone))
81                                          (tzc (posix-timezone-string->timezone-components timezone)))
82                                 (current-timezone-components timezone tzc)
83                                 #t ) )
84                    (current-timezone-components #f (default-timezone-components)) ) ) ) )
85            ((= 2 (length args))
86              (set! cached-timezone (car args))
87              (set! cached-components (cadr args)) )
88            (else
89              (error 'current-timezone-components "too few arguments" args) ) )
90      cached-components ) ) )
91
92;;
93
94#;
95(define current-locale-components
96        (let ((cached-locale #f)
97                                (cached-components (default-locale-components)))
98                (lambda args
99                  (cond ((null? args)
100              (let ((locale (current-locale)))
101                (unless (equal? cached-locale locale)
102                  (unless (and locale
103                               (and-let* (((string? locale))
104                                          (lc (posix-locale-string->locale-components locale)))
105                                 (current-locale-components locale lc)
106                                 #t ) )
107                    (current-locale-components #f (default-locale-components)) ) ) ) )
108            ((= 2 (length args))
109              (set! cached-locale (car args))
110              (set! cached-components (cadr args)) )
111            (else
112              (error 'current-locale-components "too few arguments" args) ) )
113      cached-components ) ) )
Note: See TracBrowser for help on using the repository browser.