summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2010-03-06 16:15:26 -0500
committerGravatar Adam Chlipala <adamc@hcoop.net>2010-03-06 16:15:26 -0500
commit6f22b8b971cf196d425d5dad67cdf4da9d8f41b5 (patch)
treeb422a4c17510b07702c1e16492d87680928a517f /src
parentefe9d5a1b86ec354e6503222b309caf930f42adb (diff)
Standard library moduls Incl and Mem; tweaks to Especialize and Unpoly
Diffstat (limited to 'src')
-rw-r--r--src/especialize.sml47
-rw-r--r--src/unpoly.sml16
2 files changed, 45 insertions, 18 deletions
diff --git a/src/especialize.sml b/src/especialize.sml
index 7d129b8b..4936cc61 100644
--- a/src/especialize.sml
+++ b/src/especialize.sml
@@ -1,4 +1,4 @@
-(* Copyright (c) 2008-2009, Adam Chlipala
+(* Copyright (c) 2008-2010, Adam Chlipala
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
@@ -129,6 +129,37 @@ val mayNotSpec = ref SS.empty
fun specialize' (funcs, specialized) file =
let
+ fun functionInside functiony = U.Con.exists {kind = fn _ => false,
+ con = fn TFun _ => true
+ | CFfi ("Basis", "transaction") => true
+ | CFfi ("Basis", "eq") => true
+ | CFfi ("Basis", "num") => true
+ | CFfi ("Basis", "ord") => true
+ | CFfi ("Basis", "show") => true
+ | CFfi ("Basis", "read") => true
+ | CFfi ("Basis", "sql_injectable_prim") => true
+ | CFfi ("Basis", "sql_injectable") => true
+ | CNamed n => IS.member (functiony, n)
+ | _ => false}
+
+ val functiony = foldl (fn ((d, _), functiony) =>
+ case d of
+ DCon (_, n, _, c) =>
+ if functionInside functiony c then
+ IS.add (functiony, n)
+ else
+ functiony
+ | DDatatype dts =>
+ if List.exists (fn (_, _, _, cs) =>
+ List.exists (fn (_, _, SOME c) => functionInside functiony c
+ | _ => false) cs) dts then
+ IS.addList (functiony, map #2 dts)
+ else
+ functiony
+ | _ => functiony) IS.empty file
+
+ val functionInside = functionInside functiony
+
fun bind (env, b) =
case b of
U.Decl.RelE xt => xt :: env
@@ -286,17 +317,7 @@ fun specialize' (funcs, specialized) file =
(*val () = Print.prefaces "Consider" [("e", CorePrint.p_exp CoreEnv.empty
(e, ErrorMsg.dummySpan))]*)
- val functionInside = U.Con.exists {kind = fn _ => false,
- con = fn TFun _ => true
- | CFfi ("Basis", "transaction") => true
- | CFfi ("Basis", "eq") => true
- | CFfi ("Basis", "num") => true
- | CFfi ("Basis", "ord") => true
- | CFfi ("Basis", "show") => true
- | CFfi ("Basis", "read") => true
- | CFfi ("Basis", "sql_injectable_prim") => true
- | CFfi ("Basis", "sql_injectable") => true
- | _ => false}
+
val loc = ErrorMsg.dummySpan
fun findSplit av (xs, typ, fxs, fvs, fin) =
@@ -332,6 +353,8 @@ fun specialize' (funcs, specialized) file =
andalso IS.exists (fn n => functionInside (#2 (List.nth (env, n)))) fvs) then
((*Print.prefaces "No" [("name", Print.PD.string name),
("f", Print.PD.string (Int.toString f)),
+ ("xs",
+ Print.p_list (CorePrint.p_exp CoreEnv.empty) xs),
("fxs'",
Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')];*)
default ())
diff --git a/src/unpoly.sml b/src/unpoly.sml
index 0d239cb9..41532b85 100644
--- a/src/unpoly.sml
+++ b/src/unpoly.sml
@@ -258,9 +258,9 @@ fun decl (d, st : state) =
fun kind _ = false
fun con _ = false
- fun exp e =
+ fun exp (cn, e) =
case e of
- ECApp (e, c) =>
+ orig as ECApp (e, c) =>
let
fun isIrregular (e, pos) =
case #1 e of
@@ -268,20 +268,24 @@ fun decl (d, st : state) =
IS.member (ns, n)
andalso
(case #1 c of
- CRel i => i <> nargs - pos
+ CRel i => i <> nargs - pos + cn
| _ => true)
| ECApp (e, _) => isIrregular (e, pos + 1)
| _ => false
in
isIrregular (e, 1)
end
- | ECAbs _ => true
| _ => false
- val irregular = U.Exp.exists {kind = kind, con = con, exp = exp}
+ fun bind (cn, b) =
+ case b of
+ U.Exp.RelC _ => cn+1
+ | _ => cn
+
+ val irregular = U.Exp.existsB {kind = kind, con = con, exp = exp, bind = bind} 0
in
if List.exists (fn x => irregular (deAbs (#4 x, cargs))) vis then
- (d, st)
+ (print "Poppycock!\n"; (d, st))
else
(d, {funcs = foldl (fn (vi, funcs) =>
IM.insert (funcs, #2 vi, {kinds = cargs,