DataMuseum.dk

top - download

    Length: 13600 (0x3520)
    Types: TextFile
    Names: »eceval.scm«

└─⟦a0efdde77⟧ Bits:30001252 EUUGD11 Tape, 1987 Spring Conference Helsinki
    └─ ⟦this⟧ »EUUGD11/gnu-31mar87/scheme/psets/eceval.scm« 

TextFile

;;;-*-SCHEME-*-
;;;explicit control evaluator, with modifications to handle complied
;;;code 

;;;This file contains the definition of the explicit control
;;;evaluator, in a form that an be processed by the register macine
;;;simulator.  There are also a few interface procedures, which allow
;;;the ec-evaluator to call the underlying Lisp in order to run
;;;primitive procedures.   Also a few utilities used to construct
;;;environments, to set up the initial environment, and the READ and
;;;PRINT operations used by the evaluator.  It also includes a few
;;;additional syntax procedures needed to handle compiled code.

;;;Before loading this file, one should have loaded the register
;;;machine simulator, so it can process the definition; and the
;;;ECEVAL-SYNTAX procedures, which define the representations of
;;;expressions and environments.  You should also load the COMPILER,
;;;in order to generate compiled code.

;;;Once all this has been loaded, you can run the evaluator by executing
;;;      (go)


;;;the compiler has been set up so that you can call it from within
;;;the ec-evaluator using the special form COMPILE-AND-RUN, for
;;;example
;;;EC-EVAL==> (compile-and-run (define (frob x y) (+ x (* 2 y))))


(define (go)
  (start explicit-control-evaluator))

;;;Linking to compiled code

(define (cload insts)
  (cond ((null? insts) nil)
        ((symbol? (car insts))
	 (let ((rest (cload (cdr insts))))
	   (declare-label! explicit-control-evaluator (car insts) rest)
	   rest))
        (else (cons (make-machine-instruction
                     explicit-control-evaluator
                     (car insts))
                    (cload (cdr insts))))))

;;;syntax to recognize compiled procedures

