source: project/release/4/locale/trunk/locale-components.scm @ 15643

Last change on this file since 15643 was 15643, checked in by Kon Lovett, 11 years ago

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

File size: 5.9 KB
Line 
1;;;; locale-components.scm
2;;;; Kon Lovett, May '06
3
4;; ISSUES
5;;
6;; - Components predicates are not fool-proof.
7;;
8;; - Used selectors for *-components since it is assumed extra elements will be needed by
9;; platform specific code. May switch to records later & deprecate the existing interface.
10
11(module locale-components (;export
12  ;
13  check-locale-components
14  make-locale-components
15  locale-components?
16  locale-component-ref
17  locale-component-exists?
18  set-locale-component!
19  update-locale-components!
20  ;
21  check-timezone-components
22  make-timezone-components
23  timezone-components?
24  set-timezone-component!
25  timezone-component-ref
26  update-timezone-components!
27  ;
28  make-timezone-dst-rule-julian-leap
29  make-timezone-dst-rule-julian-noleap
30  make-timezone-dst-rule-mwd
31  timezone-dst-rule-julian?
32  timezone-dst-rule-julian-leap?
33  timezone-dst-rule-julian-noleap?
34  timezone-dst-rule-mwd?
35  timezone-dst-rule-julian
36  timezone-dst-rule-day
37  timezone-dst-rule-month
38  timezone-dst-rule-week
39  timezone-dst-rule-offset)
40
41  (import chicken scheme)
42  (require-extension srfi-1
43                     type-checks type-errors)
44
45  (declare
46    (fixnum)
47    (inline)
48    (no-procedure-checks)
49    (disable-interrupts) )
50
51;;;
52
53;;
54
55(define-inline (%->boolean obj) (and obj #t))
56
57;;; Locale Components Operations
58
59(define-inline (*locale-component-exists? al what)
60  (%->boolean (assq what al)) )
61
62(define-inline (*locale-component-ref al what def)
63        (let ((cell (assq what al)))
64                (if cell (cdr cell)
65        def ) ) )
66
67; Components argument cannot be null to effect in-place modification.
68
69(define (*set-locale-component! al what value)
70  (if (null? al) (alist-cons what value al)
71    (let ((cell (assq what al)))
72      (cond (cell (set-cdr! cell value))
73            (else (set-cdr! (last-pair al) (list (cons what value)))))
74      al ) ) )
75
76(define (*update-locale-components! lc kvs)
77        (let loop ((kvs kvs))
78                (cond ((null? kvs) lc)
79                      (else
80           (set! lc (*set-locale-component! lc (car kvs) (cadr kvs)))
81           (loop (cddr kvs)) ) ) ) )
82
83;;; Locale Components
84
85(define (make-empty-locale-components) '())
86
87(define (make-locale-components nam . args)
88  (let-optionals args ((src #f) (tag 'locale))
89    (let ((lc (*set-locale-component! (make-empty-locale-components) 'tag tag)))
90      (*set-locale-component! lc 'name nam)
91      (*set-locale-component! lc 'source src)
92      lc ) ) )
93
94(define (locale-components? obj)
95        (and (pair? obj)
96             (*locale-component-exists? obj 'tag)
97             (*locale-component-exists? obj 'name)
98             (*locale-component-exists? obj 'source)) )
99
100(define-check+error-type locale-components)
101
102(define (locale-component-exists? lc what)
103  (check-locale-components 'locale-component-exists? lc)
104  (*locale-component-exists? lc what) )
105
106(define (locale-component-ref lc what . def)
107  (check-locale-components 'locale-component-ref lc)
108        (*locale-component-ref lc what (optional def #f)) )
109
110(define (set-locale-component! lc what value)
111  (check-locale-components 'set-locale-component! lc)
112        (*set-locale-component! lc what value) )
113
114(define (update-locale-components! lc . args)
115  (check-locale-components 'update-locale-components! lc)
116        (*update-locale-components! lc args) )
117
118;;; Timezone Daylight Saving Time Rule
119
120(define-record-type timezone-dst-rule-julian-noleap
121  (make-timezone-dst-rule-julian-noleap j o)
122  timezone-dst-rule-julian-noleap?
123  (j timezone-dst-rule-julian-noleap-day)
124  (o timezone-dst-rule-julian-noleap-offset) )
125
126(define-record-type timezone-dst-rule-julian-leap
127  (make-timezone-dst-rule-julian-leap j o)
128  timezone-dst-rule-julian-leap?
129  (j timezone-dst-rule-julian-leap-day)
130  (o timezone-dst-rule-julian-leap-offset) )
131
132(define-record-type timezone-dst-rule-mwd
133  (make-timezone-dst-rule-mwd m w d o)
134  timezone-dst-rule-mwd?
135  (m timezone-dst-rule-mwd-month)
136  (w timezone-dst-rule-mwd-week)
137  (d timezone-dst-rule-mwd-day)
138  (o timezone-dst-rule-mwd-offset) )
139
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")
143
144(define (timezone-dst-rule-julian? r)
145  (or (timezone-dst-rule-julian-noleap? r) (timezone-dst-rule-julian-leap? r)) )
146
147(define (timezone-dst-rule-julian r)
148  (cond ((timezone-dst-rule-julian-noleap? r) (timezone-dst-rule-julian-noleap-day r))
149        ((timezone-dst-rule-julian-leap? r) (timezone-dst-rule-julian-leap-day r))
150        (else
151         (error-timezone-dst-rule-julian 'timezone-dst-rule-julian r) ) ) )
152
153(define (timezone-dst-rule-month r)
154  (check-timezone-dst-rule-mwd 'timezone-dst-rule-month r)
155  (timezone-dst-rule-mwd-month r) )
156
157(define (timezone-dst-rule-week r)
158  (check-timezone-dst-rule-mwd 'timezone-dst-rule-week r)
159  (timezone-dst-rule-mwd-week r) )
160
161(define (timezone-dst-rule-day r)
162  (check-timezone-dst-rule-mwd 'timezone-dst-rule-day r)
163  (timezone-dst-rule-mwd-day r) )
164
165(define (timezone-dst-rule-offset r)
166  (cond ((timezone-dst-rule-julian-noleap? r) (timezone-dst-rule-julian-noleap-offset r))
167        ((timezone-dst-rule-julian-leap? r) (timezone-dst-rule-julian-leap-offset r))
168        ((timezone-dst-rule-mwd? r) (timezone-dst-rule-mwd-offset r))
169        (else
170         (error-timezone-dst-rule 'timezone-dst-rule-offset r) ) ) )
171
172;;; Timezone Components
173
174(define (make-timezone-components nam . src)
175  (make-locale-components nam (optional src #f) 'timezone) )
176
177(define (timezone-components? obj)
178        (and (locale-components? obj)
179             (eq? 'timezone (*locale-component-ref obj 'tag #f))) )
180
181(define-check+error-type timezone-components)
182
183(define (timezone-component-ref tz what . def)
184  (check-timezone-components 'timezone-component-ref tz)
185        (*locale-component-ref tz what (optional def #f)) )
186
187(define (set-timezone-component! tz what value)
188  (check-timezone-components 'set-timezone-component! tz)
189        (*set-locale-component! tz what value) )
190
191(define (update-timezone-components! tz . args)
192  (check-timezone-components 'update-timezone-components! tz)
193        (*update-locale-components! tz args) )
194
195) ;module locale-components
Note: See TracBrowser for help on using the repository browser.