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

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

Save. Mvd params into locale.scm

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