diff options
Diffstat (limited to 'main.scm')
-rw-r--r-- | main.scm | 72 |
1 files changed, 72 insertions, 0 deletions
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])) | ||