diff options
| author | Franciszek Malinka <franciszek.malinka@gmail.com> | 2021-02-25 14:42:55 +0100 |
|---|---|---|
| committer | Franciszek Malinka <franciszek.malinka@gmail.com> | 2021-02-25 14:42:55 +0100 |
| commit | 9477dbe667f250ecd23f8fc0d56b942191526421 (patch) | |
| tree | a4b50c9a726f415f835f5311c11c5d66e95f688c /Semestr 2/racket/l7z12 | |
| parent | 1968c1e590077bd51844eacfac722d7963848cb8 (diff) | |
Stare semestry, niepoukladane
Diffstat (limited to 'Semestr 2/racket/l7z12')
| -rw-r--r-- | Semestr 2/racket/l7z12/solution.rkt | 95 |
1 files changed, 95 insertions, 0 deletions
diff --git a/Semestr 2/racket/l7z12/solution.rkt b/Semestr 2/racket/l7z12/solution.rkt new file mode 100644 index 0000000..089dee4 --- /dev/null +++ b/Semestr 2/racket/l7z12/solution.rkt @@ -0,0 +1,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))))))
|