summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-09-15 12:41:54 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-09-15 12:41:54 -0400
commitb741cb156921b5de75e2955b8cd4f71c89268e7e (patch)
treed6603b8c61d4657448e07ca3389d291a44242adc
parent56492a2c4801e14de9f195b924bff0b48f68d2c4 (diff)
Escape character constants; lift indices properly in Reduce 'case' simplification
-rw-r--r--src/prim.sml4
-rw-r--r--src/reduce.sml123
2 files changed, 67 insertions, 60 deletions
diff --git a/src/prim.sml b/src/prim.sml
index 597b3fba..c84c557e 100644
--- a/src/prim.sml
+++ b/src/prim.sml
@@ -41,7 +41,7 @@ fun p_t t =
Int n => string (Int64.toString n)
| Float n => string (Real64.toString n)
| String s => box [string "\"", string (String.toString s), string "\""]
- | Char ch => box [string "#\"", string (String.str ch), string "\""]
+ | Char ch => box [string "#\"", string (String.toString (String.str ch)), string "\""]
fun int2s n =
if Int64.compare (n, Int64.fromInt 0) = LESS then
@@ -73,7 +73,7 @@ fun p_t_GCC t =
Int n => string (int2s n)
| Float n => string (float2s n)
| String s => box [string "\"", string (String.toString s), string "\""]
- | Char ch => box [string "'", string (str ch), string "'"]
+ | Char ch => box [string "'", string (String.toString (str ch)), string "'"]
fun equal x =
case x of
diff --git a/src/reduce.sml b/src/reduce.sml
index 54977432..bcd502cc 100644
--- a/src/reduce.sml
+++ b/src/reduce.sml
@@ -104,65 +104,72 @@ val deKnown = ListUtil.mapConcat (fn KnownC _ => []
datatype result = Yes of env | No | Maybe
fun match (env, p : pat, e : exp) =
- case (#1 p, #1 e) of
- (PWild, _) => Yes env
- | (PVar (x, t), _) => Yes (KnownE e :: env)
-
- | (PPrim p, EPrim p') =>
- if Prim.equal (p, p') then
- Yes env
- else
- No
-
- | (PCon (_, PConVar n1, _, NONE), ECon (_, PConVar n2, _, NONE)) =>
- if n1 = n2 then
- Yes env
- else
- No
-
- | (PCon (_, PConVar n1, _, SOME p), ECon (_, PConVar n2, _, SOME e)) =>
- if n1 = n2 then
- match (env, p, e)
- else
- No
-
- | (PCon (_, PConFfi {mod = m1, con = con1, ...}, _, NONE),
- ECon (_, PConFfi {mod = m2, con = con2, ...}, _, NONE)) =>
- if m1 = m2 andalso con1 = con2 then
- Yes env
- else
- No
-
- | (PCon (_, PConFfi {mod = m1, con = con1, ...}, _, SOME ep),
- ECon (_, PConFfi {mod = m2, con = con2, ...}, _, SOME e)) =>
- if m1 = m2 andalso con1 = con2 then
- match (env, p, e)
- else
- No
-
- | (PRecord xps, ERecord xes) =>
- if List.exists (fn ((CName _, _), _, _) => false
- | _ => true) xes then
- Maybe
- else
- let
- fun consider (xps, env) =
- case xps of
- [] => Yes env
- | (x, p, _) :: rest =>
- case List.find (fn ((CName x', _), _, _) => x' = x
- | _ => false) xes of
- NONE => No
- | SOME (_, e, _) =>
- case match (env, p, e) of
- No => No
- | Maybe => Maybe
- | Yes env => consider (rest, env)
- in
- consider (xps, env)
- end
+ let
+ val baseline = length env
+
+ fun match (env, p, e) =
+ case (#1 p, #1 e) of
+ (PWild, _) => Yes env
+ | (PVar (x, t), _) => Yes (KnownE (multiLiftExpInExp (length env - baseline) e) :: env)
+
+ | (PPrim p, EPrim p') =>
+ if Prim.equal (p, p') then
+ Yes env
+ else
+ No
+
+ | (PCon (_, PConVar n1, _, NONE), ECon (_, PConVar n2, _, NONE)) =>
+ if n1 = n2 then
+ Yes env
+ else
+ No
- | _ => Maybe
+ | (PCon (_, PConVar n1, _, SOME p), ECon (_, PConVar n2, _, SOME e)) =>
+ if n1 = n2 then
+ match (env, p, e)
+ else
+ No
+
+ | (PCon (_, PConFfi {mod = m1, con = con1, ...}, _, NONE),
+ ECon (_, PConFfi {mod = m2, con = con2, ...}, _, NONE)) =>
+ if m1 = m2 andalso con1 = con2 then
+ Yes env
+ else
+ No
+
+ | (PCon (_, PConFfi {mod = m1, con = con1, ...}, _, SOME ep),
+ ECon (_, PConFfi {mod = m2, con = con2, ...}, _, SOME e)) =>
+ if m1 = m2 andalso con1 = con2 then
+ match (env, p, e)
+ else
+ No
+
+ | (PRecord xps, ERecord xes) =>
+ if List.exists (fn ((CName _, _), _, _) => false
+ | _ => true) xes then
+ Maybe
+ else
+ let
+ fun consider (xps, env) =
+ case xps of
+ [] => Yes env
+ | (x, p, _) :: rest =>
+ case List.find (fn ((CName x', _), _, _) => x' = x
+ | _ => false) xes of
+ NONE => No
+ | SOME (_, e, _) =>
+ case match (env, p, e) of
+ No => No
+ | Maybe => Maybe
+ | Yes env => consider (rest, env)
+ in
+ consider (xps, env)
+ end
+
+ | _ => Maybe
+ in
+ match (env, p, e)
+ end
fun kindConAndExp (namedC, namedE) =
let