;;; sandbox.scm - "Safe" interpreter for a Scheme subset
;
; Copyright (c) 2009, The CHICKEN Team
; Copyright (c) 2000-2008, Felix L. Winkelmann
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
; conditions are met:
;
;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
;     disclaimer.
;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
;     disclaimer in the documentation and/or other materials provided with the distribution.
;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
;     products derived from this software without specific prior written permission.
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
; POSSIBILITY OF SUCH DAMAGE.


(module sandbox
(current-safe-environment
 current-fuel
 current-allocation-limit
 default-safe-environment
 safe-environment?
 safe-eval
 safe-environment-remove!
 safe-environment-macro-remove!
 safe-environment-set!
 safe-environment-ref
 safe-environment-macro-set!
 make-safe-environment)

(import chicken scheme)
(import-for-syntax matchable)

(use defstruct)


#>
#define C_sametypep(x, y)  C_mk_bool(C_header_bits(x) == C_header_bits(y))
<#


;;; Parameters:

(define-syntax alloc/slot
  (lambda (e r c)
    (let ([n (cadr e)]
          [i64 (##sys#fudge 3)])
         (if i64
     	`(,(r '*) ,n 8)
     	`(,(r '*) ,n 4) ) ) ) )

(define-syntax alloc/pair
  (lambda (e r c)
        (let ([n (cadr e)]
              [i64 (##sys#fudge 3)])
          (if i64
              `(,(r '*) ,n 16)
              `(,(r '*) ,n 8) ) ) ) )

(define-constant fuel/lambda 1)
(define-constant alloc/char 1)
(define-constant fuel/compile 1)
(define-constant fuel/expand 1)
(define-constant fuel/rec 1)


;;; Error handling:

(define (s-error loc msg . args)
  (signal
   (make-composite-condition
    (make-property-condition 'sandbox)
    (make-property-condition
     'exn
     'location loc
     'message msg
     'arguments args) ) ) )


;;; Environments:

(defstruct safe-environment
  name					; string
  mutable				; boolean
  parent				; environment | #f
  (extendable #t)			; boolean
  (macro-table '())			; ((symbol . proc) ...)
  (table '()))				; ((symbol . value) ...)

(define default-safe-environment (make-safe-environment name: "default"))
(define current-safe-environment (make-parameter default-safe-environment))
(define unbound-value (list 'unbound))

(define (environment-lookup id mutable?)
  (let ([e0 (current-safe-environment)])
    (let loop ([e e0])
      (let ([a (assq id (safe-environment-table e))])
	(if a
	    (if (or (not mutable?) (safe-environment-mutable e))
		a
		(s-error #f "binding not mutable" id) )
	    (let ([p (safe-environment-parent e)])
	      (or (and p (loop p))
		  (if (eq? e e0)
		      (let ([a (cons id unbound-value)])
			(if (safe-environment-extendable e)
			    (safe-environment-table-set! e (cons a (safe-environment-table e)))
			    (s-error #f (if mutable? "environment not extendable" "unbound variable") id) )
			a)
		      #f) ) ) ) ) ) ) )

(define (safe-environment-set! env id val)
  (safe-environment-table-set! env (cons (cons id val) (safe-environment-table env))) )

(define (safe-environment-remove! env id)
  (let* ([t (safe-environment-table env)]
	 [a (assq id t)] )
    (when a
      (safe-environment-table-set! env (##sys#delq a t)) ) ) )

(define (safe-environment-ref env id #!optional default)
  (let loop ([e env])
    (let ([a (assq id (safe-environment-table e))])
      (if a
	  (cdr a)
	  (let ([p (safe-environment-parent e)])
	    (or (and p (loop p))
		default) ) ) ) ) )

(define (safe-environment-macro-set! env id proc)
  (safe-environment-macro-table-set!
   env
   (cons (cons id proc) (safe-environment-macro-table env)) ) )

(define (safe-environment-macro-remove! env id)
  (let* ([t (safe-environment-macro-table env)]
	 [a (assq id t)] )
    (when a
      (safe-environment-macro-table-set! env (##sys#delq a t)) ) ) )


;;; Compile lambda to closure:

(define (check-point n)
  (let ([fuel (current-fuel)])
    (when fuel
      (let ([n (- fuel n)])
	(if (negative? n)
	    (s-error #f "out of fuel")
	    (current-fuel n) ) ) ) ) )

(define (check-alloc n)
  (let ([limit (current-allocation-limit)])
    (when limit
      (let ([n (- limit n)])
	(if (negative? n)
	    (s-error #f "allocation limit exceeded")
	    (current-allocation-limit n) ) ) ) ) )

(define current-fuel (make-parameter #f))
(define current-allocation-limit (make-parameter #f))

(define (compile-expression exp env)

  (define (lookup var e)
    (let loop ((envs e) (ei 0))
      (cond ((null? envs) (values #f var))
	    ((posq var (car envs)) => (lambda (p) (values ei p)))
	    (else (loop (cdr envs) (+ ei 1))) ) ) )

  (define (defined? var e)
    (receive (i j) (lookup var e) i) )

  (define (undefine vars e)
    (let loop ([envs e])
      (if (null? envs)
	  '()
	  (let ([envi (car envs)])
	    (cons
	     (let delq ([ee envi])
	       (if (null? ee)
		   '()
		   (let ([h (car ee)]
			 [r (cdr ee)] )
		     (if (memq h vars)
			 r
			 (cons h (delq r)) ) ) ) )
	     (loop (cdr envs)) ) ) ) ) )

  (define (posq x lst)
    (let loop ((lst lst) (i 0))
      (cond ((null? lst) #f)
	    ((eq? x (car lst)) i)
	    (else (loop (cdr lst) (+ i 1))) ) ) )

  (define (macroexpand-1-checked x e)
    (let ([x2 (safe-macroexpand-1 x)])
      (if (pair? x2)
	  (let ([h (car x2)])
	    (if (and (eq? h 'let) (not (defined? 'let e)))
		(let ([next (cdr x2)])
		  (if (and (pair? next) (symbol? (cdr next)))
		      (macroexpand-1-checked x2 e)
		      x2) )
		x2) )
	  x2) ) )

  (define (decorate p ll h)
    (##sys#eval-decorator p ll h #f) )

  (define (compile x e h)
    (check-point fuel/compile)
    (cond [(keyword? x) (lambda _ x)]
	  [(symbol? x)
	   (let-values ([(i j) (lookup x e)])
	     (cond [(not i)
		    (let ([b (environment-lookup x #f)])
		      (lambda v
			(let ([val (cdr b)])
			  (if (eq? val unbound-value)
			      (s-error #f "unbound variable" x)
			      val) ) ) ) ]
		   [(zero? i) (lambda (v) (vector-ref (car v) j))]
		   [else (lambda (v) (vector-ref (list-ref v i) j))] ) ) ]
	  [(##sys#number? x)
	   (case x
	     [(-1) (lambda v -1)]
	     [(0) (lambda v 0)]
	     [(1) (lambda v 1)]
	     [(2) (lambda v 2)]
	     [else (lambda v x)] ) ]
	  [(boolean? x)
	   (if x
	       (lambda v #t)
	       (lambda v #f) ) ]
	  [(or (char? x)
	       (eof-object? x)
	       (string? x) )
	   (lambda v x) ]
	  [(not (pair? x)) (##sys#syntax-error-hook "syntax error - illegal non-atomic object" x)]
	  [(symbol? (car x))
	   (let ([head (car x)])
	     (if (defined? head e)
		 (compile-call x e)
		 (let ([x2 (macroexpand-1-checked x e)])
		   (if (eq? x2 x)
		       (case head

			 [(quote)
			  (##sys#check-syntax 'quote x '(quote _) #f)
			  (let* ([c (cadr x)])
			    (case c
			      [(-1) (lambda v -1)]
			      [(0) (lambda v 0)]
			      [(1) (lambda v 1)]
			      [(2) (lambda v 2)]
			      [(#t) (lambda v #t)]
			      [(#f) (lambda v #f)]
			      [(()) (lambda v '())]
			      [else (lambda v c)] ) ) ]

			 [(if)
			  (##sys#check-syntax 'if x '(if _ _ . #(_)) #f)
			  (let* ([test (compile (cadr x) e #f)]
				 [cns (compile (caddr x) e #f)]
				 [alt (if (pair? (cdddr x))
					  (compile (cadddr x) e #f)
					  (compile '(##core#undefined) e #f) ) ] )
			    (lambda (v) (if (##core#app test v) (##core#app cns v) (##core#app alt v))) ) ]

			 [(begin)
			  (##sys#check-syntax 'begin x '(begin . #(_ 0)) #f)
			  (let* ([body (cdr x)]
				 [len (length body)] )
			    (case len
			      [(0) (compile '(##core#undefined) e #f)]
			      [(1) (compile (car body) e #f)]
			      [(2) (let* ([x1 (compile (car body) e #f)]
					  [x2 (compile (cadr body) e #f)] )
				     (lambda (v) (##core#app x1 v) (##core#app x2 v)) ) ]
			      [else
			       (let* ([x1 (compile (car body) e #f)]
				      [x2 (compile (cadr body) e #f)]
				      [x3 (compile `(begin ,@(cddr body)) e #f)] )
				 (lambda (v) (##core#app x1 v) (##core#app x2 v) (##core#app x3 v)) ) ] ) ) ]

			 [(set! ##core#set!)
			  (##sys#check-syntax 'set! x '(_ variable _) #f)
			  (let ([var (cadr x)])
			    (let-values ([(i j) (lookup var e)])
			      (let ([val (compile (caddr x) e var)])
				(cond [(not i)
				       (let ([b (environment-lookup var #t)])
					 (lambda (v) (set-cdr! b (##core#app val v))) ) ]
				      [(zero? i) (lambda (v) (vector-set! (car v) j (##core#app val v)))]
				      [else
				       (lambda (v)
					 (vector-set! (list-ref v i) j (##core#app val v)) ) ] ) ) ) ) ]

			 [(let)
			  (##sys#check-syntax 'let x '(let #((variable _) 0) . #(_ 1)) #f)
			  (let* ([bindings (cadr x)]
				 [n (length bindings)]
				 [vars (map (lambda (x) (car x)) bindings)]
				 [body (compile-expression
					(canonicalize-body (cddr x))
					(cons vars e) ) ] )
			    (case n
			      [(1) (let ([val (compile (cadar bindings) e (car vars))])
				     (lambda (v)
				       (##core#app body (cons (vector (##core#app val v)) v)) ) ) ]
			      [(2) (let ([val1 (compile (cadar bindings) e (car vars))]
					 [val2 (compile (cadadr bindings) e (cadr vars))] )
				     (lambda (v)
				       (##core#app body (cons (vector (##core#app val1 v) (##core#app val2 v)) v)) ) ) ]
			      [(3) (let* ([val1 (compile (cadar bindings) e (car vars))]
					  [val2 (compile (cadadr bindings) e (cadr vars))]
					  [t (cddr bindings)]
					  [val3 (compile (cadar t) e (caddr vars))] )
				     (lambda (v)
				       (##core#app
					body
					(cons (vector (##core#app val1 v) (##core#app val2 v) (##core#app val3 v)) v)) ) ) ]
			      [(4) (let* ([val1 (compile (cadar bindings) e (car vars))]
					  [val2 (compile (cadadr bindings) e (cadr vars))]
					  [t (cddr bindings)]
					  [val3 (compile (cadar t) e (caddr vars))]
					  [val4 (compile (cadadr t) e (cadddr vars))] )
				     (lambda (v)
				       (##core#app
					body
					(cons (vector (##core#app val1 v)
						      (##core#app val2 v)
						      (##core#app val3 v)
						      (##core#app val4 v))
					      v)) ) ) ]
			      [else
			       (let ([vals (map (lambda (x) (compile (cadr x) e (car x))) bindings)])
				 (lambda (v)
				   (let ([v2 (make-vector n)])
				     (do ([i 0 (+ i 1)]
					  [vlist vals (cdr vlist)] )
					 ((>= i n))
				       (vector-set! v2 i (##core#app (car vlist) v)) )
				     (##core#app body (cons v2 v)) ) ) ) ] ) ) ]

			 [(lambda)
			  (##sys#check-syntax 'lambda x '(lambda lambda-list . #(_ 1)) #f)
			  (let* ((llist (cadr x))
				 (body (cddr x))
				 (info (cons (or h '?) llist)) )
			    (##sys#decompose-lambda-list
			     llist
			     (lambda (vars argc rest)
			       (let ([body (compile-expression
					    (canonicalize-body body)
					    (cons vars e) ) ] )
				 (case argc
				   [(0) (if rest
					    (lambda (v)
					      (decorate
					       (lambda r (##core#app body (cons (vector r) v)))
					       info h) )
					    (lambda (v)
					      (decorate
					       (lambda () (##core#app body (cons #f v)))
					       info h) ) ) ]
				   [(1) (if rest
					    (lambda (v)
					      (decorate
					       (lambda (a1 . r) (##core#app body (cons (vector a1 r) v)))
					       info h) )
					    (lambda (v)
					      (decorate
					       (lambda (a1) (##core#app body (cons (vector a1) v)))
					       info h) ) ) ]
				   [(2) (if rest
					    (lambda (v)
					      (decorate
					       (lambda (a1 a2 . r) (##core#app body (cons (vector a1 a2 r) v)))
					       info h) )
					    (lambda (v)
					      (decorate
					       (lambda (a1 a2) (##core#app body (cons (vector a1 a2) v)))
					       info h) ) ) ]
				   [(3) (if rest
					    (lambda (v)
					      (decorate
					       (lambda (a1 a2 a3 . r) (##core#app body (cons (vector a1 a2 a3 r) v)))
					       info h) )
					    (lambda (v)
					      (decorate
					       (lambda (a1 a2 a3) (##core#app body (cons (vector a1 a2 a3) v)))
					       info h) ) ) ]
				   [(4) (if rest
					    (lambda (v)
					      (decorate
					       (lambda (a1 a2 a3 a4 . r) (##core#app body (cons (vector a1 a2 a3 a4 r) v)))
					       info h) )
					    (lambda (v)
					      (decorate
					       (lambda (a1 a2 a3 a4) (##core#app body (cons (vector a1 a2 a3 a4) v)))
					       info h) ) ) ]
				   [else (if rest
					     (lambda (v)
					       (decorate
						(lambda as
						  (##core#app body (cons (apply vector (fudge-argument-list argc as)) v)) )
						info h) )
					     (lambda (v)
					       (decorate
						(lambda as
						  (let ([len (length as)])
						    (if (not (= len argc))
							(s-error #f "bad argument count" argc len)
							(##core#app body (cons (apply vector as) v))) ) )
						info h) ) ) ] ) ) ) ) ) ]

			 [(##core#undefined) (lambda _ (##core#undefined))]

			 [(##core#app) (compile-call (cdr x) e)]

			 [(##core#loop-lambda)
			  ;; is this up to date?
			  (compile `(lambda ,@(cdr x)) e #f) ]

			 [else (compile-call x e)] )

		       (compile x2 e h) ) ) ) ) ]

	  [else (compile-call x e)] ) )

  (define (fudge-argument-list n alst)
    (if (null? alst)
	(list alst)
	(do ([n n (- n 1)]
	     [args alst (cdr args)]
	     [last #f args] )
	    ((= n 0)
	     (set-cdr! last (list args))
	     alst) ) ) )

  (define (checked-length lst)
    (and (list? lst)
	 (length lst) ) )

  (define (emit-eval-trace-info info)
    (##core#inline "C_emit_eval_trace_info" info #f ##sys#current-thread) )

  (define (compile-call x e)
    (let* ([fn (compile (car x) e #f)]
	   [args (cdr x)]
	   [argc (checked-length args)]
	   [info x] )
      (case argc
	[(#f) (##sys#syntax-error-hook "syntax error - malformed expression" x)]
	[(0) (lambda (v)
	       (emit-eval-trace-info info)
	       (check-point fuel/lambda)
	       ((##core#app fn v)) ) ]
	[(1) (let ([a1 (compile (car args) e #f)])
	       (lambda (v)
		 (emit-eval-trace-info info)
		 (check-point fuel/lambda)
		 ((##core#app fn v) (##core#app a1 v))) ) ]
	[(2) (let* ([a1 (compile (car args) e #f)]
		    [a2 (compile (list-ref args 1) e #f)] )
	       (lambda (v)
		 (emit-eval-trace-info info)
		 (check-point fuel/lambda)
		 ((##core#app fn v) (##core#app a1 v) (##core#app a2 v))) ) ]
	[(3) (let* ([a1 (compile (car args) e #f)]
		    [a2 (compile (list-ref args 1) e #f)]
		    [a3 (compile (list-ref args 2) e #f)] )
	       (lambda (v)
		 (emit-eval-trace-info info)
		 (check-point fuel/lambda)
		 ((##core#app fn v) (##core#app a1 v) (##core#app a2 v) (##core#app a3 v))) ) ]
	[(4) (let* ([a1 (compile (car args) e #f)]
		    [a2 (compile (list-ref args 1) e #f)]
		    [a3 (compile (list-ref args 2) e #f)]
		    [a4 (compile (list-ref args 3) e #f)] )
	       (lambda (v)
		 (emit-eval-trace-info info)
		 (check-point fuel/lambda)
		 ((##core#app fn v) (##core#app a1 v) (##core#app a2 v) (##core#app a3 v) (##core#app a4 v))) ) ]
	[else (let ([as (map (lambda (a) (compile a e #f)) args)])
		(lambda (v)
		  (emit-eval-trace-info info)
		  (check-point fuel/lambda)
		  (apply (##core#app fn v) (map (lambda (a) (##core#app a v)) as))) ) ] ) ) )

  (compile exp env #f) )


;;; Standard environment:

(safe-environment-table-set!
 default-safe-environment
 (map (lambda (s) (cons s (##sys#slot s 0)))
      '(not boolean? eq? eqv? equal? pair? car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar
	    cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr cadddr cdaaar cdaadr cdadar cdaddr
	    cddaar cddadr cdddar cddddr set-car! set-cdr! null? list?
	    symbol? string->symbol
	    number? integer? exact? real? complex? inexact? rational? zero? odd? even? positive? negative?
	    max min + - * / = > < >= <= quotient remainder modulo gcd lcm abs floor ceiling truncate round
	    exact->inexact inexact->exact exp log expt sqrt sin cos tan asin acos atan
	    string->number char? char=? char>? char<? char>=? char<=? char-ci=? char-ci<? char-ci>?
	    char-ci>=? char-ci<=? char-alphabetic? char-whitespace? char-numeric? char-upper-case?
	    char-lower-case? char-upcase char-downcase char->integer integer->char string? string=?
	    string>? string<? string>=? string<=? string-ci=? string-ci<? string-ci>? string-ci>=? string-ci<=?
	    string-length string-ref string-set!
	    string-fill! vector? vector-ref vector-set!
	    vector-length vector-fill! procedure? force
	    call-with-current-continuation
	    dynamic-wind values call-with-values) ) )

(define (primitive-set! id val)
  (safe-environment-set! default-safe-environment id val) )

(define (primitive-macro-set! id proc)
  (safe-environment-macro-set! default-safe-environment id proc) )

(define-syntax defp
  (lambda (e r c)
    (let ((args (cdr e)))
     (match args
      [((name . llist) . body) `(,(r 'primitive-set!) ',name (,(r 'lambda) ,llist ,@body))]
      [(name val) `(,(r 'primitive-set!) ',name ,val)]
      [(name) `(,(r 'primitive-set!) ',name ,name)] ) ) ) )

(define (check-plist x loc)
  (if (list? x)
      x
      (s-error loc "not a proper list" x) ) )

(defp (vector . args)
  (check-alloc (* (alloc/slot (length args))))
  (apply vector args) )

(defp (string . args)
  (check-alloc (* alloc/char (length args)))
  (apply string args) )

(defp (list . args)
  (check-alloc (* (alloc/pair (length args))))
  (apply list args) )

(defp (number->string . args)
  (let ([s (apply number->string args)])
    (check-alloc (* alloc/char (string-length s)))
    s) )

(defp (string-append . xs0)
  (let loop ([xs xs0])
    (if (or (null? xs) (null? (cdr xs)))
	(apply string-append xs0)
	(let ([s0 (car xs)])
	  (check-alloc (* alloc/char (string-length s0)))
	  (loop (cdr xs)) ) ) ) )

(defp (string->list s)
  (check-alloc (alloc/pair (string-length s)))
  (string->list s) )

(defp (string-copy s)
  (check-alloc (* (string-length s) alloc/char))
  (string-copy s) )

(defp (symbol->string s)
  (let ([str (symbol->string s)])
    (check-alloc (* alloc/char (string-length str)))
    str) )

(defp (cons x y)
  (check-alloc (alloc/pair 1))
  (cons x y) )

(defp (vector->list v)
  (check-alloc (alloc/pair (vector-length v)))
  (vector->list v) )

(defp (substring s i1 i2)
  (check-alloc (* alloc/char (- i2 i1)))
  (substring s i1 i2) )

(defp (length x) (length (check-plist x 'length)))

(defp (equal? x y)
  (let loop ([x x] [y y])
    (check-point fuel/rec)
    (or (eq? x y)
	(and (not (##sys#immediate? x))
	     (not (##sys#immediate? y))
	     (let ([sx (##sys#size x)])
	       (and (eq? (##sys#size y) sx)
		    (##core#inline "C_sametypep" x y)
		    (or (zero? sx)
			(if (##core#inline "C_byteblockp" x)
			    (and (##core#inline "C_byteblockp" y)
				 (##core#inline "C_substring_compare" x y 0 0 sx) )
			    (let ([sx-1 (fx- sx 1)])
			      (let loop2 ([i (if (##core#inline "C_specialp" x) 1 0)])
				(if (fx>= i sx-1)
				    (loop (##sys#slot x i) (##sys#slot y i))
				    (and (loop (##sys#slot x i) (##sys#slot y i))
					 (loop2 (fx+ i 1)) ) ) ) ) ) ) ) ) ) ) ) )

(defp (list-tail x n) (list-tail (check-plist x 'list-tail) n))
(defp (list-ref x n) (list-ref (check-plist x 'list-ref) n))

(defp (append . xs0)
  (let loop ([xs xs0])
    (if (or (null? xs) (null? (cdr xs)))
	(apply append xs0)
	(let ([lst (car xs)])
	  (check-plist lst 'append)
	  (check-alloc (alloc/pair (length lst)))
	  (loop (cdr xs)) ) ) ) )

(defp (reverse x)
  (let ([x (check-plist x 'reverse)])
    (check-alloc (alloc/pair (length x)))
    (reverse x) ) )

(defp (assq x y) (assq x (check-plist y 'assq)))
(defp (assv x y) (assv x (check-plist y 'assv)))
(defp (assoc x y) (assoc x (check-plist y 'assoc)))
(defp (memq x y) (memq x (check-plist y 'memq)))
(defp (memv x y) (memv x (check-plist y 'memv)))
(defp (member x y) (member x (check-plist y 'member)))

(define-constant maximum-size 10000)

(define (check-max n loc)
  (if (> n maximum-size)
      (s-error loc "size argument exceeds limit" n maximum-size)
      n) )

(defp (make-string x . y)
  (check-alloc (* x alloc/char))
  (apply make-string (check-max x 'make-string) y))

(defp (list->string x)
  (let ([x (check-plist x 'list->string)])
    (check-alloc (alloc/pair (length x)))
    (list->string x) ) )

(defp (make-vector x . y)
  (check-alloc (alloc/slot x))
  (apply make-vector (check-max x 'make-vector) y))

(defp (list->vector x)
  (let ([x (check-plist x 'list->vector)])
    (check-alloc (alloc/slot (length x)))
    (list->vector x) ) )

(defp (map p . xs)
  (for-each (cut check-plist <> 'map) xs)
  (apply map p xs) )

(defp (for-each p . xs)
  (for-each (cut check-plist <> 'for-each) xs)
  (apply for-each p xs) )

(defp (make-promise x) (##sys#make-promise x))

(defp (eval x)
  ((compile-expression x '()) '()) )

(defp (apply fn a1 . args)
  (apply
   fn
   (let build ((args (cons a1 args)))
     (let ((head (car args))
	   (rest (cdr args)) )
       (cond ((null? rest)
	      (check-plist head 'apply)
	      head)
	     (else (cons head (build rest))) ) ) ) ) )


; unsupported:
;
;   input-port?
;   output-port?
;   current-input-port
;   current-output-port
;   call-with-input-file
;   call-with-output-file
;   open-input-file
;   open-output-file
;   close-input-port
;   char-ready?
;   read-char
;   write-char
;   read
;   write
;   display
;   load
;   transcript-on
;   transcript-off
;   peek-char
;   eof-object?
;   newline
;   with-input-from-file
;   with-output-from-file
;   scheme-report-environment
;   null-environment
;   interaction-environment


;;; Macros:

(define (canonicalize-body body)
  (define (fini vars vals body)
    (if (null? vars)
	`(begin ,@body)
	(let ([vars (reverse vars)])
	  `(let ,(map (lambda (v) (list v '(##core#undefined))) vars)
	     ,@(map (lambda (v x) `(set! ,v ,x)) vars (reverse vals))
	     ,@body) ) ) )
  (define (expand body)
    (let loop ([body body] [vars '()] [vals '()])
      (check-point fuel/expand)
      (if (not (pair? body))
	  (fini vars vals body)
	  (let* ([x (car body)]
		 [rest (cdr body)]
		 [head (and (pair? x) (car x))] )
	    (cond [(not head) (fini vars vals body)]
		  [(eq? 'define head)
		   (##sys#check-syntax 'define x '(define _ . #(_ 1)) #f)
		   (let ([head (cadr x)])
		     (cond [(not (pair? head))
			    (##sys#check-syntax 'define x '(define variable _) #f)
			    (loop rest (cons head vars) (cons (caddr x) vals)) ]
			   [else
			    (##sys#check-syntax 'define x '(define (variable . lambda-list) . #(_ 1)) #f)
			    (loop rest
				  (cons (car head) vars)
				  (cons `(lambda ,(cdr head) ,@(cddr x)) vals) ) ] ) ) ]
		  [(eq? 'begin head)
		   (##sys#check-syntax 'begin x '(begin . #(_ 0)) #f)
		   (loop (append (cdr x) rest) vars vals) ]
		  [else
		   (let ([x2 (safe-macroexpand-1 x)])
		     (if (eq? x x2)
			 (fini vars vals body)
			 (loop (cons x2 rest) vars vals) ) ) ] ) ) ) ) )
  (expand body) )

(define (safe-macroexpand-1 exp)
  (if (and (pair? exp) (symbol? (car exp)))
      (let ([s (car exp)]
	    [body (cdr exp)] )
	(case s
	  [(let)
	   (##sys#check-syntax 'let body '#(_ 2))
	   (let ([bindings (car body)])
	     (cond [(symbol? bindings)
		    (##sys#check-syntax 'let body '(_ #((variable _) 0) . #(_ 1)))
		    (let ([bs (cadr body)])
		      `(##core#app
			(letrec ([,bindings (##core#loop-lambda ,(map (lambda (b) (car b)) bs) ,@(cddr body))])
			  ,bindings)
			,@(##sys#map cadr bs) ) ) ]
		   [else exp] ) ) ]
	  [else
	   (let loop ([e (current-safe-environment)])
	     (let ([m (assq s (safe-environment-macro-table e))])
	       (cond [m ((cdr m) (cdr exp))]
		     [(safe-environment-parent e) => loop]
		     [else exp] ) ) ) ] ) )
      exp) )

(define-syntax defm
  (lambda (e r c)
    (let ((head (cadr e))
          (body (cddr e)))
  `(,(r 'primitive-macro-set!)
    ',(car head)
    ,(if (and (pair? head) (not (pair? (cdr head))))
	 `(,(r 'lambda) (,(cdr head)) ,@body)
	 (let ([var (gensym)])
	   `(,(r 'lambda) (,var)
	      (,(r 'apply) (,(r 'lambda) ,(cdr head) ,@body) ,var) ) ) ) ) ) ) )

(defm (define head . body)
  (cond ((not (pair? head))
	 (##sys#check-syntax 'define head 'symbol)
	 (##sys#check-syntax 'define body '#(_ 1))
	 `(set! ,head ,(car body)) )
	(else
	 (##sys#check-syntax 'define head '(symbol . lambda-list))
	 (##sys#check-syntax 'define body '#(_ 1))
	 `(set! ,(car head) (lambda ,(cdr head) ,@body)) ) ) )

(defm (and . body)
  (if (eq? body '())
      #t
      (let ((rbody (cdr body))
	    (hbody (car body)) )
	(if (eq? rbody '())
	    hbody
	    `(if ,hbody (and ,@rbody) #f) ) ) ) )

(defm (or . body)
  (if (eq? body '())
      #f
      (let ((rbody (cdr body))
	    (hbody (car body)) )
	(if (eq? rbody '())
	    hbody
	    (let ((tmp (gensym)))
	      `(let ((,tmp ,hbody))
		 (if ,tmp ,tmp (or ,@rbody)) ) ) ) ) ) )

(defm (cond . body)
  (let expand ((clauses body))
    (if (not (pair? clauses))
	'(##core#undefined)
	(let ((clause (car clauses))
	      (rclauses (cdr clauses)) )
	  (##sys#check-syntax 'cond clause '#(_ 1))
	  (cond ((eq? 'else (car clause)) `(begin ,@(cdr clause)))
		((eq? (cdr clause) '()) `(or ,(car clause) ,(expand rclauses)))
		((eq? '=> (car (cdr clause)))
		 (let ((tmp (gensym)))
		   `(let ((,tmp ,(car clause)))
		      (if ,tmp
			  (,(car (cdr (cdr clause))) ,tmp)
			  ,(expand rclauses) ) ) ) )
		(else `(if ,(car clause)
			   (begin ,@(cdr clause))
			   ,(expand rclauses) ) ) ) ) ) ) )

(defm (case . form)
  (let ((exp (car form))
	(body (cdr form)) )
    (let ((tmp (gensym)))
      `(let ((,tmp ,exp))
	 ,(let expand ((clauses body))
	    (if (not (pair? clauses))
		'(##core#undefined)
		(let ((clause (car clauses))
		      (rclauses (cdr clauses)) )
		  (##sys#check-syntax 'case clause '#(_ 1))
		  (if (eq? 'else (car clause))
		      `(begin ,@(cdr clause))
		      `(if (or ,@(map (lambda (x) `(eqv? ,tmp ',x)) (car clause)))
			   (begin ,@(cdr clause))
			   ,(expand rclauses) ) ) ) ) ) ) ) ) )

(defm (let* . form)
  (let ((bindings (car form))
	(body (cdr form)) )
    (##sys#check-syntax 'let* bindings '#((symbol _) 0))
    (##sys#check-syntax 'let* body '#(_ 1))
    (let expand ((bs bindings))
      (if (eq? bs '())
	  (canonicalize-body body)
	  `(let (,(car bs)) ,(expand (cdr bs))) ) ) ) )

(defm (letrec . form)
  (let ((bindings (car form))
	(body (cdr form)) )
    (##sys#check-syntax 'letrec bindings '#((symbol _) 0))
    (##sys#check-syntax 'letrec body '#(_ 1))
    `(let ,(map (lambda (b) (list (car b) '(##core#undefined))) bindings)
       (begin ,@(append (map (lambda (b) `(set! ,(car b) ,(cadr b))) bindings)
			(list (canonicalize-body body)) ) ) ) ) )

(defm (do bindings test . body)
  (##sys#check-syntax 'do bindings '#((symbol _ . #(_)) 0))
  (##sys#check-syntax 'do test '#(_ 1))
  (let ((dovar (gensym "do")))
    `(let ,dovar ,(map (lambda (b) (list (car b) (car (cdr b)))) bindings)
	  (if ,(car test)
	      ,(let ((tbody (cdr test)))
		 (if (eq? tbody '())
		     '(##core#undefined)
		     `(begin ,@tbody) ) )
	      (begin
		,(if (eq? body '())
		     '(##core#undefined)
		     (canonicalize-body body) )
		(##core#app
		 ,dovar ,@(map (lambda (b)
				 (if (eq? (cdr (cdr b)) '())
				     (car b)
				     (car (cdr (cdr b))) ) )
			       bindings) ) ) ) ) ) )

(defm (quasiquote form)
  (define (walk x n) (simplify (walk1 x n)))
  (define (walk1 x n)
    (cond ((vector? x)
	   `(list->vector ,(walk (vector->list x) n)) )	;***
	  ((not (pair? x)) `(quote ,x))
	  (else
	   (let ((head (car x))
		 (tail (cdr x)) )
	     (case head
	       ((unquote)
		(if (pair? tail)
		    (let ((hx (car tail)))
		      (if (eq? n 0)
			  hx
			  (list 'list '(quote unquote) ;***
				(walk hx (- n 1)) ) ) )
		    '(quote unquote) ) )
	       ((quasiquote)
		(if (pair? tail)
		    `(list (quote quasiquote) ;***
			   ,(walk (car tail) (+ n 1)) )
		    (list 'cons (list 'quote 'quasiquote) (walk tail n)) ) ) ;***
	       (else
		(if (pair? head)
		    (let ((hx (car head))
			  (tx (cdr head)) )
		      (if (and (eq? hx 'unquote-splicing) (pair? tx))
			  (let ((htx (car tx)))
			    (if (eq? n 0)
				`(append ,htx ;***
					 ,(walk tail n) )
				`(cons (list 'unquote-splicing ;***
					     ,(walk htx (- n 1)) )
				       ,(walk tail n) ) ) )
			  `(cons ,(walk head n) ,(walk tail n)) ) ) ;***
		    `(cons ,(walk head n) ,(walk tail n)) ) ) ) ) ) ) )	;***
  (define (simplify x)
    (cond ((match-expression x '(cons a '()) '(a))
	   => (lambda (env) (simplify `(list ,(cdr (assq 'a env))))) )
	  ((match-expression x '(cons a (list . b)) '(a b))
	   => (lambda (env)
		(let ([bxs (assq 'b env)])
		  (if (fx< (length bxs) 32)
		      (simplify `(list ,(cdr (assq 'a env))
				       ,@(cdr bxs) ) )
		      x) ) ) )
	  ((match-expression x '(append a '()) '(a))
	   => (lambda (env) (cdr (assq 'a env))) )
	  (else x) ) )
  (walk form 0) )

(define match-expression
  (lambda (exp pat vars)
    (let ((env '()))
      (define (mwalk x p)
	(cond ((not (pair? p))
	       (cond ((assq p env) => (lambda (a) (equal? x (cdr a))))
		     ((memq p vars)
		      (set! env (cons (cons p x) env))
		      #t)
		     (else (eq? x p)) ) )
	      ((not (pair? x)) #f)
	      ((mwalk (car x) (car p))
	       (mwalk (cdr x) (cdr p)) )
	      (else #f) ) )
      (and (mwalk exp pat) env) ) ) )

(defm (delay x)
  `(make-promise (lambda () ,x)) )	;***


;;; User interface:

(define (safe-eval exp #!key (environment (current-safe-environment)) fuel allocation-limit)
  (condition-case
      (parameterize ([current-fuel fuel]
		     [current-safe-environment environment]
		     [current-allocation-limit allocation-limit] )
	((compile-expression exp '()) '()) )
    [ex (sandbox) (signal ex)]
    [ex () (signal (make-composite-condition (make-property-condition 'sandbox) ex))] ) ) )