source: project/release/5/sandbox/tags/1.9/sandbox.scm @ 36055

Last change on this file since 36055 was 36055, checked in by Kooda, 14 months ago

Port the sandbox egg to CHICKEN 5

File size: 30.0 KB
Line 
1;;; sandbox.scm - "Safe" interpreter for a Scheme subset
2;
3; Copyright (c) 2009, The CHICKEN Team
4; Copyright (c) 2000-2008, Felix L. Winkelmann
5; All rights reserved.
6;
7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
8; conditions are met:
9;
10;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
11;     disclaimer.
12;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
13;     disclaimer in the documentation and/or other materials provided with the distribution.
14;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
15;     products derived from this software without specific prior written permission.
16;
17; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25; POSSIBILITY OF SUCH DAMAGE.
26
27
28(module sandbox
29(current-safe-environment
30 current-fuel
31 current-allocation-limit
32 default-safe-environment
33 safe-environment?
34 safe-eval
35 safe-environment-remove!
36 safe-environment-macro-remove!
37 safe-environment-set!
38 safe-environment-ref
39 safe-environment-macro-set!
40 make-safe-environment)
41
42(import scheme
43        (chicken base)
44        (chicken condition)
45        (chicken fixnum)
46        (chicken keyword)
47        defstruct)
48
49(import-for-syntax (chicken platform) matchable)
50
51
52#>
53#define C_sametypep(x, y)  C_mk_bool(C_header_bits(x) == C_header_bits(y))
54<#
55
56
57;;; Parameters:
58
59(define-syntax alloc/slot
60  (er-macro-transformer
61  (lambda (e r c)
62    (let ([n (cadr e)]
63          [i64 (feature? #:64bit)])
64         (if i64
65        `(,(r '*) ,n 8)
66        `(,(r '*) ,n 4) ) ) ) ) )
67
68(define-syntax alloc/pair
69  (er-macro-transformer
70  (lambda (e r c)
71        (let ([n (cadr e)]
72              [i64 (feature? #:64bit)])
73          (if i64
74              `(,(r '*) ,n 16)
75              `(,(r '*) ,n 8) ) ) ) ) )
76
77(define-constant fuel/lambda 1)
78(define-constant alloc/char 1)
79(define-constant fuel/compile 1)
80(define-constant fuel/expand 1)
81(define-constant fuel/rec 1)
82
83
84;;; Error handling:
85
86(define (s-error loc msg . args)
87  (signal
88   (make-composite-condition
89    (make-property-condition 'sandbox)
90    (make-property-condition
91     'exn
92     'location loc
93     'message msg
94     'arguments args) ) ) )
95
96
97;;; Environments:
98
99(defstruct safe-environment
100  name                                  ; string
101  mutable                               ; boolean
102  parent                                ; environment | #f
103  (extendable #t)                       ; boolean
104  (macro-table '())                     ; ((symbol . proc) ...)
105  (table '()))                          ; ((symbol . value) ...)
106
107(define default-safe-environment (make-safe-environment name: "default"))
108(define current-safe-environment (make-parameter default-safe-environment))
109(define unbound-value (list 'unbound))
110
111(define (environment-lookup id mutable?)
112  (let ([e0 (current-safe-environment)])
113    (let loop ([e e0])
114      (let ([a (assq id (safe-environment-table e))])
115        (if a
116            (if (or (not mutable?) (safe-environment-mutable e))
117                a
118                (s-error #f "binding not mutable" id) )
119            (let ([p (safe-environment-parent e)])
120              (or (and p (loop p))
121                  (if (eq? e e0)
122                      (let ([a (cons id unbound-value)])
123                        (if (safe-environment-extendable e)
124                            (safe-environment-table-set! e (cons a (safe-environment-table e)))
125                            (s-error #f (if mutable? "environment not extendable" "unbound variable") id) )
126                        a)
127                      #f) ) ) ) ) ) ) )
128
129(define (safe-environment-set! env id val)
130  (safe-environment-table-set! env (cons (cons id val) (safe-environment-table env))) )
131
132(define (safe-environment-remove! env id)
133  (let* ([t (safe-environment-table env)]
134         [a (assq id t)] )
135    (when a
136      (safe-environment-table-set! env (##sys#delq a t)) ) ) )
137
138(define (safe-environment-ref env id #!optional default)
139  (let loop ([e env])
140    (let ([a (assq id (safe-environment-table e))])
141      (if a
142          (cdr a)
143          (let ([p (safe-environment-parent e)])
144            (or (and p (loop p))
145                default) ) ) ) ) )
146
147(define (safe-environment-macro-set! env id proc)
148  (safe-environment-macro-table-set!
149   env
150   (cons (cons id proc) (safe-environment-macro-table env)) ) )
151
152(define (safe-environment-macro-remove! env id)
153  (let* ([t (safe-environment-macro-table env)]
154         [a (assq id t)] )
155    (when a
156      (safe-environment-macro-table-set! env (##sys#delq a t)) ) ) )
157
158
159;;; Compile lambda to closure:
160
161(define (check-point n)
162  (let ([fuel (current-fuel)])
163    (when fuel
164      (let ([n (- fuel n)])
165        (if (negative? n)
166            (s-error #f "out of fuel")
167            (current-fuel n) ) ) ) ) )
168
169(define (check-alloc n)
170  (let ([limit (current-allocation-limit)])
171    (when limit
172      (let ([n (- limit n)])
173        (if (negative? n)
174            (s-error #f "allocation limit exceeded")
175            (current-allocation-limit n) ) ) ) ) )
176
177(define current-fuel (make-parameter #f))
178(define current-allocation-limit (make-parameter #f))
179
180(define (compile-expression exp env)
181
182  (define (lookup var e)
183    (let loop ((envs e) (ei 0))
184      (cond ((null? envs) (values #f var))
185            ((posq var (car envs)) => (lambda (p) (values ei p)))
186            (else (loop (cdr envs) (+ ei 1))) ) ) )
187
188  (define (defined? var e)
189    (receive (i j) (lookup var e) i) )
190
191  (define (undefine vars e)
192    (let loop ([envs e])
193      (if (null? envs)
194          '()
195          (let ([envi (car envs)])
196            (cons
197             (let delq ([ee envi])
198               (if (null? ee)
199                   '()
200                   (let ([h (car ee)]
201                         [r (cdr ee)] )
202                     (if (memq h vars)
203                         r
204                         (cons h (delq r)) ) ) ) )
205             (loop (cdr envs)) ) ) ) ) )
206
207  (define (posq x lst)
208    (let loop ((lst lst) (i 0))
209      (cond ((null? lst) #f)
210            ((eq? x (car lst)) i)
211            (else (loop (cdr lst) (+ i 1))) ) ) )
212
213  (define (macroexpand-1-checked x e)
214    (let ([x2 (safe-macroexpand-1 x)])
215      (if (pair? x2)
216          (let ([h (car x2)])
217            (if (and (eq? h 'let) (not (defined? 'let e)))
218                (let ([next (cdr x2)])
219                  (if (and (pair? next) (symbol? (cdr next)))
220                      (macroexpand-1-checked x2 e)
221                      x2) )
222                x2) )
223          x2) ) )
224
225  (define (decorate p ll h)
226    (##sys#eval-decorator p ll h #f) )
227
228  (define (compile x e h)
229    (check-point fuel/compile)
230    (cond [(keyword? x) (lambda _ x)]
231          [(symbol? x)
232           (let-values ([(i j) (lookup x e)])
233             (cond [(not i)
234                    (let ([b (environment-lookup x #f)])
235                      (lambda v
236                        (let ([val (cdr b)])
237                          (if (eq? val unbound-value)
238                              (s-error #f "unbound variable" x)
239                              val) ) ) ) ]
240                   [(zero? i) (lambda (v) (vector-ref (car v) j))]
241                   [else (lambda (v) (vector-ref (list-ref v i) j))] ) ) ]
242          [(##sys#number? x)
243           (case x
244             [(-1) (lambda v -1)]
245             [(0) (lambda v 0)]
246             [(1) (lambda v 1)]
247             [(2) (lambda v 2)]
248             [else (lambda v x)] ) ]
249          [(boolean? x)
250           (if x
251               (lambda v #t)
252               (lambda v #f) ) ]
253          [(or (char? x)
254               (eof-object? x)
255               (string? x) )
256           (lambda v x) ]
257          [(not (pair? x)) (##sys#syntax-error-hook "syntax error - illegal non-atomic object" x)]
258          [(symbol? (car x))
259           (let ([head (car x)])
260             (if (defined? head e)
261                 (compile-call x e)
262                 (let ([x2 (macroexpand-1-checked x e)])
263                   (if (eq? x2 x)
264                       (case head
265
266                         [(quote)
267                          (##sys#check-syntax 'quote x '(quote _) #f)
268                          (let* ([c (cadr x)])
269                            (case c
270                              [(-1) (lambda v -1)]
271                              [(0) (lambda v 0)]
272                              [(1) (lambda v 1)]
273                              [(2) (lambda v 2)]
274                              [(#t) (lambda v #t)]
275                              [(#f) (lambda v #f)]
276                              [(()) (lambda v '())]
277                              [else (lambda v c)] ) ) ]
278
279                         [(if)
280                          (##sys#check-syntax 'if x '(if _ _ . #(_)) #f)
281                          (let* ([test (compile (cadr x) e #f)]
282                                 [cns (compile (caddr x) e #f)]
283                                 [alt (if (pair? (cdddr x))
284                                          (compile (cadddr x) e #f)
285                                          (compile '(##core#undefined) e #f) ) ] )
286                            (lambda (v) (if (##core#app test v) (##core#app cns v) (##core#app alt v))) ) ]
287
288                         [(begin)
289                          (##sys#check-syntax 'begin x '(begin . #(_ 0)) #f)
290                          (let* ([body (cdr x)]
291                                 [len (length body)] )
292                            (case len
293                              [(0) (compile '(##core#undefined) e #f)]
294                              [(1) (compile (car body) e #f)]
295                              [(2) (let* ([x1 (compile (car body) e #f)]
296                                          [x2 (compile (cadr body) e #f)] )
297                                     (lambda (v) (##core#app x1 v) (##core#app x2 v)) ) ]
298                              [else
299                               (let* ([x1 (compile (car body) e #f)]
300                                      [x2 (compile (cadr body) e #f)]
301                                      [x3 (compile `(begin ,@(cddr body)) e #f)] )
302                                 (lambda (v) (##core#app x1 v) (##core#app x2 v) (##core#app x3 v)) ) ] ) ) ]
303
304                         [(set! ##core#set!)
305                          (##sys#check-syntax 'set! x '(_ variable _) #f)
306                          (let ([var (cadr x)])
307                            (let-values ([(i j) (lookup var e)])
308                              (let ([val (compile (caddr x) e var)])
309                                (cond [(not i)
310                                       (let ([b (environment-lookup var #t)])
311                                         (lambda (v) (set-cdr! b (##core#app val v))) ) ]
312                                      [(zero? i) (lambda (v) (vector-set! (car v) j (##core#app val v)))]
313                                      [else
314                                       (lambda (v)
315                                         (vector-set! (list-ref v i) j (##core#app val v)) ) ] ) ) ) ) ]
316
317                         [(let)
318                          (##sys#check-syntax 'let x '(let #((variable _) 0) . #(_ 1)) #f)
319                          (let* ([bindings (cadr x)]
320                                 [n (length bindings)]
321                                 [vars (map (lambda (x) (car x)) bindings)]
322                                 [body (compile-expression
323                                        (canonicalize-body (cddr x))
324                                        (cons vars e) ) ] )
325                            (case n
326                              [(1) (let ([val (compile (cadar bindings) e (car vars))])
327                                     (lambda (v)
328                                       (##core#app body (cons (vector (##core#app val v)) v)) ) ) ]
329                              [(2) (let ([val1 (compile (cadar bindings) e (car vars))]
330                                         [val2 (compile (cadadr bindings) e (cadr vars))] )
331                                     (lambda (v)
332                                       (##core#app body (cons (vector (##core#app val1 v) (##core#app val2 v)) v)) ) ) ]
333                              [(3) (let* ([val1 (compile (cadar bindings) e (car vars))]
334                                          [val2 (compile (cadadr bindings) e (cadr vars))]
335                                          [t (cddr bindings)]
336                                          [val3 (compile (cadar t) e (caddr vars))] )
337                                     (lambda (v)
338                                       (##core#app
339                                        body
340                                        (cons (vector (##core#app val1 v) (##core#app val2 v) (##core#app val3 v)) v)) ) ) ]
341                              [(4) (let* ([val1 (compile (cadar bindings) e (car vars))]
342                                          [val2 (compile (cadadr bindings) e (cadr vars))]
343                                          [t (cddr bindings)]
344                                          [val3 (compile (cadar t) e (caddr vars))]
345                                          [val4 (compile (cadadr t) e (cadddr vars))] )
346                                     (lambda (v)
347                                       (##core#app
348                                        body
349                                        (cons (vector (##core#app val1 v)
350                                                      (##core#app val2 v)
351                                                      (##core#app val3 v)
352                                                      (##core#app val4 v))
353                                              v)) ) ) ]
354                              [else
355                               (let ([vals (map (lambda (x) (compile (cadr x) e (car x))) bindings)])
356                                 (lambda (v)
357                                   (let ([v2 (make-vector n)])
358                                     (do ([i 0 (+ i 1)]
359                                          [vlist vals (cdr vlist)] )
360                                         ((>= i n))
361                                       (vector-set! v2 i (##core#app (car vlist) v)) )
362                                     (##core#app body (cons v2 v)) ) ) ) ] ) ) ]
363
364                         [(lambda)
365                          (##sys#check-syntax 'lambda x '(lambda lambda-list . #(_ 1)) #f)
366                          (let* ((llist (cadr x))
367                                 (body (cddr x))
368                                 (info (cons (or h '?) llist)) )
369                            (##sys#decompose-lambda-list
370                             llist
371                             (lambda (vars argc rest)
372                               (let ([body (compile-expression
373                                            (canonicalize-body body)
374                                            (cons vars e) ) ] )
375                                 (case argc
376                                   [(0) (if rest
377                                            (lambda (v)
378                                              (decorate
379                                               (lambda r (##core#app body (cons (vector r) v)))
380                                               info h) )
381                                            (lambda (v)
382                                              (decorate
383                                               (lambda () (##core#app body (cons #f v)))
384                                               info h) ) ) ]
385                                   [(1) (if rest
386                                            (lambda (v)
387                                              (decorate
388                                               (lambda (a1 . r) (##core#app body (cons (vector a1 r) v)))
389                                               info h) )
390                                            (lambda (v)
391                                              (decorate
392                                               (lambda (a1) (##core#app body (cons (vector a1) v)))
393                                               info h) ) ) ]
394                                   [(2) (if rest
395                                            (lambda (v)
396                                              (decorate
397                                               (lambda (a1 a2 . r) (##core#app body (cons (vector a1 a2 r) v)))
398                                               info h) )
399                                            (lambda (v)
400                                              (decorate
401                                               (lambda (a1 a2) (##core#app body (cons (vector a1 a2) v)))
402                                               info h) ) ) ]
403                                   [(3) (if rest
404                                            (lambda (v)
405                                              (decorate
406                                               (lambda (a1 a2 a3 . r) (##core#app body (cons (vector a1 a2 a3 r) v)))
407                                               info h) )
408                                            (lambda (v)
409                                              (decorate
410                                               (lambda (a1 a2 a3) (##core#app body (cons (vector a1 a2 a3) v)))
411                                               info h) ) ) ]
412                                   [(4) (if rest
413                                            (lambda (v)
414                                              (decorate
415                                               (lambda (a1 a2 a3 a4 . r) (##core#app body (cons (vector a1 a2 a3 a4 r) v)))
416                                               info h) )
417                                            (lambda (v)
418                                              (decorate
419                                               (lambda (a1 a2 a3 a4) (##core#app body (cons (vector a1 a2 a3 a4) v)))
420                                               info h) ) ) ]
421                                   [else (if rest
422                                             (lambda (v)
423                                               (decorate
424                                                (lambda as
425                                                  (##core#app body (cons (apply vector (fudge-argument-list argc as)) v)) )
426                                                info h) )
427                                             (lambda (v)
428                                               (decorate
429                                                (lambda as
430                                                  (let ([len (length as)])
431                                                    (if (not (= len argc))
432                                                        (s-error #f "bad argument count" argc len)
433                                                        (##core#app body (cons (apply vector as) v))) ) )
434                                                info h) ) ) ] ) ) ) ) ) ]
435
436                         [(##core#undefined) (lambda _ (##core#undefined))]
437
438                         [(##core#app) (compile-call (cdr x) e)]
439
440                         [(##core#loop-lambda)
441                          ;; is this up to date?
442                          (compile `(lambda ,@(cdr x)) e #f) ]
443
444                         [else (compile-call x e)] )
445
446                       (compile x2 e h) ) ) ) ) ]
447
448          [else (compile-call x e)] ) )
449
450  (define (fudge-argument-list n alst)
451    (if (null? alst)
452        (list alst)
453        (do ([n n (- n 1)]
454             [args alst (cdr args)]
455             [last #f args] )
456            ((= n 0)
457             (set-cdr! last (list args))
458             alst) ) ) )
459
460  (define (checked-length lst)
461    (and (list? lst)
462         (length lst) ) )
463
464  (define (emit-eval-trace-info info)
465    (##core#inline "C_emit_eval_trace_info" info #f ##sys#current-thread) )
466
467  (define (compile-call x e)
468    (let* ([fn (compile (car x) e #f)]
469           [args (cdr x)]
470           [argc (checked-length args)]
471           [info x] )
472      (case argc
473        [(#f) (##sys#syntax-error-hook "syntax error - malformed expression" x)]
474        [(0) (lambda (v)
475               (emit-eval-trace-info info)
476               (check-point fuel/lambda)
477               ((##core#app fn v)) ) ]
478        [(1) (let ([a1 (compile (car args) e #f)])
479               (lambda (v)
480                 (emit-eval-trace-info info)
481                 (check-point fuel/lambda)
482                 ((##core#app fn v) (##core#app a1 v))) ) ]
483        [(2) (let* ([a1 (compile (car args) e #f)]
484                    [a2 (compile (list-ref args 1) e #f)] )
485               (lambda (v)
486                 (emit-eval-trace-info info)
487                 (check-point fuel/lambda)
488                 ((##core#app fn v) (##core#app a1 v) (##core#app a2 v))) ) ]
489        [(3) (let* ([a1 (compile (car args) e #f)]
490                    [a2 (compile (list-ref args 1) e #f)]
491                    [a3 (compile (list-ref args 2) e #f)] )
492               (lambda (v)
493                 (emit-eval-trace-info info)
494                 (check-point fuel/lambda)
495                 ((##core#app fn v) (##core#app a1 v) (##core#app a2 v) (##core#app a3 v))) ) ]
496        [(4) (let* ([a1 (compile (car args) e #f)]
497                    [a2 (compile (list-ref args 1) e #f)]
498                    [a3 (compile (list-ref args 2) e #f)]
499                    [a4 (compile (list-ref args 3) e #f)] )
500               (lambda (v)
501                 (emit-eval-trace-info info)
502                 (check-point fuel/lambda)
503                 ((##core#app fn v) (##core#app a1 v) (##core#app a2 v) (##core#app a3 v) (##core#app a4 v))) ) ]
504        [else (let ([as (map (lambda (a) (compile a e #f)) args)])
505                (lambda (v)
506                  (emit-eval-trace-info info)
507                  (check-point fuel/lambda)
508                  (apply (##core#app fn v) (map (lambda (a) (##core#app a v)) as))) ) ] ) ) )
509
510  (compile exp env #f) )
511
512
513;;; Standard environment:
514
515(safe-environment-table-set!
516 default-safe-environment
517 (map (lambda (s) (cons s (##sys#slot (symbol-append 'scheme# s) 0)))
518      '(not boolean? eq? eqv? equal? pair? car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar
519            cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr cadddr cdaaar cdaadr cdadar cdaddr
520            cddaar cddadr cdddar cddddr set-car! set-cdr! null? list?
521            symbol? string->symbol
522            number? integer? exact? real? complex? inexact? rational? zero? odd? even? positive? negative?
523            max min + - * / = > < >= <= quotient remainder modulo gcd lcm abs floor ceiling truncate round
524            exact->inexact inexact->exact exp log expt sqrt sin cos tan asin acos atan
525            string->number char? char=? char>? char<? char>=? char<=? char-ci=? char-ci<? char-ci>?
526            char-ci>=? char-ci<=? char-alphabetic? char-whitespace? char-numeric? char-upper-case?
527            char-lower-case? char-upcase char-downcase char->integer integer->char string? string=?
528            string>? string<? string>=? string<=? string-ci=? string-ci<? string-ci>? string-ci>=? string-ci<=?
529            string-length string-ref string-set!
530            string-fill! vector? vector-ref vector-set!
531            vector-length vector-fill! procedure? force
532            call-with-current-continuation
533            dynamic-wind values call-with-values) ) )
534
535(define (primitive-set! id val)
536  (safe-environment-set! default-safe-environment id val) )
537
538(define (primitive-macro-set! id proc)
539  (safe-environment-macro-set! default-safe-environment id proc) )
540
541(define-syntax defp
542  (er-macro-transformer
543  (lambda (e r c)
544    (let ((args (cdr e)))
545     (match args
546      [((name . llist) . body) `(,(r 'primitive-set!) ',name (,(r 'lambda) ,llist ,@body))]
547      [(name val) `(,(r 'primitive-set!) ',name ,val)]
548      [(name) `(,(r 'primitive-set!) ',name ,name)] ) ) ) ) )
549
550(define (check-plist x loc)
551  (if (list? x)
552      x
553      (s-error loc "not a proper list" x) ) )
554
555(defp (vector . args)
556  (check-alloc (* (alloc/slot (length args))))
557  (apply vector args) )
558
559(defp (string . args)
560  (check-alloc (* alloc/char (length args)))
561  (apply string args) )
562
563(defp (list . args)
564  (check-alloc (* (alloc/pair (length args))))
565  (apply list args) )
566
567(defp (number->string . args)
568  (let ([s (apply number->string args)])
569    (check-alloc (* alloc/char (string-length s)))
570    s) )
571
572(defp (string-append . xs0)
573  (let loop ([xs xs0])
574    (if (or (null? xs) (null? (cdr xs)))
575        (apply string-append xs0)
576        (let ([s0 (car xs)])
577          (check-alloc (* alloc/char (string-length s0)))
578          (loop (cdr xs)) ) ) ) )
579
580(defp (string->list s)
581  (check-alloc (alloc/pair (string-length s)))
582  (string->list s) )
583
584(defp (string-copy s)
585  (check-alloc (* (string-length s) alloc/char))
586  (string-copy s) )
587
588(defp (symbol->string s)
589  (let ([str (symbol->string s)])
590    (check-alloc (* alloc/char (string-length str)))
591    str) )
592
593(defp (cons x y)
594  (check-alloc (alloc/pair 1))
595  (cons x y) )
596
597(defp (vector->list v)
598  (check-alloc (alloc/pair (vector-length v)))
599  (vector->list v) )
600
601(defp (substring s i1 i2)
602  (check-alloc (* alloc/char (- i2 i1)))
603  (substring s i1 i2) )
604
605(defp (length x) (length (check-plist x 'length)))
606
607(defp (equal? x y)
608  (let loop ([x x] [y y])
609    (check-point fuel/rec)
610    (or (eq? x y)
611        (and (not (##sys#immediate? x))
612             (not (##sys#immediate? y))
613             (let ([sx (##sys#size x)])
614               (and (eq? (##sys#size y) sx)
615                    (##core#inline "C_sametypep" x y)
616                    (or (zero? sx)
617                        (if (##core#inline "C_byteblockp" x)
618                            (and (##core#inline "C_byteblockp" y)
619                                 (##core#inline "C_substring_compare" x y 0 0 sx) )
620                            (let ([sx-1 (fx- sx 1)])
621                              (let loop2 ([i (if (##core#inline "C_specialp" x) 1 0)])
622                                (if (fx>= i sx-1)
623                                    (loop (##sys#slot x i) (##sys#slot y i))
624                                    (and (loop (##sys#slot x i) (##sys#slot y i))
625                                         (loop2 (fx+ i 1)) ) ) ) ) ) ) ) ) ) ) ) )
626
627(defp (list-tail x n) (list-tail (check-plist x 'list-tail) n))
628(defp (list-ref x n) (list-ref (check-plist x 'list-ref) n))
629
630(defp (append . xs0)
631  (let loop ([xs xs0])
632    (if (or (null? xs) (null? (cdr xs)))
633        (apply append xs0)
634        (let ([lst (car xs)])
635          (check-plist lst 'append)
636          (check-alloc (alloc/pair (length lst)))
637          (loop (cdr xs)) ) ) ) )
638
639(defp (reverse x)
640  (let ([x (check-plist x 'reverse)])
641    (check-alloc (alloc/pair (length x)))
642    (reverse x) ) )
643
644(defp (assq x y) (assq x (check-plist y 'assq)))
645(defp (assv x y) (assv x (check-plist y 'assv)))
646(defp (assoc x y) (assoc x (check-plist y 'assoc)))
647(defp (memq x y) (memq x (check-plist y 'memq)))
648(defp (memv x y) (memv x (check-plist y 'memv)))
649(defp (member x y) (member x (check-plist y 'member)))
650
651(define-constant maximum-size 10000)
652
653(define (check-max n loc)
654  (if (> n maximum-size)
655      (s-error loc "size argument exceeds limit" n maximum-size)
656      n) )
657
658(defp (make-string x . y)
659  (check-alloc (* x alloc/char))
660  (apply make-string (check-max x 'make-string) y))
661
662(defp (list->string x)
663  (let ([x (check-plist x 'list->string)])
664    (check-alloc (alloc/pair (length x)))
665    (list->string x) ) )
666
667(defp (make-vector x . y)
668  (check-alloc (alloc/slot x))
669  (apply make-vector (check-max x 'make-vector) y))
670
671(defp (list->vector x)
672  (let ([x (check-plist x 'list->vector)])
673    (check-alloc (alloc/slot (length x)))
674    (list->vector x) ) )
675
676(defp (map p . xs)
677  (for-each (cut check-plist <> 'map) xs)
678  (apply map p xs) )
679
680(defp (for-each p . xs)
681  (for-each (cut check-plist <> 'for-each) xs)
682  (apply for-each p xs) )
683
684(defp (make-promise x) (##sys#make-promise x))
685
686(defp (eval x)
687  ((compile-expression x '()) '()) )
688
689(defp (apply fn a1 . args)
690  (apply
691   fn
692   (let build ((args (cons a1 args)))
693     (let ((head (car args))
694           (rest (cdr args)) )
695       (cond ((null? rest)
696              (check-plist head 'apply)
697              head)
698             (else (cons head (build rest))) ) ) ) ) )
699
700
701; unsupported:
702;
703;   input-port?
704;   output-port?
705;   current-input-port
706;   current-output-port
707;   call-with-input-file
708;   call-with-output-file
709;   open-input-file
710;   open-output-file
711;   close-input-port
712;   char-ready?
713;   read-char
714;   write-char
715;   read
716;   write
717;   display
718;   load
719;   transcript-on
720;   transcript-off
721;   peek-char
722;   eof-object?
723;   newline
724;   with-input-from-file
725;   with-output-from-file
726;   scheme-report-environment
727;   null-environment
728;   interaction-environment
729
730
731;;; Macros:
732
733(define (canonicalize-body body)
734  (define (fini vars vals body)
735    (if (null? vars)
736        `(begin ,@body)
737        (let ([vars (reverse vars)])
738          `(let ,(map (lambda (v) (list v '(##core#undefined))) vars)
739             ,@(map (lambda (v x) `(set! ,v ,x)) vars (reverse vals))
740             ,@body) ) ) )
741  (define (expand body)
742    (let loop ([body body] [vars '()] [vals '()])
743      (check-point fuel/expand)
744      (if (not (pair? body))
745          (fini vars vals body)
746          (let* ([x (car body)]
747                 [rest (cdr body)]
748                 [head (and (pair? x) (car x))] )
749            (cond [(not head) (fini vars vals body)]
750                  [(eq? 'define head)
751                   (##sys#check-syntax 'define x '(define _ . #(_ 1)) #f)
752                   (let ([head (cadr x)])
753                     (cond [(not (pair? head))
754                            (##sys#check-syntax 'define x '(define variable _) #f)
755                            (loop rest (cons head vars) (cons (caddr x) vals)) ]
756                           [else
757                            (##sys#check-syntax 'define x '(define (variable . lambda-list) . #(_ 1)) #f)
758                            (loop rest
759                                  (cons (car head) vars)
760                                  (cons `(lambda ,(cdr head) ,@(cddr x)) vals) ) ] ) ) ]
761                  [(eq? 'begin head)
762                   (##sys#check-syntax 'begin x '(begin . #(_ 0)) #f)
763                   (loop (append (cdr x) rest) vars vals) ]
764                  [else
765                   (let ([x2 (safe-macroexpand-1 x)])
766                     (if (eq? x x2)
767                         (fini vars vals body)
768                         (loop (cons x2 rest) vars vals) ) ) ] ) ) ) ) )
769  (expand body) )
770
771(define (safe-macroexpand-1 exp)
772  (if (and (pair? exp) (symbol? (car exp)))
773      (let ([s (car exp)]
774            [body (cdr exp)] )
775        (case s
776          [(let)
777           (##sys#check-syntax 'let body '#(_ 2))
778           (let ([bindings (car body)])
779             (cond [(symbol? bindings)
780                    (##sys#check-syntax 'let body '(_ #((variable _) 0) . #(_ 1)))
781                    (let ([bs (cadr body)])
782                      `(##core#app
783                        (letrec ([,bindings (##core#loop-lambda ,(map (lambda (b) (car b)) bs) ,@(cddr body))])
784                          ,bindings)
785                        ,@(##sys#map cadr bs) ) ) ]
786                   [else exp] ) ) ]
787          [else
788           (let loop ([e (current-safe-environment)])
789             (let ([m (assq s (safe-environment-macro-table e))])
790               (cond [m ((cdr m) (cdr exp))]
791                     [(safe-environment-parent e) => loop]
792                     [else exp] ) ) ) ] ) )
793      exp) )
794
795(define-syntax defm
796  (er-macro-transformer
797  (lambda (e r c)
798    (let ((head (cadr e))
799          (body (cddr e)))
800  `(,(r 'primitive-macro-set!)
801    ',(car head)
802    ,(if (and (pair? head) (not (pair? (cdr head))))
803         `(,(r 'lambda) (,(cdr head)) ,@body)
804         (let ([var (gensym)])
805           `(,(r 'lambda) (,var)
806              (,(r 'apply) (,(r 'lambda) ,(cdr head) ,@body) ,var) ) ) ) ) ) ) ) )
807
808(defm (define head . body)
809  (cond ((not (pair? head))
810         (##sys#check-syntax 'define head 'symbol)
811         (##sys#check-syntax 'define body '#(_ 1))
812         `(set! ,head ,(car body)) )
813        (else
814         (##sys#check-syntax 'define head '(symbol . lambda-list))
815         (##sys#check-syntax 'define body '#(_ 1))
816         `(set! ,(car head) (lambda ,(cdr head) ,@body)) ) ) )
817
818(defm (and . body)
819  (if (eq? body '())
820      #t
821      (let ((rbody (cdr body))
822            (hbody (car body)) )
823        (if (eq? rbody '())
824            hbody
825            `(if ,hbody (and ,@rbody) #f) ) ) ) )
826
827(defm (or . body)
828  (if (eq? body '())
829      #f
830      (let ((rbody (cdr body))
831            (hbody (car body)) )
832        (if (eq? rbody '())
833            hbody
834            (let ((tmp (gensym)))
835              `(let ((,tmp ,hbody))
836                 (if ,tmp ,tmp (or ,@rbody)) ) ) ) ) ) )
837
838(defm (cond . body)
839  (let expand ((clauses body))
840    (if (not (pair? clauses))
841        '(##core#undefined)
842        (let ((clause (car clauses))
843              (rclauses (cdr clauses)) )
844          (##sys#check-syntax 'cond clause '#(_ 1))
845          (cond ((eq? 'else (car clause)) `(begin ,@(cdr clause)))
846                ((eq? (cdr clause) '()) `(or ,(car clause) ,(expand rclauses)))
847                ((eq? '=> (car (cdr clause)))
848                 (let ((tmp (gensym)))
849                   `(let ((,tmp ,(car clause)))
850                      (if ,tmp
851                          (,(car (cdr (cdr clause))) ,tmp)
852                          ,(expand rclauses) ) ) ) )
853                (else `(if ,(car clause)
854                           (begin ,@(cdr clause))
855                           ,(expand rclauses) ) ) ) ) ) ) )
856
857(defm (case . form)
858  (let ((exp (car form))
859        (body (cdr form)) )
860    (let ((tmp (gensym)))
861      `(let ((,tmp ,exp))
862         ,(let expand ((clauses body))
863            (if (not (pair? clauses))
864                '(##core#undefined)
865                (let ((clause (car clauses))
866                      (rclauses (cdr clauses)) )
867                  (##sys#check-syntax 'case clause '#(_ 1))
868                  (if (eq? 'else (car clause))
869                      `(begin ,@(cdr clause))
870                      `(if (or ,@(map (lambda (x) `(eqv? ,tmp ',x)) (car clause)))
871                           (begin ,@(cdr clause))
872                           ,(expand rclauses) ) ) ) ) ) ) ) ) )
873
874(defm (let* . form)
875  (let ((bindings (car form))
876        (body (cdr form)) )
877    (##sys#check-syntax 'let* bindings '#((symbol _) 0))
878    (##sys#check-syntax 'let* body '#(_ 1))
879    (let expand ((bs bindings))
880      (if (eq? bs '())
881          (canonicalize-body body)
882          `(let (,(car bs)) ,(expand (cdr bs))) ) ) ) )
883
884(defm (letrec . form)
885  (let ((bindings (car form))
886        (body (cdr form)) )
887    (##sys#check-syntax 'letrec bindings '#((symbol _) 0))
888    (##sys#check-syntax 'letrec body '#(_ 1))
889    `(let ,(map (lambda (b) (list (car b) '(##core#undefined))) bindings)
890       (begin ,@(append (map (lambda (b) `(set! ,(car b) ,(cadr b))) bindings)
891                        (list (canonicalize-body body)) ) ) ) ) )
892
893(defm (do bindings test . body)
894  (##sys#check-syntax 'do bindings '#((symbol _ . #(_)) 0))
895  (##sys#check-syntax 'do test '#(_ 1))
896  (let ((dovar (gensym "do")))
897    `(let ,dovar ,(map (lambda (b) (list (car b) (car (cdr b)))) bindings)
898          (if ,(car test)
899              ,(let ((tbody (cdr test)))
900                 (if (eq? tbody '())
901                     '(##core#undefined)
902                     `(begin ,@tbody) ) )
903              (begin
904                ,(if (eq? body '())
905                     '(##core#undefined)
906                     (canonicalize-body body) )
907                (##core#app
908                 ,dovar ,@(map (lambda (b)
909                                 (if (eq? (cdr (cdr b)) '())
910                                     (car b)
911                                     (car (cdr (cdr b))) ) )
912                               bindings) ) ) ) ) ) )
913
914(defm (quasiquote form)
915  (define (walk x n) (simplify (walk1 x n)))
916  (define (walk1 x n)
917    (cond ((vector? x)
918           `(list->vector ,(walk (vector->list x) n)) ) ;***
919          ((not (pair? x)) `(quote ,x))
920          (else
921           (let ((head (car x))
922                 (tail (cdr x)) )
923             (case head
924               ((unquote)
925                (if (pair? tail)
926                    (let ((hx (car tail)))
927                      (if (eq? n 0)
928                          hx
929                          (list 'list '(quote unquote) ;***
930                                (walk hx (- n 1)) ) ) )
931                    '(quote unquote) ) )
932               ((quasiquote)
933                (if (pair? tail)
934                    `(list (quote quasiquote) ;***
935                           ,(walk (car tail) (+ n 1)) )
936                    (list 'cons (list 'quote 'quasiquote) (walk tail n)) ) ) ;***
937               (else
938                (if (pair? head)
939                    (let ((hx (car head))
940                          (tx (cdr head)) )
941                      (if (and (eq? hx 'unquote-splicing) (pair? tx))
942                          (let ((htx (car tx)))
943                            (if (eq? n 0)
944                                `(append ,htx ;***
945                                         ,(walk tail n) )
946                                `(cons (list 'unquote-splicing ;***
947                                             ,(walk htx (- n 1)) )
948                                       ,(walk tail n) ) ) )
949                          `(cons ,(walk head n) ,(walk tail n)) ) ) ;***
950                    `(cons ,(walk head n) ,(walk tail n)) ) ) ) ) ) ) ) ;***
951  (define (simplify x)
952    (cond ((match-expression x '(cons a '()) '(a))
953           => (lambda (env) (simplify `(list ,(cdr (assq 'a env))))) )
954          ((match-expression x '(cons a (list . b)) '(a b))
955           => (lambda (env)
956                (let ([bxs (assq 'b env)])
957                  (if (fx< (length bxs) 32)
958                      (simplify `(list ,(cdr (assq 'a env))
959                                       ,@(cdr bxs) ) )
960                      x) ) ) )
961          ((match-expression x '(append a '()) '(a))
962           => (lambda (env) (cdr (assq 'a env))) )
963          (else x) ) )
964  (walk form 0) )
965
966(define match-expression
967  (lambda (exp pat vars)
968    (let ((env '()))
969      (define (mwalk x p)
970        (cond ((not (pair? p))
971               (cond ((assq p env) => (lambda (a) (equal? x (cdr a))))
972                     ((memq p vars)
973                      (set! env (cons (cons p x) env))
974                      #t)
975                     (else (eq? x p)) ) )
976              ((not (pair? x)) #f)
977              ((mwalk (car x) (car p))
978               (mwalk (cdr x) (cdr p)) )
979              (else #f) ) )
980      (and (mwalk exp pat) env) ) ) )
981
982(defm (delay x)
983  `(make-promise (lambda () ,x)) )      ;***
984
985
986;;; User interface:
987
988(define (safe-eval exp #!key (environment (current-safe-environment)) fuel allocation-limit)
989  (condition-case
990      (parameterize ([current-fuel fuel]
991                     [current-safe-environment environment]
992                     [current-allocation-limit allocation-limit] )
993        ((compile-expression exp '()) '()) )
994    [ex (sandbox) (signal ex)]
995    [ex () (signal (make-composite-condition (make-property-condition 'sandbox) ex))] ) ) )
Note: See TracBrowser for help on using the repository browser.