diff options
-rw-r--r-- | environment.scm | 5 | ||||
-rw-r--r-- | main.scm | 92 | ||||
-rw-r--r-- | prelude/primitives.scm | 15 |
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)) |
@@ -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) |