src/Pure/Tools/codegen_package.ML
changeset 18850 92ef83e5eaea
parent 18756 5eb3df798405
child 18865 31aed965135c
equal deleted inserted replaced
18849:05a16861d3a5 18850:92ef83e5eaea
    74 end;
    74 end;
    75 
    75 
    76 structure CodegenPackage : CODEGEN_PACKAGE =
    76 structure CodegenPackage : CODEGEN_PACKAGE =
    77 struct
    77 struct
    78 
    78 
    79 open CodegenThingolOp;
    79 open CodegenThingol;
    80 infix 8 `%%;
    80 infix 8 `%%;
    81 infixr 6 `->;
    81 infixr 6 `->;
    82 infixr 6 `-->;
    82 infixr 6 `-->;
    83 infix 4 `$;
    83 infix 4 `$;
    84 infix 4 `$$;
    84 infix 4 `$$;
   671   case get_first (fn eqx => eqx (c, ty)) (get_eqextrs thy tabs)
   671   case get_first (fn eqx => eqx (c, ty)) (get_eqextrs thy tabs)
   672    of SOME (eq_thms, ty) =>
   672    of SOME (eq_thms, ty) =>
   673         let
   673         let
   674           val sortctxt = ClassPackage.extract_sortctxt thy ty;
   674           val sortctxt = ClassPackage.extract_sortctxt thy ty;
   675           fun dest_eqthm eq_thm =
   675           fun dest_eqthm eq_thm =
   676             eq_thm
   676             let
   677             |> prop_of
   677               val ((t, args), rhs) = (apfst strip_comb o Logic.dest_equals o prop_of) eq_thm;
   678             |> Logic.dest_equals
   678             in case t
   679             |> apfst (strip_comb #> snd);
   679              of Const (c', _) => if c' = c then (args, rhs)
       
   680                  else error ("illegal function equation for " ^ quote c
       
   681                    ^ ", actually defining " ^ quote c')
       
   682               | _ => error ("illegal function equation for " ^ quote c)
       
   683             end;
   680           fun mk_eq (args, rhs) trns =
   684           fun mk_eq (args, rhs) trns =
   681             trns
   685             trns
   682             |> fold_map (exprgen_term thy tabs o devarify_term) args
   686             |> fold_map (exprgen_term thy tabs o devarify_term) args
   683             ||>> (exprgen_term thy tabs o devarify_term) rhs
   687             ||>> (exprgen_term thy tabs o devarify_term) rhs
   684             |-> (fn (args, rhs) => pair (map ipat_of_iexpr args, rhs))
   688             |-> (fn (args, rhs) => pair (map ipat_of_iexpr args, rhs))
  1177           |> #target_data
  1181           |> #target_data
  1178           |> (fn data => (the oo Symtab.lookup) data target);
  1182           |> (fn data => (the oo Symtab.lookup) data target);
  1179         in (seri (
  1183         in (seri (
  1180           (Option.map fst oo Symtab.lookup o #syntax_tyco) target_data,
  1184           (Option.map fst oo Symtab.lookup o #syntax_tyco) target_data,
  1181           (Option.map fst oo Symtab.lookup o #syntax_const) target_data
  1185           (Option.map fst oo Symtab.lookup o #syntax_const) target_data
  1182         ) "Generated" cs module : unit; thy) end;
  1186         ) cs module : unit; thy) end;
  1183   in
  1187   in
  1184     thy
  1188     thy
  1185     |> generate_code raw_consts
  1189     |> generate_code raw_consts
  1186     |-> (fn cs => serialize cs)
  1190     |-> (fn cs => serialize cs)
  1187   end;
  1191   end;
  1189 structure P = OuterParse
  1193 structure P = OuterParse
  1190 and K = OuterKeyword
  1194 and K = OuterKeyword
  1191 
  1195 
  1192 in
  1196 in
  1193 
  1197 
  1194 val (classK, generateK, serializeK,
  1198 val (generateK, serializeK,
  1195      primclassK, primtycoK, primconstK,
  1199      primclassK, primtycoK, primconstK,
  1196      syntax_tycoK, syntax_constK, aliasK) =
  1200      syntax_tycoK, syntax_constK, aliasK) =
  1197   ("code_class", "code_generate", "code_serialize",
  1201   ("code_generate", "code_serialize",
  1198    "code_primclass", "code_primtyco", "code_primconst",
  1202    "code_primclass", "code_primtyco", "code_primconst",
  1199    "code_syntax_tyco", "code_syntax_const", "code_alias");
  1203    "code_syntax_tyco", "code_syntax_const", "code_alias");
  1200 val dependingK =
  1204 val dependingK =
  1201   ("depending_on");
  1205   ("depending_on");
  1202 
  1206 
  1203 val classP =
       
  1204   OuterSyntax.command classK "codegen data for classes" K.thy_decl (
       
  1205     P.xname
       
  1206     -- ((P.$$$ "\\<Rightarrow>" || P.$$$ "=>") |-- (P.list1 P.name))
       
  1207     -- (Scan.optional ((P.$$$ "\\<Rightarrow>" || P.$$$ "=>") |-- (P.list1 P.name)) [])
       
  1208     >> (fn ((name, tycos), consts) => (Toplevel.theory (ClassPackage.add_classentry name consts tycos)))
       
  1209   )
       
  1210 
       
  1211 val generateP =
  1207 val generateP =
  1212   OuterSyntax.command generateK "generate executable code for constants" K.thy_decl (
  1208   OuterSyntax.command generateK "generate executable code for constants" K.thy_decl (
  1213     P.$$$ "("
  1209     Scan.repeat1 (P.name -- Scan.option (P.$$$ "::" |-- P.typ))
  1214     |-- Scan.repeat1 (P.name -- Scan.option (P.$$$ "::" |-- P.typ))
       
  1215     --| P.$$$ ")"
       
  1216     >> (fn raw_consts =>
  1210     >> (fn raw_consts =>
  1217           Toplevel.theory (generate_code (SOME raw_consts) #> snd))
  1211           Toplevel.theory (generate_code (SOME raw_consts) #> snd))
  1218   );
  1212   );
  1219 
  1213 
  1220 val serializeP =
  1214 val serializeP =
  1221   OuterSyntax.command serializeK "serialize executable code for constants" K.thy_decl (
  1215   OuterSyntax.command serializeK "serialize executable code for constants" K.thy_decl (
  1222     P.name
  1216     P.name
  1223     -- Scan.option (
  1217     -- Scan.option (Scan.repeat1 (P.name -- Scan.option (P.$$$ "::" |-- P.typ)))
  1224          P.$$$ "("
       
  1225          |-- Scan.repeat1 (P.name -- Scan.option (P.$$$ "::" |-- P.typ))
       
  1226          --| P.$$$ ")"
       
  1227        )
       
  1228     #-> (fn (target, raw_consts) =>
  1218     #-> (fn (target, raw_consts) =>
  1229           get_serializer target
  1219           P.$$$ "("
       
  1220           |-- get_serializer target
       
  1221           --| P.$$$ ")"
  1230           >> (fn seri =>
  1222           >> (fn seri =>
  1231             Toplevel.theory (serialize_code target seri raw_consts)
  1223             Toplevel.theory (serialize_code target seri raw_consts)
  1232           ))
  1224           ))
  1233   );
  1225   );
  1234 
  1226 
  1265          P.$$$ "(" |-- P.list1 P.name --| P.$$$ ")") []
  1257          P.$$$ "(" |-- P.list1 P.name --| P.$$$ ")") []
  1266     -- Scan.repeat1 (P.name -- P.text)
  1258     -- Scan.repeat1 (P.name -- P.text)
  1267       >> (fn ((raw_const, depends), primdefs) =>
  1259       >> (fn ((raw_const, depends), primdefs) =>
  1268             (Toplevel.theory oo fold) (add_prim_const raw_const depends) primdefs)
  1260             (Toplevel.theory oo fold) (add_prim_const raw_const depends) primdefs)
  1269   );
  1261   );
  1270 
       
  1271 val _ : OuterParse.token list -> (string -> string -> theory -> theory) * OuterParse.token list
       
  1272  = parse_syntax_tyco;
       
  1273 
  1262 
  1274 val syntax_tycoP =
  1263 val syntax_tycoP =
  1275   OuterSyntax.command syntax_tycoK "define code syntax for type constructor" K.thy_decl (
  1264   OuterSyntax.command syntax_tycoK "define code syntax for type constructor" K.thy_decl (
  1276     Scan.repeat1 (
  1265     Scan.repeat1 (
  1277       P.xname
  1266       P.xname
  1293     )
  1282     )
  1294     >> (Toplevel.theory oo fold) (fn (raw_c, syns) =>
  1283     >> (Toplevel.theory oo fold) (fn (raw_c, syns) =>
  1295           fold (fn (target, modifier) => modifier raw_c target) syns)
  1284           fold (fn (target, modifier) => modifier raw_c target) syns)
  1296   );
  1285   );
  1297 
  1286 
  1298 val _ = OuterSyntax.add_parsers [classP, generateP, serializeP, aliasP,
  1287 val _ = OuterSyntax.add_parsers [generateP, serializeP, aliasP,
  1299   primclassP, primtycoP, primconstP, syntax_tycoP, syntax_constP];
  1288   primclassP, primtycoP, primconstP, syntax_tycoP, syntax_constP];
  1300 val _ = OuterSyntax.add_keywords ["\\<Rightarrow>", "=>", dependingK];
  1289 val _ = OuterSyntax.add_keywords [dependingK];
  1301 
  1290 
  1302 
  1291 
  1303 
  1292 
  1304 (** theory setup **)
  1293 (** theory setup **)
  1305 
  1294 
  1306 val _ = Context.add_setup
  1295 val _ = Context.add_setup (
  1307  (add_eqextr ("defs", eqextr_defs) #>
  1296   add_eqextr ("defs", eqextr_defs)
  1308   add_defgen ("clsdecl", defgen_clsdecl) #>
  1297   #> add_defgen ("funs", defgen_funs)
  1309   add_defgen ("funs", defgen_funs) #>
  1298   #> add_defgen ("clsdecl", defgen_clsdecl)
  1310   add_defgen ("clsmem", defgen_clsmem) #>
  1299   #> add_defgen ("clsmem", defgen_clsmem)
  1311   add_defgen ("datatypecons", defgen_datatypecons));
  1300   #> add_defgen ("clsinst", defgen_clsinst)
  1312 
  1301   #> add_defgen ("datatypecons", defgen_datatypecons)
  1313 (*   add_appconst_i ("op =", ((2, 2), appgen_eq))  *)
  1302 (*   add_appconst_i ("op =", ((2, 2), appgen_eq))  *)
  1314 (*   add_defgen ("clsinst", defgen_clsinst)  *)
  1303 );
  1315 
  1304 
  1316 end; (* local *)
  1305 end; (* local *)
  1317 
  1306 
  1318 end; (* struct *)
  1307 end; (* struct *)