src/Pure/Tools/nbe_eval.ML
changeset 23397 2cc3352f6c3c
parent 23178 07ba6b58b3d2
child 24219 e558fe311376
equal deleted inserted replaced
23396:6d72ababc58f 23397:2cc3352f6c3c
    21     | AbsN of int * nterm (*binding of named variables*);
    21     | AbsN of int * nterm (*binding of named variables*);
    22   datatype Univ = 
    22   datatype Univ = 
    23       Constr of string*(Univ list)       (*named constructors*)
    23       Constr of string*(Univ list)       (*named constructors*)
    24     | Var of string*(Univ list)          (*free variables*)
    24     | Var of string*(Univ list)          (*free variables*)
    25     | BVar of int*(Univ list)            (*bound named variables*)
    25     | BVar of int*(Univ list)            (*bound named variables*)
    26     | Fun of (Univ list -> Univ) * (Univ list) * int * (unit -> nterm)
    26     | Fun of (Univ list -> Univ) * (Univ list) * int
    27                                          (*functions*);
    27                                          (*functions*);
    28 
    28 
    29   val eval: theory -> Univ Symtab.table -> term -> nterm
    29   val eval: theory -> Univ Symtab.table -> term -> nterm
    30   val apply: Univ -> Univ -> Univ
    30   val apply: Univ -> Univ -> Univ
    31   val prep_term: theory -> term -> term
    31   val prep_term: theory -> term -> term
    85 
    85 
    86 datatype Univ = 
    86 datatype Univ = 
    87     Constr of string*(Univ list)       (* Named Constructors *)
    87     Constr of string*(Univ list)       (* Named Constructors *)
    88   | Var of string*(Univ list)          (* Free variables *)
    88   | Var of string*(Univ list)          (* Free variables *)
    89   | BVar of int*(Univ list)         (* Bound named variables *)
    89   | BVar of int*(Univ list)         (* Bound named variables *)
    90   | Fun of (Univ list -> Univ) * (Univ list) * int * (unit -> nterm);
    90   | Fun of (Univ list -> Univ) * (Univ list) * int;
    91 
       
    92 fun to_term (Constr(name, args))    = apps (C name) (map to_term args)
       
    93   | to_term (Var   (name, args))    = apps (V name) (map to_term args)
       
    94   | to_term (BVar  (name, args))    = apps (B name) (map to_term args)
       
    95   | to_term (Fun(_,args,_,name_thunk)) = apps (name_thunk ()) (map to_term args);
       
    96 
    91 
    97 (*
    92 (*
    98    A typical operation, why functions might be good for, is
    93    A typical operation, why functions might be good for, is
    99    application. Moreover, functions are the only values that can
    94    application. Moreover, functions are the only values that can
   100    reasonably we applied in a semantical way.
    95    reasonably we applied in a semantical way.
   101 *)
    96 *)
   102 
    97 
   103 fun apply (Fun(f,xs,1,name))  x = f (x::xs)
    98 fun apply (Fun(f,xs,1))  x = f (x::xs)
   104   | apply (Fun(f,xs,n,name))  x = Fun(f,x::xs,n-1,name)
    99   | apply (Fun(f,xs,n))  x = Fun(f,x::xs,n-1)
   105   | apply (Constr(name,args)) x = Constr(name,x::args)
   100   | apply (Constr(name,args)) x = Constr(name,x::args)
   106   | apply (Var(name,args))    x = Var(name,x::args)
   101   | apply (Var(name,args))    x = Var(name,x::args)
   107   | apply (BVar(name,args))   x = BVar(name,x::args);
   102   | apply (BVar(name,args))   x = BVar(name,x::args);
   108 
   103 
   109 fun mk_Fun(name,v,0) = (name,v [])
   104 fun mk_Fun(name,v,0) = (name,v [])
   110   | mk_Fun(name,v,n) = (name,Fun(v,[],n, fn () => C name));
   105   | mk_Fun(name,v,n) = (name,Fun(v,[],n));
   111 
   106 
   112 
   107 
   113 (* ------------------ evaluation with greetings to Tarski ------------------ *)
   108 (* ------------------ evaluation with greetings to Tarski ------------------ *)
   114 
   109 
   115 fun prep_term thy (Const c) = Const (CodegenNames.const thy
   110 fun prep_term thy (Const c) = Const (CodegenNames.const thy
   116       (CodegenConsts.const_of_cexpr thy c), dummyT)
   111       (CodegenConsts.const_of_cexpr thy c), dummyT)
   117   | prep_term thy (Free v_ty) = Free v_ty
   112   | prep_term thy (Free v_ty) = Free v_ty
   118   | prep_term thy (s $ t) = prep_term thy s $ prep_term thy t
   113   | prep_term thy (s $ t) = prep_term thy s $ prep_term thy t
   119   | prep_term thy (Abs (raw_v, ty, raw_t)) =
   114   | prep_term thy (Abs (raw_v, ty, raw_t)) =
   120       let
   115       let val (v,t) = Syntax.variant_abs (raw_v, ty, raw_t);
   121         val (v, t) = Syntax.variant_abs (raw_v, ty, raw_t);
       
   122       in Abs (v, ty, prep_term thy t) end;
   116       in Abs (v, ty, prep_term thy t) end;
   123 
   117 
   124 
   118 
   125 (* generation of fresh names *)
   119 (* generation of fresh names *)
   126 
   120 
   127 val counter = ref 0;
   121 val counter = ref 0;
   128 fun new_name () = (counter := !counter +1; !counter);
   122 fun new_name () = (counter := !counter +1; !counter);
       
   123 
       
   124 fun to_term (Constr(name, args))    = apps (C name) (map to_term args)
       
   125   | to_term (Var   (name, args))    = apps (V name) (map to_term args)
       
   126   | to_term (BVar  (name, args))    = apps (B name) (map to_term args)
       
   127   | to_term (F as Fun _) =
       
   128       let val var = new_name()
       
   129       in AbsN(var, to_term (apply F (BVar(var,[])))) end;
   129 
   130 
   130 
   131 
   131 (* greetings to Tarski *)
   132 (* greetings to Tarski *)
   132 
   133 
   133 fun eval thy tab t =
   134 fun eval thy tab t =
   137       | evl vars (Free (v, _)) =
   138       | evl vars (Free (v, _)) =
   138           the_default (Var (v, [])) (AList.lookup (op =) vars v)
   139           the_default (Var (v, [])) (AList.lookup (op =) vars v)
   139       | evl vars (s $ t) =
   140       | evl vars (s $ t) =
   140           apply (evl vars s) (evl vars t)
   141           apply (evl vars s) (evl vars t)
   141       | evl vars (Abs (v, _, t)) =
   142       | evl vars (Abs (v, _, t)) =
   142           Fun (fn [x] => evl (AList.update (op =) (v, x) vars) t, [], 1,
   143           Fun (fn [x] => evl (AList.update (op =) (v, x) vars) t, [], 1)
   143             fn () => let val var = new_name() in
       
   144               AbsN (var, to_term (evl (AList.update (op =) (v, BVar (var, [])) vars) t)) end)
       
   145   in (counter := 0; to_term (evl [] (prep_term thy t))) end;
   144   in (counter := 0; to_term (evl [] (prep_term thy t))) end;
   146 
   145 
   147 end;
   146 end;