src/Pure/codegen.ML
changeset 29270 0eade173f77e
parent 29266 4a478f9d2847
child 30288 a32700e45ab3
equal deleted inserted replaced
29269:5c25a2012975 29270:0eade173f77e
   275   let val {preprocs, ...} = CodegenData.get thy
   275   let val {preprocs, ...} = CodegenData.get thy
   276   in fold (fn (_, f) => f thy) preprocs end;
   276   in fold (fn (_, f) => f thy) preprocs end;
   277 
   277 
   278 fun preprocess_term thy t =
   278 fun preprocess_term thy t =
   279   let
   279   let
   280     val x = Free (Name.variant (add_term_names (t, [])) "x", fastype_of t);
   280     val x = Free (Name.variant (OldTerm.add_term_names (t, [])) "x", fastype_of t);
   281     (* fake definition *)
   281     (* fake definition *)
   282     val eq = setmp quick_and_dirty true (SkipProof.make_thm thy)
   282     val eq = setmp quick_and_dirty true (SkipProof.make_thm thy)
   283       (Logic.mk_equals (x, t));
   283       (Logic.mk_equals (x, t));
   284     fun err () = error "preprocess_term: bad preprocessor"
   284     fun err () = error "preprocess_term: bad preprocessor"
   285   in case map prop_of (preprocess thy [eq]) of
   285   in case map prop_of (preprocess thy [eq]) of
   457 fun thyname_of_const thy =
   457 fun thyname_of_const thy =
   458   thyname_of thy (Consts.the_tags (Sign.consts_of thy));
   458   thyname_of thy (Consts.the_tags (Sign.consts_of thy));
   459 
   459 
   460 fun rename_terms ts =
   460 fun rename_terms ts =
   461   let
   461   let
   462     val names = List.foldr add_term_names
   462     val names = List.foldr OldTerm.add_term_names
   463       (map (fst o fst) (rev (fold Term.add_vars ts []))) ts;
   463       (map (fst o fst) (rev (fold Term.add_vars ts []))) ts;
   464     val reserved = filter ML_Syntax.is_reserved names;
   464     val reserved = filter ML_Syntax.is_reserved names;
   465     val (illegal, alt_names) = split_list (map_filter (fn s =>
   465     val (illegal, alt_names) = split_list (map_filter (fn s =>
   466       let val s' = mk_id s in if s = s' then NONE else SOME (s, s') end) names)
   466       let val s' = mk_id s in if s = s' then NONE else SOME (s, s') end) names)
   467     val ps = (reserved @ illegal) ~~
   467     val ps = (reserved @ illegal) ~~
   482 
   482 
   483 
   483 
   484 (**** retrieve definition of constant ****)
   484 (**** retrieve definition of constant ****)
   485 
   485 
   486 fun is_instance T1 T2 =
   486 fun is_instance T1 T2 =
   487   Type.raw_instance (T1, if null (typ_tfrees T2) then T2 else Logic.varifyT T2);
   487   Type.raw_instance (T1, if null (OldTerm.typ_tfrees T2) then T2 else Logic.varifyT T2);
   488 
   488 
   489 fun get_assoc_code thy (s, T) = Option.map snd (find_first (fn ((s', T'), _) =>
   489 fun get_assoc_code thy (s, T) = Option.map snd (find_first (fn ((s', T'), _) =>
   490   s = s' andalso is_instance T T') (#consts (CodegenData.get thy)));
   490   s = s' andalso is_instance T T') (#consts (CodegenData.get thy)));
   491 
   491 
   492 fun get_aux_code xs = map_filter (fn (m, code) =>
   492 fun get_aux_code xs = map_filter (fn (m, code) =>
   596          separate (Pretty.brk 1) (p :: ps) @ [str ")"])
   596          separate (Pretty.brk 1) (p :: ps) @ [str ")"])
   597      else Pretty.block (separate (Pretty.brk 1) (p :: ps));
   597      else Pretty.block (separate (Pretty.brk 1) (p :: ps));
   598 
   598 
   599 fun new_names t xs = Name.variant_list
   599 fun new_names t xs = Name.variant_list
   600   (map (fst o fst o dest_Var) (OldTerm.term_vars t) union
   600   (map (fst o fst o dest_Var) (OldTerm.term_vars t) union
   601     add_term_names (t, ML_Syntax.reserved_names)) (map mk_id xs);
   601     OldTerm.add_term_names (t, ML_Syntax.reserved_names)) (map mk_id xs);
   602 
   602 
   603 fun new_name t x = hd (new_names t [x]);
   603 fun new_name t x = hd (new_names t [x]);
   604 
   604 
   605 fun if_library x y = if member (op =) (!mode) "library" then x else y;
   605 fun if_library x y = if member (op =) (!mode) "library" then x else y;
   606 
   606