From 9477dbe667f250ecd23f8fc0d56b942191526421 Mon Sep 17 00:00:00 2001
From: Franciszek Malinka <franciszek.malinka@gmail.com>
Date: Thu, 25 Feb 2021 14:42:55 +0100
Subject: Stare semestry, niepoukladane

---
 Semestr 2/racket/l7z12/solution.rkt | 95 +++++++++++++++++++++++++++++++++++++
 1 file changed, 95 insertions(+)
 create mode 100644 Semestr 2/racket/l7z12/solution.rkt

(limited to 'Semestr 2/racket/l7z12/solution.rkt')

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))))))
-- 
cgit v1.2.3