source: project/release/4/r7rs/trunk/scheme.base.scm @ 29956

Last change on this file since 29956 was 29956, checked in by evhan, 8 years ago

r7rs: cond-expand's matching clause should expand to a begin

File size: 12.2 KB
Line 
1(module scheme.base ()
2
3(import (except scheme syntax-rules cond-expand
4                       assoc list-set! list-tail member
5                       char=? char<? char>? char<=? char>=?
6                       string=? string<? string>? string<=? string>=?))
7(import (prefix (only scheme char=? char<? char>? char<=? char>=?
8                             string=? string<? string>? string<=? string>=?)
9                %))
10(import (except chicken with-exception-handler raise quotient remainder modulo))
11(import numbers)
12
13(include "scheme.base-interface.scm")
14
15(begin-for-syntax (require-library r7rs-compile-time))
16(import-for-syntax r7rs-compile-time)
17
18
19(define-syntax import
20  (er-macro-transformer
21   (lambda (x r c)
22     (##sys#expand-import 
23      (cons (car x)
24            (map (lambda (spec)
25                   (fixup-import/export-spec (strip-syntax spec) 'import))
26                 (cdr x)))
27      r c
28      ##sys#current-environment ##sys#macro-environment
29      #f #f 'import) ) ) )
30
31
32;;;
33;;; 4.2.1. Conditionals
34;;;
35
36(define-syntax cond-expand
37  (er-macro-transformer
38   (lambda (x r c)
39     (cons 'begin (process-cond-expand (cdr x))))))
40
41
42;;;
43;;; 4.2.7. Exception handling
44;;;
45
46;; guard & guard-aux copied verbatim from the draft.
47;; guard-aux put in a letrec-syntax due to import/export issues...
48(define-syntax guard
49  (syntax-rules ()
50    ((guard (var clause ...) e1 e2 ...)
51     (letrec-syntax ((guard-aux 
52                      (syntax-rules ___ (else =>)
53                        ((guard-aux reraise (else result1 result2 ___))
54                         (begin result1 result2 ___))
55                        ((guard-aux reraise (test => result))
56                         (let ((temp test))
57                           (if temp
58                               (result temp)
59                               reraise)))
60                        ((guard-aux reraise (test => result)
61                                    clause1 clause2 ___)
62                         (let ((temp test))
63                           (if temp
64                               (result temp)
65                               (guard-aux reraise clause1 clause2 ___))))
66                        ((guard-aux reraise (test))
67                         (or test reraise))
68                        ((guard-aux reraise (test) clause1 clause2 ___)
69                         (let ((temp test))
70                           (if temp
71                               temp
72                               (guard-aux reraise clause1 clause2 ___))))
73                        ((guard-aux reraise (test result1 result2 ___))
74                         (if test
75                             (begin result1 result2 ___)
76                             reraise))
77                        ((guard-aux reraise
78                                    (test result1 result2 ___)
79                                    clause1 clause2 ___)
80                         (if test
81                             (begin result1 result2 ___)
82                             (guard-aux reraise clause1 clause2 ___))))))
83      ((call/cc
84        (lambda (guard-k)
85          (with-exception-handler
86           (lambda (condition)
87             ((call/cc
88               (lambda (handler-k)
89                 (guard-k
90                  (lambda ()
91                    (let ((var condition))
92                      (guard-aux
93                       (handler-k
94                        (lambda ()
95                          (raise-continuable condition)))
96                       clause ...))))))))
97           (lambda ()
98             (call-with-values
99                 (lambda () e1 e2 ...)
100               (lambda args
101                 (guard-k
102                  (lambda ()
103                    (apply values args))))))))))))))
104
105;;;
106;;; 5.4. Syntax definitions
107;;;
108(include "synrules.scm")
109
110
111;;;
112;;; 6.3 Booleans
113;;;
114
115;(: boolean=? ((procedure #:enforce) (boolean boolean #!rest boolean) boolean))
116(: boolean=? (boolean boolean #!rest boolean -> boolean))
117
118(define (boolean=? b1 b2 . rest)
119  (##sys#check-boolean b1 'boolean=?)
120  ;; Loop across all args, checking for booleans.  Don't shortcut and
121  ;; stop when we find nonequality.
122  (let lp ((b1 b1)
123           (b2 b2)
124           (rest rest)
125           (result (eq? b1 b2)))
126    (##sys#check-boolean b2 'boolean=?)
127    (if (null? rest)
128        (and result (eq? b1 b2))
129        (lp b2 (car rest) (cdr rest) (and result (eq? b1 b2))))))
130
131
132;;;
133;;; 6.4 pairs and lists
134;;;
135
136(: make-list (forall (x) (fixnum #!optional x -> (list-of x))))
137
138(define make-list
139  (case-lambda
140   ((n) (make-list n #f))
141   ((n fill)
142    (##sys#check-integer n 'make-list)
143    (unless (fx>= n 0)
144      (error 'make-list "not a positive integer" n))
145    (do ((i n (fx- i 1))
146         (result '() (cons fill result)))
147        ((fx= i 0) result)))))
148
149
150(: list-tail (forall (x) ((list-of x) fixnum -> (list-of x))))
151
152(define (list-tail l n)
153  (##sys#check-integer n 'list-tail)
154  (unless (fx>= n 0)
155    (error 'list-tail "not a positive integer" n))
156  (do ((i n (fx- i 1))
157       (result l (cdr result)))
158      ((fx= i 0) result)
159    (when (null? result)
160      (error 'list-tail "out of range"))))
161
162
163(: list-set! (list fixnum -> undefined))
164
165(define (list-set! l n obj)
166  (##sys#check-integer n 'list-set!)
167  (unless (fx>= n 0)
168    (error 'list-set! "not a positive integer" n))
169  (do ((i n (fx- i 1))
170       (l l (cdr l)))
171      ((fx= i 0) (set-car! l obj))
172    (when (null? l)
173      (error 'list-set! "out of range"))))
174
175(: member (forall (a b) (a (list-of b) #!optional (procedure (b a) *) ; sic
176                         -> (or boolean (list-of b)))))
177
178;; XXX These aren't exported to the types file!?
179(define-specialization (member (x (or symbol procedure immediate)) (lst list))
180  (##core#inline "C_u_i_memq" x lst))
181(define-specialization (member x (lst (list-of (or symbol procedure immediate))))
182  (##core#inline "C_u_i_memq" x lst))
183(define-specialization (member x lst)
184  (##core#inline "C_i_member" x lst))
185
186(define member
187  (case-lambda
188   ((x lst) (##core#inline "C_i_member" x lst))
189   ((x lst eq?)
190    (let lp ((lst lst))
191      (cond ((null? lst) #f)
192            ((eq? (car lst) x) lst)
193            (else (lp (cdr lst))))))))
194
195
196(: assoc (forall (a b c) (a (list-of (pair b c)) #!optional (procedure (b a) *) ; sic
197                            -> (or boolean (list-of (pair b c))))))
198
199;; XXX These aren't exported to the types file!?
200(define-specialization (assoc (x (or symbol procedure immediate)) (lst (list-of pair)))
201  (##core#inline "C_u_i_assq" x lst))
202(define-specialization (assoc x (lst (list-of (pair (or symbol procedure immediate) *))))
203  (##core#inline "C_u_i_assq" x lst))
204(define-specialization (assoc x lst)
205  (##core#inline "C_i_assoc" x lst))
206
207(define assoc
208  (case-lambda
209   ((x lst) (##core#inline "C_i_assoc" x lst))
210   ((x lst eq?)
211    (let lp ((lst lst))
212      (cond ((null? lst) #f)
213            ((not (pair? (car lst)))
214             (error 'assoc "unexpected non-pair in list" (car lst)))
215            ((eq? (caar lst) x) (car lst))
216            (else (lp (cdr lst))))))))
217
218
219(: list-copy (forall (a) ((list-of a) -> (list-of a))))
220
221;; TODO: Test if this is the quickest way to do this, or whether we
222;; should just cons recursively like our SRFI-1 implementation does.
223(define (list-copy lst)
224  (let lp ((res '())
225           (lst lst))
226    (if (null? lst)
227        (##sys#fast-reverse res)
228        (lp (cons (car lst) res) (cdr lst)))))
229
230;;;
231;;; 6.6 Characters
232;;;
233
234(define-syntax define-extended-arity-comparator
235  (syntax-rules ()
236    ((_ name comparator check-type)
237     (define name
238       (let ((cmp comparator))
239         (lambda (o1 o2 . os)
240           (check-type o1 'name)
241           (let lp ((o1 o1) (o2 o2) (os os) (eq #t))
242             (check-type o2 'name)
243             (if (null? os)
244                 (and eq (cmp o1 o2))
245                 (lp o2 (car os) (cdr os) (and eq (cmp o1 o2)))))))))))
246
247(: char=? (char char #!rest char -> boolean))
248(: char<? (char char #!rest char -> boolean))
249(: char>? (char char #!rest char -> boolean))
250(: char<=? (char char #!rest char -> boolean))
251(: char>=? (char char #!rest char -> boolean))
252
253(define-extended-arity-comparator char=? %char=? ##sys#check-char)
254(define-extended-arity-comparator char>? %char>? ##sys#check-char)
255(define-extended-arity-comparator char<? %char<? ##sys#check-char)
256(define-extended-arity-comparator char<=? %char<=? ##sys#check-char)
257(define-extended-arity-comparator char>=? %char>=? ##sys#check-char)
258
259;;;
260;;; 6.7 Strings
261;;;
262
263(: string=? (string string #!rest string -> boolean))
264(: string<? (string string #!rest string -> boolean))
265(: string>? (string string #!rest string -> boolean))
266(: string<=? (string string #!rest string -> boolean))
267(: string>=? (string string #!rest string -> boolean))
268
269(define-extended-arity-comparator string=? %string=? ##sys#check-string)
270(define-extended-arity-comparator string<? %string<? ##sys#check-string)
271(define-extended-arity-comparator string>? %string>? ##sys#check-string)
272(define-extended-arity-comparator string<=? %string<=? ##sys#check-string)
273(define-extended-arity-comparator string>=? %string>=? ##sys#check-string)
274
275;;;
276;;; 6.11. Exceptions
277;;;
278
279(: with-exception-handler ((* -> . *) (-> . *) -> . *))
280(: raise (* -> noreturn))
281(: raise-continuable (* -> . *))
282
283;; XXX TODO: This is not threadsafe!
284(define-values (with-exception-handler raise raise-continuable)
285  (let ((exception-handlers
286         (let ((lst (list ##sys#current-exception-handler)))
287           (set-cdr! lst lst)
288           lst)))
289    (values
290     ;; with-exception-handler
291     (lambda (handler thunk)
292       (dynamic-wind
293        (lambda ()
294          ;; We might be interoperating with srfi-12 handlers set by intermediate
295          ;; non-R7RS code, so check if a new handler was set in the meanwhile.
296          (unless (eq? (car exception-handlers) ##sys#current-exception-handler)
297            (set! exception-handlers
298              (cons ##sys#current-exception-handler exception-handlers)))
299          (set! exception-handlers (cons handler exception-handlers))
300          (set! ##sys#current-exception-handler handler))
301        thunk
302        (lambda ()
303          (set! exception-handlers (cdr exception-handlers))
304          (set! ##sys#current-exception-handler (car exception-handlers)))))
305     ;; raise
306     (lambda (obj)
307       (with-exception-handler
308        (cadr exception-handlers)
309        (lambda ()
310          ((cadr exception-handlers) obj)
311          ((car exception-handlers)
312           (make-property-condition
313            'exn
314            'message "exception handler returned"
315            'arguments '()
316            'location #f)))))
317     ;; raise-continuable
318     (lambda (obj)
319       (with-exception-handler
320        (cadr exception-handlers)
321        (lambda ()
322          ((cadr exception-handlers) obj)))))))
323
324(: error-object? (* --> boolean : (struct condition)))
325(: error-object-message ((struct condition) -> string))
326(: error-object-irritants ((struct condition) -> list))
327
328(define error-object? condition?)
329(define error-object-message (condition-property-accessor 'exn 'message))
330(define error-object-irritants (condition-property-accessor 'exn 'arguments))
331
332(: read-error? (* --> boolean))
333(: file-error? (* --> boolean))
334
335(define-values (read-error? file-error?)
336  (let ((exn?    (condition-predicate 'exn))
337        (i/o?    (condition-predicate 'i/o))
338        (file?   (condition-predicate 'file))
339        (syntax? (condition-predicate 'syntax)))
340    (values
341     ;; read-error?
342     (lambda (obj)
343       (and (exn? obj)
344            (or (i/o? obj) ; XXX Not fine-grained enough.
345                (syntax? obj))))
346     ;; file-error?
347     (lambda (obj)
348       (and (exn? obj)
349            (file? obj))))))
350
351
352;;;
353;;; 6.13. Input and Output
354;;;
355
356(: call-with-port (port (port -> . *) -> . *))
357(: close-port (port -> void))
358(: output-port-open? (output-port -> boolean))
359(: input-port-open? (input-port -> boolean))
360(: eof-object (--> eof))
361
362(define (call-with-port port proc)
363  (receive ret
364      (proc port)
365    (close-port port)
366    (apply values ret)))
367
368(define (close-port port)
369  (cond ((input-port? port)
370         (close-input-port port))
371        ((output-port? port)
372         (close-output-port port))
373        (else
374         (error 'close-port "not a port" port))))
375
376(define (output-port-open? port)
377  (##sys#check-output-port port #f 'output-port-open?)
378  (not (port-closed? port)))
379(define (input-port-open? port)
380  (##sys#check-input-port port #f 'input-port-open?)
381  (not (port-closed? port)))
382
383(define (eof-object) #!eof)
384
385)
Note: See TracBrowser for help on using the repository browser.