DataMuseum.dk

top - download

    Length: 9222 (0x2406)
    Types: TextFile
    Names: »ps8eval.scm«

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

TextFile

;;;This is the file PS8-EVAL.SCM

;;;SETTING UP THE ENVIRONMENT

;;;We initialize the global environment by snarfing a few primitives from
;;;the underlying scheme system, and binding them (to symbols of the same
;;;name).  The actual structure of the environment is determined by the
;;;constructors EXTEND-ENVIRONMENT and THE-EMPTY-ENV, which are listed below
;;;with the code that manipulates environments.  If you want to add more
;;;primitives to your evaluator, you can modify INITIALIZE-GLOBAL-ENVIRONMENT
;;;to make it snarf more primitives from Scheme.

(define the-global-environment '())

(define (initialize-global-environment)
  (set! the-global-environment
        (add-scheme-primitives
         '(+ - * / = < > cons car cdr atom? eq? null?)
         the-empty-environment)))

(define (add-scheme-primitives prim-list base-env)
  (extend-environment
   prim-list
   (mapcar (lambda (prim)
             (eval prim user-initial-environment))
           prim-list)
   base-env))

;;;INITIALIZATION AND DRIVER LOOP

;;;The following code initializes the machine and starts the Lisp
;;;system.  You should not call it very often, because it will clobber
;;;the global environment, and you will lose any definitions you have
;;;accumulated.

(define (initialize-lisp)
  (initialize-global-environment)
  (driver-loop))

;;;Here is the actual driver loop.  It reads in an expression, passes it
;;;to the machine to be evaluated in the global environment, and prints the
;;;result

;;;When/If your interaction with the evaluator bombs out in an error, you
;;;should restart it by calling DRIVER-LOOP.  Note that the driver uses
;;;a prompt of "**==>" to help you avoid confusing typing to the
;;;simulator with typing to the underlying SCHEME interpreter.

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

(define (driver-loop)
  (user-print (mini-eval (prompted-read '**==>) the-global-environment))
  (newline)
  (driver-loop))

;;;we use a special PRINT here, which avoids printing the environment
;;;part of a compound procedure, since the latter is a very long (or
;;;even circular) list

(define (user-print object)
  (cond
   ((compound-procedure? object)
    (print (list 'compound-procedure
                 (procedure-text object))))
   (else (print object))))

\f


;;;THE GUTS OF THE EVALUATOR

(define (mini-eval exp env)
  (cond ((self-evaluating? exp) exp)
        ((quoted? exp) (text-of-quotation exp))
        ((variable? exp) (lookup-variable-value exp env))
        ((definition? exp) (eval-definition exp env))
        ((assignment? exp) (eval-assignment exp env))
        ((lambda? exp) (make-procedure exp env))
        ((conditional? exp) (eval-cond (clauses exp) env))
        ((application? exp)
         (mini-apply (mini-eval (operator exp) env)
		     (list-of-values (operands exp) env)))
        (else (error "Unknown expression type -- EVAL" exp))))


(define (mini-apply procedure arguments)
  (cond ((primitive-procedure? procedure)
         (apply-primitive-procedure procedure arguments))
        ((compound-procedure? procedure)
         (eval-sequence (procedure-body procedure)
                        (extend-environment
                         (procedure-parameters procedure)
                         arguments
                         (procedure-environment procedure))))
        (else (error "Unknown procedure type -- APPLY"
		     (list procedure arguments)))))


(define (list-of-values exps env)
  (cond ((no-operands? exps) '())
        (else (cons (mini-eval (first-operand exps) env)
                    (list-of-values (rest-operands exps)
                                    env)))))
(define (eval-sequence exps env)
  (cond ((last-exp? exps) (mini-eval (first-exp exps) env))
        (else (mini-eval (first-exp exps) env)
              (eval-sequence (rest-exps exps) env))))

(define (eval-cond clist env)
  (cond ((no-clauses? clist) '())
        ((else-clause? (first-clause clist))
         (eval-sequence (action-sequence (first-clause clist))
                        env))
        ((true? (mini-eval (predicate (first-clause clist)) env))
         (eval-sequence (action-sequence (first-clause clist))
                        env))
        (else (eval-cond (rest-clauses clist) env))))



(define (eval-assignment exp env)
  (let ((value (mini-eval (assignment-value exp) env)))
    (set-variable-value! (assignment-variable exp) value env)
    value))

(define (eval-definition exp env)
  (define-variable! (definition-variable exp)
                    (mini-eval (definition-value exp) env)
                    env)
  (definition-variable exp))


\f


;;;Syntax of the language


(define (self-evaluating? exp)
  (or (number? exp) (eq? exp 'nil)))

(define (quoted? exp)
  (if (not (atom? exp)) (eq? (car exp) 'quote)))

(define (text-of-quotation exp) (cadr exp))

(define (variable? exp) (symbol? exp))

(define (assignment? exp)
  (if (not (atom? exp)) (eq? (car exp) 'set!)))

(define (assignment-variable exp) (cadr exp))

(define (assignment-value exp) (caddr exp))

(define (definition? exp)
  (if (not (atom? exp)) (eq? (car exp) 'define)))


(define (definition-variable exp)
  (cond ((variable? (cadr exp))
         (cadr exp))
        (else
         (caadr exp))))


(define (definition-value exp) 
  (cond ((variable? (cadr exp))
         (caddr exp))           
        (else
         (make-lambda (cdadr exp)    ;Formal parameters
		      (cddr exp))))) ;Body


(define (lambda? exp)
  (if (not (atom? exp)) (eq? (car exp) 'lambda)))

(define (make-lambda formals body)
  (cons 'lambda (cons formals body)))

(define (lambda-formals lambda-exp) (cadr lambda-exp))

(define (lambda-body lambda-exp) (cddr lambda-exp))
\f


(define (conditional? exp)
  (if (not (atom? exp)) (eq? (car exp) 'cond)))

(define (clauses exp) (cdr exp))

(define (no-clauses? clauses) (null? clauses))

(define (first-clause clauses) (car clauses))

(define (rest-clauses clauses) (cdr clauses))

(define (else-clause? clause) (eq? (predicate clause) 'else))

(define (predicate clause) (car clause))

(define (true? x) (not (eq? x nil)))

(define (action-sequence clause) (cdr clause))

(define (last-exp? seq) (eq? (cdr seq) nil))

(define (first-exp seq) (car seq))

(define (rest-exps seq) (cdr seq))

(define (application? exp) (not (atom? exp)))

(define (operator app) (car app))

(define (operands app) (cdr app))

(define (no-operands? args) (eq? args nil))

(define (first-operand args) (car args))

(define (rest-operands args) (cdr args))

(define (last-operand? args)
  (null? (cdr args)))

(define (make-procedure lambda-exp env)
  (list 'procedure lambda-exp env))

(define (compound-procedure? proc)
  (if (not (atom? proc))
       (eq? (car proc) 'procedure)))

(define (procedure-text proc) (cadr proc))

(define (procedure-parameters proc)
  (lambda-formals (procedure-text proc)))

(define (procedure-body proc)
  (lambda-body (procedure-text proc)))

(define (procedure-environment proc)
  (caddr proc))
\f


;;;APPLYING PRIMITIVE PROCEDURES

;;;The mechanism for applying primitive procedures is somewhat different
;;;from the one given in the course notes.  We can recognize primitive
;;;procedures (which are all inherited from Scheme) by asking Scheme if
;;;the object we have is a Scheme procedure:

(define (primitive-procedure? p)
  (memq (object-type p)
	'(primitive-procedure procedure)))

;;;To apply a primitive procedure, we ask the underlying
;;;Scheme system to perform the application.  (Of course, an
;;;implementation on a low-level machine would perform the application in
;;;some other way.)

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

\f


;;;ENVIRONMENTS


;;;Environments are represented as association lists, as described in
;;;section 4.1.3 of the notes.

(define the-empty-environment '())

(define (add-binding-pair var val env)
  (cons (list var val) env))

(define (lookup-variable-value var env)
  (let ((bp (binding-pair var env)))
    (cond ((null? bp) (error "Unbound variable" var))
          (else (cadr bp)))))

(define (set-variable-value! var val env)
  (let ((bp (binding-pair var env)))
    (cond ((null? bp) (error "Unbound variable" var))
          (else (set-car! (cdr bp) val)))))

(define (define-variable! var val env)
  (set-car! env
            (cons (list var val)
                  (car env))))

(define (extend-environment variables values base-env)
  (define (pair-up variables values)
    (cond ((null? variables)
           (cond ((null? values) '())
                 (t
                  (error "Too many arguments supplied"
			 (list variable values)))))
          ((null? values)
           (error "Too few arguments supplied"
		  (list variables values)))
          (else (cons (list (car variables) (car values))
                      (pair-up (cdr variables)
                               (cdr values))))))
  (cons (pair-up variables values) base-env))

(define (binding-pair var env)
  (define (scan pairlist)
    (cond ((null? pairlist)
           (cond ((null? (cdr env)) '())
                 (else (binding-pair var (cdr env)))))
          ((eq? var (caar pairlist)) (car pairlist))
          (else (scan (cdr pairlist)))))
  (scan (car env)))