summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--environment.scm5
-rw-r--r--main.scm92
-rw-r--r--prelude/primitives.scm15
3 files changed, 99 insertions, 13 deletions
diff --git a/environment.scm b/environment.scm
index 5906a1d..4917a40 100644
--- a/environment.scm
+++ b/environment.scm
@@ -1,6 +1,9 @@
1(define-module (environment) 1(define-module (environment)
2 #: export (lookup-variable-value 2 #: export (lookup-variable-value
3 setup-environment)) 3 setup-environment
4 set-variable-value!
5 define-variable!
6 extend-env))
4 7
5(add-to-load-path ".") 8(add-to-load-path ".")
6(use-modules (prelude/primitives)) 9(use-modules (prelude/primitives))
diff --git a/main.scm b/main.scm
index 8db3289..7476efb 100644
--- a/main.scm
+++ b/main.scm
@@ -44,7 +44,7 @@
44 [(cond-else? (car clauses)) (cond-consequent (car clauses))] 44 [(cond-else? (car clauses)) (cond-consequent (car clauses))]
45 [(last-clause? clauses) (make-if (cond-predicate (car clauses)) 45 [(last-clause? clauses) (make-if (cond-predicate (car clauses))
46 (cond-consequent (car clauses)) 46 (cond-consequent (car clauses))
47 '())] 47 'false)]
48 [else (make-if (cond-predicate (car clauses)) 48 [else (make-if (cond-predicate (car clauses))
49 (cond-consequent (car clauses)) 49 (cond-consequent (car clauses))
50 (cond->if (make-cond (cdr clauses))))]))) 50 (cond->if (make-cond (cdr clauses))))])))
@@ -64,16 +64,56 @@
64 64
65;;; assignment 65;;; assignment
66(define (assignment? expr) (tagged? expr 'set!)) 66(define (assignment? expr) (tagged? expr 'set!))
67(define (assignment-name expr) (cadr expr))
68(define (assignment-value expr) (caddr expr))
69
70;;; definition
71(define (definition? expr) (tagged? expr 'define))
72(define (definition-name expr) (cadr expr))
73(define (definition-value expr) (caddr expr))
74
75;;; lambda
76(define (lambda-form? expr) (tagged? expr 'lambda))
77(define (lambda-params expr) (cadr expr))
78(define (lambda-body expr) (cddr expr))
79(define (make-lambda params body) (cons 'lambda (cons params body)))
80
81;;; begin
82(define (begin-form? expr) (tagged? expr 'begin))
83(define (begin-actions begin-form) (cdr begin-form))
84(define (last-action? actions) (null? (cdr actions)))
85(define (make-begin actions) (cons 'begin actions))
86(define (sequence->expr actions)
87 (cond
88 [(null? actions) '()]
89 [(last-action? actions) (car actions)]
90 [else (make-begin actions)]))
91
92;;; let
93(define (let-form? expr) (tagged? expr 'let))
94(define (let-bindings expr) (cadr expr))
95(define (let-body expr) (cddr expr))
96(define (let-binding-variables bindings) (map car bindings))
97(define (let-binding-values bindings) (map cadr bindings))
98(define (let->lambda expr)
99 (let ([bindings (let-bindings expr)])
100 (make-lambda (let-binding-variables bindings)
101 (let-body expr))))
67 102
68(define (eval-expr expr env) 103(define (eval-expr expr env)
69 (cond 104 (cond
70 [(self-evaluating? expr) expr] 105 [(self-evaluating? expr) expr]
106 [(variable? expr) (lookup-variable-value expr env)]
71 [(if-else? expr) (eval-if expr env)] 107 [(if-else? expr) (eval-if expr env)]
108 [(begin-form? expr) (eval-sequence (begin-actions expr) env)]
109 [(lambda-form? expr) (make-lambda (lambda-params expr)
110 (lambda-body expr))]
111 [(let-form? expr) (eval-let expr env)]
112 [(assignment? expr) (eval-assignment expr env)]
113 [(definition? expr) (eval-definition expr env)]
72 [(cond-form? expr) (eval-cond expr env)] 114 [(cond-form? expr) (eval-cond expr env)]
73 [(quote-form? expr) (quotation-text expr)] 115 [(quote-form? expr) (quotation-text expr)]
74 [(function-application? expr) 116 [(function-application? expr) (eval-function-application expr env)]))
75 (apply-expr (operator expr)
76 (list-of-values (operands expr) env))]))
77 117
78(define (eval-if expr env) 118(define (eval-if expr env)
79 (if (true? (eval-expr (if-predicate expr) env)) 119 (if (true? (eval-expr (if-predicate expr) env))
@@ -83,6 +123,43 @@
83(define (eval-cond expr env) 123(define (eval-cond expr env)
84 (eval-expr (cond->if expr) env)) 124 (eval-expr (cond->if expr) env))
85 125
126(define (eval-sequence exprs env)
127 (cond
128 [(last-action? exprs) (eval-expr (car exprs) env)]
129 [else (begin
130 (eval-expr (car exprs) env)
131 (eval-sequence (cdr exprs) env))]))
132
133(define (eval-let expr env)
134 (eval-function-application (cons (let->lambda expr)
135 (let-binding-values (let-bindings expr)))
136 env))
137
138(define (eval-assignment expr env)
139 (set-variable-value!
140 (assignment-name expr)
141 (eval-expr (assignment-value expr) env)
142 env))
143
144(define (eval-definition expr env)
145 (define-variable!
146 (definition-name expr)
147 (eval-expr (definition-value expr) env)
148 env))
149
150(define (eval-function-application expr env)
151 (let ([proc (operator expr)]
152 [args (list-of-values (operands expr) env)])
153 (cond
154 [(primitive? proc) (apply-primitive-proc proc args)]
155 [else
156 (let ([compound-proc (eval-expr proc env)])
157 (eval-sequence
158 (lambda-body compound-proc)
159 (extend-env (lambda-params compound-proc)
160 args
161 env)))])))
162
86(define (primitive? proc) 163(define (primitive? proc)
87 (is-elem-assoc-list proc primitives)) 164 (is-elem-assoc-list proc primitives))
88 165
@@ -113,4 +190,9 @@
113 (driver-loop)))))) 190 (driver-loop))))))
114 191
115(define (show-lisp-expr object) 192(define (show-lisp-expr object)
116 (display object)) 193 (cond
194 [(tagged? object 'lambda)
195 (display "#<procedure ")
196 (display (lambda-params object))
197 (display ">")]
198 [else (display object)]))
diff --git a/prelude/primitives.scm b/prelude/primitives.scm
index 2e5f5d9..cd7f1bf 100644
--- a/prelude/primitives.scm
+++ b/prelude/primitives.scm
@@ -7,7 +7,7 @@
7 bool? 7 bool?
8 true?)) 8 true?))
9 9
10(define (lift-bool expr) (if expr 'true 'false)) 10(define (convert-bool expr) (if expr 'true 'false))
11(define (true? expr) (eq? expr 'true)) 11(define (true? expr) (eq? expr 'true))
12(define (false? expr) (eq? expr 'false)) 12(define (false? expr) (eq? expr 'false))
13(define (bool? expr) 13(define (bool? expr)
@@ -34,17 +34,18 @@
34 34
35(define (not-fn x) (not (true? x))) 35(define (not-fn x) (not (true? x)))
36 36
37(define (lift-arithmetic op) 37(define (lift-bool op)
38 (lambda vals (lift-bool (apply op vals)))) 38 (lambda vals (convert-bool (apply op vals))))
39 39
40(define primitives 40(define primitives
41 `((+ . ,+) 41 `((+ . ,+)
42 (- . ,-) 42 (- . ,-)
43 (* . ,*) 43 (* . ,*)
44 (< . ,(lift-arithmetic <)) 44 (< . ,(lift-bool <))
45 (> . ,(lift-arithmetic >)) 45 (> . ,(lift-bool >))
46 (<= . ,(lift-arithmetic <=)) 46 (<= . ,(lift-bool <=))
47 (>= . ,(lift-arithmetic >=)) 47 (>= . ,(lift-bool >=))
48 (eq? . ,(lift-bool eq?))
48 (&& . ,and-special) 49 (&& . ,and-special)
49 (|| . ,or-special) 50 (|| . ,or-special)
50 (/= . ,not-fn) 51 (/= . ,not-fn)