eval.scm

Scheme跨平台编译器

			     [(##core#check)
			      (compile (cadr x) e h tf cntr) ]

			     [(##core#immutable)
			      (compile (cadr x) e #f tf cntr) ]
		   
			     [(##core#undefined) (lambda (v) (##core#undefined))]

			     [(if)
			      (##sys#check-syntax 'if x '(if _ _ . #(_)) #f)
			      (let* ([test (compile (cadr x) e #f tf cntr)]
				     [cns (compile (caddr x) e #f tf cntr)]
				     [alt (if (pair? (cdddr x))
					      (compile (cadddr x) e #f tf cntr)
					      (compile '(##core#undefined) e #f tf cntr) ) ] )
				(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 (##sys#slot x 1)]
				     [len (length body)] )
				(case len
				  [(0) (compile '(##core#undefined) e #f tf cntr)]
				  [(1) (compile (##sys#slot body 0) e #f tf cntr)]
				  [(2) (let* ([x1 (compile (##sys#slot body 0) e #f tf cntr)]
					      [x2 (compile (cadr body) e #f tf cntr)] )
					 (lambda (v) (##core#app x1 v) (##core#app x2 v)) ) ]
				  [else
				   (let* ([x1 (compile (##sys#slot body 0) e #f tf cntr)]
					  [x2 (compile (cadr body) e #f tf cntr)] 
					  [x3 (compile `(begin ,@(##sys#slot (##sys#slot body 1) 1)) e #f tf cntr)] )
				     (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)))
				(receive (i j) (lookup var e)
				  (let ((val (compile (caddr x) e var tf cntr)))
				    (cond [(not i)
					   (let ([var (##sys#alias-global-hook var)])
					     (if ##sys#eval-environment
						 (let ([loc (##sys#hash-table-location
							     ##sys#eval-environment 
							     var
							     ##sys#environment-is-mutable) ] )
						   (unless loc (##sys#error "assignment of undefined identifier" var))
						   (if (##sys#slot loc 2)
						       (lambda (v) (##sys#setslot loc 1 (##core#app val v)))
						       (lambda v (##sys#error "assignment to immutable variable" var)) ) )
						 (lambda (v)
						   (##sys#setslot var 0 (##core#app val v))) ) ) ]
					  [(zero? i) (lambda (v) (##sys#setslot (##sys#slot v 0) j (##core#app val v)))]
					  [else
					   (lambda (v)
					     (##sys#setslot
					      (##core#inline "C_u_i_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)] 
				     [e2 (cons vars e)]
				     [body (##sys#compile-to-closure
					    (##sys#canonicalize-body (cddr x) (cut defined? <> e2) me cntr)
					    e2
					    me
					    cntr) ] )
				(case n
				  [(1) (let ([val (compile (cadar bindings) e (car vars) tf cntr)])
					 (lambda (v)
					   (##core#app body (cons (vector (##core#app val v)) v)) ) ) ]
				  [(2) (let ([val1 (compile (cadar bindings) e (car vars) tf cntr)]
					     [val2 (compile (cadadr bindings) e (cadr vars) tf cntr)] )
					 (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) tf cntr)]
					      [val2 (compile (cadadr bindings) e (cadr vars) tf cntr)] 
					      [t (cddr bindings)]
					      [val3 (compile (cadar t) e (caddr vars) tf cntr)] )
					 (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) tf cntr)]
					      [val2 (compile (cadadr bindings) e (cadr vars) tf cntr)] 
					      [t (cddr bindings)]
					      [val3 (compile (cadar t) e (caddr vars) tf cntr)] 
					      [val4 (compile (cadadr t) e (cadddr vars) tf cntr)] )
					 (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) tf cntr)) bindings)])
				     (lambda (v)
				       (let ([v2 (##sys#make-vector n)])
					 (do ([i 0 (fx+ i 1)]
					      [vlist vals (##sys#slot vlist 1)] )
					     ((fx>= i n))
					   (##sys#setslot v2 i (##core#app (##sys#slot vlist 0) 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)] )
				(when (##sys#extended-lambda-list? llist)
				  (set!-values 
				   (llist body) 
				   (##sys#expand-extended-lambda-list 
				    llist body
				    ##sys#syntax-error-hook) ) ) 
				(##sys#decompose-lambda-list
				 llist
				 (lambda (vars argc rest)
				   (let* ((e2 (cons vars e))
					  (body 
					   (##sys#compile-to-closure
					    (##sys#canonicalize-body body (cut defined? <> e2) me (or h cntr))
					    e2
					    me
					    (or h cntr) ) ) )
				     (case argc
				       [(0) (if rest
						(lambda (v)
						  (decorate
						   (lambda r
						     (##core#app body (cons (vector r) v)))
						   info h cntr) )
						(lambda (v)
						  (decorate
						   (lambda () (##core#app body (cons #f v)))
						   info h cntr) ) ) ]
				       [(1) (if rest
						(lambda (v)
						  (decorate
						   (lambda (a1 . r)
						     (##core#app body (cons (vector a1 r) v)))
						   info h cntr) ) 
						(lambda (v)
						  (decorate 
						   (lambda (a1)
						     (##core#app body (cons (vector a1) v)))
						   info h cntr) ) ) ]
				       [(2) (if rest
						(lambda (v) 
						  (decorate
						   (lambda (a1 a2 . r)
						     (##core#app body (cons (vector a1 a2 r) v)))
						   info h cntr) )
						(lambda (v)
						  (decorate
						   (lambda (a1 a2)
						     (##core#app body (cons (vector a1 a2) v)))
						   info h cntr) ) ) ]
				       [(3) (if rest
						(lambda (v) 
						  (decorate
						   (lambda (a1 a2 a3 . r)
						     (##core#app body (cons (vector a1 a2 a3 r) v)))
						   info h cntr) )
						(lambda (v)
						  (decorate
						   (lambda (a1 a2 a3)
						     (##core#app body (cons (vector a1 a2 a3) v)))
						   info h cntr) ) ) ]
				       [(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 cntr) )
						(lambda (v)
						  (decorate
						   (lambda (a1 a2 a3 a4)
						     (##core#app body (##sys#cons (##sys#vector a1 a2 a3 a4) v)))
						   info h cntr) ) ) ]
				       [else 
					(if rest
					    (lambda (v)
					      (decorate
					       (lambda as
						 (##core#app
						  body
						  (##sys#cons (apply ##sys#vector (fudge-argument-list argc as)) v)) )
					       info h cntr) )
					    (lambda (v)
					      (decorate
					       (lambda as 
						 (let ([len (length as)])
						   (if (not (fx= len argc))
						       (##sys#error "bad argument count" argc len)
						       (##core#app body (##sys#cons (apply ##sys#vector as) v)))))
					       info h cntr) ) ) ] ) ) ) ) ) ]
				
			     [(##core#loop-lambda)
			      (compile `(lambda ,@(cdr x)) e #f tf cntr) ]

			     [(##core#named-lambda)
			      (compile `(lambda ,@(cddr x)) e (cadr x) tf cntr) ]

			     [(##core#require-for-syntax)
			      (let ([ids (map (lambda (x) ((##sys#compile-to-closure x '() '()) '() #f)) (cdr x))])
				(apply ##sys#require ids)
				(let ([rs (##sys#lookup-runtime-requirements ids)])
				  (compile
				   (if (null? rs)
				       '(##core#undefined)
				       `(##sys#require ,@(map (lambda (x) `',x) rs)) )
				   e #f tf cntr) ) ) ]

			     [(##core#require-extension)
			      (compile
			       (let loop ([ids (cdr x)])
				 (if (null? ids)
				     '(##core#undefined)
				     (let-values ([(exp _) (##sys#do-the-right-thing (cadar ids) #f)])
				       `(begin ,exp ,(loop (cdr ids))) ) ) )
			       e #f tf cntr) ]

			     [(##core#elaborationtimeonly ##core#elaborationtimetoo) ; <- Note this!
			      (##core#app (##sys#compile-to-closure (cadr x) '() '() #f) '())
			      (compile '(##core#undefined) e #f tf cntr) ]

			     [(##core#compiletimetoo)
			      (compile (cadr x) e #f tf cntr) ]

			     [(##core#compiletimeonly ##core#callunit) 
			      (compile '(##core#undefined) e #f tf cntr) ]

			     [(##core#declare)
			      (if (memq #:compiling ##sys#features)
				  (for-each (lambda (d) (##compiler#process-declaration (cadr d))) (cdr x)) 
				  (##sys#warn "declarations are ignored in interpreted code" x) )
			      (compile '(##core#undefined) e #f tf cntr) ]

			     [(##core#define-inline ##core#define-constant)
			      (compile `(set! ,(cadadr x) ,@(cddr x)) e #f tf cntr) ]
                   
			     [(##core#primitive ##core#inline ##core#inline_allocate ##core#foreign-lambda 
						##core#define-foreign-variable 
						##core#define-external-variable ##core#let-location
						##core#foreign-primitive
						##core#foreign-lambda* ##core#define-foreign-type)
			      (##sys#syntax-error-hook "can not evaluate compiler-special-form" x) ]

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

			     [else
			      (cond [(eq? head 'location)
				     (##sys#syntax-error-hook "can not evaluate compiler-special-form" x) ]

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

			   (compile x2 e h tf cntr) ) ) ) ) ]

	      [else
	       (emit-syntax-trace-info tf x cntr)
	       (compile-call x e tf cntr)] ) )

      (define (fudge-argument-list n alst)
	(if (null? alst) 
	    (list alst)
	    (do ((n n (fx- n 1))
		 (c 0 (fx+ c 1))
		 (args alst 
		       (if (eq? '() args)
			   (##sys#error "bad argument count" n c)
			   (##sys#slot args 1)))
		 (last #f args) )
		((fx= n 0)
		 (##sys#setslot last 1 (list args))
		 alst) ) ) )

      (define (checked-length lst)
	(let loop ([lst lst] [n 0])
	  (cond [(null? lst) n]
		[(pair? lst) (loop (##sys#slot lst 1) (fx+ n 1))]
		[else #f] ) ) )

      (define (compile-call x e tf cntr)
	(let* ([fn (compile (##sys#slot x 0) e #f tf cntr)]
	       [args (##sys#slot x 1)]
	       [argc (checked-length args)]
	       [info x] )
	  (case argc
	    [(#f) (##sys#syntax-error-hook "malformed expression" x)]
	    [(0) (lambda (v)
		   (emit-trace-info tf info cntr)
		   ((fn v)))]
	    [(1) (let ([a1 (compile (##sys#slot args 0) e #f tf cntr)])
		   (lambda (v)
		     (emit-trace-info tf info cntr)
		     ((##core#app fn v) (##core#app a1 v))) ) ]
	    [(2) (let* ([a1 (compile (##sys#slot args 0) e #f tf cntr)]
			[a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr)] )
		   (lambda (v)
		     (emit-trace-info tf info cntr)
		     ((##core#app fn v) (##core#app a1 v) (##core#app a2 v))) ) ]
	    [(3) (let* ([a1 (compile (##sys#slot args 0) e #f tf cntr)]
			[a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr)]
			[a3 (compile (##core#inline "C_u_i_list_ref" args 2) e #f tf cntr)] )
		   (lambda (v)
		     (emit-trace-info tf info cntr)
		     ((##core#app fn v) (##core#app a1 v) (##core#app a2 v) (##core#app a3 v))) ) ]
	    [(4) (let* ([a1 (compile (##sys#slot args 0) e #f tf cntr)]
			[a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr)]
			[a3 (compile (##core#inline "C_u_i_list_ref" args 2) e #f tf cntr)] 
			[a4 (compile (##core#inline "C_u_i_list_ref" args 3) e #f tf cntr)] )
		   (lambda (v)
		     (emit-trace-info tf info cntr)
		     ((##core#app fn v) (##core#app a1 v) (##core#app a2 v) (##core#app a3 v) (##core#app a4 v))) ) ]
	    [else (let ([as (##sys#map (lambda (a) (compile a e #f tf cntr)) args)])
		    (lambda (v)
		      (emit-trace-info tf info cntr)
		      (apply (##core#app fn v) (##sys#map (lambda (a) (##core#app a v)) as))) ) ] ) ) )

      (compile exp env #f (fx> ##sys#eval-debug-level 0) (:optional cntr #f)) ) ) )

(define ##sys#eval-handler 
  (make-parameter
   (lambda (x . env)
     (let ([mut ##sys#environment-is-mutable]
	   [e #f] )
       (when (pair? env)
	 (let ([env (car env)])
	   (when env
	     (##sys#check-structure env 'environment)
	     (set! e (##sys#slot env 1)) 
	     (set! mut (##sys#slot env 2)) ) ) )
       ((fluid-let ([##sys#environment-is-mutable mut]
		    [##sys#eval-environment e] )
	  (##sys#compile-to-closure x '() '()) )
	'() ) ) ) ) )

(define eval-handler ##sys#eval-handler)

(define (eval x . env)
  (apply (##sys#eval-handler) 
	 (##sys#interpreter-toplevel-macroexpand-hook x)
	 env) )

;;; Split lambda-list into its parts:

(define ##sys#decompose-lambda-list
  (let ([reverse reverse])
    (lambda (llist0 k)

      (define (err)
	(set! ##sys#syntax-error-culprit #f)
	(##sys#syntax-error-hook "illegal lambda-list syntax" llist0) )

      (let loop ([llist llist0] [vars '()] [argc 0])
	(cond [(eq? llist '()) (k (reverse vars) argc #f)]
	      [(not (##core#inline "C_blockp" llist)) (err)]
	      [(##core#inline "C_symbolp" llist) (k (reverse (cons llist vars)) argc llist)]
	      [(not (##core#inline "C_pairp" llist)) (err)]
	      [else (loop (##sys#slot llist 1)
			  (cons (##sys#slot llist 0) vars)
			  (fx+ argc 1) ) ] ) ) ) ) )