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

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

Added errors file.

File size: 4.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(declare
12  (usual-integrations)
13  (fixnum)
14  (inline)
15  (no-procedure-checks)
16  (export
17    ;
18    check-locale-components
19    make-locale-components
20    locale-components?
21    locale-component-ref
22    set-locale-component!
23    update-locale-components!
24    ;
25    check-timezone-components
26    make-timezone-components
27    timezone-components?
28    set-timezone-component!
29    timezone-component-ref
30    update-timezone-components!
31    ;
32    make-timezone-dst-rule-julian-leap
33    make-timezone-dst-rule-julian-noleap
34    make-timezone-dst-rule-mwd
35    timezone-dst-rule-julian-leap?
36    timezone-dst-rule-julian-noleap?
37    timezone-dst-rule-mwd?
38    timezone-dst-rule-day
39    timezone-dst-rule-julian
40    timezone-dst-rule-month
41    timezone-dst-rule-offset
42    timezone-dst-rule-week) )
43
44(require-extension srfi-1 local-errors)
45
46;;;
47
48;;
49
50(define-inline (%->boolean obj) (and obj #t))
51
52;;; Association List Operations
53
54;;
55
56(define (%locale-component-exists? al what)
57  (%->boolean (assq what al)) )
58
59(define (%locale-component-ref al what . def)
60        (let ((p (assq what al)))
61                (if p (cdr p)
62        (optional def #f) ) ) )
63
64;; Components argument cannot be null to effect in-place modification.
65
66(define (%set-locale-component! al what value)
67        (let ((p (assq what al)))
68                (cond (p
69                        (set-cdr! p value))
70          ((null? al)
71            (set! al (alist-cons what value al)))
72          (else
73            (set-cdr! (last-pair al) (list (cons what value)))))
74                al ) )
75
76;;
77
78(define (%update-locale-components! lc . args)
79        (let loop ((key-val-lst args))
80                (if (null? key-val-lst) lc
81                    (begin
82          (set-locale-component! lc (car key-val-lst) (cadr key-val-lst))
83          (loop (cddr key-val-lst)) ) ) ) )
84
85;;; Timezone Daylight Saving Time Rule
86
87;;
88
89(define (timezone-dst-rule-julian-noleap? r)
90        (let ((d (car r)))
91                (and (= 2 (length d)) (= 1 (car d))) ) )
92
93;;
94
95(define (timezone-dst-rule-julian-leap? r)
96        (let ((d (car r)))
97                (and (= 2 (length d)) (= 0 (car d))) ) )
98
99;;
100
101(define (timezone-dst-rule-mwd? r)
102        (let ((d (car r)))
103                (= 3 (length d)) ) )
104
105;;
106
107(define (timezone-dst-rule-julian r)
108        (cadar r) )
109
110;;
111
112(define (timezone-dst-rule-month r)
113        (caar r) )
114
115;;
116
117(define (timezone-dst-rule-week r)
118        (cadar r) )
119
120;;
121
122(define (timezone-dst-rule-day r)
123        (caddar r) )
124
125;;
126
127(define (timezone-dst-rule-offset r)
128        (cdr r) )
129
130;;
131
132(define (make-timezone-dst-rule-julian-noleap j o)
133        (cons (list 1 j) o) )
134
135;;
136
137(define (make-timezone-dst-rule-julian-leap j o)
138        (cons (list 0 j) o) )
139
140;;
141
142(define (make-timezone-dst-rule-mwd m w d o)
143        (cons (list m w d) o) )
144
145;;; Locale Components
146
147;;
148
149(define (empty-locale-components)
150        '() )
151
152;;
153
154(define (make-locale-components nam . args)
155  (let-optionals args ((src #f) (tag 'locale))
156    (let ((lc (empty-locale-components)))
157      (%set-locale-component! lc 'tag tag)
158      (%set-locale-component! lc 'name nam)
159      (%set-locale-component! lc 'source src)
160      lc ) ) )
161
162;;
163
164(define (locale-components? obj)
165        (and (pair? obj)
166             (%locale-component-exists? obj 'tag)
167             (%locale-component-exists? obj 'name)
168             (%locale-component-exists? obj 'source)) )
169
170(define (check-locale-components loc obj)
171  (unless (locale-components? obj)
172    (type-error loc "a timezone-components object" obj) ) )
173
174;;
175
176(define (locale-component-exists? lc what)
177  (check-locale-components 'locale-component-exists? lc)
178  (%locale-component-exists? lc what) )
179
180;;
181
182(define (locale-component-ref lc what . def)
183  (check-locale-components 'locale-component-ref lc)
184        (apply %locale-component-ref lc what def) )
185
186;;
187
188(define (set-locale-component! lc what value)
189  (check-locale-components 'set-locale-component! lc)
190        (%set-locale-component! lc what value) )
191
192;;
193
194(define (update-locale-components! lc . args)
195  (check-locale-components 'update-locale-components! lc)
196        (apply %update-locale-components! lc args) )
197
198;;; Timezone Components
199
200;;
201
202(define (make-timezone-components n s)
203        (make-locale-components n s 'timezone) )
204
205;;
206
207(define (timezone-components? obj)
208        (and (locale-components? obj)
209             (eq? 'timezone (%locale-component-ref obj 'tag))) )
210
211(define (check-timezone-components loc obj)
212  (unless (timezone-components? obj)
213    (type-error loc "a timezone-components object" obj) ) )
214
215;;
216
217(define (timezone-component-ref tz what . def)
218  (check-timezone-components 'timezone-component-ref tz)
219        (apply %locale-component-ref tz what def) )
220
221;;
222
223(define (set-timezone-component! tz what value)
224  (check-timezone-components 'set-timezone-component! tz)
225        (%set-locale-component! tz what value) )
226
227;;
228
229(define (update-timezone-components! tz . args)
230  (check-timezone-components 'update-timezone-components! tz)
231        (apply %update-locale-components! tz args) )
Note: See TracBrowser for help on using the repository browser.