(define (compiled-procedure? p)
  (if (atom? p)
      nil
      (eq? (car p) 'compiled-procedure)))

(define (make-compiled-procedure code env)
  (list 'compiled-procedure code env))

(define (code-of-compiled-procedure p) (cadr p))

(define (env-of-compiled-procedure p) (caddr p))


;;code to recognize compilation commands

(define (compilation? exp)
  (eq? (car exp) 'compile-and-run))

(define (compilation-expression exp)
  (cadr exp))

;;;Primitives:
;;;For our purposes, a "primitive procedure" is one that is given in
;;;a specified list of primitives.

(define (primitive-procedure? p)
  (applicable? p))

(define primitive-procedure-names
  '(car cdr cons atom? eq?
    + - * / > < =))
    
(define primitive-procedures
  (list car cdr cons atom? eq?
        + - * / > < =))

;;;the arglist for eceval appears in reverse order, so this reversal
;;;must be undone when passing args off to a Scheme procedure

(define (apply-primitive-procedure p args)
  (apply p (reverse args)))

;;; The same reversal is needed when we interface to the
;;;environment-constructing routines, to build the environment for
;;;procedure application

(define (make-bindings proc args)
  (extend-environment (parameters proc)
                      (reverse args)
                      (procedure-environment proc)))

;;; seting up the initial environment

(define (setup-environment)
  (define initial-env
    (extend-environment primitive-procedure-names
                        primitive-procedures
                        nil))
  (define-variable! 'nil nil initial-env)
  (define-variable! 't (not nil) initial-env)
  initial-env)

(define the-simulated-global-environment (setup-environment))

(define (user-print object)
  (cond ((compound-procedure? object)
         (print (list 'compound-procedure
                      (parameters object)
                      (procedure-body object)
                      '<procedure-env>)))
        ((compiled-procedure? object)
         (print '<compiled-procedure>))
        (else (print object))))

(define (prompting-read prompt)
  (newline)
  (princ prompt)
  (read))

;;;Here is the definition of the evaluator itself.

(enable-language-features)

(define (cons* first-element . rest-elements)
  (let loop ((this-element first-element)
	     (rest-elements rest-elements))
    (if (null? rest-elements)
	this-element
	(cons this-element
	      (loop (car rest-elements)
		    (cdr rest-elements))))))

(define-macro (define-machine name . body)
  `(DEFINE ,name
     (CHECK-SYNTAX-AND-ASSEMBLE '(DEFINE-MACHINE ,name . ,body))))

(add-syntax! 'define-machine
  (macro (name . body)
  `(DEFINE ,name
     (CHECK-SYNTAX-AND-ASSEMBLE '(DEFINE-MACHINE ,name . ,body)))))

(disable-language-features)

(define-machine explicit-control-evaluator
  (registers exp env unev argl fun val continue)
  (operations
  (assign exp (compilation-expression (fetch exp)))
  (assign val (compile (fetch exp)))
  (assign continue (cload (caddr (fetch val))))
   (assign argl '())
   (assign argl (cons (fetch val) (fetch argl)))
   (assign continue accumulate-arg)
   (assign continue accumulate-last-arg)
   (assign continue setup-no-arg-apply)
   (assign continue print-result)
   (assign continue ev-assignment-1)
   (assign continue ev-definition-1)
   (assign continue eval-sequence-continue)
   (assign continue eval-args)
   (assign continue evcond-decide)
   (assign continue (code-of-compiled-procedure (fetch fun)))
   (assign env (make-bindings (fetch fun) (fetch argl)))
   (assign env the-simulated-global-environment)
   (assign exp (prompting-read 'EC-EVAL==>))
   (assign exp (assignment-value (fetch exp)))
   (assign exp (definition-value (fetch exp)))
   (assign exp (first-clause (fetch unev)))
   (assign exp (first-exp (fetch unev)))
   (assign exp (first-operand (fetch unev)))
   (assign exp (operator (fetch exp)))
   (assign exp (predicate (fetch exp)))
   (assign exp (transform-let (fetch exp)))
   (assign fun (fetch val))
   (assign unev (action-sequence (fetch exp)))
   (assign unev (assignment-variable (fetch exp)))
   (assign unev (clauses (fetch exp)))
   (assign unev (definition-variable (fetch exp)))
   (assign unev (operands (fetch exp)))
   (assign unev (procedure-body (fetch fun)))
   (assign unev (rest-clauses (fetch unev)))
   (assign unev (rest-exps (fetch unev)))
   (assign unev (rest-operands (fetch unev)))
   (assign val (apply-primitive-procedure (fetch fun) (fetch argl)))
   (assign val (fetch exp))
   (assign val (fetch fun))
   (assign val (fetch unev))
   (assign val (lookup-variable-value (fetch exp) (fetch env)))
   (assign val (make-procedure (fetch exp) (fetch env)))
   (assign val (text-of-quotation (fetch exp)))
   (assign val nil)
   (assign val 'Unknown-expression-type-error)
   (assign val 'Unknown-procedure-type-error)
   (goto read-eval-print-loop)
   (goto apply-dispatch)
   (goto signal-error)
   (goto eval-sequence)
   (goto eval-arg-loop)
   (goto eval-dispatch)
   (goto evcond-pred)
   (goto unknown-expression-type-error)
   (goto unknown-procedure-type-error)
   (goto (fetch continue))
   (branch (application? (fetch exp)) ev-application)
   (branch (assignment? (fetch exp)) ev-assignment)
   (branch (compound-procedure? (fetch fun)) compound-apply)
   (branch (conditional? (fetch exp)) ev-cond)
   (branch (compilation? (fetch exp)) ev-compilation)
   (branch (definition? (fetch exp)) ev-definition)
   (branch (no-clauses? (fetch unev)) evcond-return-nil)
   (branch (else-clause? (fetch exp)) evcond-else-clause)
   (branch (lambda? (fetch exp)) ev-lambda)
   (branch (last-exp? (fetch unev)) last-exp)
   (branch (last-operand? (fetch unev)) eval-last-arg)
   (branch (no-args? (fetch exp)) ev-no-args)
   (branch (primitive-procedure? (fetch fun)) primitive-apply)
   (branch (compiled-procedure? (fetch fun)) compiled-apply)
   (branch (quoted? (fetch exp)) ev-quote)
   (branch (self-evaluating? (fetch exp)) ev-return)
   (branch (true? (fetch val)) evcond-true-predicate)
   (branch (variable? (fetch exp)) ev-variable)
   (perform (initialize-stack))
   (perform (define-variable! (fetch unev) (fetch val) (fetch env)))
   (perform (set-variable-value! (fetch unev) (fetch val) (fetch env)))
   (perform (user-print (fetch val)))
   (save argl) (restore argl)
   (save continue) (restore continue)
   (save env) (restore env)
   (save fun) (restore fun)
   (save unev) (restore unev))

(controller
 read-eval-print-loop
  (perform (initialize-stack))
  (assign exp (prompting-read 'EC-EVAL==>))
  (assign env the-simulated-global-environment)
  (assign continue print-result)
  (goto eval-dispatch)
 print-result
  (perform (user-print (fetch val)))
  (goto read-eval-print-loop)

 eval-dispatch
  (branch (self-evaluating? (fetch exp)) ev-return)
  (branch (quoted? (fetch exp)) ev-quote)
  (branch (variable? (fetch exp)) ev-variable)
  (branch (definition? (fetch exp)) ev-definition)
  (branch (assignment? (fetch exp)) ev-assignment)
  (branch (lambda? (fetch exp)) ev-lambda)
  (branch (conditional? (fetch exp)) ev-cond)
  (branch (compilation? (fetch exp)) ev-compilation)
  (branch (no-args? (fetch exp)) ev-no-args)
  (branch (application? (fetch exp)) ev-application)
  (goto unknown-expression-type-error)

 ev-return
  (assign val (fetch exp))
  (goto (fetch continue))
 ev-quote
  (assign val (text-of-quotation (fetch exp)))
  (goto (fetch continue))
 ev-variable
  (assign val
         (lookup-variable-value (fetch exp)
                                (fetch env)))
  (goto (fetch continue))
 ev-lambda
  (assign val
         (make-procedure (fetch exp)
                         (fetch env)))
  (goto (fetch continue))

 ev-compilation
  (save continue)
  (assign exp (compilation-expression (fetch exp)))
  (assign val (compile (fetch exp)))
  (assign continue (cload (caddr (fetch val))))
  (goto (fetch continue))

 ev-no-args
  (assign exp (operator (fetch exp)))
  (save continue)
  (assign continue setup-no-arg-apply)
  (goto eval-dispatch)

 setup-no-arg-apply
  (assign fun (fetch val))
  (assign argl '())
  (goto apply-dispatch)

 ev-application
  (assign unev (operands (fetch exp)))
  (assign exp (operator (fetch exp)))
  (save continue)
  (save env)
  (save unev)
  (assign continue eval-args)
  (goto eval-dispatch)

 eval-args
  (restore unev)
  (restore env)
  (assign fun (fetch val))
  (save fun)
  (assign argl '())
  (goto eval-arg-loop)

 eval-arg-loop
  (save argl)
  (assign exp (first-operand (fetch unev)))
  (branch (last-operand? (fetch unev)) eval-last-arg)
  (save env)
  (save unev)
  (assign continue accumulate-arg)
  (goto eval-dispatch)

 accumulate-arg
  (restore unev)
  (restore env)
  (restore argl)
  (assign argl (cons (fetch val) (fetch argl)))
  (assign unev (rest-operands (fetch unev)))
  (goto eval-arg-loop)

 eval-last-arg
  (assign continue accumulate-last-arg)
  (goto eval-dispatch)
 accumulate-last-arg
  (restore argl)
  (assign argl (cons (fetch val) (fetch argl)))
  (restore fun)
  (goto apply-dispatch)

 apply-dispatch
  (branch (primitive-procedure? (fetch fun)) primitive-apply)
  (branch (compound-procedure? (fetch fun)) compound-apply)
  (branch (compiled-procedure? (fetch fun)) compiled-apply)
  (goto unknown-procedure-type-error)

 primitive-apply
  (assign val
         (apply-primitive-procedure (fetch fun)
                                    (fetch argl)))
  (restore continue)
  (goto (fetch continue))

 compound-apply
  (assign env (make-bindings (fetch fun) (fetch argl)))
  (assign unev (procedure-body (fetch fun)))
  (goto eval-sequence)

 compiled-apply
  (assign continue (code-of-compiled-procedure (fetch fun)))
  (goto (fetch continue))

 eval-sequence
  (assign exp (first-exp (fetch unev)))
  (branch (last-exp? (fetch unev)) last-exp)
  (save unev)
  (save env)
  (assign continue eval-sequence-continue)
  (goto eval-dispatch)
 eval-sequence-continue
  (restore env)
  (restore unev)
  (assign unev (rest-exps (fetch unev)))
  (goto eval-sequence)
 last-exp
  (restore continue)
  (goto eval-dispatch)

 ev-cond
  (save continue)
  (assign continue evcond-decide)
  (assign unev (clauses (fetch exp)))
 evcond-pred
  (branch (no-clauses? (fetch unev)) evcond-return-nil)
  (assign exp (first-clause (fetch unev)))
  (branch (else-clause? (fetch exp)) evcond-else-clause)
  (save env)
  (save unev)
  (assign exp (predicate (fetch exp)))
  (goto eval-dispatch)
 evcond-return-nil
  (restore continue)
  (assign val nil)
  (goto (fetch continue))

 evcond-decide
  (restore unev)
  (restore env)
  (branch (true? (fetch val)) evcond-true-predicate)
  (assign unev (rest-clauses (fetch unev)))
  (goto evcond-pred)

 evcond-true-predicate
  (assign exp (first-clause (fetch unev)))
 evcond-else-clause
  (assign unev (action-sequence (fetch exp)))
  (goto eval-sequence)

 ev-assignment
  (assign unev (assignment-variable (fetch exp)))
  (save unev)
  (assign exp (assignment-value (fetch exp)))
  (save env)
  (save continue)
  (assign continue ev-assignment-1)
  (goto eval-dispatch)
 ev-assignment-1
  (restore continue)
  (restore env)
  (restore unev)
  (perform (set-variable-value! (fetch unev) (fetch val) (fetch env)))
  (goto (fetch continue))

 ev-definition
  (assign unev (definition-variable (fetch exp)))
  (save unev)
  (assign exp (definition-value (fetch exp)))
  (save env)
  (save continue)
  (assign continue ev-definition-1)
  (goto eval-dispatch)
 ev-definition-1
  (restore continue)
  (restore env)
  (restore unev)
  (perform (define-variable! (fetch unev) (fetch val) (fetch env)))
  (assign val (fetch unev))
  (goto (fetch continue))

 unknown-procedure-type-error
  (assign val 'unknown-procedure-type-error)
  (goto signal-error)
 unknown-expression-type-error
  (assign val 'unknown-expression-type-error)
  (goto signal-error)

 signal-error
  (perform (user-print (fetch val)))
  (goto read-eval-print-loop)

 done
  ))