eopl module

8 years ago · 695b682773
parent 1aea686c88
commit 695b682773
1 changed files with 91 additions and 0 deletions
--- a/br/eopl.rkt
+++ b/br/eopl.rkt
@ -0,0 +1,91 @@
+#lang br
+(require rackunit (for-syntax br/datum sugar/debug))
+(provide define-datatype occurs-free?)
+
+#;(begin
+    (struct lc-exp () #:transparent)
+    
+    (struct var-exp lc-exp (var) #:transparent
+      #:guard (λ(var name)
+                (unless (symbol? var)
+                  (error name (format "arg ~a not ~a" var 'symbol?)))
+                (values var)))
+    
+    (struct lambda-exp lc-exp (bound-var body) #:transparent
+      #:guard (λ(bound-var body name)
+                (unless (symbol? bound-var)
+                  (error name (format "arg ~a not ~a" bound-var 'symbol?)))
+                (unless (lc-exp? body)
+                  (error name (format "arg ~a not ~a" body 'lc-exp?)))
+                (values bound-var body)))
+    
+    (struct app-exp lc-exp (rator rand) #:transparent
+      #:guard (λ(rator rand name)
+                (unless (lc-exp? rator)
+                  (error name (format "arg ~a not ~a" rator 'lc-exp?)))
+                (unless (lc-exp? rand)
+                  (error name (format "arg ~a not ~a" rand 'lc-exp?)))
+                (values rator rand))))
+
+
+(define #'(define-datatype <base-type> <base-type-predicate?>
+            (<subtype> [<field> <field-predicate?>] ...) ...)
+  #'(begin
+      (struct <base-type> () #:transparent)
+      (struct <subtype> <base-type> (<field> ...) #:transparent
+        #:guard (λ(<field> ... name)
+                  (unless (<field-predicate?> <field>)
+                    (error name (format "arg ~a is not ~a" <field> '<field-predicate?>))) ...
+                  (values <field> ...))) ...))
+
+
+(define-datatype lc-exp lc-exp?
+  (var-exp [var symbol?])
+  (lambda-exp [bound-var symbol?] [body lc-exp?])
+  (app-exp [rator lc-exp?] [rand lc-exp?]))
+
+
+#;(define (occurs-free? search-var exp)
+    (cond
+      [(var-exp? exp) (let ([var (var-exp-var exp)])
+                        (eqv? var  search-var))]
+      [(lambda-exp? exp) (let ([bound-var (lambda-exp-bound-var exp)]
+                               [body (lambda-exp-body exp)])
+                           (and (not (eqv? search-var bound-var))
+                                (occurs-free? search-var body)))]
+      [(app-exp? exp) (let ([rator (app-exp-rator exp)]
+                            [rand (app-exp-rand exp)])
+                        (or
+                         (occurs-free? search-var rator)
+                         (occurs-free? search-var rand)))]))
+
+
+(define #'(cases-let <input-var> <subtype> (<field> ...) <body> ...)
+  (inject-syntax ([#'(<subtype-field> ...) (map-syntax (λ(field) (format-datum '~a-~a #'<subtype> field)) #'(<field> ...))])
+                 #'(let ([<field> (<subtype-field> <input-var>)] ...)
+                     <body> ...)))
+
+
+(define #'(cases <base-type> <input-var> [<subtype> (<field> ...) <body> ...] ...)
+  (inject-syntax ([#'(<subtype?> ...) (map-syntax (λ(s) (format-datum '~a? s)) #'(<subtype> ...))])
+                 #'(cond
+                     [(<subtype?> <input-var>) (cases-let <input-var> <subtype> (<field> ...) <body> ...)] ...)))
+
+(define (occurs-free? search-var exp)
+  (cases lc-exp exp
+    [var-exp (var) (eqv? var search-var)]
+    [lambda-exp (bound-var body)
+                (and (not (eqv? search-var bound-var))
+                     (occurs-free? search-var body))]
+    [app-exp (rator rand)
+             (or
+              (occurs-free? search-var rator)
+              (occurs-free? search-var rand))]))
+
+
+
+(check-true (occurs-free? 'foo (var-exp 'foo)))
+(check-false (occurs-free? 'foo (var-exp 'bar)))
+(check-false (occurs-free? 'foo (lambda-exp 'foo (var-exp 'bar))))
+(check-true (occurs-free? 'foo (lambda-exp 'bar (var-exp 'foo))))
+(check-true (occurs-free? 'foo (lambda-exp 'bar (lambda-exp 'zim (lambda-exp 'zam (var-exp 'foo))))))