Mercurial > urweb

changeset 181:31dfab1d4050

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Cjrize ECon
author Adam Chlipala <adamc@hcoop.net>
date Sun, 03 Aug 2008 11:17:33 -0400
parents c7a5c8e0a0e0
children d11754ffe252
files src/cjr.sml src/cjr_env.sig src/cjr_env.sml src/cjr_print.sml src/cjrize.sml
diffstat 5 files changed, 127 insertions(+), 10 deletions(-) [+]
line wrap: on
line diff
--- a/src/cjr.sml	Sun Aug 03 11:03:35 2008 -0400
+++ b/src/cjr.sml	Sun Aug 03 11:17:33 2008 -0400
@@ -38,10 +38,24 @@
 
 withtype typ = typ' located
 
+datatype patCon =
+         PConVar of int
+       | PConFfi of string * string
+
+datatype pat' =
+         PWild
+       | PVar of string
+       | PPrim of Prim.t
+       | PCon of patCon * pat option
+       | PRecord of (string * pat) list
+
+withtype pat = pat' located
+
 datatype exp' =
          EPrim of Prim.t
        | ERel of int
        | ENamed of int
+       | ECon of int * exp option
        | EFfi of string * string
        | EFfiApp of string * string * exp list
        | EApp of exp * exp
@@ -49,6 +63,8 @@
        | ERecord of int * (string * exp) list
        | EField of exp * string
 
+       | ECase of exp * (pat * exp) list * typ
+
        | EWrite of exp
        | ESeq of exp * exp
 
--- a/src/cjr_env.sig	Sun Aug 03 11:03:35 2008 -0400
+++ b/src/cjr_env.sig	Sun Aug 03 11:17:33 2008 -0400
@@ -39,6 +39,8 @@
     val pushDatatype : env -> string -> int -> (string * int * Cjr.typ option) list -> env
     val lookupDatatype : env -> int -> string * (string * int * Cjr.typ option) list
 
+    val lookupConstructor : env -> int -> string * Cjr.typ option * int
+
     val pushERel : env -> string -> Cjr.typ -> env
     val lookupERel : env -> int -> string * Cjr.typ
     val listERels : env -> (string * Cjr.typ) list
