Mercurial > urweb

changeset 1257:fd1a49b51db5

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Fix C-mangling of datatype names
author Adam Chlipala <adamc@hcoop.net>
date Sun, 16 May 2010 15:34:24 -0400
parents d7d5b167f267
children 78b36c50daf9
files lib/ur/monad.ur lib/ur/monad.urs src/cjr_print.sml src/prim.sml
diffstat 4 files changed, 23 insertions(+), 6 deletions(-) [+]
line wrap: on
line diff
--- a/lib/ur/monad.ur	Sat May 15 12:52:34 2010 -0400
+++ b/lib/ur/monad.ur	Sun May 16 15:34:24 2010 -0400
@@ -92,3 +92,15 @@
          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
--- a/lib/ur/monad.urs	Sat May 15 12:52:34 2010 -0400
+++ b/lib/ur/monad.urs	Sun May 16 15:34:24 2010 -0400
@@ -60,3 +60,10 @@
                    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
--- a/src/cjr_print.sml	Sat May 15 12:52:34 2010 -0400
+++ b/src/cjr_print.sml	Sun May 16 15:34:24 2010 -0400
@@ -79,7 +79,7 @@
       | 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 @@
       | 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 =>
--- a/src/prim.sml	Sat May 15 12:52:34 2010 -0400
+++ b/src/prim.sml	Sun May 16 15:34:24 2010 -0400
@@ -74,14 +74,12 @@
     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