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

Last change on this file since 29432 was 29432, checked in by sjamaan, 7 years ago

r7rs: mem*, ass*, list-copy; this completes 6.4: pairs and lists

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