(temporary workaround)
authorhaftmann
Thu, 25 Sep 2008 11:14:01 +0200
changeset 28353 40306cc4d16a
parent 28352 cab797b79421
child 28354 c5fe7372ae4e
(temporary workaround)
src/HOL/ex/ROOT.ML
src/Pure/Isar/code.ML
--- a/src/HOL/ex/ROOT.ML	Thu Sep 25 10:17:23 2008 +0200
+++ b/src/HOL/ex/ROOT.ML	Thu Sep 25 11:14:01 2008 +0200
@@ -18,7 +18,7 @@
 ];
 
 no_document use_thy "Codegenerator";
-(*no_document use_thy "Codegenerator_Pretty";*)
+no_document use_thy "Codegenerator_Pretty";
 
 use_thys [
   "Numeral",
--- a/src/Pure/Isar/code.ML	Thu Sep 25 10:17:23 2008 +0200
+++ b/src/Pure/Isar/code.ML	Thu Sep 25 11:14:01 2008 +0200
@@ -773,13 +773,18 @@
 local
 
 fun apply_functrans thy [] = []
-  | apply_functrans thy (thms as thm :: _) =
+  | apply_functrans thy (thms as (thm, _) :: _) =
       let
         val const = const_of_func thy thm;
         val functrans = (map (fn (_, (_, f)) => f thy) o #functrans
           o the_thmproc o the_exec) thy;
-        val thms' = perhaps (perhaps_loop (perhaps_apply functrans)) thms;
-      in certify_const thy const thms' end;
+        val thms' = perhaps (perhaps_loop (perhaps_apply functrans)) (map fst thms);
+        val thms'' = certify_const thy const thms';
+        val linears = map snd thms;
+      in (*FIXME temporary workaround*) if length thms'' = length linears
+        then thms'' ~~ linears
+        else map (rpair true) thms''
+      end;
 
 fun rhs_conv conv thm =
   let
@@ -801,10 +806,10 @@
   in
     thms
     |> apply_functrans thy
-    |> map (Code_Unit.rewrite_func pre)
+    |> (map o apfst) (Code_Unit.rewrite_func pre)
     (*FIXME - must check here: rewrite rule, defining equation, proper constant *)
-    |> map (AxClass.unoverload thy)
-    |> common_typ_funcs
+    |> (map o apfst) (AxClass.unoverload thy)
+    |> burrow_fst common_typ_funcs
   end;
 
 
@@ -858,7 +863,7 @@
       o ObjectLogic.drop_judgment thy o Thm.plain_prop_of o fst);
   in
     get_funcs thy const
-    |> burrow_fst (preprocess thy)
+    |> preprocess thy
     |> drop_refl thy
   end;