source: project/release/4/sandbox/trunk/sandbox.scm @ 25271

Last change on this file since 25271 was 25271, checked in by felix winkelmann, 8 years ago

sandbox 1.8: bugfix by Alan Post, also removed incorrect test

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