--- a/src/cjr_env.sml	Sun Aug 03 11:03:35 2008 -0400
+++ b/src/cjr_env.sml	Sun Aug 03 11:17:33 2008 -0400
@@ -39,6 +39,7 @@
 
 type env = {
      datatypes : (string * (string * int * typ option) list) IM.map,
+     constructors : (string * typ option * int) IM.map,
 
      numRelE : int,
      relE : (string * typ) list,
@@ -49,6 +50,7 @@
 
 val empty = {
     datatypes = IM.empty,
+    constructors = IM.empty,
 
     numRelE = 0,
     relE = [],
@@ -59,6 +61,9 @@
 
 fun pushDatatype (env : env) x n xncs =
     {datatypes = IM.insert (#datatypes env, n, (x, xncs)),
+     constructors = foldl (fn ((x, n, to), constructors) =>
+                              IM.insert (constructors, n, (x, to, n)))
+                          (#constructors env) xncs,
 
      numRelE = #numRelE env,
      relE = #relE env,
@@ -71,8 +76,14 @@
         NONE => raise UnboundNamed n
       | SOME x => x
 
+fun lookupConstructor (env : env) n =
+    case IM.find (#constructors env, n) of
+        NONE => raise UnboundNamed n
+      | SOME x => x
+
 fun pushERel (env : env) x t =
     {datatypes = #datatypes env,
+     constructors = #constructors env,
 
      numRelE = #numRelE env + 1,
      relE = (x, t) :: #relE env,
@@ -90,6 +101,7 @@
 
 fun pushENamed (env : env) x n t =
     {datatypes = #datatypes env,
+     constructors = #constructors env,
 
      numRelE = #numRelE env,
      relE = #relE env,
@@ -104,6 +116,7 @@
 
 fun pushStruct (env : env) n xts =
     {datatypes = #datatypes env,
+     constructors = #constructors env,
 
      numRelE = #numRelE env,
      relE = #relE env,
--- a/src/cjr_print.sml	Sun Aug 03 11:03:35 2008 -0400
+++ b/src/cjr_print.sml	Sun Aug 03 11:17:33 2008 -0400
@@ -90,6 +90,51 @@
         EPrim p => Prim.p_t p
       | ERel n => p_rel env n
       | ENamed n => p_enamed env n
+      | ECon (n, eo) =>
+        let
+            val (x, _, dn) = E.lookupConstructor env n
+            val (dx, _) = E.lookupDatatype env dn
+        in
+            box [string "{(",
+                 newline,
+                 string "struct",
+                 space,
+                 string "__lwd_",
+                 string dx,
+                 string "_",
+                 string (Int.toString dn),
+                 space,
+                 string "*tmp",
+                 space,
+                 string "=",
+                 space,
+                 string "lw_malloc(ctx, sizeof(struct __lwd_",
+                 string dx,
+                 string "_",
+                 string (Int.toString dn),
+                 string "));",
+                 newline,
+                 string "tmp->tag",
+                 space,
+                 string "=",
+                 space,
+                 string ("__lwc_" ^ x ^ "_" ^ Int.toString n),
+                 string ";",
+                 newline,
+                 case eo of
+                     NONE => box []
+                   | SOME e => box [string "tmp->data.",
+                                    string x,
+                                    space,
+                                    string "=",
+                                    space,
+                                    p_exp env e,
+                                    string ";",
+                                    newline],
+                 string "tmp;",
+                 newline,
+                 string "})"]          
+        end
 
       | EFfi (m, x) => box [string "lw_", string m, string "_", string x]
       | EFfiApp (m, x, es) => box [string "lw_",
@@ -121,7 +166,7 @@
                                  space,
                                  string ("__lws_" ^ Int.toString i),
                                  space,
-                                 string "__lw_tmp",
+                                 string "tmp",
                                  space,
                                  string "=",
                                  space,
@@ -130,7 +175,7 @@
                                             p_exp env e) xes,
                                  string "};",
                                  space,
-                                 string "__lw_tmp;",
+                                 string "tmp;",
                                  space,
                                  string "})" ]
       | EField (e, x) =>
@@ -138,6 +183,8 @@
              string ".",
              string x]
 
+      | ECase _ => raise Fail "CjrPrint ECase"
+
       | EWrite e => box [string "(lw_write(ctx, ",
                          p_exp env e,
                          string "), lw_unit_v)"]
@@ -430,7 +477,7 @@
                          string "__lws_",
                          string (Int.toString i),
                          space,
-                         string "__lw_tmp",
+                         string "tmp",
                          space,
                          string "=",
                          space,
@@ -440,7 +487,7 @@
                          space,
                          string "};",
                          newline,
-                         string "__lw_tmp;",
+                         string "tmp;",
                          newline,
                          string "})"]
                 end
@@ -467,13 +514,13 @@
                                  space,
                                  string ("__lwd_" ^ x ^ "_" ^ Int.toString i),
                                  space,
-                                 string "*__lw_tmp = lw_malloc(ctx, sizeof(struct __lwd_",
+                                 string "*tmp = lw_malloc(ctx, sizeof(struct __lwd_",
                                  string x,
                                  string "_",
                                  string (Int.toString i),
                                  string "));",
                                  newline,
-                                 string "__lw_tmp->tag",
+                                 string "tmp->tag",
                                  space,
                                  string "=",
                                  space,
@@ -491,7 +538,7 @@
                                  newline,
                                  case to of
                                      NONE => box []
-                                   | SOME t => box [string "__lw_tmp->data.",
+                                   | SOME t => box [string "tmp->data.",
                                                     string x',
                                                     space,
                                                     string "=",
@@ -499,7 +546,7 @@
                                                     unurlify t,
                                                     string ";",
                                                     newline],
-                                 string "__lw_tmp;",
+                                 string "tmp;",
                                  newline,
                                  string "})",
                                  space,
--- a/src/cjrize.sml	Sun Aug 03 11:03:35 2008 -0400
+++ b/src/cjrize.sml	Sun Aug 03 11:17:33 2008 -0400
@@ -103,12 +103,38 @@
 
 val dummye = (L'.EPrim (Prim.Int 0), ErrorMsg.dummySpan)
 
+fun cifyPatCon pc =
+    case pc of
+        L.PConVar n => L'.PConVar n
+      | L.PConFfi mx => L'.PConFfi mx
+
+fun cifyPat (p, loc) =
+    case p of
+        L.PWild => (L'.PWild, loc)
+      | L.PVar x => (L'.PVar x, loc)
+      | L.PPrim p => (L'.PPrim p, loc)
+      | L.PCon (pc, po) => (L'.PCon (cifyPatCon pc, Option.map cifyPat po), loc)
+      | L.PRecord xps => (L'.PRecord (map (fn (x, p) => (x, cifyPat p)) xps), loc)
+
 fun cifyExp ((e, loc), sm) =
     case e of
         L.EPrim p => ((L'.EPrim p, loc), sm)
       | L.ERel n => ((L'.ERel n, loc), sm)
       | L.ENamed n => ((L'.ENamed n, loc), sm)
-      | L.ECon _ => raise Fail "Cjrize ECon"
+      | L.ECon (n, eo) =>
+        let
+            val (eo, sm) =
+                case eo of
+                    NONE => (NONE, sm)
+                  | SOME e =>
+                    let
+                        val (e, sm) = cifyExp (e, sm)
+                    in
+                        (SOME e, sm)
+                    end
+        in
+            ((L'.ECon (n, eo), loc), sm)
+        end
       | L.EFfi mx => ((L'.EFfi mx, loc), sm)
       | L.EFfiApp (m, x, es) =>
         let
@@ -153,7 +179,20 @@
             ((L'.EField (e, x), loc), sm)
         end
 
-      | L.ECase _ => raise Fail "Cjrize ECase"
+      | L.ECase (e, pes, t) =>
+        let
+                val (e, sm) = cifyExp (e, sm)
+                val (pes, sm) = ListUtil.foldlMap
+                                    (fn ((p, e), sm) =>
+                                        let
+                                            val (e, sm) = cifyExp (e, sm)
+                                        in
+                                            ((cifyPat p, e), sm)
+                                        end) sm pes
+                val (t, sm) = cifyTyp (t, sm)
+            in
+                ((L'.ECase (e, pes, t), loc), sm)
+            end
 
       | L.EStrcat (e1, e2) =>
         let