src/Pure/Tools/nbe.ML
changeset 23090 eb3000a5c478
parent 22902 ac833b4bb7ee
child 23136 5a0378eada70
equal deleted inserted replaced
23089:9669110656b9 23090:eb3000a5c478
   131 
   131 
   132 fun eval_term thy funcgr t =
   132 fun eval_term thy funcgr t =
   133   let
   133   let
   134     fun subst_Frees [] = I
   134     fun subst_Frees [] = I
   135       | subst_Frees inst =
   135       | subst_Frees inst =
   136           Term.map_aterms (fn (t as Free(s, _)) => the_default t (AList.lookup (op =) inst s)
   136           Term.map_aterms (fn (t as Free (s, _)) => the_default t (AList.lookup (op =) inst s)
   137                       | t => t);
   137                             | t => t);
   138     val anno_vars =
   138     val anno_vars =
   139       subst_Frees (map (fn (s, T) => (s, Free (s, T))) (Term.add_frees t []))
   139       subst_Frees (map (fn (s, T) => (s, Free (s, T))) (Term.add_frees t []))
   140       #> subst_Vars  (map (fn (ixn, T) => (ixn, Var(ixn,T))) (Term.add_vars t []))
   140       #> subst_Vars (map (fn (ixn, T) => (ixn, Var (ixn, T))) (Term.add_vars t []))
   141     fun check_tvars t = if null (Term.term_tvars t) then t else
   141     fun check_tvars t = if null (Term.term_tvars t) then t else
   142       error ("Illegal schematic type variables in normalized term: "
   142       error ("Illegal schematic type variables in normalized term: "
   143         ^ setmp show_types true (Sign.string_of_term thy) t);
   143         ^ setmp show_types true (Sign.string_of_term thy) t);
   144     val ty = type_of t;
   144     val ty = type_of t;
   145     fun constrain t =
   145     fun constrain t =
   146       singleton (ProofContext.infer_types (ProofContext.init thy)) (TypeInfer.constrain t ty);
   146       singleton (ProofContext.infer_types_pats (ProofContext.init thy)) (TypeInfer.constrain t ty);
   147     val _ = ensure_funs thy funcgr t;
   147     val _ = ensure_funs thy funcgr t;
   148   in
   148   in
   149     t
   149     t
   150     |> tracing (fn t => "Input:\n" ^ Display.raw_string_of_term t)
   150     |> tracing (fn t => "Input:\n" ^ Display.raw_string_of_term t)
   151     |> NBE_Eval.eval thy (!tab)
   151     |> NBE_Eval.eval thy (!tab)
   152     |> tracing (fn nt => "Normalized:\n" ^ NBE_Eval.string_of_nterm nt)
   152     |> tracing (fn nt => "Normalized:\n" ^ NBE_Eval.string_of_nterm nt)
   153     |> NBE_Codegen.nterm_to_term thy
   153     |> NBE_Codegen.nterm_to_term thy
   154     |> tracing (fn t =>"Converted back:\n" ^ Display.raw_string_of_term t)
   154     |> tracing (fn t => "Converted back:\n" ^ setmp show_types true Display.raw_string_of_term t)
       
   155     |> tracing (fn _ => "Term type:\n" ^ Display.raw_string_of_typ ty)
   155     |> anno_vars
   156     |> anno_vars
   156     |> tracing (fn t =>"Vars typed:\n" ^ Display.raw_string_of_term t)
   157     |> tracing (fn t => "Vars typed:\n" ^ setmp show_types true Display.raw_string_of_term t)
   157     |> constrain
   158     |> constrain
       
   159     |> tracing (fn t => "Types inferred:\n" ^ setmp show_types true Display.raw_string_of_term t)
   158     |> check_tvars
   160     |> check_tvars
   159   end;
   161   end;
   160 
   162 
   161 (* evaluation oracle *)
   163 (* evaluation oracle *)
   162 
   164