add basic evaluator, environment

5 files changed, 213 insertions, 0 deletions

diff --git a/environment.scm b/environment.scm
new file mode 100644
index 0000000..2444059
--- /dev/null
+++ b/environment.scm
@@ -0,0 +1,72 @@
+(include "prelude/primitives.scm")
+
+;;; env
+(define (enclosing-env environ) (cdr environ))
+(define (first-frame environ) (car environ))
+(define the-empty-env '())
+(define (empty-env? environ) (eq? environ the-empty-env))
+
+;; frames
+(define (make-frame variables values)
+  (cons variables values))
+(define frame-variables car)
+(define frame-values cdr)
+(define (add-binding-to-frame! var val frame)
+  (begin
+    (set-car! frame (cons var (frame-variables frame)))
+    (set-cdr! frame (cons val (frame-values frame)))))
+(define (extend-env vars vals base-env)
+  (if (= (length vars) (length vals))
+      (cons (make-frame vars vals) base-env)
+      (error "Too few or too many arguments supplied" vars vals)))
+
+;;; variable lookup
+(define (lookup-variable-value var env)
+  (cond
+    [(empty-env? env) (error "Unbound variable" var)]
+    [else
+      (let ([f (first-frame env)])
+        (let scan ([variables (frame-variables f)]
+                   [values (frame-values f)])
+          (cond
+            [(null? variables)
+             (lookup-variable-value var
+                                    (enclosing-env env))]
+            [(eq? var (car variables)) (car values)]
+            [else (scan (cdr variables) (cdr values))])))]))
+
+;;; environment modification
+(define (set-variable-value! var val env)
+  (cond
+    [(empty-env? env) (error "Unbound variable" var)]
+    [else
+      (let ([f (first-frame env)])
+        (let scan ([variables (frame-variables f)]
+                   [values (frame-values f)])
+          (cond
+            [(null? variables) (set-variable-value! 
+                                 var
+                                 val
+                                 (enclosing-env env))]
+            [(eq? var (car variables)) (set-car! values val)]
+            [else (scan (cdr variables) (cdr values))])))]))
+
+(define (define-variable! var val env)
+  (let ([f (first-frame env)])
+    (define (scan vars vals)
+      (cond
+        [(null? vars) (add-binding-to-frame! var val f)]
+        [(eq? var (car vars)) (set-car! vals val)]
+        [else (scan (cdr vars) (cdr vals))]))
+    (scan (frame-variables f)
+          (frame-values f))))
+
+(define (setup-environment)
+  (let ([initial-env (extend-env
+                       (primitive-names)
+                       (primitive-objs)
+                       the-empty-env)])
+    (define-variable! 'true #t initial-env)
+    (define-variable! 'false #f initial-env)
+    initial-env))
+
diff --git a/main.scm b/main.scm
new file mode 100644
index 0000000..08a5a22
--- /dev/null
+++ b/main.scm
@@ -0,0 +1,72 @@
+(include "prelude/primitives.scm")
+(include "util/table.scm")
+(include "util/alist.scm")
+
+(define (lift-bool expr) (if expr 'true 'false))
+
+(define (tagged? expr tag)
+  (if (pair? expr)
+      (eq? (car expr) tag)
+      #f))
+
+;;; self-evaluating
+(define (self-evaluating? expr)
+  (or (number? expr)
+      (string? expr)
+      (bool? expr)))
+
+(define variable? symbol?)
+
+;;; if-else
+(define (if-else? expr) (tagged? expr 'if))
+(define (if-predicate expr) (cadr expr))
+(define (if-consequent expr) (caddr expr))
+(define (if-alternative expr) 
+  (if (not (null? (cdddr expr)))
+      (cadddr expr)
+      'false))
+
+;;; function application
+(define (function-application? expr) (pair? expr))
+(define (operator expr) (car expr))
+(define (operands expr) (cdr expr))
+(define (no-operands? expr) (null? expr))
+(define (list-of-values ls env)
+  (if (no-operands? ls)
+      '()
+      (let ([first (eval-expr (car ls) env)])
+        (let ([rest (list-of-values (cdr ls) env)])
+          (cons first rest)))))
+
+;;; quoted expressions
+(define (quote-form? expr) (tagged? expr 'quote))
+(define (quotation-text expr) (cadr expr))
+
+;;; assignment
+(define (assignment? expr) (tagged? expr 'set!))
+
+(define (eval-expr expr env)
+  (cond
+    [(self-evaluating? expr) expr]
+    [(if-else? expr) (eval-if expr env)]
+    [(quote-form? expr) (quotation-text expr)]
+    [(function-application? expr)
+     (apply-expr (operator expr)
+                 (list-of-values (operands expr) env))]))
+
+(define (eval-if expr env)
+  (if (true? (eval-expr (if-predicate expr) env))
+      (eval-expr (if-consequent expr) env)
+      (eval-expr (if-alternative expr) env)))
+
+(define (primitive? proc)
+  (is-elem-assoc-list proc primitives))
+
+(define (apply-primitive-proc proc args)
+  (let ([p (lookup-assoc-list proc primitives)])
+    (apply p args)))
+
+(define (apply-expr proc args)
+  (cond
+    [(primitive? proc) (apply-primitive-proc proc args)]
+    [else 'false]))
diff --git a/prelude/primitives.scm b/prelude/primitives.scm
new file mode 100644
index 0000000..96dd1dd
--- /dev/null
+++ b/prelude/primitives.scm
@@ -0,0 +1,36 @@
+(define (true? expr) (eq? expr 'true))
+(define (false? expr) (eq? expr 'false))
+(define (bool? expr)
+  (or (true? expr)
+      (false? expr)))
+
+(define (and-special . items)
+  (if (null? items)
+      'false
+      (let ([first (car items)])
+        (cond
+          [(true? first) (apply and-special (cdr items))]
+          [(false? first) 'false]
+          [else (error "AND: unable to evaluate non-boolean form" first)]))))
+
+(define (or-special . items)
+  (if (null? items)
+      'false
+      (let ([first (car items)])
+        (cond
+          [(true? first) 'true]
+          [(false? first) (apply or-special (cdr items))]
+          [else (error "OR: unable to evaluate non-boolean form" first)]))))
+
+(define (not-fn x) (not (true? x)))
+
+(define primitives
+  `((+ . ,+)
+    (- . ,-)
+    (* . ,*)
+    (&& . ,and-special)
+    (|| . ,or-special)
+    (/= . ,not-fn)))
+
+(define (primitive-names) (map car primitives))
+(define (primitive-objs) (map cdr primitives))
diff --git a/util/alist.scm b/util/alist.scm
new file mode 100644
index 0000000..4e19440
--- /dev/null
+++ b/util/alist.scm
@@ -0,0 +1,12 @@
+(define (is-elem-assoc-list key assoc-list)
+  (cond
+    [(null? assoc-list) #f]
+    [(eq? key (caar assoc-list)) #t]
+    [else (lookup-assoc-list key (cdr assoc-list))]))
+
+(define (lookup-assoc-list key assoc-list)
+  (cond
+    [(null? assoc-list) #f]
+    [(eq? key (caar assoc-list)) (cdar assoc-list)]
+    [else (lookup-assoc-list key (cdr assoc-list))]))
+
diff --git a/util/table.scm b/util/table.scm
new file mode 100644
index 0000000..7cc68e8
--- /dev/null
+++ b/util/table.scm
@@ -0,0 +1,21 @@
+(define (make-table)
+  (list '*table*))
+
+(define (key-assoc key records)
+  (cond
+    [(null? records) #f]
+    [(equal? key (caar records)) (car records)]
+    [else (key-assoc key (cdr records))]))
+
+(define (lookup key table)
+  (let ([r (key-assoc key (cdr table))])
+    (if r
+        (cdr r)
+        #f)))
+
+(define (table-insert! key value table)
+  (let ([r (key-assoc key (cdr table))])
+    (if r
+        (set-cdr! r value)
+        (set-cdr! table (cons (cons key value)
+                              (cdr table))))))