;;; ;;; meval.ss ;;; ;;; CS200 Spring 2003 ;;; Problem Set 7 ;;; ;;; Based on Mini-Scheme developed by David Evans for CS655 Spring 2001. ;;; Incorporates code adapted from SICP Chapter 4 and correction by Michael Deighan. ;;; (require (lib "trace.ss")) (load "listprocs.ss") ;;; ;;; We represent different entities using tagged lists. ;;; (define (tagged-list? expr tag) (if (pair? expr) (eq? (car expr) tag) #f)) (define (self-evaluating? expr) (or (number? expr) (string? expr) (primitive-procedure? expr))) (define (variable? expr) (symbol? expr)) (define (quoted? expr) (tagged-list? expr `quote)) (define (text-of-quotation expr) (cadr expr)) (define (definition? expr) (tagged-list? expr 'define)) (define (definition-variable expr) (cadr expr)) (define (definition-value expr) (caddr expr)) (define (define-variable! var value env) ;;; We always add the new definition at the beginning of the frame. That way, ;;; frame-lookup-name will find the new definition first if it is redefined. (set-car! env (cons (cons var value) (car env))) 'ok) (define (lambda? expr) (tagged-list? expr 'lambda)) (define (make-lambda params body) (list 'lambda params body)) (define (lambda-parameters expr) (cadr expr)) (define (lambda-body expr) (cddr expr)) (define (and? expr) (tagged-list? expr 'and)) (define (make-and operands) (list 'and operands)) (define (and-operands expr) (cdr expr)) (define (make-procedure parameters body environment) (list 'procedure parameters body environment)) (define (compound-procedure? expr) (tagged-list? expr 'procedure)) (define (procedure-parameters procedure) (cadr procedure)) (define (procedure-body procedure) (caddr procedure)) (define (procedure-environment procedure) (cadddr procedure)) (define (application? expr) (pair? expr)) (define (application-operator expr) (car expr)) (define (application-operands expr) (cdr expr)) (define (primitive-procedure? expr) (tagged-list? expr 'primitive-procedure)) (define (make-primitive-procedure expr) (list 'primitive-procedure expr)) (define (primitive-procedure-procedure procedure) (cadr procedure)) ;;; ;;; Core of the evaluator - eval and apply ;;; ;;; We have named them "meval" and "mapply" to avoid any confusion with ;;; the built-in Scheme eval and apply. ;;; (define (apply-primitive procedure operands) ;;; Use the underlying Scheme apply to apply a primitive (apply (primitive-procedure-procedure procedure) operands)) (define (apply-compound procedure operands) (meval-sequence (procedure-body procedure) (extend-environment (procedure-parameters procedure) operands (procedure-environment procedure)))) (define (mapply procedure operands) (cond ((primitive-procedure? procedure) (apply-primitive procedure operands)) ((compound-procedure? procedure) (apply-compound procedure operands)) (else (error "Unknown applicator: " procedure)))) (define (meval-sequence seq env) ;;; Evaluate to the value of the last expression in the sequence (get-last (map (lambda (expr) (meval expr env)) seq))) (define (meval expr env) (cond ((self-evaluating? expr) expr) ((quoted? expr) (text-of-quotation expr)) ((definition? expr) (define-variable! (definition-variable expr) (meval (definition-value expr) env) env)) ((lambda? expr) (make-procedure (lambda-parameters expr) (lambda-body expr) env)) ((application? expr) (mapply (meval (application-operator expr) env) (map (lambda (subexpr) (meval subexpr env)) (application-operands expr)))) ((variable? expr) (environment-lookup-name expr env)) ;; Must be last (else (error "Unrecognized expression: " expr)))) ;;; ;;; Environments ;;; (define the-empty-environment '()) (define (make-new-environment frame env) (cons frame env)) (define (first-frame env) (car env)) (define (enclosing-environment env) (cdr env)) (define (make-empty-frame) (list)) (define (extend-environment names values env) (make-new-environment (map (lambda (name value) (cons name value)) names values) env)) (define (environment-lookup-name name env) (if (null? env) (error "No binding for" name) (if (frame-contains? name (first-frame env)) (frame-lookup-name name (first-frame env)) (environment-lookup-name name (enclosing-environment env))))) (define (bind-variable name value env) (add-binding-to-frame! name value (first-frame env))) (define (add-binding-to-frame! name value frame) (car frame) ;; ! frame cannot be null or append! doesn't work (append! frame (list (cons name value)))) ; Note why we use append! not append (define (frame-contains? name frame) (insertl (lambda (var result) (if (eq? (car var) name) #t result)) frame #f)) (define (frame-lookup-name name frame) (if (null? frame) (error "Name not found in frame:" name) (if (eq? (car (car frame)) name) (cdr (car frame)) (frame-lookup-name name (cdr frame))))) ;;; Mini-scheme can add, multiply and subtract using the underlying Scheme primitives: (define the-global-environment (make-new-environment (list ;; Some popular constants (cons 'true #t) (cons 'false #f) (cons 'null null) ;; Primitive procedures (cons '+ (make-primitive-procedure +)) (cons '* (make-primitive-procedure *)) (cons '- (make-primitive-procedure -)) (cons '= (make-primitive-procedure =)) (cons '<= (make-primitive-procedure <=)) (cons '>= (make-primitive-procedure >=)) (cons '< (make-primitive-procedure <)) (cons '> (make-primitive-procedure >)) (cons 'append (make-primitive-procedure append)) (cons 'car (make-primitive-procedure car)) (cons 'cdr (make-primitive-procedure cdr)) (cons 'cadr (make-primitive-procedure cadr)) (cons 'cons (make-primitive-procedure cons)) (cons 'empty? (make-primitive-procedure empty?)) (cons 'length (make-primitive-procedure length)) (cons 'list (make-primitive-procedure list)) (cons 'list? (make-primitive-procedure list?)) (cons 'not (make-primitive-procedure not)) (cons 'null? (make-primitive-procedure null?)) (cons 'eq? (make-primitive-procedure eq?)) (cons 'eqv? (make-primitive-procedure eqv?)) (cons 'printf (make-primitive-procedure printf)) ;; These are not regular Scheme primitives, but are definied in listprocs.ss ;; It doesn't matter to Mini-Scheme, of course --- it just applies them using ;; the underlying Scheme apply. (cons 'assert (make-primitive-procedure assert)) ) the-empty-environment)) ;;; ;;; Driver Loop ;;; (define input-prompt ";;; Mini-Scheme input:") (define output-prompt ";;; Mini-Scheme value:") (define (driver-loop) (prompt-for-input input-prompt) (let ((input (read))) (if (eq? input 'quit) (display "Done.") (let ((output (meval input the-global-environment))) (announce-output output-prompt) (user-print output) (driver-loop))))) (define (prompt-for-input string) (newline) (newline) (display string) (newline)) (define (announce-output string) (display string) (newline)) (define (user-print object) (if (compound-procedure? object) (display (list 'compound-procedure (procedure-parameters object) (procedure-body object) ')) (display object)))