etng-r2/evaluator.scm
author Tony Garnock-Jones <tonygarnockjones@gmail.com>
Wed, 16 Jan 2019 17:15:58 +0000
changeset 438 1fe179d53161
parent 216 aa55f1375161
permissions -rw-r--r--
Add missing primitive implementation for the plain interpreter.
(define-syntax define-global!
  (syntax-rules ()
    ((_ 'name value) (define name value))))

(define gensym
  (let ((counter 14641))
    (lambda ()
      (let ((v (string->symbol (string-append "g" (number->string counter)))))
	(set! counter (+ counter 1))
	v))))

(define-global! 'global-env
  (let ()
    (define (munge-entry entry) (cons (car entry) (cons (box (cadr entry)) (box (caddr entry)))))
    (map munge-entry
	 `((quote macro ,(lambda (x env exp) x))
	   (define macro ,(lambda (x env exp) `(define ,(cadr x) ,@(map exp (cddr x)))))
	   (lambda macro ,(lambda (x env exp) `(lambda ,(cadr x) ,@(map exp (cddr x)))))
	   (begin macro ,(lambda (x env exp) `(begin ,@(map exp (cdr x)))))
	   (if macro ,(lambda (x env exp) `(if ,@(map exp (cdr x)))))
	   (set! macro ,(lambda (x env exp) `(set! ,(cadr x) ,(exp (caddr x)))))
	   (%assemble macro ,(lambda (x env exp) `(%assemble ,(cadr x) ,(map exp (caddr x))
						    ,@(cdddr x))))

	   (let macro ,(lambda (x env exp)
			 (let ((names (map car (cadr x)))
			       (inits (map cadr (cadr x)))
			       (exps (cddr x)))
			   (exp `((lambda ,names ,@exps) ,@inits)))))
	   (cond macro ,(lambda (x env exp)
			  (exp (cond
				((null? (cdr x)) `(begin))
				((eq? (caadr x) 'else) `(begin ,@(cdadr x)))
				(else `(if ,(caadr x) (begin ,@(cdadr x)) (cond ,@(cddr x))))))))
	   (case macro ,(lambda (x env exp)
			  (let ((v (gensym)))
			    (exp `(let ((,v ,(cadr x)))
				    (cond
				     ,@(map (lambda (clause)
					      (cond
					       ((eq? (car clause) 'else) clause)
					       ((null? (cdar clause))
						`((eq? ,v ',(caar clause)) ,@(cdr clause)))
					       (else (12345678 'multi-case-not-supported clause))))
					    (cddr x))))))))
	   (and macro ,(lambda (x env exp)
			 (exp (cond
			       ((null? (cdr x)) `(begin))
			       ((null? (cddr x)) (cadr x))
			       (else `(if ,(cadr x) (and ,@(cddr x)) #f))))))
	   (,'quasiquote macro
			 ,(lambda (x env exp)
			    (define (qq exp depth)
			      (cond
			       ((not (pair? exp)) `(quote ,exp))
			       ((eq? (car exp) 'quasiquote)
				`(cons ','quasiquote (cons ,(qq (cadr exp) (+ depth 1)) '())))
			       ((eq? (car exp) 'unquote)
				(if (= depth 1)
				    (cadr exp)
				    `(cons ','unquote (cons ,(qq (cadr exp) (- depth 1)) '()))))
			       ((and (pair? (car exp))
				     (eq? (caar exp) 'unquote-splicing))
				(if (= depth 1)
				    `(append ,(cadar exp) ,(qq (cdr exp) depth))
				    `(cons ,(qq (car exp) (- depth 1))
					   ,(qq (cdr exp) depth))))
			       (else `(cons ,(qq (car exp) depth)
					    ,(qq (cdr exp) depth)))))
			    (exp (qq (cadr x) 1))))
	   (define-macro macro ,(lambda (x env exp)
				  (let ((name (cadr x))
					(transformer (eval (exp (caddr x)))))
				    (set! global-env (cons (munge-entry
							    (cons name
								  (cons 'macro
									(cons transformer '()))))
							   global-env))
				    `',name)))
	   (define-global! global ,(lambda (arguments k)
				     (let ((name (car arguments))
					   (value (cadr arguments)))
				       ;; FIXME: should set if entry already exists!
				       (set! global-env (cons (munge-entry
							       (cons name
								     (cons 'global
									   (cons value '()))))
							      global-env))
				       (k name))))))))

(define-global! 'make-eval
  (lambda (
	   error
	   undefined
	   allocate-env
	   update-env
	   load-env
	   unbound-variable-read
	   load-literal
	   load-closure
	   do-if
	   push-frame
	   update-frame
	   do-primitive
	   do-call
	   push-continuation
	   )
    (define (env-null? env) (null? env))
    (define (env-name env) (caar env))
    (define (env-annotation env) (unbox (cadar env)))
    (define (env-value env) (unbox (cddar env)))
    (define (set-env-value! env value)
      (set-box! (cadar env) (update-env (env-name env) (env-annotation env) value))
      (set-box! (cddar env) value))
    (define (env-next env) (cdr env))
    (define (make-env name value next)
      (cons (cons name (cons (box (allocate-env name value)) (box value))) next))
    (define (search-one-env env n k fk)
      (cond
       ((env-null? env) (fk))
       ((eq? (env-name env) n) (k (env-annotation env) (env-value env) env))
       (else (search-one-env (env-next env) n k fk))))
    (define (search-env env n k fk)
      (search-one-env env n k (lambda () (search-one-env global-env n k fk))))
    (define (expand x env)
      (define (exp x) (expand x env))
      (if (pair? x)
	  (if (symbol? (car x))
	      (search-env env (car x)
			  (lambda (annotation v cell) (if (eq? annotation 'macro)
							  (v x env exp)
							  (map exp x)))
			  (lambda () (map exp x)))
	      (map exp x))
	  x))
    (define (make-recursive-env defs env)
      (if (null? defs)
	  env
	  (make-env (caar defs) #f (make-recursive-env (cdr defs) env))))
    (define (e-recursive-definitions defs xs env k)
      (let ((new-env (make-recursive-env defs env)))
	(define (fill-init defs pos)
	  (if (null? defs)
	      (e (cons 'begin xs) new-env k)
	      (e (cdar defs) new-env
		 (push-continuation
		  (lambda (v)
		    (set-env-value! pos v)
		    (fill-init (cdr defs) (env-next pos)))))))
	(fill-init defs new-env)))
    (define (e-body defs xs env k)
      (if (null? xs)
	  (e-recursive-definitions defs xs env k)
	  (let ((x (car xs)))
	    (if (not (pair? x))
		(e-recursive-definitions defs (cons x (cdr xs)) env k)
		(case (car x)
		  ((begin) (e-body defs (append (cdr x) (cdr xs)) env k))
		  ((define) (if (pair? (cadr x))
				(e-body (cons (cons (caadr x)
						    `(lambda ,(cdadr x) ,@(cddr x)))
					      defs) (cdr xs) env k)
				(e-body (cons (cons (cadr x) (caddr x)) defs) (cdr xs) env k)))
		  (else (e-recursive-definitions defs (cons x (cdr xs)) env k)))))))
    (define (extend-env-with-actuals formals actuals env)
      (if (null? formals)
	  env
	  (make-env (car formals) (car actuals)
		    (extend-env-with-actuals (cdr formals) (cdr actuals) env))))
    (define (e-operands index unevaluated evaluated env k)
      (if (null? unevaluated)
	  (k (reverse evaluated))
	  (e (car unevaluated) env
	     (push-continuation
	      (lambda (newly-evaluated)
		(e-operands (+ index 1)
			    (cdr unevaluated)
			    (cons (update-frame index newly-evaluated) evaluated)
			    env
			    k))))))
    (define (e x env k)
      (cond
       ((symbol? x) (search-env env x
				(lambda (annotation v cell)
				  (if (eq? annotation 'macro)
				      (error 'macro-in-variable-position x)
				      (k (load-env x annotation v))))
				(lambda ()
				  (k (unbound-variable-read x)))))
       ((not (pair? x)) (k (load-literal x)))
       (else
	(case (car x)
	  ((quote) (k (load-literal (cadr x))))
	  ((define) (error 'internal-definition-in-invalid-position x))
	  ((lambda) (k (load-closure
			(cadr x)
			(lambda (actuals k)
			  (let ((new-env (extend-env-with-actuals (cadr x) actuals env)))
			    (e-body '() (cddr x) new-env k))))))
	  ((begin) (cond ((null? (cdr x)) (k (undefined)))
			 ((null? (cddr x)) (e (cadr x) env k))
			 (else (e (cadr x) env
				  (push-continuation
				   (lambda (v)
				     (e (cons 'begin (cddr x)) env k)))))))
	  ((if) (e (cadr x) env
		   (push-continuation
		    (lambda (v)
		      (do-if v
			     (lambda () (e (caddr x) env k))
			     (lambda () (e (cadddr x) env k)))))))
	  ((set!) (search-env env (cadr x)
			      (lambda (annotation v cell)
				(if (eq? annotation 'macro)
				    (error 'macro-in-variable-position x)
				    (e (caddr x) env
				       (push-continuation
					(lambda (v)
					  (set-env-value! cell v)
					  (k v))))))
			      (lambda () (error 'unbound-variable x))))
	  ((%assemble) (e-operands 0 (caddr x) '() env
				   (push-frame (length (caddr x))
					       (lambda (operands)
						 (do-primitive (cadr x)
							       operands
							       (cdddr x)
							       k)))))
	  (else (e-operands 0 (cdr x) '() env
			    (push-frame (length (cdr x))
					(lambda (operands)
					  (e (car x) env
					     (push-continuation
					      (lambda (operator)
						(do-call operator operands k))))))))))))
    (lambda (x)
      (let ((expanded (expand x '())))
	(e expanded '() (lambda (v) v))))))

(define primitive-eval eval)

(define-global! 'eval
  (let ()
    (define (error key val) (12345678 'magic-error-procedure key val))
    (define (undefined) 17)
    (define (allocate-env name v) 'local)
    (define (update-env name old-annotation v) old-annotation)
    (define (load-env name annotation v) v)
    (define (unbound-variable-read x) (error 'unbound-variable-read x))
    (define (load-literal x) x)
    (define (load-closure formals f) f)
    (define (do-if v tk fk) (if v (tk) (fk)))
    (define (push-frame count k) k)
    (define (update-frame index v) v)
    (define (do-primitive names vals expressions k)
      (define (search expressions)
	;;(write `(do-primitive:search ,names ,vals ,expressions)) (newline)
	(cond
	 ((null? expressions)
	  (error 'missing-scheme-assembly-expression `(%assemble ,names ,vals ,@expressions)))
	 ((eq? (caar expressions) 'scheme)
	  (k ((primitive-eval `(lambda (actuals) (apply (lambda ,names ,@(cdar expressions))
							actuals)))
	      vals)))
	 (else (search (cdr expressions)))))
      (search expressions))
    (define (do-call operator operands k) (operator operands k))
    (define (push-continuation k) k)
    (make-eval error undefined allocate-env update-env load-env unbound-variable-read
	       load-literal load-closure do-if push-frame update-frame
	       do-primitive do-call push-continuation)))

(define-global! 'compile
  (lambda (exp)
    (let ((continuation-depth (make-parameter 0)))
      (define (error key val) (12345678 'magic-error-procedure key val))
      (define (undefined) (load-literal 17))
      (define (allocate-env name v)
	(write `(allocate-env ,name ,v)) (newline)
	'local)
      (define (update-env name old-annotation v)
	(write `(update-env ,name ,old-annotation)) (newline)
	old-annotation)
      (define (load-env name annotation v)
	(write `(load-env ,name ,annotation)) (newline)
	v)
      (define (unbound-variable-read name)
	(write `(load-implicit-global ,name)) (newline)
	'implicit-global-value)
      (define (load-literal x)
	(write `(load-literal ,x)) (newline)
	x)
      (define (load-closure formals f)
	(write `(load-closure ,formals)) (newline)
	(parameterize ((continuation-depth 0))
	  (write `(IN================)) (newline)
	  (f formals (lambda (v)
		       (write `(return)) (newline)
		       v))
	  (write `(OUT===============)) (newline)
	  'closure-result))
      (define (do-if v tk fk)
	(write `(do-if ,v)) (newline)
	(write `tk) (newline)
	(tk)
	(write `fk) (newline)
	(fk))
      (define (push-frame count k)
	(write `(push-frame ,count)) (newline)
	k)
      (define (update-frame index v)
	(write `(update-frame ,index ,v)) (newline)
	v)
      (define (do-primitive names vals expressions k)
	(write `(%assemble ,names ,vals ,expressions))
	(k 'primitive-result))
      (define (do-call operator operands k)
	(write `(do-call ,(if (= (continuation-depth) 0)
			      'tailcall
			      'normalcall) ,operator ,operands))
	(newline)
	(k 'do-call-result))
      (define (push-continuation k)
	;;(write `(push-continuation)) (newline)
	(continuation-depth (+ (continuation-depth) 1))
	(lambda (v)
	  ;;(write `(pop-continuation ,v)) (newline)
	  (continuation-depth (- (continuation-depth) 1))
	  (k v)))
      ((make-eval error undefined allocate-env update-env load-env unbound-variable-read
		  load-literal load-closure do-if push-frame update-frame
		  do-primitive do-call push-continuation)
       exp))))

(define (read-file filename)
  (call-with-input-file filename
    (lambda (handle)
      (let loop ()
	(let ((sexp (read handle)))
	  (if (eof-object? sexp)
	      '()
	      (cons sexp (loop))))))))

(define-global! 'base-load*
  (lambda (filename evaluator)
    (for-each evaluator (read-file filename))))

(define-global! 'base-load
  (lambda (filename)
    (base-load* filename eval)))

(base-load "evaluator-base-library.scm")

(define (syms x)
  (cond
   ((pair? x) (syms (car x)) (syms (cdr x)))
   ((null? x))
   (else (write x) (newline))))

(define (r* repl-eval)
  (display ">>> ")
  (let ((x (read)))
    (if (eof-object? x)
	'done
	(begin (write (repl-eval x))
	       (newline)
	       (r* repl-eval)))))

(define (r) (r* eval))

;;(eval `(define-global! 'global-env ',global-env))
(r)

;;; Local Variables:
;;; eval: (put '%assemble 'scheme-indent-function 2)
;;; End: