From ef41082c253bd2a93f57e1d841adb0ac916c7a05 Mon Sep 17 00:00:00 2001
From: Ramakrishnan Muthukrishnan <vu3rdd@gmail.com>
Date: Sun, 15 Jan 2012 20:22:49 +0530
Subject: [PATCH] metacircular evaluator with analysis

---
 src/sicp/metacircular2-with-analysis-test.rkt |  83 +++++
 src/sicp/metacircular2-with-analysis.rkt      | 286 ++++++++++++++++++
 2 files changed, 369 insertions(+)
 create mode 100644 src/sicp/metacircular2-with-analysis-test.rkt
 create mode 100644 src/sicp/metacircular2-with-analysis.rkt

diff --git a/src/sicp/metacircular2-with-analysis-test.rkt b/src/sicp/metacircular2-with-analysis-test.rkt
new file mode 100644
index 0000000..354fb4d
--- /dev/null
+++ b/src/sicp/metacircular2-with-analysis-test.rkt
@@ -0,0 +1,83 @@
+#lang racket
+
+(require "metacircular2-with-analysis.rkt"
+         rackunit)
+
+(require rackunit/text-ui)
+
+(define metacircular2-tests
+  (test-suite "test suite for meta circular evaluator"
+   (let ([env1 (make-environment)])
+     (check-equal? (eval '(+ 1 1) env1) 2 "simple addition")
+     (check-equal? (eval '(- 2 1) env1) 1 "simple subtraction")
+     (check-equal? (eval '(quote x) env1) 'x "quote")
+     (eval '(define x 20) env1)
+     (check-equal? (eval 'x env1) 20 "definition of identifiers with simple values")
+     (eval '(set! x 42) env1) 
+     (check-equal? (eval 'x env1) 42 "set!")
+     (eval '(define (square x) (* x x)) env1)
+     (check-equal? (eval '(square 10) env1) 100 "simple function definition")
+     (eval '(define (square x) (let ([s (* x x)]) s)) env1)
+     (check-equal? (eval '(square 20) env1) 400 "different way to define square")
+     (eval '(define (absolute x)
+              (cond ((> x 0) x)
+                    ((= x 0) (display 'zero) 0)
+                    (else (- x))))
+           env1)
+     (check-equal? (eval '(absolute -2) env1) 2 "conditionals")
+     (check-equal? (eval '(absolute 2) env1) 2 "conditionals")
+     (eval '(define (foo) (let ((x 42) (y 100)) (list x y))) env1)
+     (check-equal? (eval '(foo) env1) '(42 100) "simple let")
+     (check-equal? (eval '(let* ((x 3)
+                                 (y (+ x 2))
+                                 (z (+ x y 5)))
+                            (* x z))
+                         env1)
+                   39
+                   "let* test")
+     (eval '(define (f x)
+              (define (even? n)
+                (if (= n 0)
+                    true
+                    (odd? (- n 1))))
+              (define (odd? n)
+                (if (= n 0)
+                    false
+                    (even? (- n 1))))
+              (odd? x))
+           env1)
+     (check-equal? (eval '(f 2) env1) false "internal definitions")
+     (check-equal? (eval '(f 3) env1) true "internal definitions")
+     (eval '(define (f1 x)
+              (letrec ((even?
+                        (lambda (n)
+                          (if (= n 0)
+                              true
+                              (odd? (- n 1)))))
+                       (odd?
+                        (lambda (n)
+                          (if (= n 0)
+                              false
+                              (even? (- n 1))))))
+                (even? x)))
+           env1)
+     (check-equal? (eval '(f1 2) env1) true "internal definitions")
+     (check-equal? (eval '(f1 3) env1) false "internal definitions")
+     (eval '(define (fib n)
+              (let fib-iter ((a 1)
+                             (b 0)
+                             (count n))
+                (if (= count 0)
+                    b
+                    (fib-iter (+ a b) a (- count 1)))))
+           env1)
+     (check-equal? (eval '(fib 10) env1) 55 "named let")
+     (eval '(define (factorial n)
+              (if (= n 1)
+                  1
+                  (* (factorial (- n 1)) n)))
+           env1)
+     (check-equal? (eval '(factorial 10) env1) 3628800 "factorial test"))))
+
+
+(run-tests metacircular2-tests)
\ No newline at end of file
diff --git a/src/sicp/metacircular2-with-analysis.rkt b/src/sicp/metacircular2-with-analysis.rkt
new file mode 100644
index 0000000..ba97212
--- /dev/null
+++ b/src/sicp/metacircular2-with-analysis.rkt
@@ -0,0 +1,286 @@
+#lang racket
+
+(require (rename-in racket/base
+                    (apply apply-in-underlying-scheme)
+                    (eval eval-in-underlying-scheme)))
+
+(provide (all-defined-out))
+
+(define (self-evaluating? expr)
+  (match expr
+    [(? number? expr) #t]
+    [(? char? expr) #t]
+    [(? string? expr) #t]
+    [_ #f]))
+
+(define (variable? expr) (symbol? expr))
+
+
+;; sequence
+(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))))
+
+;; begin
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+
+;; lambda
+(define (make-lambda parameters body)
+  (cons 'lambda (cons parameters body)))
+
+(define (analyze-sequence exps)
+  (define (sequentially proc1 proc2)
+    (lambda (env) (proc1 env) (proc2 env)))
+  (define (loop first-proc rest-procs)
+    (if (null? rest-procs)
+        first-proc
+        (loop (sequentially first-proc (car rest-procs))
+              (cdr rest-procs))))
+  (let ((procs (map analyze exps)))
+    (if (null? procs)
+        (error "Empty sequence -- ANALYZE")
+        (loop (car procs) (cdr procs)))))
+
+;; environment data structures
+(define (enclosing-environment env) (cdr env))
+(define (first-frame env) (car env))
+(define the-empty-environment '())
+
+(define (make-frame variables values)
+  (let ([ht (make-hash)])
+    (for-each (lambda (var val)
+                (hash-set! ht var val))
+              variables
+              values)
+    ht))
+
+(define (frame-variables frame)
+  (hash-keys frame))
+
+(define (frame-values frame)
+  (hash-values frame))
+
+(define (add-binding-to-frame! var val frame)
+  (hash-set! frame var val))
+
+;; environment is a list of frames, most recent being the last 
+;; one consed into the list
+(define (extend-environment vars vals base-env)
+  (let ([frame (make-frame vars vals)])
+    (cons frame base-env)))
+
+(define (lookup-variable-value var env)
+  (if (eq? env the-empty-environment)
+      (error "unbound variable: " var)
+      (let ([frame (first-frame env)])
+        (let ([value (hash-ref frame var (lambda () (lookup-variable-value var (enclosing-environment env))))])
+          (if (eq? value '*unassigned*)
+              (error "evaluating a variable that is not assigned a value -- " var)
+              value)))))
+
+(define (set-variable-value! var val env)
+  (if (eq? env the-empty-environment)
+      (error "unbound variable: " var)
+      (let ([frame (first-frame env)])
+        (if (hash-has-key? frame var)
+            (hash-set! frame var val)
+            (set-variable-value! var val (enclosing-environment env))))))
+
+(define (define-variable! var val env)
+  (let ([frame (first-frame env)])
+    (if (hash-has-key? frame var)
+        (hash-set! frame var val)
+        (add-binding-to-frame! var val frame))))
+
+;; primitive procedure
+(define (primitive-implementation proc) (cadr proc))
+
+(define primitive-procedures
+  (list (list 'car car)
+        (list 'cdr cdr)
+        (list 'cons cons)
+        (list 'null? null?)
+        (list 'list list)
+        (list '+ +)
+        (list '- -)
+        (list '* *)
+        (list '/ /)
+        (list '= =)
+        (list '> >)
+        (list '< <)))
+
+(define (primitive-procedure-names)
+  (map car primitive-procedures))
+
+(define (primitive-procedure-objects)
+  (map (lambda (proc) (list 'primitive (cadr proc)))
+       primitive-procedures))
+
+(define (apply-primitive-procedure proc args)
+  (apply-in-underlying-scheme
+   (primitive-implementation proc) args))
+
+;; global env
+(define (make-environment)
+  (let ((initial-env
+         (extend-environment (primitive-procedure-names)
+                             (primitive-procedure-objects)
+                             the-empty-environment)))
+    (define-variable! 'true true initial-env)
+    (define-variable! 'false false initial-env)
+    initial-env))
+
+(define the-global-environment (make-environment))
+
+;; application
+(define (list-of-values exps env)
+  (if (no-operands? exps)
+      '()
+      (cons (eval (first-operand exps) env)
+            (list-of-values (rest-operands exps) env))))
+
+(define (no-operands? ops) (null? ops))
+(define (first-operand ops) (car ops))
+(define (rest-operands ops) (cdr ops))
+
+;; compound procedure
+(define (make-procedure params body env)
+  (list 'procedure params (scan-out-definitions body) env))
+
+(define (procedure-parameters p) (cadr p))
+(define (procedure-body p) (scan-out-definitions (caddr p)))
+(define (procedure-environment p) (cadddr p))
+
+(define (execute-application procedure arguments)
+  (match procedure
+    [`(primitive ,f ...)  (apply-primitive-procedure procedure arguments)]
+    [`(procedure ,f ...)  ((procedure-body procedure)
+                           (extend-environment
+                            (procedure-parameters procedure)
+                            arguments
+                            (procedure-environment procedure)))]
+    [_                (error "Unknown procedure type -- APPLY" procedure)]))
+
+;; truth
+(define (true? x)
+  (not (eq? x false)))
+
+(define (false? x)
+  (eq? x false))
+
+;; cond
+(define (cond->if clauses)
+  (define (seq->exp actions) 
+    (if (empty? (cdr actions)) 
+        (car actions) 
+        `(begin ,@actions)))
+  (if (empty? clauses)
+      'false
+      (let ([clause (car clauses)])
+        (match clause
+          [`(else ,action ...) (seq->exp action)]
+          [`(,pred ,action ...) `(if ,pred 
+                                     ,(seq->exp action) 
+                                     ,(cond->if (cdr clauses)))]))))
+
+;; let
+(define (let->combination lexpr)
+  (match-let* ([`(let ,(? (lambda (x) (or (pair? x) (empty? x))) bindings) ,body ..1) lexpr]
+               [`((,var ,val) ...) bindings])
+    `((lambda ,var ,@body) ,@val)))
+
+;; named let
+(define (named-let->combination lexpr)
+  (match-let* ([`(let ,(? symbol? name) ,(? (lambda (x) (or (pair? x) (empty? x))) bindings) ,body ..1) lexpr]
+               [`((,var ,val) ...) bindings])
+    `(begin (define ,name (lambda ,var ,@body))
+            (,name ,@val))))
+
+;; let*
+(define (let*->nested-lets lexpr)
+  (match lexpr
+    [`(let* (,first-binding ,rest-bindings ...) ,body ..1)
+     `(let (,first-binding) ,(let*->nested-lets `(let* ,rest-bindings ,@body)))]
+     [`(let* () ,body ..1) `(let () ,@body)]))
+
+;; internal definitions
+(define (scan-out-definitions body)
+  (match body
+    [`((define ,var ,e) ..1 ,rest)
+     `((let ,(map (lambda (v) (list (car v) ''*unassigned*)) var)
+        ,@(map (lambda (v e) `(set! ,(car v) (lambda ,(cdr v) ,e))) var e)
+        ,rest))]
+    [_  body]))
+
+;; letrec
+(define (letrec->combination lexpr)
+  (match lexpr
+    [`(letrec (,bindings ...) ,body ..1)
+     `(let ,(map (lambda (v) (list (car v) ''*unassigned*)) bindings)
+        ,@(map (lambda (binding) 
+                 (let ([name (car binding)]
+                       [value (cadr binding)])
+                   `(set! ,name ,value))) 
+               bindings)
+        ,@body)]))
+
+(define (analyze exp)
+  ;; use this display statement to visualize the recursive evaluation process
+  ;;(display (format "~s~%" exp))
+  (match exp
+    [(? self-evaluating? exp) (lambda (env) exp)]
+    [(? variable? exp) (lambda (env) (lookup-variable-value exp env))]
+    [`(quote ,x) (lambda (env) x)]
+    [`(set! ,var ,val) (let ([vproc (analyze val)])
+                         (lambda (env) 
+                           (set-variable-value! var (vproc env) env)))]
+    [`(define ,(? (lambda (x) (not (pair? x))) var) ,b) (let ([vproc (analyze b)])
+                                                          (lambda (env)
+                                                            (define-variable! var (vproc env) env)))]
+    [`(define ,(? pair? var) ,b ..1) (let ([pproc (analyze (make-lambda (cdr var) b))]
+                                           [pname (car var)])
+                                       (lambda (env)
+                                         (define-variable! pname (pproc env) env)))]
+    [`(if ,pred ,consequent ,alternative) (let ([pproc (analyze pred)]
+                                                [cproc (analyze consequent)]
+                                                [aproc (analyze alternative)])
+                                            (lambda (env)
+                                              (if (true? (pproc env))
+                                                  (cproc env)
+                                                  (aproc env))))]
+    [`(lambda ,parameters ,body ..1) (let ([bproc (analyze-sequence body)])
+                                       (lambda (env)
+                                         (make-procedure parameters bproc env)))]
+    [`(begin ,exp ...) (analyze-sequence exp)]
+    [`(cond ,clauses ...) (analyze (cond->if clauses))]
+    [`(let ,(? (lambda (x) (or (pair? x) (empty? x))) bindings) ,body ..1) (analyze (let->combination exp))]
+    [`(let ,(? symbol? name) ,bindings ,body ..1) (analyze (named-let->combination exp))]
+    [`(let* ,bindings ,body ..1) (analyze (let*->nested-lets exp))]
+    [`(letrec ,bindings ,body ..1) (analyze (letrec->combination exp))]
+    [(list f x ...) (let ([fproc (analyze f)]
+                          [aprocs (map analyze x)])
+                      (lambda (env)
+                        (execute-application (fproc env)
+                                             (map (lambda (proc)
+                                                    (proc env))
+                                                  aprocs))))]
+    [_ (error "unable to evaluate expression -- EVAL " exp)]))
+
+;; eval
+(define (eval exp env)
+  ((analyze exp) env))
+
+(define (interpret)
+  (let loop ([input (read)]
+             [env the-global-environment])
+    (let ([output (eval input env)])
+      (display output)
+      (loop (read) env))))
+
+(define (t expr)
+  (let ([t1 (current-inexact-milliseconds)])
+    (eval expr the-global-environment)
+    (displayln (- (current-inexact-milliseconds) t1))))
\ No newline at end of file
-- 
2.37.2