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

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

Save

File size: 6.1 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                     locale-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-locale-components loc obj)
101  (unless (locale-components? obj)
102    (locale-type-error loc "a locale-components object" obj) ) )
103
104(define (locale-component-exists? lc what)
105  (check-locale-components 'locale-component-exists? lc)
106  (*locale-component-exists? lc what) )
107
108(define (locale-component-ref lc what . def)
109  (check-locale-components 'locale-component-ref lc)
110        (*locale-component-ref lc what (optional def #f)) )
111
112(define (set-locale-component! lc what value)
113  (check-locale-components 'set-locale-component! lc)
114        (*set-locale-component! lc what value) )
115
116(define (update-locale-components! lc . args)
117  (check-locale-components 'update-locale-components! lc)
118        (*update-locale-components! lc args) )
119
120;;; Timezone Daylight Saving Time Rule
121
122(define-record-type timezone-dst-rule-julian-noleap
123  (make-timezone-dst-rule-julian-noleap j o)
124  timezone-dst-rule-julian-noleap?
125  (j timezone-dst-rule-julian-noleap-day)
126  (o timezone-dst-rule-julian-noleap-offset) )
127
128(define-record-type timezone-dst-rule-julian-leap
129  (make-timezone-dst-rule-julian-leap j o)
130  timezone-dst-rule-julian-leap?
131  (j timezone-dst-rule-julian-leap-day)
132  (o timezone-dst-rule-julian-leap-offset) )
133
134(define-record-type timezone-dst-rule-mwd
135  (make-timezone-dst-rule-mwd m w d o)
136  timezone-dst-rule-mwd?
137  (m timezone-dst-rule-mwd-month)
138  (w timezone-dst-rule-mwd-week)
139  (d timezone-dst-rule-mwd-day)
140  (o timezone-dst-rule-mwd-offset) )
141
142(define (check-timezone-dst-rule-mwd loc r)
143  (unless (timezone-dst-rule-mwd? r)
144    (locale-type-error loc "timezone-dst-rule-mwd" r) ) )
145
146(define (timezone-dst-rule-julian? r)
147  (or (timezone-dst-rule-julian-noleap? r) (timezone-dst-rule-julian-leap? r)) )
148
149(define (timezone-dst-rule-julian r)
150  (cond ((timezone-dst-rule-julian-noleap? r) (timezone-dst-rule-julian-noleap-day r))
151        ((timezone-dst-rule-julian-leap? r) (timezone-dst-rule-julian-leap-day r))
152        (else
153         (locale-type-error 'timezone-dst-rule-offset "timezone-dst-rule-julian" r) ) ) )
154
155(define (timezone-dst-rule-month r)
156  (check-timezone-dst-rule-mwd 'timezone-dst-rule-month r)
157  (timezone-dst-rule-mwd-month r) )
158
159(define (timezone-dst-rule-week r)
160  (check-timezone-dst-rule-mwd 'timezone-dst-rule-week r)
161  (timezone-dst-rule-mwd-week r) )
162
163(define (timezone-dst-rule-day r)
164  (check-timezone-dst-rule-mwd 'timezone-dst-rule-day r)
165  (timezone-dst-rule-mwd-day r) )
166
167(define (timezone-dst-rule-offset r)
168  (cond ((timezone-dst-rule-julian-noleap? r) (timezone-dst-rule-julian-noleap-offset r))
169        ((timezone-dst-rule-julian-leap? r) (timezone-dst-rule-julian-leap-offset r))
170        ((timezone-dst-rule-mwd? r) (timezone-dst-rule-mwd-offset r))
171        (else
172         (locale-type-error 'timezone-dst-rule-offset "timezone-dst-rule" r) ) ) )
173
174;;; Timezone Components
175
176(define (make-timezone-components nam . src)
177  (make-locale-components nam (optional src #f) 'timezone) )
178
179(define (timezone-components? obj)
180        (and (locale-components? obj)
181             (eq? 'timezone (*locale-component-ref obj 'tag #f))) )
182
183(define (check-timezone-components loc obj)
184  (unless (timezone-components? obj)
185    (locale-type-error loc "a timezone-components object" obj) ) )
186
187(define (timezone-component-ref tz what . def)
188  (check-timezone-components 'timezone-component-ref tz)
189        (*locale-component-ref tz what (optional def #f)) )
190
191(define (set-timezone-component! tz what value)
192  (check-timezone-components 'set-timezone-component! tz)
193        (*set-locale-component! tz what value) )
194
195(define (update-timezone-components! tz . args)
196  (check-timezone-components 'update-timezone-components! tz)
197        (*update-locale-components! tz args) )
198
199) ;module locale-components
Note: See TracBrowser for help on using the repository browser.