crook

Author: dvanhorn

iniquity-plus/ast.rkt

@@ -30,6 +30,8 @@
 ;;           | (App Id (Listof Expr))
 ;;           | (Apply Id (Listof Expr) Expr)
 
+;; type ClosedExpr = { e ∈ Expr | e contains no free variables }
+
 ;; type Id  = Symbol
 ;; type Datum = Integer
 ;;            | Boolean

iniquity-plus/compile-stdin.rkt

@@ -10,5 +10,6 @@
 ;; emit asm code on stdout
 (define (main)
   (read-line) ; ignore #lang racket line
-  (asm-display (compile (apply parse (read-all)))))
+  (asm-display (compile
+                        (apply parse-closed (read-all)))))
 

iniquity-plus/interp-stdin.rkt

@@ -9,5 +9,6 @@
 ;; print result on stdout
 (define (main)
   (read-line) ; ignore #lang racket line
-  (println (interp (apply parse (read-all)))))
+  (println (interp
+                   (apply parse-closed (read-all)))))
 

iniquity-plus/parse.rkt

@@ -1,100 +1,233 @@
 #lang racket
-(provide parse parse-e parse-define)
+(provide parse parse-closed parse-e parse-define)
 (require "ast.rkt")
 
-;; S-Expr ... -> Prog
-(define (parse . s)
-  (match s
-    [(cons (and (cons 'define _) d) s)
-     (match (apply parse s)
-       [(Prog ds e)
-        (Prog (cons (parse-define d) ds) e)])]
-    [(cons e '()) (Prog '() (parse-e e))]
-    [_ (error "program parse error")]))
-
-;; S-Expr -> Defn
+;; [Listof S-Expr] -> Prog
+(define (parse . ss)
+  (match (parse-prog ss (parse-defn-names ss) '() '() '())
+    [(list _ _ p) p]))
+
+;; [Listof S-Expr] -> ClosedProg
+(define (parse-closed . ss)
+  (match (parse-prog ss (parse-defn-names ss) '() '() '())
+    [(list '() '() p) p]
+    [(list ys gs p) (error "undefined identifiers" (append ys gs))]))
+
+;; S-Expr -> Expr
+;; Parse a (potentially open) expression
+(define (parse-e s)
+  (match (parse-e/acc s '() '() '() '())
+    [(list _ _ e) e]))
+
+;; S-Expr -> Expr
+;; Parse a (potentially open) definition
 (define (parse-define s)
+  (match (parse-define/acc s '() '() '() '())
+    [(list _ _ d) d]))
+
+;; S-Expr -> r:[Listof Id]
+;;   where: (distinct? r)
+;; Extracts defined function names from given program-like s-expr
+;; Does not fully parse definition
+;; Example:
+;;   (parse-defn-names '((define (f x) x) (define (g y) y) 1) -> '(f g)
+(define (parse-defn-names ss)
+  (define (rec ss fs)
+    (match ss
+      [(list s) fs]
+      [(cons (cons 'define sd) sr)
+       (match (parse-defn-name sd)
+         [f (if (memq f fs)
+                (error "duplicate definition" f)
+                (rec sr (cons f fs)))])]
+      [_ (error "parse error")]))
+  (rec ss '()))
+
+(define (parse-defn-name s)
+  (match s
+    [(cons (cons (? symbol? f) _) _) f]
+    [(cons (? symbol? f) _) f]
+    [_ (error "parse error")]))
+
+;; S-Expr [Listof Id] [Listof Id] [Listof Id] [Listof Id] -> (list [Listof Id] [Listof Id] Prog)
+;;   s: program shaped s-expr to be parsed
+;;   fs: defined function names
+;;   xs: bound variables
+;;   ys: free variables
+;;   gs: undefined function names
+;; returns list of free variables, undefined function names, and parse of program
+(define (parse-prog s fs xs ys gs)
+  (match s
+    [(list s)
+     (match (parse-e/acc s fs xs ys gs)
+       [(list ys gs e)
+        (list ys gs (Prog '() e))])]
+    [(cons s ss)
+     (match (parse-define/acc s fs xs ys gs)
+       [(list ys gs (and d (Defn f _)))
+        (match (parse-prog ss (cons f fs) xs ys gs)
+          [(list ys gs (Prog ds e))
+           (list ys gs (Prog (cons d ds) e))])])]))
+
+
+;; S-Expr [Listof Id] [Listof Id] [Listof Id] [Listof Id] -> (list [Listof Id] [Listof Id] Defn)
+;;   s: definition shaped s-expr to be parsed
+;;   fs: defined function names
+;;   xs: bound variables
+;;   ys: free variables
+;;   gs: undefined function names
+;; returns list of free variables, undefined function names, and parse of definition
+(provide (all-defined-out))
+(define (parse-define/acc s fs xs ys gs)
+  (match s
+    [(list 'define (? symbol? f) (cons 'case-lambda sr))
+     (match (parse-case-lambda/acc sr fs xs ys gs)
+       [(list ys gs fun)
+        (list ys gs (Defn f fun))])]
+    [(cons 'define (cons (cons (? symbol? f) ps) sr))
+     (match (parse-define-plain-or-rest-fun/acc (cons ps sr) fs xs ys gs)
+       [(list ys gs fun)
+        (list ys gs (Defn f fun))])]
+    [_ (error "parse error")]))
+
+(define (parse-case-lambda/acc s fs xs ys gs)
+  (match s
+    ['() (list ys gs (FunCase '()))]
+    [(cons s sr)
+     (match (parse-define-plain-or-rest-fun/acc s fs xs ys gs)
+       [(list ys gs l)
+        (match (parse-case-lambda/acc sr fs xs ys gs)
+          [(list ys gs (FunCase ls))
+           (list ys gs (FunCase (cons l ls)))])])]
+    [_ (error "parse error")]))
+
+(define (parse-define-plain-or-rest-fun/acc s fs xs ys gs)
+  (match s
+    [(list '() s)
+     (match (parse-e/acc s fs xs ys gs)
+       [(list ys gs e)
+        (list ys gs (FunPlain '() e))])]
+    [(list (? symbol? r) s)
+     (match (parse-e/acc s fs (cons r xs) ys gs)
+       [(list ys gs e)
+        (list ys gs (FunRest '() r e))])]
+    [(list (cons (? symbol? x) r) s)
+     (match (parse-define-plain-or-rest-fun/acc (list r s) fs (cons x xs) ys gs)
+       [(list ys gs (FunPlain xs e))
+        (list ys gs (FunPlain (cons x xs) e))]
+       [(list ys gs (FunRest xs r e))
+        (list ys gs (FunRest (cons x xs) r e))])]
+    [_ (error "parse error")]))
+
+;; S-Expr [Listof Id] [Listof Id] [Listof Id] [Listof Id] -> (list [Listof Id] [Listof Id] Expr)
+;;   s: expression shaped s-expr to be parsed
+;;   fs: defined function names
+;;   xs: bound variables
+;;   ys: free variables
+;;   gs: undefined function names
+;; returns list of free variables, undefined function names, and parse of expression
+(define (parse-e/acc s fs xs ys gs)
+  (define (rec s xs ys gs)
+    (define ns (append fs xs))
+    (match s
+      [(and 'eof (? (not-in ns)))
+       (list ys gs (Eof))]
+      [(? datum?)
+       (list ys gs (Lit s))]
+      [(list 'quote (list))
+       (list ys gs (Lit '()))]
+      [(? symbol? (? (not-in fs)))
+       (if (memq s xs)
+           (list ys gs (Var s))
+           (list (cons s ys) gs (Var s)))]
+      [(list-rest (? symbol? (? (not-in ns) k)) sr)
+       (match k
+         ['let
+          (match sr
+            [(list (list (list (? symbol? x) s1)) s2)
+             (match (rec s1 xs ys gs)
+               [(list ys gs e1)
+                (match (rec s2 (cons x xs) ys gs)
+                  [(list ys gs e2)
+                   (list ys gs (Let x e1 e2))])])]
+            [_ (error "let: bad syntax" s)])]
+         ['apply
+          (match sr
+            [(list-rest (? symbol? f) sr)
+             (parse-apply/acc sr f fs xs ys (if (memq f fs) gs (cons f gs)))])]
+         [_
+          (match (parse-es/acc sr fs xs ys gs)
+            [(list ys gs es)
+             (match (cons k es)
+               [(list (? op0? o))
+                (list ys gs (Prim0 o))]
+               [(list (? op1? o) e1)
+                (list ys gs (Prim1 o e1))]
+               [(list (? op2? o) e1 e2)
+                (list ys gs (Prim2 o e1 e2))]
+               [(list (? op3? o) e1 e2 e3)
+                (list ys gs (Prim3 o e1 e2 e3))]
+               [(list 'begin e1 e2)
+                (list ys gs (Begin e1 e2))]
+               [(list 'if e1 e2 e3)
+                (list ys gs (If e1 e2 e3))]
+               [(list-rest g es)
+                (list ys (cons g gs) (App g es))])])])]
+      [(list-rest (? symbol? g) sr)
+       (match (parse-es/acc sr fs xs ys gs)
+         [(list ys s es)
+          (list ys (if (memq g fs) gs (cons g gs)) (App g es))])]
+      [_
+       (error "parse error" s)]))
+  (rec s xs ys gs))
+
+;; S-Expr Id [Listof Id] [Listof Id] [Listof Id] [Listof Id] -> (list [Listof Id] [Listof Id] Apply)
+(define (parse-apply/acc s f fs xs ys gs)
+  (match s
+    [(list s)
+     (match (parse-e/acc s fs xs ys gs)
+       [(list ys gs e)
+        (list ys gs (Apply f '() e))])]
+    [(cons s sr)
+     (match (parse-e/acc s fs xs ys gs)
+       [(list ys gs e)
+        (match (parse-apply/acc sr f fs xs ys gs)
+          [(list ys gs (Apply f es e0))
+           (list ys gs (Apply f (cons e es) e0))])])]))
+
+;; S-Expr [Listof Id] [Listof Id] [Listof Id] [Listof Id] -> (list [Listof Id] [Listof Id] [Listof Expr])
+;;   s: list of expressions shaped s-expr to be parsed
+;;   fs: defined function names
+;;   xs: bound variables
+;;   ys: free variables
+;;   gs: undefined function names
+;; returns list of free variables, undefined function names, and list of parsed expressions
+(define (parse-es/acc s fs xs ys gs)
   (match s
-    [(list 'define (? symbol? f)
-           (cons 'case-lambda cs))
-     (Defn f (FunCase (parse-case-lambda-clauses cs)))]
-    [(list 'define (cons (? symbol? f) xs) e)
-     (if (all symbol? xs)
-         (Defn f (parse-param-list xs e))
-         (error "parse definition error"))]
-    [_ (error "Parse defn error" s)]))
-
-;; like andmap, but work on improper lists too
+    ['() (list ys gs '())]
+    [(cons s ss)
+     (match (parse-e/acc s fs xs ys gs)
+       [(list ys gs e)
+        (match (parse-es/acc ss fs xs ys gs)
+          [(list ys gs es)
+           (list ys gs (cons e es))])])]
+    [_ (error "parse error")]))
+
+(define (distinct? xs)
+  (not (check-duplicates xs)))
+
+;; like andmap, but works on improper lists too
 (define (all p? xs)
   (match xs
     ['() #t]
     [(cons x xs) (and (p? x) (all p? xs))]
     [x (p? x)]))
 
-;; S-Expr -> [Listof FunCaseClause]
-(define (parse-case-lambda-clauses cs)
-  (match cs
-    ['() '()]
-    [(cons c cs)
-     (cons (parse-case-lambda-clause c)
-           (parse-case-lambda-clauses cs))]
-     [_
-      (error "parse case-lambda error")]))
-
-;; S-Expr -> FunRest
-(define (parse-case-lambda-clause c)
-  (match c
-    [(list (? symbol? x) e)
-     (FunRest '() x (parse-e e))]
-    [(list xs e)
-     (parse-param-list xs e)]))
-
-;; S-Expr S-Expr -> FunPlain or FunRest
-(define (parse-param-list xs e)
-  (match xs
-    ['() (FunPlain '() (parse-e e))]
-    [(cons x xs)
-     (match (parse-param-list xs e)
-       [(FunPlain xs e) (FunPlain (cons x xs) e)]
-       [(FunRest xs y e) (FunRest (cons x xs) y e)])]
-    [(? symbol? xs)
-     (FunRest '() xs (parse-e e))]
-    [_
-     (error "parse parameter list error")]))
-
-;; S-Expr -> Expr
-(define (parse-e s)
-  (match s
-    [(? datum?)               (Lit s)]
-    ['eof                     (Eof)]
-    [(? symbol?)              (Var s)]
-    [(list 'quote (list))     (Lit '())]
-    [(list (? op0? p0))       (Prim0 p0)]
-    [(list (? op1? p1) e)     (Prim1 p1 (parse-e e))]
-    [(list (? op2? p2) e1 e2) (Prim2 p2 (parse-e e1) (parse-e e2))]
-    [(list (? op3? p3) e1 e2 e3)
-     (Prim3 p3 (parse-e e1) (parse-e e2) (parse-e e3))]
-    [(list 'begin e1 e2)
-     (Begin (parse-e e1) (parse-e e2))]
-    [(list 'if e1 e2 e3)
-     (If (parse-e e1) (parse-e e2) (parse-e e3))]
-    [(list 'let (list (list (? symbol? x) e1)) e2)
-     (Let x (parse-e e1) (parse-e e2))]
-    [(cons 'apply (cons (? symbol? f) es))
-     (parse-apply f es)]
-    [(cons (? symbol? f) es)
-     (App f (map parse-e es))]
-    [_ (error "Parse error" s)]))
-
-;; Id S-Expr -> Expr
-(define (parse-apply f es)
-  (match es
-    [(list e) (Apply f '() (parse-e e))]
-    [(cons e es)
-     (match (parse-apply f es)
-       [(Apply f es e0)
-        (Apply f (cons (parse-e e) es) e0)])]
-    [_ (error "parse apply error")]))
+;; [Listof Any] -> (Any -> Boolean)
+(define (not-in m)
+  (λ (x) (not (memq x m))))
+(define (in m)
+  (λ (x) (memq x m)))
 
 
 ;; Any -> Boolean

iniquity-plus/test/compile.rkt

@@ -4,6 +4,6 @@
 (require "../exec.rkt")
 (require "../exec-io.rkt")
 (require "test-runner.rkt")
-(test (λ p (exec (apply parse p))))
-(test/io (λ (in . p) (exec/io (apply parse p) in)))
+(test (λ p (exec (apply parse-closed p))))
+(test/io (λ (in . p) (exec/io (apply parse-closed p) in)))
 

iniquity-plus/test/interp.rkt

@@ -3,6 +3,6 @@
 (require "../interp-io.rkt")
 (require "../parse.rkt")
 (require "test-runner.rkt")
-(test (λ p (interp (apply parse p))))
-(test/io (λ (in . p) (interp/io (apply parse p) in)))
+(test (λ p (interp (apply parse-closed p))))
+(test/io (λ (in . p) (interp/io (apply parse-closed p) in)))