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 |