blob: 089dee4b2333f96ad3112663ab6f27d0efd84481 (
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
|
#lang racket
(provide (struct-out const)
(struct-out binop)
(struct-out var-expr)
(struct-out let-expr)
(struct-out pos)
(struct-out var-free)
(struct-out var-bound)
annotate-expression)
;; ---------------
;; Jezyk wejsciowy
;; ---------------
(struct pos (file line col) #:transparent)
(struct const (val) #:transparent)
(struct binop (op l r) #:transparent)
(struct var-expr (id) #:transparent)
(struct let-expr (loc id e1 e2) #:transparent)
(define (expr? e)
(match e
[(const n) (number? n)]
[(binop op l r) (and (symbol? op) (expr? l) (expr? r))]
[(var-expr x) (symbol? x)]
[(let-expr loc x e1 e2)
(and (pos? loc) (symbol? x) (expr? e1) (expr? e2))]
[_ false]))
(define (make-pos s)
(pos (syntax-source s)
(syntax-line s)
(syntax-column s)))
(define (parse e)
(let ([r (syntax-e e)])
(cond
[(number? r) (const r)]
[(symbol? r) (var-expr r)]
[(and (list? r) (= 3 (length r)))
(match (syntax-e (car r))
['let (let* ([e-def (syntax-e (second r))]
[x (syntax-e (first e-def))])
(let-expr (make-pos (first e-def))
(if (symbol? x) x (error "parse error!"))
(parse (second e-def))
(parse (third r))))]
[op (binop op (parse (second r)) (parse (third r)))])]
[else (error "parse error!")])))
;; ---------------
;; Jezyk wyjsciowy
;; ---------------
(struct var-free (id) #:transparent)
(struct var-bound (pos id) #:transparent)
(define (expr-annot? e)
(match e
[(const n) (number? n)]
[(binop op l r) (and (symbol? op) (expr-annot? l) (expr-annot? r))]
[(var-free x) (symbol? x)]
[(var-bound loc x) (and (pos? loc) (symbol? x))]
[(let-expr loc x e1 e2)
(and (pos? loc) (symbol? x) (expr-annot? e1) (expr-annot? e2))]
[_ false]))
(struct environ (xs))
(define env-empty (environ null))
(define (env-add x v env)
(environ (cons (cons x v) (environ-xs env))))
(define (env-lookup x env)
(define (assoc-lookup xs)
(cond [(null? xs) false]
[(eq? x (car (car xs))) (cdr (car xs))]
[else (assoc-lookup (cdr xs))]))
(assoc-lookup (environ-xs env)))
(define (annotate-expression-env e env)
(match e
[(const r) (const r)]
[(binop op l r) (binop op (annotate-expression-env l env) (annotate-expression-env r env))]
[(var-expr x) (let ((pos (env-lookup x env)))
(if pos
(var-bound pos x)
(var-free x)))]
[(let-expr loc x e1 e2) (let-expr loc x (annotate-expression-env e1 env) (annotate-expression-env e2 (env-add x loc env)))]))
(define (annotate-expression e)
(annotate-expression-env e env-empty))
(define (test) (annotate-expression (parse #'(let [x 5] (let [x (* x y)] (+ x y))))))
|
