diff src/monoize.sml @ 193:8a70e2919e86

Specialization of single-parameter datatypes
author Adam Chlipala <adamc@hcoop.net>
date Fri, 08 Aug 2008 17:55:51 -0400
parents 9bbf4d383381
children 890a61991263
line wrap: on
line diff
--- a/src/monoize.sml	Fri Aug 08 10:59:06 2008 -0400
+++ b/src/monoize.sml	Fri Aug 08 17:55:51 2008 -0400
@@ -67,14 +67,16 @@
             (L'.TFfi ("Basis", "string"), loc)
 
           | L.CRel _ => poly ()
-          | L.CNamed n => raise Fail "Monoize CNamed"
-            (*let
-                val (_, xncs) = Env.lookupDatatype env n
+          | L.CNamed n =>
+            let
+                val (_, xs, xncs) = Env.lookupDatatype env n
 
                 val xncs = map (fn (x, n, to) => (x, n, Option.map (monoType env) to)) xncs
             in
-                (L'.TDatatype (MonoUtil.classifyDatatype xncs, n, xncs), loc)
-            end*)
+                case xs of
+                    [] => (L'.TDatatype (MonoUtil.classifyDatatype xncs, n, xncs), loc)
+                  | _ => poly ()
+            end
           | L.CFfi mx => (L'.TFfi mx, loc)
           | L.CApp _ => poly ()
           | L.CAbs _ => poly ()
@@ -206,7 +208,7 @@
                     let
                         fun makeDecl n fm =
                             let
-                                val (x, xncs) = raise Fail "Monoize TDataype" (*Env.lookupDatatype env i*)
+                                val (x, _, xncs) = Env.lookupDatatype env i
 
                                 val (branches, fm) =
                                     ListUtil.foldlMap
@@ -292,13 +294,23 @@
       | L.PConFfi {mod = m, datatyp, con, arg, ...} => L'.PConFfi {mod = m, datatyp = datatyp, con = con,
                                                                    arg = Option.map (monoType env) arg}
 
-fun monoPat env (p, loc) =
-    case p of
-        L.PWild => (L'.PWild, loc)
-      | L.PVar (x, t) => (L'.PVar (x, monoType env t), loc)
-      | L.PPrim p => (L'.PPrim p, loc)
-      | L.PCon (dk, pc, _, po) => raise Fail "Monoize PCon" (*(L'.PCon (dk, monoPatCon env pc, Option.map (monoPat env) po), loc)*)
-      | L.PRecord xps => (L'.PRecord (map (fn (x, p, t) => (x, monoPat env p, monoType env t)) xps), loc)
+val dummyPat = (L'.PPrim (Prim.Int 0), ErrorMsg.dummySpan)
+
+fun monoPat env (all as (p, loc)) =
+    let
+        fun poly () =
+            (E.errorAt loc "Unsupported pattern";
+             Print.eprefaces' [("Pattern", CorePrint.p_pat env all)];
+             dummyPat)
+    in
+        case p of
+            L.PWild => (L'.PWild, loc)
+          | L.PVar (x, t) => (L'.PVar (x, monoType env t), loc)
+          | L.PPrim p => (L'.PPrim p, loc)
+          | L.PCon (dk, pc, [], po) => (L'.PCon (dk, monoPatCon env pc, Option.map (monoPat env) po), loc)
+          | L.PCon _ => poly ()
+          | L.PRecord xps => (L'.PRecord (map (fn (x, p, t) => (x, monoPat env p, monoType env t)) xps), loc)
+    end
 
 fun monoExp (env, st, fm) (all as (e, loc)) =
     let
@@ -311,8 +323,8 @@
             L.EPrim p => ((L'.EPrim p, loc), fm)
           | L.ERel n => ((L'.ERel n, loc), fm)
           | L.ENamed n => ((L'.ENamed n, loc), fm)
-          | L.ECon (dk, pc, _, eo) => raise Fail "Monoize ECon"
-            (*let
+          | L.ECon (dk, pc, [], eo) =>
+            let
                 val (eo, fm) =
                     case eo of
                         NONE => (NONE, fm)
@@ -324,7 +336,8 @@
                         end
             in
                 ((L'.ECon (dk, monoPatCon env pc, eo), loc), fm)
-            end*)
+            end
+          | L.ECon _ => poly ()
           | L.EFfi mx => ((L'.EFfi mx, loc), fm)
           | L.EFfiApp (m, x, es) =>
             let
@@ -718,12 +731,13 @@
     in
         case d of
             L.DCon _ => NONE
-          | L.DDatatype (x, n, _, xncs) => raise Fail "Monoize DDatatype"
-            (*let
+          | L.DDatatype (x, n, [], xncs) =>
+            let
                 val d = (L'.DDatatype (x, n, map (fn (x, n, to) => (x, n, Option.map (monoType env) to)) xncs), loc)
             in
                 SOME (Env.declBinds env all, fm, d)
-            end*)
+            end
+          | L.DDatatype _ => poly ()
           | L.DVal (x, n, t, e, s) =>
             let
                 val (e, fm) = monoExp (env, St.empty, fm) e