Permalink
Browse files

Add ch4.scm metacircular evaluator start

  • Loading branch information...
1 parent a15282b commit 91c5b3df03e3a7f60a59a36aaafa94cb31bf17b5 Mike Prentice committed Nov 25, 2012
Showing with 255 additions and 0 deletions.
  1. +255 −0 ch4.scm
View
255 ch4.scm
@@ -0,0 +1,255 @@
+;; SICP chapter 4: The Metacircular Evaluator
+
+(define dispatch-table
+ '((self-evaluating? . (lambda (exp env) exp))
+ (variable? . lookup-variable-value)
+ (quoted? . (lambda (exp env) (text-of-quotation exp)))
+ (assignment? . eval-assignment)
+ (definition? . eval-definition)
+ (if? . eval-if)
+ (lambda? . (lambda (exp env)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env)))
+ (begin? . (lambda (exp env)
+ (eval-sequence (begin-actions exp) env)))
+ (cond? . (lambda (exp env) (eval (cond->if exp) env)))
+ (and? . (lambda (exp env) (eval-and exp env)))
+ (or? . (lambda (exp env) (eval-or exp env)))
+ (let? . (lambda (exp env) (eval (let->combination exp) env)))
+ (let*? . (lambda (exp env) (eval (let*->nested-lets exp) env)))
+ (application? . (lambda (exp env)
+ (apply (eval (operator exp) env)
+ (list-of-values (operands exp)
+ env))))))
+
+(define (eval exp env)
+ (define (eval-loop dispatch-table)
+ (if (null? dispatch-table)
+ (error "Unknown expression type -- EVAL" exp)
+ (if ((caar dispatch-table) exp)
+ ((cdar dispatch-table) exp env)
+ (eval-loop (cdr dispatch-table)))))
+ (eval-loop dispatch-table))
+
+(define (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" procedure))))
+
+;; Exercise 4.1
+(define (list-of-values-left exps env)
+ (if (no-operands? exps)
+ '()
+ (let ((a (eval (first-operand exps) env)))
+ (cons a (list-of-values (rest-operands exps) env)))))
+(define (list-of-values-right exps env)
+ (if (no-operands? exps)
+ '()
+ (let ((b (list-of-values (rest-operands exps) env)))
+ (cons (eval (first-operand exps) env)
+ b))))
+
+(define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+(define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+(define (eval-sequence exps env)
+ (cond ((last-exp? exps) (eval (first-exp exps) env))
+ (else (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps) env))))
+
+(define (eval-assignment exp env)
+ (set-variable-value! (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+
+(define (eval-definition exp env)
+ (define-variable! (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+
+(define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+
+(define (variable? exp) (symbol? exp))
+
+(define (quoted? exp)
+ (tagged-list? exp 'quote))
+(define (text-of-quotation exp) (cadr exp))
+
+(define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+(define (assignment? exp)
+ (tagged-list? exp 'set!))
+(define (assignment-variable exp) (cadr exp))
+(define (assignment-value exp) (caddr exp))
+
+(define (definition? exp)
+ (tagged-list? exp 'define))
+(define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+(define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda (cdadr exp)
+ (cddr exp))))
+
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters exp) (cadr exp))
+(define (lambda-body exp) (cddr exp))
+
+(define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+(define (if? exp) (tagged-list? exp 'if))
+(define (if-predicate exp) (cadr exp))
+(define (if-consequent exp) (caddr exp))
+(define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (caddr exp)
+ 'false))
+
+(define (make-if predicate consequent alternative)
+ (list 'if predicate consequent alternative))
+
+(define (begin? exp) (tagged-list? exp 'begin))
+(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))
+
+(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))
+
+(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))
+(define (cond-=>-clause? clause)
+ (tagged-list? (cond-actions clause) '=>))
+(define (cond-=>-action clause)
+ (list (cadr (cond-actions clause))
+ (cond-predicate clause)))
+(define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+
+;;; TODO: fix => clauses to work with side effects
+(define (expand-clauses clauses)
+ (if (null? clauses)
+ 'false ; no else clause
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (cond ((cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp (cond-actions first))
+ (error "ELSE clause isn't last -- COND->IF"
+ clauses)))
+ ((cond-=>-clause? first)
+ (make-if (cond-predicate first)
+ (cond-=>-action first)
+ (expand-clauses rest)))
+ (else (make-if (cond-predicate first)
+ (sequence->exp (cond-actions first))
+ (expand-clauses rest)))))))
+
+(define (and? exp) (tagged-list? exp 'and))
+(define (or? exp) (tagged-list? exp 'or))
+(define (eval-and exp env)
+ (define (eval-clauses clauses acc)
+ (if (null? clauses)
+ acc
+ (let ((clause-value (eval (car clauses) env)))
+ (if (true? clause-value)
+ (eval-clauses (cdr clauses) clause-value)
+ 'false))))
+ (eval-clauses (andor-clauses exp) 'true))
+(define (eval-or exp env)
+ (define (eval-clauses clauses acc)
+ (if (null? clauses)
+ acc
+ (let ((clause-value (eval (car clauses) env)))
+ (if (true? clause-value)
+ clause-value
+ (eval-clauses (cdr clauses) clause-value)))))
+ (eval-clauses (andor-clauses exp) 'false))
+(define (andor-clauses exp) (cdr exp))
+(define (and->if exp)
+ (if (null? (andor-clauses exp))
+ 'true
+ (expand-and-clauses (andor-clauses exp))))
+(define (or->if exp)
+ (if (null? (andor-clauses exp))
+ 'false
+ (expand-or-clauses (andor-clauses exp))))
+(define (expand-and-clauses clauses)
+ (if (null? (cdr clauses))
+ (car clauses)
+ (make-if (car clauses)
+ (expand-and-clauses (cdr clauses))
+ 'false)))
+(define (expand-or-clauses clauses)
+ (if (null? (cdr clauses))
+ (car clauses)
+ (make-if (car clauses)
+ (car clauses)
+ (expand-or-clauses (cdr clauses)))))
+
+(define (let? exp) (tagged-list? exp 'let))
+(define (let-assignments exp) (cadr exp))
+(define (let-variables exp)
+ (map car (let-assignments exp)))
+(define (let-values exp)
+ (map cadr (let-assignments exp)))
+(define (let-body exp) (cddr exp))
+(define (let->combination exp)
+ (cons (list 'lambda (let-variables exp) (let-body exp))
+ (let-values exp)))
+
+(define (let*? exp) (tagged-list? exp 'let*))
+(define (let*->nested-lets exp)
+ (if (null? (cdr (let-assignments exp)))
+ (cons 'let (cdr exp))
+ (list 'let
+ (list (car (let-assignments exp)))
+ (let*->nested-lets
+ (cons 'let*
+ (cons (cdr (let-assignments exp))
+ (let-body exp)))))))

0 comments on commit 91c5b3d

Please sign in to comment.