;;; METACIRCULAR EVALUATOR FROM CHAPTER 4 (SECTIONS 4.1.1-4.1.4) of
;;; STRUCTURE AND INTERPRETATION OF COMPUTER PROGRAMS
;;; *** Modified for CSE 341, Winter 2010, and with additional comments ***
;;; Mostly matches code in ch4.scm
;;; Differences:
;;; - We name eval and apply in the metacircular evaluator mc-eval and mc-apply,
;;; to avoid conflicting with the ones in Scheme
;;; - Frames in the environment are represented using structs rather than lists
;;; (this avoids a compatability problem between the Pretty Big dialect and R5RS -
;;; we don't use set-car! or set-cdr!)
;;; - We use #t and #f to represent the boolean values in the language being interpreted
;;; (the book uses true and false)
;;; - The user-print function is deleted (no longer needed given the use of structs to
;;; represent frames)
;;; This file can be loaded into DrScheme.
;;; Then you can initialize and start the evaluator by evaluating
;;; (run)
;;; If you want to restart the evaluator without resetting the environment, type
;;; (driver-loop)
;;; For the code that you hand in, start with this file and modify it. Clearly mark
;;; the parts that you change by surrounding them with these lines:
;; ****************************************************************************
;; (your code goes here)
;; ****************************************************************************
;;;SECTION 4.1.1
;; Eval and apply. These two functions form the heart of the metacircular
;; interpreter. We use eval to evaluate expressions, and apply to apply a
;; user-defined function to its arguments.
;; (These are named mc-eval and mc-apply for this version, to avoid conflicting
;; with the built-in functions in the underlying Scheme.)
;; evaluate an expression with a given environment
(define (mc-eval exp env)
(cond ((self-evaluating? exp) exp) ; string, number, or boolean evaluates to itself
((variable? exp) (lookup-variable-value exp env)) ; lookup variable value in env
((quoted? exp) (text-of-quotation exp)) ; get value of quoted
((assignment? exp) (eval-assignment exp env)) ; set a previously defined variable
((definition? exp) (eval-definition exp env)) ; define a variable in this scope
((if? exp) (eval-if exp env)) ; evaluate if statement
((lambda? exp) ; make an anonymous function from the given lambda list
(make-procedure (lambda-parameters exp)
(lambda-body exp)
env))
((begin? exp) ; evaluate a sequence of expressions in order
(eval-sequence (begin-actions exp) env))
((cond? exp) (mc-eval (cond->if exp) env)) ; convert cond expr into series of 'if's and eval
((application? exp) ; apply a function to its arguments
(mc-apply (mc-eval (operator exp) env)
(list-of-values (operands exp) env)))
(else
(error "Unknown expression type -- mc-eval" exp))))
;; custom apply function for the interpreter
(define (mc-apply procedure arguments)
;; if 'procedure' is a primitive, call a helper function.
;; otherwise it should be a user-defined procedure. In that
;; case, make a new environment in which to evaluate its body.
;; The new environment is the procedure's environment in which it
;; was closed (capturing any non-local variables), with a new
;; frame that includes bindings for the formal parameters to the
;; procedure. These are bound to the actual arguments given to
;; 'apply'
(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 -- mc-apply" procedure))))
;; eval each of the elements of the list
;; return the list of evaluated elements in the same order
(define (list-of-values exps env)
(if (no-operands? exps)
'()
(cons (mc-eval (first-operand exps) env)
(list-of-values (rest-operands exps) env))))
;; helpers that evaluate their given type of expression
;; To evaluate an if expression, evaluate the predicate part. If its
;; value is not #f, evaluate and return the consequent; otherwise
;; evaluate and return the else part.
(define (eval-if exp env)
(if (mc-eval (if-predicate exp) env)
(mc-eval (if-consequent exp) env)
(mc-eval (if-alternative exp) env)))
(define (eval-sequence exps env)
(cond ((last-exp? exps) (mc-eval (first-exp exps) env))
(else (mc-eval (first-exp exps) env)
(eval-sequence (rest-exps exps) env))))
(define (eval-assignment exp env)
(set-variable-value! (assignment-variable exp)
(mc-eval (assignment-value exp) env)
env)
'ok)
(define (eval-definition exp env)
(define-variable! (definition-variable exp)
(mc-eval (definition-value exp) env)
env)
'ok)
;;;SECTION 4.1.2
;; Eval and Apply Predicates/Helpers
;; strings, numbers, and booleans are self-evaluating and evaluate to themselves, others do not
(define (self-evaluating? exp)
(cond ((number? exp) #t)
((string? exp) #t)
((eq? exp #t) #t)
((eq? exp #f) #t)
(else #f)))
;; tests whether a list has the form ('quote ...)
(define (quoted? exp)
(tagged-list? exp 'quote))
(define (text-of-quotation exp) (cadr exp))
;; helper for predicates
;; tagged list takes a tag ('lambda, 'quote, etc) and attempts to match it to the first item of exp
(define (tagged-list? exp tag)
(if (pair? exp) ; is this a non-empty list (at least one cons pair)?
(eq? (car exp) tag)
#f))
;; helper that checks that the expression passed in is a symbol
(define (variable? exp) (symbol? exp))
;; helper that checks that the expression is a list of the form ('set! ...)
(define (assignment? exp)
(tagged-list? exp 'set!))
;; well-named helpers that get the appropriate item from the list
(define (assignment-variable exp) (cadr exp))
(define (assignment-value exp) (caddr exp))
;; checks that the list begins with the form ('define, ...)
(define (definition? exp)
(tagged-list? exp 'define))
;; could be of the form (define x ...) or (define (f ...) ...)
(define (definition-variable exp)
(if (symbol? (cadr exp))
(cadr exp)
(caadr exp)))
;; if of the form (define x expr) just get exp
;; if of the form (define (f x) expr), make a lambda of the form (lambda (x) expr)
(define (definition-value exp)
(if (symbol? (cadr exp))
(caddr exp)
(make-lambda (cdadr exp)
(cddr exp))))
;; is this a lambda?
(define (lambda? exp) (tagged-list? exp 'lambda))
(define (lambda-parameters exp) (cadr exp))
(define (lambda-body exp) (cddr exp))
;; helper to make a lambda given a list of parameters and a body
;; ('lambda (parameters) body)
(define (make-lambda parameters body)
(cons 'lambda (cons parameters body)))
;; is this an if?
(define (if? exp) (tagged-list? exp 'if))
(define (if-predicate exp) (cadr exp))
(define (if-consequent exp) (caddr exp))
;; "else" expression could be missing, in that case return #f
(define (if-alternative exp)
(if (not (null? (cdddr exp)))
(cadddr exp)
#f))
;; helper that makes an if
;; ('if predicate consequent alternative)
(define (make-if predicate consequent alternative)
(list 'if predicate consequent alternative))
;; is this a begin block (sequence)
;; (begin (expr1) (expr2) (expr3) ...)
(define (begin? exp) (tagged-list? exp 'begin))
;; sequence helpers
(define (begin-actions exp) (cdr exp))
(define (last-exp? seq) (null? (cdr seq)))
(define (first-exp seq) (car seq))
(define (rest-exps seq) (cdr seq))
;; helper to a begin convert a sequence (expr1 expr2 expr3 ...)
;; into a begin expression
(define (sequence->exp seq)
(cond ((null? seq) seq)
((last-exp? seq) (first-exp seq))
(else (make-begin seq))))
(define (make-begin seq) (cons 'begin seq))
;; is this an application of a function to its arguments?
(define (application? exp) (pair? exp))
(define (operator exp) (car exp))
(define (operands exp) (cdr exp))
(define (no-operands? ops) (null? ops))
(define (first-operand ops) (car ops))
(define (rest-operands ops) (cdr ops))
(define (cond? exp) (tagged-list? exp 'cond))
(define (cond-clauses exp) (cdr exp))
(define (cond-else-clause? clause)
(eq? (cond-predicate clause) 'else))
(define (cond-predicate clause) (car clause))
(define (cond-actions clause) (cdr clause))
;; conditional to a group of if statements
(define (cond->if exp)
(expand-clauses (cond-clauses exp)))
(define (expand-clauses clauses)
(if (null? clauses)
#f
(let ((first (car clauses))
(rest (cdr clauses)))
(if (cond-else-clause? first)
(if (null? rest)
(sequence->exp (cond-actions first))
(error "ELSE clause isn't last -- COND->IF"
clauses))
(make-if (cond-predicate first)
(sequence->exp (cond-actions first))
(expand-clauses rest))))))
;;;SECTION 4.1.3
(define (make-procedure parameters body env)
(list 'procedure parameters body env))
(define (compound-procedure? p)
(tagged-list? p 'procedure))
(define (procedure-parameters p) (cadr p))
(define (procedure-body p) (caddr p))
(define (procedure-environment p) (cadddr p))
;; Environment
;; gets the enclosing environment from env
(define (enclosing-environment env) (cdr env))
;; gets the first frame of an environment
(define (first-frame env) (car env))
(define the-empty-environment '())
;; Use a struct to represent a frame, so that we can assign into its list of
;; variables and values in PLT "Pretty Big".
;; This automatically defines a constructor make-frame, and accessors and setters
;; frame-variables, frame-values, set-frame-variables!, and set-frame-values!.
(define-struct frame (variables values))
;; Add a new variable binding to a frame. (This changes the frame that's passed in.)
(define (add-binding-to-frame! var val frame)
(set-frame-variables! frame (cons var (frame-variables frame)))
(set-frame-values! frame (cons val (frame-values frame))))
;; add the lists of given vars and vals to the base-environment
;; ensuring that the lists are the same length
(define (extend-environment vars vals base-env)
(if (= (length vars) (length vals))
(cons (make-frame vars vals) base-env)
(if (< (length vars) (length vals))
(error "Too many arguments supplied" vars vals)
(error "Too few arguments supplied" vars vals))))
;; looks up a variable's value in the given environment
;; search for var in first-frame of environment, then the next frame, etc
(define (lookup-variable-value var env)
(define (env-loop env)
(define (scan vars vals)
(cond ((null? vars)
(env-loop (enclosing-environment env)))
((eq? var (car vars))
(car vals))
(else (scan (cdr vars) (cdr vals)))))
(if (eq? env the-empty-environment)
(error "Unbound variable" var)
(let ((frame (first-frame env)))
(scan (frame-variables frame)
(frame-values frame)))))
(env-loop env))
;; Searches for a variable in the environment and sets it to the given value.
;; The variable should have been defined earlier using 'define', so that is
;; somewhere in the environment; if not signal an error.
(define (set-variable-value! var val env)
(define (env-loop env)
(define (scan frame)
(let ((newvalues (update-values var val (frame-variables frame) (frame-values frame))))
(if (null? newvalues)
(env-loop (enclosing-environment env))
(set-frame-values! frame newvalues))))
(if (eq? env the-empty-environment)
(error "Unbound variable -- SET!" var)
(scan (first-frame env))))
(env-loop env))
;; Sets or defines a variable in the first frame.
;; Look in the first frame of env for var. If found,
;; change the corresponding value; if not found, add it to that frame.
(define (define-variable! var val env)
(let* ((frame (first-frame env))
(vars (frame-variables frame))
(vals (frame-values frame))
(newvals (update-values var val vars vals)))
;; newvals will be () if the variable name wasn't found; otherwise it will
;; be the updated list of values
(if (null? newvals)
(add-binding-to-frame! var val frame)
(set-frame-values! frame newvals))))
;; Helper function for environments. We're trying to assign 'newvalue' to 'var'.
;; vars and values are the variables and values in a given frame.
;; If we find var in vars, return the updated listof values; if we don't find it return ()
(define (update-values var newvalue vars values)
(cond ((null? vars) '()) ; didn't find var
((eq? var (car vars)) (cons newvalue (cdr values))) ; found it
(else
; recursive case: try update-values on the remaining vars and values.
; If this returns () then we didn't find var, and return () from this invocation
; as well. Otherwise we did find it, and vs is the updated list of values.
(let ((vs (update-values var newvalue (cdr vars) (cdr values))))
(if (null? vs) '() (cons (car values) vs))))))
;;;SECTION 4.1.4
;; sets up the initial environment
(define (setup-environment)
(let ((initial-env
(extend-environment (primitive-procedure-names)
(primitive-procedure-objects)
the-empty-environment)))
initial-env))
;; Primitive procedures
(define (primitive-procedure? proc)
(tagged-list? proc 'primitive))
(define (primitive-implementation proc) (cadr proc))
(define primitive-procedures
(list (list 'car car)
(list 'cdr cdr)
(list 'cons cons)
(list 'null? null?)
;; more primitives go here!
))
(define (primitive-procedure-names)
(map car primitive-procedures))
(define (primitive-procedure-objects)
(map (lambda (proc) (list 'primitive (cadr proc)))
primitive-procedures))
;; using the apply from underlying scheme, apply the primitive procedure to the arguments
(define (apply-primitive-procedure proc args)
(apply (primitive-implementation proc) args))
;; I/O
(define input-prompt ";;; M-Eval input:")
(define output-prompt ";;; M-Eval value:")
;; driver-loop defines a read-eval-print loop for the metacircular interpreter
(define (driver-loop)
(prompt-for-input input-prompt)
(let ((input (read)))
(let ((output (mc-eval input the-global-environment)))
(announce-output output-prompt)
(write output)))
(driver-loop))
(define (prompt-for-input string)
(newline) (newline) (display string) (newline))
(define (announce-output string)
(newline) (display string) (newline))
;; Set up the global environment
(define the-global-environment (setup-environment))
;; function to start the read-eval-print environment --
;; reset the global environment to its initial state and start the driver loop
(define (run)
(set! the-global-environment (setup-environment))
(driver-loop))
;; the value returned by loading the metacircular interpeter is the following symbol:
'METACIRCULAR-EVALUATOR-LOADED