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

Last change on this file since 29599 was 29599, checked in by sjamaan, 8 years ago

r7rs: import and export the quotient/remainder division procedures. Update numbers dependency version to 2.9

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