From 44ffaada5a0dc5ade3a73fe9b54fea1639eb2730 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Sun, 16 May 2010 15:34:24 -0400
Subject: Fix C-mangling of datatype names

---
 lib/ur/monad.ur   | 12 ++++++++++++
 lib/ur/monad.urs  |  7 +++++++
 src/cjr_print.sml |  4 ++--
 src/prim.sml      |  6 ++----
 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
-- 
cgit v1.2.3