blob: 08a5a220350e35efc16592ed25f5d6d0b5d42ecb (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
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]))
|
