blob: 1dcfbfc7e561a3af0ecf3028a25b48d85c4b19ca (
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
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
|
#lang typed/racket
; Do let-env.rkt dodajemy wartosci boolowskie
;
; Miejsca, ktore sie zmienily oznaczone sa przez !!!
; --------- ;
; Wyrazenia ;
; --------- ;
(define-type Expr (U const binop var-expr let-expr if-expr))
(define-type Value (U Real Boolean))
(define-type BinopSym (U '+ '- '/ '* '% '= '> '>= '< '<= 'and 'or))
(struct const ([val : Value]) #:transparent)
(struct binop ([op : BinopSym] [l : Expr] [r : Expr]) #:transparent)
(struct var-expr ([id : Symbol]) #:transparent)
(struct let-expr ([id : Symbol] [e1 : Expr] [e2 : Expr]) #:transparent)
(struct if-expr ([eb : Expr] [et : Expr] [ef : Expr]) #:transparent)
(define-predicate expr? Expr)
(define-predicate value? Value)
(define-predicate binop-sym? BinopSym)
(define-predicate let-list? (List Symbol Any))
(: parse (-> Any Expr))
(define (parse q)
(match q
[_ #:when (value? q) (const q)]
[_ #:when (eq? q 'true) (const true)]
[_ #:when (eq? q 'false) (const false)] ; <---------------------------- !!!
[_ #:when (symbol? q) (var-expr q)]
[`(,s ,e1 ,e2)
#:when (and (eq? s 'let) (let-list? e1))
(let-expr (car e1)
(parse (cadr e1))
(parse e2))]
[`(,s ,eb ,et ,ef)
#:when (eq? s 'if)
(if-expr (parse eb)
(parse et)
(parse ef))]
[`(,s ,e1 ,e2)
#:when (binop-sym? s)
(binop s
(parse e1)
(parse e2))]
[else (error "Parse error" q)]))
;;; (define (test-parse) (parse '(let [x (+ 2 2)] (+ x 1))))
; ---------- ;
; Srodowiska ;
; ---------- ;
(struct environ ([xs : (Listof (Pairof Symbol Value))]))
(define env-empty (environ null))
(: env-add (-> Symbol Value environ environ))
(define (env-add x v env)
(environ (cons (cons x v) (environ-xs env))))
(: env-lookup (-> Symbol environ Value))
(define (env-lookup x env)
(: assoc-lookup (-> (Listof (Pairof Symbol Value)) Value))
(define (assoc-lookup xs)
(cond [(null? xs) (error "Unknown identifier" x)]
[(eq? x (car (car xs))) (cdr (car xs))]
[else (assoc-lookup (cdr xs))]))
(assoc-lookup (environ-xs env)))
; --------- ;
; Ewaluacja ;
; --------- ;
(: arith-op (-> (-> Real Real Real) (-> Value Value Value)))
(define (arith-op op)
(lambda (x y) (if (and (real? x) (real? y))
(ann (op x y) Value)
(error "Wrong args for arithmetic operator" op x y))))
(: mod-op (-> (-> Integer Integer Integer) (-> Value Value Value)))
(define (mod-op op)
(lambda (x y) (if (and (exact-integer? x) (exact-integer? y))
(ann (op x y) Value)
(error "Wrong args for modulo operator" op x y))))
(: logic-op (-> (-> Boolean Boolean Boolean) (-> Value Value Value)))
(define (logic-op op)
(lambda (x y) (if (and (boolean? x) (boolean? y))
(ann (op x y) Value)
(error "Wrong args for logic operator" op x y))))
(: comp-op (-> (-> Real Real Boolean) (-> Value Value Value)))
(define (comp-op op)
(lambda (x y) (if (and (real? x) (real? y))
(ann (op x y) Value)
(error "Wrong args for comparator" op x y))))
(: op->proc (-> BinopSym (-> Value Value Value)))
(define (op->proc op)
(match op ['+ (arith-op +)] ['- (arith-op -)] ['* (arith-op *)] ['/ (arith-op /)]
['% (mod-op modulo)]
['= (comp-op =)] ['> (comp-op >)] ['>= (comp-op >=)] ['< (comp-op <)] ['<= (comp-op <=)]
['and (logic-op (lambda (x y) (and x y)))]
['or (logic-op (lambda (x y) (or x y)))]))
(: eval-env (-> Expr environ Value))
(define (eval-env e env)
(match e
[(const n) n]
[(binop op l r) ((op->proc op) (eval-env l env)
(eval-env r env))]
[(let-expr x e1 e2)
(eval-env e2 (env-add x (eval-env e1 env) env))]
[(var-expr x) (env-lookup x env)]
[(if-expr eb et ef) (if (eval-env eb env) ; <----------------- !!!
(eval-env et env)
(eval-env ef env))]))
(: eval (-> Expr Value))
(define (eval e) (eval-env e env-empty))
(define program
'(if (or (< (% 123 10) 5)
true)
(+ 2 3)
(/ 2 0)))
;;; (define (test-eval) (eval (parse program)))
|
