summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAkshay <[email protected]>2020-11-04 03:23:43 +0000
committerAkshay <[email protected]>2020-11-04 03:23:43 +0000
commitc93d192c32c376705d3b0a740c81156a44e63ecb (patch)
tree8b25ec67c7c1f857d598d383537283e086017e88
parent893980d4e5d3e698bed652fbfb021b128a5d6b3c (diff)
add basic evaluator, environment
-rw-r--r--environment.scm72
-rw-r--r--main.scm72
-rw-r--r--prelude/primitives.scm36
-rw-r--r--util/alist.scm12
-rw-r--r--util/table.scm21
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 @@
1(include "prelude/primitives.scm")
2
3;;; env
4(define (enclosing-env environ) (cdr environ))
5(define (first-frame environ) (car environ))
6(define the-empty-env '())
7(define (empty-env? environ) (eq? environ the-empty-env))
8
9;; frames
10(define (make-frame variables values)
11 (cons variables values))
12(define frame-variables car)
13(define frame-values cdr)
14(define (add-binding-to-frame! var val frame)
15 (begin
16 (set-car! frame (cons var (frame-variables frame)))
17 (set-cdr! frame (cons val (frame-values frame)))))
18(define (extend-env vars vals base-env)
19 (if (= (length vars) (length vals))
20 (cons (make-frame vars vals) base-env)
21 (error "Too few or too many arguments supplied" vars vals)))
22
23;;; variable lookup
24(define (lookup-variable-value var env)
25 (cond
26 [(empty-env? env) (error "Unbound variable" var)]
27 [else
28 (let ([f (first-frame env)])
29 (let scan ([variables (frame-variables f)]
30 [values (frame-values f)])
31 (cond
32 [(null? variables)
33 (lookup-variable-value var
34 (enclosing-env env))]
35 [(eq? var (car variables)) (car values)]
36 [else (scan (cdr variables) (cdr values))])))]))
37
38;;; environment modification
39(define (set-variable-value! var val env)
40 (cond
41 [(empty-env? env) (error "Unbound variable" var)]
42 [else
43 (let ([f (first-frame env)])
44 (let scan ([variables (frame-variables f)]
45 [values (frame-values f)])
46 (cond
47 [(null? variables) (set-variable-value!
48 var
49 val
50 (enclosing-env env))]
51 [(eq? var (car variables)) (set-car! values val)]
52 [else (scan (cdr variables) (cdr values))])))]))
53
54(define (define-variable! var val env)
55 (let ([f (first-frame env)])
56 (define (scan vars vals)
57 (cond
58 [(null? vars) (add-binding-to-frame! var val f)]
59 [(eq? var (car vars)) (set-car! vals val)]
60 [else (scan (cdr vars) (cdr vals))]))
61 (scan (frame-variables f)
62 (frame-values f))))
63
64(define (setup-environment)
65 (let ([initial-env (extend-env
66 (primitive-names)
67 (primitive-objs)
68 the-empty-env)])
69 (define-variable! 'true #t initial-env)
70 (define-variable! 'false #f initial-env)
71 initial-env))
72
diff --git a/main.scm b/main.scm
new file mode 100644
index 0000000..08a5a22
--- /dev/null
+++ b/main.scm
@@ -0,0 +1,72 @@
1(include "prelude/primitives.scm")
2(include "util/table.scm")
3(include "util/alist.scm")
4
5(define (lift-bool expr) (if expr 'true 'false))
6
7(define (tagged? expr tag)
8 (if (pair? expr)
9 (eq? (car expr) tag)
10 #f))
11
12;;; self-evaluating
13(define (self-evaluating? expr)
14 (or (number? expr)
15 (string? expr)
16 (bool? expr)))
17
18(define variable? symbol?)
19
20;;; if-else
21(define (if-else? expr) (tagged? expr 'if))
22(define (if-predicate expr) (cadr expr))
23(define (if-consequent expr) (caddr expr))
24(define (if-alternative expr)
25 (if (not (null? (cdddr expr)))
26 (cadddr expr)
27 'false))
28
29;;; function application
30(define (function-application? expr) (pair? expr))
31(define (operator expr) (car expr))
32(define (operands expr) (cdr expr))
33(define (no-operands? expr) (null? expr))
34(define (list-of-values ls env)
35 (if (no-operands? ls)
36 '()
37 (let ([first (eval-expr (car ls) env)])
38 (let ([rest (list-of-values (cdr ls) env)])
39 (cons first rest)))))
40
41;;; quoted expressions
42(define (quote-form? expr) (tagged? expr 'quote))
43(define (quotation-text expr) (cadr expr))
44
45;;; assignment
46(define (assignment? expr) (tagged? expr 'set!))
47
48(define (eval-expr expr env)
49 (cond
50 [(self-evaluating? expr) expr]
51 [(if-else? expr) (eval-if expr env)]
52 [(quote-form? expr) (quotation-text expr)]
53 [(function-application? expr)
54 (apply-expr (operator expr)
55 (list-of-values (operands expr) env))]))
56
57(define (eval-if expr env)
58 (if (true? (eval-expr (if-predicate expr) env))
59 (eval-expr (if-consequent expr) env)
60 (eval-expr (if-alternative expr) env)))
61
62(define (primitive? proc)
63 (is-elem-assoc-list proc primitives))
64
65(define (apply-primitive-proc proc args)
66 (let ([p (lookup-assoc-list proc primitives)])
67 (apply p args)))
68
69(define (apply-expr proc args)
70 (cond
71 [(primitive? proc) (apply-primitive-proc proc args)]
72 [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 @@
1(define (true? expr) (eq? expr 'true))
2(define (false? expr) (eq? expr 'false))
3(define (bool? expr)
4 (or (true? expr)
5 (false? expr)))
6
7(define (and-special . items)
8 (if (null? items)
9 'false
10 (let ([first (car items)])
11 (cond
12 [(true? first) (apply and-special (cdr items))]
13 [(false? first) 'false]
14 [else (error "AND: unable to evaluate non-boolean form" first)]))))
15
16(define (or-special . items)
17 (if (null? items)
18 'false
19 (let ([first (car items)])
20 (cond
21 [(true? first) 'true]
22 [(false? first) (apply or-special (cdr items))]
23 [else (error "OR: unable to evaluate non-boolean form" first)]))))
24
25(define (not-fn x) (not (true? x)))
26
27(define primitives
28 `((+ . ,+)
29 (- . ,-)
30 (* . ,*)
31 (&& . ,and-special)
32 (|| . ,or-special)
33 (/= . ,not-fn)))
34
35(define (primitive-names) (map car primitives))
36(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 @@
1(define (is-elem-assoc-list key assoc-list)
2 (cond
3 [(null? assoc-list) #f]
4 [(eq? key (caar assoc-list)) #t]
5 [else (lookup-assoc-list key (cdr assoc-list))]))
6
7(define (lookup-assoc-list key assoc-list)
8 (cond
9 [(null? assoc-list) #f]
10 [(eq? key (caar assoc-list)) (cdar assoc-list)]
11 [else (lookup-assoc-list key (cdr assoc-list))]))
12
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 @@
1(define (make-table)
2 (list '*table*))
3
4(define (key-assoc key records)
5 (cond
6 [(null? records) #f]
7 [(equal? key (caar records)) (car records)]
8 [else (key-assoc key (cdr records))]))
9
10(define (lookup key table)
11 (let ([r (key-assoc key (cdr table))])
12 (if r
13 (cdr r)
14 #f)))
15
16(define (table-insert! key value table)
17 (let ([r (key-assoc key (cdr table))])
18 (if r
19 (set-cdr! r value)
20 (set-cdr! table (cons (cons key value)
21 (cdr table))))))