SICP instructor's manual metacircular evaluator

Author: ramalho

references/sicp/instructors-manual/README.md

@@ -0,0 +1,19 @@
+# Concrete Metacircular Evaluator
+
+Code adapted from the "evaluator with concrete syntax" listed on pages 121-122
+of the "Instructor's Manual to accompany Structure and Interpretation of
+Computer Programs" by Julie Sussman with Harold Abelson and Gerald Jay Sussman.
+
+Changes:
+
+* function names changed to ALL-CAPS to avoid confusion with
+  functions provided by Racket;
+* parameters named `env` renamed to `environ` to avoid confusion with `exp`;
+* use of `#t`, `#f` instead of `true`, `false`;
+* APPLY rewritten to avoid the need for `primitive-procedure?`;
+  the corresponding function in Racket is `primitive?` but it is not
+  useful to us because `(primitive? +)` returns `#f`, so we can't use it
+  to distinguish user-defined procedures from the built-ins.
+
+Tested in Racket 8.3.
+

references/sicp/instructors-manual/concrete-test.rkt

@@ -14,12 +14,32 @@
 
 (check-exn (regexp "Unbound variable 'x") (lambda ()
     (LOOKUP-VARIABLE-VALUE 'x '())))
-; WIP:
+
 (check-equal? (LOOKUP-VARIABLE-VALUE 'x '(([x . 8]))) 8)
 
 (check-equal? (MAKE-FRAME '(a) '(1)) '([a . 1]) "Smalest frame")
 
 (check-equal? (EVAL 1 '()) 1)
+(check-equal? (EVAL '(QUOTE symbol) '()) 'symbol)
+(check-equal? (EVAL '(QUOTE (1 2 3)) '()) '(1 2 3))
 (check-equal? (EVAL 'x (EXTEND-ENVIRONMENT '(x) '(8) '())) 8)
 (check-equal? (EVAL '(+ 3 4) (MAKE-BUILTINS)) 7)
-(check-equal? (EVAL '(+ (* 3 4) (* 5 6)) (MAKE-BUILTINS)) 42)
+(check-equal? (EVAL '(+ (* 3 4) (* 5 6)) (MAKE-BUILTINS)) 42)
+(check-equal? (EVAL '((LAMBDA (x) (* x x)) 111) (MAKE-BUILTINS)) 12321)
+(check-equal? (EVAL '(((LAMBDA (x)
+                               (LAMBDA (y) (+ x y)))
+                       3)
+                      4)
+                    (MAKE-BUILTINS)) 7)
+
+(check-equal? (EVAL '((LAMBDA (x y)
+                               ((LAMBDA (y) (+ x y))
+                                (* x y)))
+                       3 4)
+                    (MAKE-BUILTINS)) 15)
+
+(check-equal? (EVAL '((LAMBDA (x) (IF (< x 0) (- 0 x) x)) 2)
+                    (MAKE-BUILTINS)) 2)
+
+(check-equal? (EVAL '((LAMBDA (x) (IF (< x 0) (- 0 x) x)) -3)
+                    (MAKE-BUILTINS)) 3)

references/sicp/instructors-manual/concrete.rkt

@@ -11,21 +11,45 @@
 
 (define (EVAL exp environ)
   ;; dispatch on expression type
-  (cond [(number? exp) exp]    ; self-evaluating
-        [(symbol? exp)
+  (cond [(number? exp) exp]                    ; self-evaluating
+        [(symbol? exp)                         ; variable?
          (LOOKUP-VARIABLE-VALUE exp environ)]
+        [(eq? (car exp) 'QUOTE) (cadr exp)]    ; quoted?
+        ;; rule for procedure objects in the environment model
+        [(eq? (car exp) 'LAMBDA)               ; lambda?
+         (list 'procedure                      ; make-procedure
+               (cadr exp)                      ; lambda-parameters
+               (caddr exp)                     ; lambda-body
+               environ)]
+        [(eq? (car exp) 'IF)                   ; if?
+         (EVAL-IF exp environ)]
         [else
-         (apply (EVAL (car exp) environ)       ; operator
-                (LIST-OF-VALUES (cdr exp)  ; operands
+         (APPLY (EVAL (car exp) environ)       ; operator
+                (LIST-OF-VALUES (cdr exp)      ; operands
                                 environ))]))
 
+(define (APPLY procedure arguments)
+  ;; dispatch on procedure type
+  (cond [(and (list? procedure) (eq? (car procedure) 'procedure)) ; compoud-procedure?
+         (EVAL
+          (caddr procedure)       ; procedure-body
+          (EXTEND-ENVIRONMENT
+           (cadr procedure)       ; procedure-parameters
+           arguments 
+           (cadddr procedure)))]  ; procedure-environment
+  [else (apply procedure arguments)])) ; (apply ...) from host interpreter
 
 (define (LIST-OF-VALUES exps environ)
   (if (null? exps)
       '()
       (cons (EVAL (car exps) environ)
             (LIST-OF-VALUES (cdr exps) environ))))
 
+(define (EVAL-IF exp environ)
+  (if (EVAL (cadr exp) environ)      ; if-predicate
+      (EVAL (caddr exp) environ)         ; if-consequent
+      (EVAL (cadddr exp) environ)))  ; if-alternative
+
 (define (EXTEND-ENVIRONMENT vars values base-environ)
   (cons (MAKE-FRAME vars values) base-environ))
 
@@ -52,8 +76,8 @@
 
 (define (MAKE-BUILTINS)
   (EXTEND-ENVIRONMENT
-   '(+ - * /)
-   (list + - * /)
+   '(+ - * / <)
+   (list + - * / <)
    '()))
 
 ; Needed to support rackunit tests in concrete-test.rkt.