summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2010-05-16 15:34:24 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2010-05-16 15:34:24 -0400
commit44ffaada5a0dc5ade3a73fe9b54fea1639eb2730 (patch)
treea87856f597a385b0dcd0541eecad1cc355221a61
parenta86fbcb8f79e6f505ff2bd93fe6a73aacd1f7c31 (diff)
Fix C-mangling of datatype names
-rw-r--r--lib/ur/monad.ur12
-rw-r--r--lib/ur/monad.urs7
-rw-r--r--src/cjr_print.sml4
-rw-r--r--src/prim.sml6
4 files changed, 23 insertions, 6 deletions
diff --git a/lib/ur/monad.ur b/lib/ur/monad.ur
index 211b6cbd..4fc1de87 100644
--- a/lib/ur/monad.ur
+++ b/lib/ur/monad.ur
@@ -92,3 +92,15 @@ fun foldMapR [K] [m] (_ : monad m) [tf :: K -> Type] [tf' :: K -> Type] [tr :: {
return ({nm = p'.1} ++ p.1, p'.2))
(fn _ => return ({}, i))
fl
+
+fun appR2 [K] [m] (_ : monad m) [tf1 :: K -> Type] [tf2 :: K -> Type]
+ (f : nm :: Name -> t :: K -> rest :: {K}
+ -> [[nm] ~ rest] =>
+ tf1 t -> tf2 t -> m unit)
+ [r ::: {K}] (fl : folder r) =
+ @Top.fold [fn r :: {K} => $(map tf1 r) -> $(map tf2 r) -> m unit]
+ (fn [nm :: Name] [t :: K] [rest :: {K}] [[nm] ~ rest] acc r1 r2 =>
+ acc (r1 -- nm) (r2 -- nm);
+ f [nm] [t] [rest] ! r1.nm r2.nm)
+ (fn _ _ => return ())
+ fl
diff --git a/lib/ur/monad.urs b/lib/ur/monad.urs
index cf20dd0f..7bac8756 100644
--- a/lib/ur/monad.urs
+++ b/lib/ur/monad.urs
@@ -60,3 +60,10 @@ val foldMapR : K --> m ::: (Type -> Type) -> monad m
tf t -> tr rest -> m (tf' t * tr ([nm = t] ++ rest)))
-> tr []
-> r ::: {K} -> folder r -> $(map tf r) -> m ($(map tf' r) * tr r)
+
+val appR2 : K --> m ::: (Type -> Type) -> monad m
+ -> tf1 :: (K -> Type) -> tf2 :: (K -> Type)
+ -> (nm :: Name -> t :: K -> rest :: {K}
+ -> [[nm] ~ rest] =>
+ tf1 t -> tf2 t -> m unit)
+ -> r ::: {K} -> folder r -> $(map tf1 r) -> $(map tf2 r) -> m unit
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index f0038de6..06999dec 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -79,7 +79,7 @@ fun p_typ' par env (t, loc) =
| TDatatype (Enum, n, _) =>
(box [string "enum",
space,
- string ("__uwe_" ^ #1 (E.lookupDatatype env n) ^ "_" ^ Int.toString n)]
+ string ("__uwe_" ^ ident (#1 (E.lookupDatatype env n)) ^ "_" ^ Int.toString n)]
handle CjrEnv.UnboundNamed _ => string ("__uwd_UNBOUND__" ^ Int.toString n))
| TDatatype (Option, n, xncs) =>
(case ListUtil.search #3 (!xncs) of
@@ -93,7 +93,7 @@ fun p_typ' par env (t, loc) =
| TDatatype (Default, n, _) =>
(box [string "struct",
space,
- string ("__uwd_" ^ #1 (E.lookupDatatype env n) ^ "_" ^ Int.toString n ^ "*")]
+ string ("__uwd_" ^ ident (#1 (E.lookupDatatype env n)) ^ "_" ^ Int.toString n ^ "*")]
handle CjrEnv.UnboundNamed _ => string ("__uwd_UNBOUND__" ^ Int.toString n))
| TFfi (m, x) => box [string "uw_", p_ident m, string "_", p_ident x]
| TOption t =>
diff --git a/src/prim.sml b/src/prim.sml
index 849518f4..d4471143 100644
--- a/src/prim.sml
+++ b/src/prim.sml
@@ -74,14 +74,12 @@ fun pad (n, ch, s) =
else
str ch ^ pad (n-1, ch, s)
-val gccify = String.toCString
-
fun p_t_GCC t =
case t of
Int n => string (int2s n)
| Float n => string (float2s n)
- | String s => box [string "\"", string (gccify s), string "\""]
- | Char ch => box [string "'", string (gccify (str ch)), string "'"]
+ | String s => box [string "\"", string (String.toCString s), string "\""]
+ | Char ch => box [string "'", string (Char.toCString ch), string "'"]
fun equal x =
case x of