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

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

r7rs: reverse, list-tail, list-ref and list-set!

File size: 8.2 KB
Line 
1(module scheme.base ()
2
3(import (except scheme syntax-rules cond-expand))
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;;;
169;;; 6.11. Exceptions
170;;;
171
172(: with-exception-handler ((* -> . *) (-> . *) -> . *))
173(: raise (* -> noreturn))
174(: raise-continuable (* -> . *))
175
176;; XXX TODO: This is not threadsafe!
177(define-values (with-exception-handler raise raise-continuable)
178  (let ((exception-handlers
179         (let ((lst (list ##sys#current-exception-handler)))
180           (set-cdr! lst lst)
181           lst)))
182    (values
183     ;; with-exception-handler
184     (lambda (handler thunk)
185       (dynamic-wind
186        (lambda ()
187          ;; We might be interoperating with srfi-12 handlers set by intermediate
188          ;; non-R7RS code, so check if a new handler was set in the meanwhile.
189          (unless (eq? (car exception-handlers) ##sys#current-exception-handler)
190            (set! exception-handlers
191              (cons ##sys#current-exception-handler exception-handlers)))
192          (set! exception-handlers (cons handler exception-handlers))
193          (set! ##sys#current-exception-handler handler))
194        thunk
195        (lambda ()
196          (set! exception-handlers (cdr exception-handlers))
197          (set! ##sys#current-exception-handler (car exception-handlers)))))
198     ;; raise
199     (lambda (obj)
200       (with-exception-handler
201        (cadr exception-handlers)
202        (lambda ()
203          ((cadr exception-handlers) obj)
204          ((car exception-handlers)
205           (make-property-condition
206            'exn
207            'message "exception handler returned"
208            'arguments '()
209            'location #f)))))
210     ;; raise-continuable
211     (lambda (obj)
212       (with-exception-handler
213        (cadr exception-handlers)
214        (lambda ()
215          ((cadr exception-handlers) obj)))))))
216
217(: error-object? (* --> boolean : (struct condition)))
218(: error-object-message ((struct condition) -> string))
219(: error-object-irritants ((struct condition) -> list))
220
221(define error-object? condition?)
222(define error-object-message (condition-property-accessor 'exn 'message))
223(define error-object-irritants (condition-property-accessor 'exn 'arguments))
224
225(: read-error? (* --> boolean))
226(: file-error? (* --> boolean))
227
228(define-values (read-error? file-error?)
229  (let ((exn?    (condition-predicate 'exn))
230        (i/o?    (condition-predicate 'i/o))
231        (file?   (condition-predicate 'file))
232        (syntax? (condition-predicate 'syntax)))
233    (values
234     ;; read-error?
235     (lambda (obj)
236       (and (exn? obj)
237            (or (i/o? obj) ; XXX Not fine-grained enough.
238                (syntax? obj))))
239     ;; file-error?
240     (lambda (obj)
241       (and (exn? obj)
242            (file? obj))))))
243
244
245;;;
246;;; 6.13. Input and Output
247;;;
248
249(: call-with-port (port (port -> . *) -> . *))
250(: close-port (port -> void))
251(: output-port-open? (output-port -> boolean))
252(: input-port-open? (input-port -> boolean))
253(: eof-object (--> eof))
254
255(define (call-with-port port proc)
256  (receive ret
257      (proc port)
258    (close-port port)
259    (apply values ret)))
260
261(define (close-port port)
262  (cond ((input-port? port)
263         (close-input-port port))
264        ((output-port? port)
265         (close-output-port port))
266        (else
267         (error 'close-port "not a port" port))))
268
269(define (output-port-open? port)
270  (##sys#check-output-port port #f 'output-port-open?)
271  (not (port-closed? port)))
272(define (input-port-open? port)
273  (##sys#check-input-port port #f 'input-port-open?)
274  (not (port-closed? port)))
275
276(define (eof-object) #!eof)
277
278)
Note: See TracBrowser for help on using the repository browser.