Milestone: compile.rkt goes through.

Author: dvanhorn

langs/outlaw/ast.rkt

@@ -1,14 +1,14 @@
 #lang racket
 (provide (all-defined-out))
 
-;; type Prog = (Prog (Listof Defn) Expr)
-(struct Prog (ds e) #:prefab)
+;; type Prog = (Prog (Listof Defn))
+(struct Prog (ds))
 
 ;; type Lib = (Lib (Listof Id) (Listof Defn))
-(struct Lib (ids ds) #:prefab)
+(struct Lib (ids ds))
 
 ;; type Defn = (Defn Id Lambda)
-(struct Defn (f l) #:prefab)
+(struct Defn (f l))
 
 ;; type Expr   = (Eof)
 ;;             | (Quote Datum)
@@ -63,31 +63,33 @@
 ;;            | (PSymb Symbol)
 ;;            | (PStr String)
 ;;            | (PStruct Id (Listof Pat))
+;;            | (PPred Expr)
 ;; type Lit   = Boolean
 ;;            | Character
 ;;            | Integer
 ;;            | '()
 
-(struct Eof     ()           #:prefab)
-(struct Prim    (p es)       #:prefab)
-(struct If      (e1 e2 e3)   #:prefab)
-(struct Begin   (e1 e2)      #:prefab)
-(struct Let     (xs es e)    #:prefab)
-(struct Var     (x)          #:prefab)
-(struct App     (e es)       #:prefab)
-(struct Lam     (f xs e)     #:prefab)
-(struct LamRest (f xs x e)   #:prefab)
-(struct LamCase (f cs)       #:prefab)
-(struct Apply   (e es el)    #:prefab)
-(struct Quote   (d)          #:prefab)
-(struct Match   (e ps es)    #:prefab)
+(struct Eof     ())
+(struct Prim    (p es))
+(struct If      (e1 e2 e3))
+(struct Begin   (e1 e2))
+(struct Let     (xs es e))
+(struct Var     (x))
+(struct App     (e es))
+(struct Lam     (f xs e))
+(struct LamRest (f xs x e))
+(struct LamCase (f cs))
+(struct Apply   (e es el))
+(struct Quote   (d))
+(struct Match   (e ps es))
 
-(struct PVar  (x)          #:prefab)
-(struct PWild ()           #:prefab)
-(struct PLit  (x)          #:prefab)
-(struct PBox  (p)          #:prefab)
-(struct PCons (p1 p2)      #:prefab)
-(struct PAnd  (p1 p2)      #:prefab)
-(struct PSymb (s)          #:prefab)
-(struct PStr (s)           #:prefab)
-(struct PStruct (n ps)     #:prefab)
+(struct PVar  (x))
+(struct PWild ())
+(struct PLit  (x))
+(struct PBox  (p))
+(struct PCons (p1 p2))
+(struct PAnd  (p1 p2))
+(struct PSymb (s))
+(struct PStr (s))
+(struct PStruct (n ps))
+(struct PPred (e))

langs/outlaw/compile-expr.rkt

@@ -232,7 +232,7 @@
 ;; Pat Expr CEnv GEnv Symbol Bool -> Asm
 (define (compile-match-clause p e c g done t?)
   (let ((next (gensym)))
-    (match (compile-pattern p '() next)
+    (match (compile-pattern p c g '() next)
       [(list i f cm)
        (seq (Mov rax (Offset rsp 0)) ; restore value being matched
             i
@@ -242,8 +242,8 @@
             f
             (Label next))])))
 
-;; Pat CEnv Symbol -> (list Asm Asm CEnv)
-(define (compile-pattern p cm next)
+;; Pat CEnv GEnv CEnv Symbol -> (list Asm Asm CEnv)
+(define (compile-pattern p c g cm next)
   (match p
     [(PWild)
      (list (seq) (seq) cm)]
@@ -287,9 +287,9 @@
                   (Jmp next))
              cm))]
     [(PAnd p1 p2)
-     (match (compile-pattern p1 (cons #f cm) next)
+     (match (compile-pattern p1 c g (cons #f cm) next)
        [(list i1 f1 cm1)
-        (match (compile-pattern p2 cm1 next)
+        (match (compile-pattern p2 c g cm1 next)
           [(list i2 f2 cm2)
            (list
             (seq (Push rax)
@@ -299,7 +299,7 @@
             (seq f1 f2)
             cm2)])])]
     [(PBox p)
-     (match (compile-pattern p cm next)
+     (match (compile-pattern p c g cm next)
        [(list i1 f1 cm1)
         (let ((fail (gensym)))
           (list
@@ -316,9 +316,9 @@
                 (Jmp next))
            cm1))])]
     [(PCons p1 p2)
-     (match (compile-pattern p1 (cons #f cm) next)
+     (match (compile-pattern p1 c g (cons #f cm) next)
        [(list i1 f1 cm1)
-        (match (compile-pattern p2 cm1 next)
+        (match (compile-pattern p2 c g cm1 next)
           [(list i2 f2 cm2)
            (let ((fail (gensym)))
              (list
@@ -340,7 +340,7 @@
                    (Jmp next))
               cm2))])])]
     [(PStruct n ps)
-     (match (compile-struct-patterns ps (cons #f cm) next 1)
+     (match (compile-struct-patterns ps c g (cons #f cm) next 1)
        [(list i f cm)
         (let ((fail (gensym)))
           (list
@@ -359,16 +359,41 @@
                 (Label fail)
                 (Add rsp (*8 (length cm)))
                 (Jmp next))
-           cm))])]))
+           cm))])]
+    
+    [(PPred e)
+     (list
+      (let ((r (gensym 'ret)))                     
+        (seq (Lea r15 r)
+             (Push r15) ; rp
+             (Push rax) ; arg (saved for the moment)
+             (compile-e e (list* #f #f c) g #f)
+             (Pop r15)
+             (Push rax)
+             (Push r15)
+             
+             (assert-proc rax)
+             (Xor rax type-proc)
+             (Mov r15 1)
+             (Mov rax (Offset rax 0))
+             (Jmp rax)
+             (Label r)
+             (Cmp rax val-false)
+             (Je next)))
+      (seq)
+      cm)]))
+
+                      
+     
 
 ;; [Listof Pat] CEnv Symbol Nat -> (list Asm Asm CEnv)
-(define (compile-struct-patterns ps cm next i)
+(define (compile-struct-patterns ps c g cm next i)
   (match ps
     ['() (list '() '() cm)]
     [(cons p ps)
-     (match (compile-pattern p cm next)
+     (match (compile-pattern p c g cm next)
        [(list i1 f1 cm1)
-        (match (compile-struct-patterns ps cm1 next (add1 i))
+        (match (compile-struct-patterns ps c g cm1 next (add1 i))
           [(list is fs cmn)
            (list
             (seq (Mov rax (Offset rax (*8 i)))

langs/outlaw/compile-literals.rkt

@@ -52,8 +52,8 @@
 ;; Prog -> [Listof (U Symbol String)]
 (define (literals* p)
   (match p
-    [(Prog ds e)
-     (append (append-map literals-d ds) (literals-e e))]))
+    [(Prog ds)
+     (append-map literals-d ds)]))
 
 ;; Defn -> [Listof (U Symbol String)]
 (define (literals-d d)
@@ -97,6 +97,7 @@
     [(PBox p) (literals-pat p)]
     [(PCons p1 p2) (append (literals-pat p1) (literals-pat p2))]
     [(PAnd p1 p2) (append (literals-pat p1) (literals-pat p2))]
+    [(PPred e) (literals-e e)]
     [_ '()]))
 
 ;; Datum -> [Listof (U Symbol String)]

langs/outlaw/compile.rkt

@@ -19,7 +19,7 @@
 
 (define (compile p)
   (match p
-    [(Prog ds e)
+    [(Prog ds)
      (let ((gs (append stdlib-ids (define-ids ds))))
        (seq (externs)
             (map (lambda (i) (Extern (symbol->label i))) stdlib-ids)
@@ -30,7 +30,7 @@
             (init-lib)
 
             (compile-defines ds gs)
-            (compile-e e '() gs #t)
+            (compile-variable (last-define-id ds) '() gs)
             (Ret)
             (compile-lambda-defines (lambdas p) gs)
             (Global 'raise_error_align)
@@ -45,6 +45,11 @@
           (Data)
           (compile-literals p)))]))
 
+(define (last-define-id ds)
+  (match ds
+    [(cons (Defn x _) '()) x]
+    [(cons d ds) (last-define-id ds)]))
+
 (define (init-lib)
   (let ((r (gensym))) ; call init_lib
     (seq (Extern 'init_lib)
@@ -54,7 +59,7 @@
          (Label r))))
 
 (define stdlib-ids
-  '(list make-list list? foldr map length append
+  '(list list* make-list list? foldr map filter length append
          memq member append-map vector->list
          reverse
          number->string gensym read read-char
@@ -63,6 +68,8 @@
          list->string string->list
          char<=?
          remove-duplicates remq* remove* remove
+         andmap vector list->vector boolean?
+         substring odd?
          ;; Op0
          read-byte peek-byte void
          ;; Op1
@@ -134,4 +141,4 @@
 
             (compile-lambda-defines (lambdas-ds ds) g)
             (Data)
-            (compile-literals (Prog ds (Quote #t)))))]))
+            (compile-literals (Prog ds))))]))

langs/outlaw/error.c

@@ -0,0 +1,12 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include "values.h"
+#include "runtime.h"
+
+void print_str(val_str_t*);
+
+void error(val_t msg) {
+  print_str(val_unwrap_str(msg));
+  putchar('\n');
+  exit(1);
+}

langs/outlaw/fv.rkt

@@ -28,7 +28,7 @@
 
 ;; Pat Expr -> [Listof Id]
 (define (fv-clause* p e)
-  (remq* (bv-pat* p) (fv* e)))
+  (remq* (bv-pat* p) (append (fv-pat* e) (fv* e))))
 
 ;; Pat -> [Listof Id]
 (define (bv-pat* p)
@@ -39,3 +39,14 @@
     [(PBox p) (bv-pat* p)]
     [(PStruct n ps) (append-map bv-pat* ps)]
     [_ '()]))
+
+;; Pat -> [Listof Id]
+(define (fv-pat* p)
+  (match p
+    [(PBox p) (fv-pat* p)]
+    [(PCons p1 p2) (append (fv-pat* p1) (fv-pat* p2))]
+    [(PAnd p1 p2) (append (fv-pat* p1) (fv-pat* p2))]
+    [(PStruct n ps) (append-map fv-pat* ps)]
+    [(PPred e) (fv* e)]
+    [_ '()]))
+  

langs/outlaw/lambdas.rkt

@@ -6,8 +6,8 @@
 ;; List all of the lambda expressions in p
 (define (lambdas p)
   (match p
-    [(Prog ds e)
-     (append (lambdas-ds ds) (lambdas-e e))]))
+    [(Prog ds)
+     (lambdas-ds ds)]))
 
 ;; Defns -> [Listof Lam]
 ;; List all of the lambda expressions in ds
@@ -31,7 +31,9 @@
     [(LamRest f xs x e1) (cons e (lambdas-e e1))]
     [(LamCase f cs)      (cons e (lambdas-cs cs))]
     [(Apply e es el)     (append (lambdas-e e) (append-map lambdas-e es) (lambdas-e el))]
-    [(Match e ps es)    (append (lambdas-e e) (append-map lambdas-e es))]
+    [(Match e ps es)    (append (lambdas-e e)
+                                (append-map lambdas-pat ps)
+                                (append-map lambdas-e es))]
     [_                  '()]))
 
 ;; [Listof LamCaseClause] -> [Listof Lam]
@@ -44,3 +46,13 @@
     [(cons (LamRest f xs x e) cs)
      (append (lambdas-e e)
              (lambdas-cs cs))]))
+
+;; Pat -> [Listof Lam]
+(define (lambdas-pat p)
+  (match p
+    [(PBox p) (lambdas-pat p)]
+    [(PCons p1 p2) (append (lambdas-pat p1) (lambdas-pat p2))]
+    [(PAnd p1 p2) (append (lambdas-pat p1) (lambdas-pat p2))]
+    [(PStruct n ps) (append-map lambdas-pat ps)]
+    [(PPred e) (lambdas-e e)]
+    [_ '()]))