blob: 61804b30a0d70631efa1e78f90be1f7c7f3c37e5 (
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
|
#lang typed/racket
; --------- ;
; Wyrazenia ;
; --------- ;
(provide parse typecheck)
(define-type Expr (U const binop var-expr let-expr if-expr))
(define-type Value (U Real Boolean))
(define-type ArithOp (U '+ '- '/ '* '%))
;;; (define-type ModOp '%)
(define-type CompOp (U '= '> '>= '< '<=))
(define-type LogicOp (U 'and 'or))
(define-type BinopSym (U ArithOp CompOp LogicOp))
(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 arith-op? ArithOp)
;;; (define-predicate mod-op? ModOp)
(define-predicate comp-op? CompOp)
(define-predicate logic-op? LogicOp)
(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)]))
; ---------- ;
; Srodowiska ;
; ---------- ;
(define-type EType (U 'real 'boolean))
(define-predicate EType? EType)
(struct environ ([xs : (Listof (Pairof Symbol EType))]))
(define env-empty (environ null))
(: env-add (-> Symbol EType environ environ))
(define (env-add x v env)
(environ (cons (cons x v) (environ-xs env))))
(: env-lookup (-> Symbol environ EType))
(define (env-lookup x env)
(: assoc-lookup (-> (Listof (Pairof Symbol EType)) EType))
(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)))
(: check-op (-> Expr Expr EType EType environ (U EType #f)))
(define (check-op e1 e2 arg-type ret-type env)
(if (and (eq? (typecheck-env e1 env) arg-type)
(eq? (typecheck-env e2 env) arg-type))
ret-type
#f))
(: typecheck-env (-> Expr environ (U EType #f)))
(define (typecheck-env e env)
(match e
[(const val)
(cond
[(real? val) 'real]
[(boolean? val) 'boolean])]
[(var-expr id) (env-lookup id env)]
[(binop op e1 e2)
(cond
[(arith-op? op) (check-op e1 e2 'real 'real env)]
[(comp-op? op) (check-op e1 e2 'real 'boolean env)]
[(logic-op? op) (check-op e1 e2 'boolean 'boolean env)])]
[(let-expr id e1 e2)
(let ((id-type (typecheck-env e1 env)))
(if id-type
(typecheck-env e2 (env-add id id-type env))
#f))]
[(if-expr eb et ef)
(let ((eb-type (typecheck-env eb env)))
(if (not (eq? eb-type 'boolean))
#f
(let ((et-type (typecheck-env et env))
(ef-type (typecheck-env ef env)))
(if (eq? et-type ef-type) ;;; nie trzeba sprawdzac czy ktores z nich to #f
et-type ;;; jesli tak jest, to i tak sie na pewno zwroci #f
#f))))]))
(: typecheck (-> Expr (U EType #f)))
(define (typecheck e)
(typecheck-env e env-empty))
(define program
'(if (or (< (% 123 10) 5)
true)
(+ 2 3)
(/ 2 0)))
(define (test-eval) (eval (parse program)))
|
