eval.scm

Scheme跨平台编译器

			  (err "`#!rest' argument marker in wrong context") ) ]
		     [(#!key)
		      (if (not rvar) (set! rvar (gensym)))
		      (if (fx<= mode 3)
			  (loop 3 req opt '() r)
			  (err "`#!key' argument marker in wrong context") ) ]
		     [else
		      (cond [(symbol? x)
			     (case mode
			       [(0) (loop 0 (cons x req) '() '() r)]
			       [(1) (loop 1 req (cons (list x #f) opt) '() r)]
			       [(2) (err "invalid lambda list syntax after `#!rest' marker")]
			       [else (loop 3 req opt (cons (list x) key) r)] ) ]
			    [(and (list? x) (eq? 2 (length x)))
			     (case mode
			       [(0) (err "invalid required argument syntax")]
			       [(1) (loop 1 req (cons x opt) '() r)]
			       [(2) (err "invalid lambda list syntax after `#!rest' marker")]
			       [else (loop 3 req opt (cons x key) r)] ) ]
			    [else (err "invalid lambda list syntax")] ) ] ) ) ] ) ) ) ) ) )


;;; Expansion of bodies (and internal definitions)

(define ##sys#canonicalize-body
  (let ([reverse reverse]
	[map map] )
    (lambda (body lookup #!optional me container)
      (define (fini vars vals mvars mvals body)
	(if (and (null? vars) (null? mvars))
	    (let loop ([body2 body] [exps '()])
	      (if (not (pair? body2)) 
		  `(begin ,@body) ; no more defines, otherwise we would have called `expand'
		  (let ([x (##sys#slot body2 0)])
		    (if (and (pair? x) (memq (##sys#slot x 0) `(define define-values)))
			`(begin . ,(##sys#append (reverse exps) (list (expand body2))))
			(loop (##sys#slot body2 1) (cons x exps)) ) ) ) )
	    (let ([vars (reverse vars)])
	      `(let ,(##sys#map (lambda (v) (##sys#list v (##sys#list '##core#undefined))) 
				(apply ##sys#append vars mvars) )
		 ,@(map (lambda (v x) `(##core#set! ,v ,x)) vars (reverse vals))
		 ,@(map (lambda (vs x)
			  (let ([tmps (##sys#map gensym vs)])
			    `(##sys#call-with-values
			      (lambda () ,x)
			      (lambda ,tmps 
				,@(map (lambda (v t) `(##core#set! ,v ,t)) vs tmps) ) ) ) ) 
			(reverse mvars)
			(reverse mvals) )
		 ,@body) ) ) )
      (define (expand body)
	(let loop ([body body] [vars '()] [vals '()] [mvars '()] [mvals '()])
	  (if (not (pair? body))
	      (fini vars vals mvars mvals body)
	      (let* ([x (##sys#slot body 0)]
		     [rest (##sys#slot body 1)] 
		     [head (and (pair? x) (##sys#slot x 0))] )
		(cond [(not head) (fini vars vals mvars mvals body)]
		      [(and (symbol? head) (lookup head))
		       (fini vars vals mvars mvals body) ]
		      [(eq? 'define head)
		       (##sys#check-syntax 'define x '(define _ . #(_ 0)) #f)
		       (let loop2 ([x x])
			 (let ([head (cadr x)])
			   (cond [(not (pair? head))
				  (##sys#check-syntax 'define x '(define variable . #(_ 0)) #f)
				  (loop rest (cons head vars)
					(cons (if (pair? (cddr x))
						  (caddr x)
						  '(##sys#void) )
					      vals)
					mvars mvals) ]
				 [(pair? (##sys#slot head 0))
				  (##sys#check-syntax 'define x '(define (_ . lambda-list) . #(_ 1)) #f)
				  (loop2 (cons 'define (##sys#expand-curried-define head (cddr x)))) ]
				 [else
				  (##sys#check-syntax 'define x '(define (variable . lambda-list) . #(_ 1)) #f)
				  (loop rest
					(cons (##sys#slot head 0) vars)
					(cons `(lambda ,(##sys#slot head 1) ,@(cddr x)) vals)
					mvars mvals) ] ) ) ) ]
		      [(eq? 'define-values head)
		       (##sys#check-syntax 'define-values x '(define-values #(_ 0) _) #f)
		       (loop rest vars vals (cons (cadr x) mvars) (cons (caddr x) mvals)) ]
		      [(eq? 'begin head)
		       (##sys#check-syntax 'begin x '(begin . #(_ 0)) #f)
		       (loop (##sys#append (##sys#slot x 1) rest) vars vals mvars mvals) ]
		      [else
		       (let ([x2 (##sys#macroexpand-0 x me)])
			 (if (eq? x x2)
			     (fini vars vals mvars mvals body)
			     (loop (cons x2 rest) vars vals mvars mvals) ) ) ] ) ) ) ) )
      (expand body) ) ) )


;;; A simple expression matcher

(define ##sys#match-expression
  (lambda (exp pat vars)
    (let ((env '()))
      (define (mwalk x p)
	(cond ((or (not (##core#inline "C_blockp" p)) (not (##core#inline "C_pairp" p)))
	       (cond ((assq p env) => (lambda (a) (equal? x (##sys#slot a 1))))
		     ((memq p vars)
		      (set! env (cons (cons p x) env))
		      #t)
		     (else (eq? x p)) ) )
	      ((or (not (##core#inline "C_blockp" x)) (not (##core#inline "C_pairp" x))) #f)
	      ((mwalk (##sys#slot x 0) (##sys#slot p 0))
	       (mwalk (##sys#slot x 1) (##sys#slot p 1)) )
	      (else #f) ) )
      (and (mwalk exp pat) env) ) ) )


;;; Expand "curried" lambda-list syntax for `define'

(define (##sys#expand-curried-define head body)
  (let* ([name #f])
    (define (loop head body)
      (if (symbol? (##sys#slot head 0))
	  (begin
	    (set! name (##sys#slot head 0))
	    `(lambda ,(##sys#slot head 1) ,@body) )
	  (loop (##sys#slot head 0) `((lambda ,(##sys#slot head 1) ,@body)) ) ))
    (let ([exp (loop head body)])
      (list name exp) ) ) )


;;; Lo-level hashtable support:

;; Note:
;;
;; - Keys are compared using 'eq?'.
;; - The fixed "not found" value is #f. So booleans as values are suspect.

(define ##sys#hash-symbol
  (let ([cache-s #f]
	[cache-h #f] )
    (lambda (s n)
      (if (eq? s cache-s)
	  (##core#inline "C_fixnum_modulo" cache-h n)
	  (let ([h (##core#inline "C_hash_string" (##sys#slot s 1))])
	    (set! cache-s s)
	    (set! cache-h h)
	    (##core#inline "C_fixnum_modulo" h n) ) ) ) ) )

(define (##sys#hash-table-ref ht key)
  (let ((k (##sys#hash-symbol key (##core#inline "C_block_size" ht))))
    (let loop ((bucket (##sys#slot ht k)))
      (if (eq? bucket '())
	  #f
	  (let ((b (##sys#slot bucket 0)))
	    (if (eq? key (##sys#slot b 0))
		(##sys#slot b 1)
		(loop (##sys#slot bucket 1)) ) ) ) ) ) )

(define (##sys#hash-table-set! ht key val)
  (let* ((k (##sys#hash-symbol key (##core#inline "C_block_size" ht)))
         (bucket0 (##sys#slot ht k)) )
    (let loop ((bucket bucket0))
      (if (eq? bucket '())
          (##sys#setslot ht k (cons (cons key val) bucket0))
          (let ((b (##sys#slot bucket 0)))
            (if (eq? key (##sys#slot b 0))
		(##sys#setslot b 1 val)
		(loop (##sys#slot bucket 1)) ) ) ) ) ) )

(define (##sys#hash-table-update! ht key updtfunc valufunc)
  (##sys#hash-table-set! ht key (updtfunc (or (##sys#hash-table-ref ht key) (valufunc)))) )

(define (##sys#hash-table-for-each p ht)
  (let ((len (##core#inline "C_block_size" ht)))
    (do ((i 0 (fx+ i 1)))
	((fx>= i len))
      (##sys#for-each (lambda (bucket) 
		        (p (##sys#slot bucket 0) (##sys#slot bucket 1) ) )
		      (##sys#slot ht i) ) ) ) )

(define (##sys#hash-table->alist ht)
  (let ([len (##core#inline "C_block_size" ht)] )
    (let loop ([i 0] [lst '()])
      (if (fx>= i len)
	  lst
	  (let loop2 ([bucket (##sys#slot vec i)]
		      [lst lst])
	    (if (null? bucket)
		(loop (fx+ i 1) lst)
		(loop2 (##sys#slot bucket 1)
		       (let ([x (##sys#slot bucket 0)])
			 (cons (cons (##sys#slot x 0) (##sys#slot x 1)) lst) ) ) ) ) ) ) ) )

(define ##sys#hash-table-location
  (let ([unbound (##sys#slot '##sys#arbitrary-unbound-symbol 0)])
    (lambda (ht key addp)
      (let* ([k (##sys#hash-symbol key (##sys#size ht))]
	     [bucket0 (##sys#slot ht k)] )
	(let loop ([bucket bucket0])
	  (if (null? bucket)
	      (and addp
		   (let ([p (vector key unbound #t)])
		     (##sys#setslot ht k (cons p bucket0))
		     p) )
	      (let ([b (##sys#slot bucket 0)])
		(if (eq? key (##sys#slot b 0))
		    b
		    (loop (##sys#slot bucket 1)) ) ) ) ) ) ) ) )


;;; Compile lambda to closure:

(define ##sys#eval-environment #f)
(define ##sys#environment-is-mutable #f)

(define (##sys#eval-decorator p ll h cntr)
  (##sys#decorate-lambda
   p 
   (lambda (x) (and (not (##sys#immediate? x)) (##core#inline "C_lambdainfop" x)))
   (lambda (p i)
     (##sys#setslot 
      p i 
      (##sys#make-lambda-info 
       (let ((o (open-output-string)))
	 (write ll o)
	 (get-output-string o))))
     p) ) )

(define ##sys#unbound-in-eval #f)
(define ##sys#eval-debug-level 1)
(define (##sys#alias-global-hook s) s)

(define ##sys#compile-to-closure
  (let ([macro? macro?]
	[write write]
	[cadadr cadadr]
	[reverse reverse]
	(keyword? keyword?)
	[open-output-string open-output-string]
	[get-output-string get-output-string] 
	[with-input-from-file with-input-from-file]
	[unbound (##sys#slot '##sys#arbitrary-unbound-symbol 0)]
	[display display] )
    (lambda (exp env me . cntr)

      (define (lookup var e)
	(let loop ((envs e) (ei 0))
	  (cond ((null? envs) (values #f var))
		((posq var (##sys#slot envs 0)) => (lambda (p) (values ei p)))
		(else (loop (##sys#slot envs 1) (fx+ 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 (##sys#slot envs 0)])
		(cons
		 (let delq ([ee envi])
		   (if (null? ee)
		       '()
		       (let ([h (##sys#slot ee 0)]
			     [r (##sys#slot ee 1)] )
			 (if (memq h vars)
			     r
			     (cons h (delq r)) ) ) ) )
		 (loop (##sys#slot envs 1)) ) ) ) ) )

      (define (posq x lst)
	(let loop ((lst lst) (i 0))
	  (cond ((null? lst) #f)
		((eq? x (##sys#slot lst 0)) i)
		(else (loop (##sys#slot lst 1) (fx+ i 1))) ) ) )

      (define (macroexpand-1-checked x e)
	(let ([x2 (##sys#macroexpand-1-local x '())])
	  (if (pair? x2)
	      (let ([h (##sys#slot x2 0)])
		(if (and (eq? h 'let) (not (defined? 'let e)))
		    (let ([next (##sys#slot x2 1)])
		      (if (and (pair? next) (symbol? (##sys#slot next 0)))
			  (macroexpand-1-checked x2 e)
			  x2) )
		    x2) )
	      x2) ) )

      (define (emit-trace-info tf info cntr) 
	(when tf
	  (##core#inline "C_emit_eval_trace_info" info cntr ##sys#current-thread) ) )

      (define (emit-syntax-trace-info tf info cntr) 
	(when tf
	  (##core#inline "C_emit_syntax_trace_info" info cntr ##sys#current-thread) ) )
	
      (define (decorate p ll h cntr)
	(##sys#eval-decorator p ll h cntr) )

      (define (compile x e h tf cntr)
	(cond [(symbol? x)
	       (if (keyword? x)
		   (lambda v x)
		   (receive (i j) (lookup x e)
		     (cond [(not i)
			    (let ((x (##sys#alias-global-hook x)))
			      (if ##sys#eval-environment
				  (let ([loc (##sys#hash-table-location ##sys#eval-environment x #t)])
				    (unless loc (##sys#syntax-error-hook "reference to undefined identifier" x))
				    (cond-expand 
				     [unsafe (lambda v (##sys#slot loc 1))]
				     [else
				      (lambda v 
					(let ([val (##sys#slot loc 1)])
					  (if (eq? unbound val)
					      (##sys#error "unbound variable" x)
					      val) ) ) ] ) )
				  (cond-expand
				   [unsafe (lambda v (##core#inline "C_slot" x 0))]
				   [else
				    (when (and ##sys#unbound-in-eval (not (##sys#symbol-has-toplevel-binding? x)))
				      (set! ##sys#unbound-in-eval (cons (cons x cntr) ##sys#unbound-in-eval)) )
				    (lambda v (##core#inline "C_retrieve" x))] ) ) ) ]
			   [(zero? i) (lambda (v) (##sys#slot (##sys#slot v 0) j))]
			   [else (lambda (v) (##sys#slot (##core#inline "C_u_i_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 "illegal non-atomic object" x)]
	      [(symbol? (##sys#slot x 0))
	       (emit-syntax-trace-info tf x cntr)
	       (let ([head (##sys#slot x 0)])
		 (if (defined? head e)
		     (compile-call x e tf cntr)
		     (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)] ) ) ]

			     [(##core#global-ref)
			      (let ([var (cadr x)])
				(if ##sys#eval-environment
				    (let ([loc (##sys#hash-table-location ##sys#eval-environment var #t)])
				      (lambda v (##sys#slot loc 1)) )
				    (lambda v (##core#inline "C_slot" var 0)) ) ) ]