diff options
Diffstat (limited to 'contrib')
73 files changed, 5457 insertions, 3543 deletions
diff --git a/contrib/correctness/pmisc.ml b/contrib/correctness/pmisc.ml index 29d8fdcf..076b11cd 100644 --- a/contrib/correctness/pmisc.ml +++ b/contrib/correctness/pmisc.ml @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliātre *) -(* $Id: pmisc.ml 5920 2004-07-16 20:01:26Z herbelin $ *) +(* $Id: pmisc.ml 8752 2006-04-27 19:37:33Z herbelin $ *) open Pp open Util @@ -216,7 +216,7 @@ let rec type_v_knsubst s = function and type_c_knsubst s ((id,v),e,pl,q) = ((id, type_v_knsubst s v), e, List.map (fun p -> { p with p_value = subst_mps s p.p_value }) pl, - option_app (fun q -> { q with a_value = subst_mps s q.a_value }) q) + option_map (fun q -> { q with a_value = subst_mps s q.a_value }) q) and binder_knsubst s (id,b) = (id, match b with BindType v -> BindType (type_v_knsubst s v) | _ -> b) diff --git a/contrib/correctness/pmonad.ml b/contrib/correctness/pmonad.ml index 31effc1b..8f1b5946 100644 --- a/contrib/correctness/pmonad.ml +++ b/contrib/correctness/pmonad.ml @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliātre *) -(* $Id: pmonad.ml 5920 2004-07-16 20:01:26Z herbelin $ *) +(* $Id: pmonad.ml 8752 2006-04-27 19:37:33Z herbelin $ *) open Util open Names @@ -76,9 +76,9 @@ let rec abstract_post ren env (e,q) = let after_id id = id_of_string ((string_of_id id) ^ "'") in let (_,go) = Peffect.get_repr e in let al = List.map (fun id -> (id,after_id id)) go in - let q = option_app (named_app (subst_in_constr al)) q in + let q = option_map (named_app (subst_in_constr al)) q in let tgo = List.map (fun (id,aid) -> (aid, trad_type_in_env ren env id)) al in - option_app (named_app (abstract tgo)) q + option_map (named_app (abstract tgo)) q (* Translation of effects types in cic types. * @@ -365,7 +365,7 @@ let make_app env ren args ren' (tf,cf) ((bl,cb),s,capp) c = @(eq_phi ren'' env s svi tf) @(List.map (fun c -> CC_hole c) holes)) in - let qapp' = option_app (named_app (subst_in_constr svi)) qapp in + let qapp' = option_map (named_app (subst_in_constr svi)) qapp in let t = make_let_in ren'' env fe [] (current_vars ren''' outf,qapp') (res,tyres) (t,ty) diff --git a/contrib/correctness/psyntax.ml4 b/contrib/correctness/psyntax.ml4 index eeec28a5..98d43112 100644 --- a/contrib/correctness/psyntax.ml4 +++ b/contrib/correctness/psyntax.ml4 @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliātre *) -(* $Id: psyntax.ml4 7740 2005-12-26 20:07:21Z herbelin $ *) +(* $Id: psyntax.ml4 8752 2006-04-27 19:37:33Z herbelin $ *) (*i camlp4deps: "parsing/grammar.cma" i*) @@ -786,7 +786,7 @@ END VERNAC COMMAND EXTEND Correctness [ "Correctness" preident(str) program(pgm) then_tac(tac) ] - -> [ Ptactic.correctness str pgm (option_app Tacinterp.interp tac) ] + -> [ Ptactic.correctness str pgm (option_map Tacinterp.interp tac) ] END (* Show Programs *) diff --git a/contrib/correctness/ptactic.ml b/contrib/correctness/ptactic.ml index e5347670..babc607d 100644 --- a/contrib/correctness/ptactic.ml +++ b/contrib/correctness/ptactic.ml @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliātre *) -(* $Id: ptactic.ml 7837 2006-01-11 09:47:32Z herbelin $ *) +(* $Id: ptactic.ml 8759 2006-04-28 12:24:14Z herbelin $ *) open Pp open Options @@ -208,8 +208,8 @@ let reduce_open_constr (em0,c) = | Cast (c',t) -> (match kind_of_term c' with | Evar (ev,_) -> - if not (Evd.in_dom em ev) then - Evd.add em ev (Evd.map em0 ev) + if not (Evd.mem em ev) then + Evd.add em ev (Evd.find em0 ev) else em | _ -> fold_constr collect em c) diff --git a/contrib/correctness/putil.ml b/contrib/correctness/putil.ml index 0eb8806c..18c3ba35 100644 --- a/contrib/correctness/putil.ml +++ b/contrib/correctness/putil.ml @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliātre *) -(* $Id: putil.ml 7837 2006-01-11 09:47:32Z herbelin $ *) +(* $Id: putil.ml 8752 2006-04-27 19:37:33Z herbelin $ *) open Util open Names @@ -41,7 +41,7 @@ let anonymous x = { a_name = Anonymous; a_value = x } let anonymous_pre b x = { p_assert = b; p_name = Anonymous; p_value = x } let force_name f x = - option_app (fun q -> { a_name = Name (f q.a_name); a_value = q.a_value }) x + option_map (fun q -> { a_name = Name (f q.a_name); a_value = q.a_value }) x let force_post_name x = force_name post_name x @@ -143,7 +143,7 @@ let rec type_c_subst s ((id,t),e,p,q) = let s' = s @ List.map (fun (x,x') -> (at_id x "", at_id x' "")) s in (id, type_v_subst s t), Peffect.subst s e, List.map (pre_app (subst_in_constr s)) p, - option_app (post_app (subst_in_constr s')) q + option_map (post_app (subst_in_constr s')) q and type_v_subst s = function Ref v -> Ref (type_v_subst s v) @@ -160,7 +160,7 @@ and binder_subst s = function let rec type_c_rsubst s ((id,t),e,p,q) = (id, type_v_rsubst s t), e, List.map (pre_app (real_subst_in_constr s)) p, - option_app (post_app (real_subst_in_constr s)) q + option_map (post_app (real_subst_in_constr s)) q and type_v_rsubst s = function Ref v -> Ref (type_v_rsubst s v) diff --git a/contrib/correctness/pwp.ml b/contrib/correctness/pwp.ml index 1e485180..f422c5cd 100644 --- a/contrib/correctness/pwp.ml +++ b/contrib/correctness/pwp.ml @@ -8,7 +8,7 @@ (* Certification of Imperative Programs / Jean-Christophe Filliātre *) -(* $Id: pwp.ml 5920 2004-07-16 20:01:26Z herbelin $ *) +(* $Id: pwp.ml 8752 2006-04-27 19:37:33Z herbelin $ *) open Util open Names @@ -64,7 +64,7 @@ let update_post env top ef c = let force_post up env top q e = let (res,ef,p,_) = e.info.kappa in let q' = - if up then option_app (named_app (update_post env top ef)) q else q + if up then option_map (named_app (update_post env top ef)) q else q in let i = { env = e.info.env; kappa = (res,ef,p,q') } in { desc = e.desc; pre = e.pre; post = q'; loc = e.loc; info = i } @@ -260,7 +260,7 @@ and propagate ren p = | Apply (f,l) -> let _,(_,so,ok),(_,_,_,qapp) = effect_app ren env f l in if ok then - let q = option_app (named_app (real_subst_in_constr so)) qapp in + let q = option_map (named_app (real_subst_in_constr so)) qapp in post_if_none env q p else p @@ -285,7 +285,7 @@ and propagate ren p = None -> Some (anonymous s) | Some i -> Some { a_value = conj i.a_value s; a_name = i.a_name } in - let q = option_app (named_app abstract_unit) q in + let q = option_map (named_app abstract_unit) q in post_if_none env q p | SApp ([Variable id], [e1;e2]) diff --git a/contrib/extraction/common.ml b/contrib/extraction/common.ml index 8d8438dc..346201ec 100644 --- a/contrib/extraction/common.ml +++ b/contrib/extraction/common.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: common.ml 7651 2005-12-16 03:19:20Z letouzey $ i*) +(*i $Id: common.ml 8930 2006-06-09 02:14:34Z letouzey $ i*) open Pp open Util @@ -112,7 +112,8 @@ let contents_first_level mp = | Extraction.Term -> add false (id_of_label l)) | (_, SPBmind mib) -> Array.iter - (fun mip -> if mip.mind_sort <> (Prop Null) then begin + (fun mip -> if snd (Inductive.mind_arity mip) <> InProp + then begin add upper_type mip.mind_typename; Array.iter (add true) mip.mind_consnames end) @@ -267,8 +268,6 @@ module StdParams = struct let globals () = !global_ids - (* TODO: remettre des conditions [lang () = Haskell] disant de qualifier. *) - let unquote s = if lang () <> Scheme then s else @@ -288,23 +287,31 @@ module StdParams = struct let mp = modpath_of_r r in let ls = if mp = List.hd mpl then [s] (* simpliest situation *) - else - try (* has [mp] something in common with one of those in [mpl] ? *) - let pref = common_prefix_from_list mp mpl in - (*i TODO: possibilité de clash i*) - list_firstn ((mp_length mp)-(mp_length pref)+1) ls - with Not_found -> (* [mp] is othogonal with every element of [mp]. *) - let base = base_mp mp in - if !modular && - (at_toplevel mp) && - not (Refset.mem r !to_qualify) && - not (clash base [] s mpl) - then snd (list_sep_last ls) - else ls + else match lang () with + | Scheme -> [s] (* no modular Scheme extraction... *) + | Toplevel -> [s] (* idem *) + | Haskell -> + if !modular then + ls (* for the moment we always qualify in modular Haskell *) + else [s] + | Ocaml -> + try (* has [mp] something in common with one of those in [mpl] ? *) + let pref = common_prefix_from_list mp mpl in + (*i TODO: possibilité de clash i*) + list_firstn ((mp_length mp)-(mp_length pref)+1) ls + with Not_found -> (* [mp] is othogonal with every element of [mp]. *) + let base = base_mp mp in + if !modular && + (at_toplevel mp) && + not (Refset.mem r !to_qualify) && + not (clash base [] s mpl) + then snd (list_sep_last ls) + else ls in add_module_contents mp s; (* update the visible environment *) str (dottify ls) + (* The next function is used only in Ocaml extraction...*) let pp_module mpl mp = let ls = if !modular @@ -393,15 +400,15 @@ let print_structure_to_file f prm struc = in let print_dummys = (struct_ast_search ((=) MLdummy) struc, - struct_type_search Tdummy struc, - struct_type_search Tunknown struc) + struct_type_search Mlutil.isDummy struc, + struct_type_search ((=) Tunknown) struc) in let print_magic = if lang () <> Haskell then false else struct_ast_search (function MLmagic _ -> true | _ -> false) struc in (* print the implementation *) - let cout = option_app (fun (f,_) -> open_out f) f in + let cout = option_map (fun (f,_) -> open_out f) f in let ft = match cout with | None -> !Pp_control.std_ft | Some cout -> Pp_control.with_output_to cout in diff --git a/contrib/extraction/extraction.ml b/contrib/extraction/extraction.ml index a4bf973d..e97df539 100644 --- a/contrib/extraction/extraction.ml +++ b/contrib/extraction/extraction.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: extraction.ml 7639 2005-12-02 10:01:15Z gregoire $ i*) +(*i $Id: extraction.ml 8931 2006-06-09 07:43:37Z letouzey $ i*) (*i*) open Util @@ -35,6 +35,9 @@ exception I of inductive_info to avoid loops in [extract_inductive] *) let internal_call = ref KNset.empty +(* A set of all fixpoint functions currently being extracted *) +let current_fixpoints = ref ([] : constant list) + let none = Evd.empty let type_of env c = Retyping.get_type_of env none (strip_outer_cast c) @@ -80,6 +83,14 @@ let rec flag_of_type env t = let is_default env t = (flag_of_type env t = (Info, Default)) +exception NotDefault of kill_reason + +let check_default env t = + match flag_of_type env t with + | _,TypeScheme -> raise (NotDefault Ktype) + | Logic,_ -> raise (NotDefault Kother) + | _ -> () + let is_info_scheme env t = (flag_of_type env t = (Info, TypeScheme)) (*s [type_sign] gernerates a signature aimed at treating a type application. *) @@ -87,7 +98,8 @@ let is_info_scheme env t = (flag_of_type env t = (Info, TypeScheme)) let rec type_sign env c = match kind_of_term (whd_betadeltaiota env none c) with | Prod (n,t,d) -> - (is_info_scheme env t)::(type_sign (push_rel_assum (n,t) env) d) + (if is_info_scheme env t then Keep else Kill Kother) + :: (type_sign (push_rel_assum (n,t) env) d) | _ -> [] let rec type_scheme_nb_args env c = @@ -105,8 +117,8 @@ let rec type_sign_vl env c = match kind_of_term (whd_betadeltaiota env none c) with | Prod (n,t,d) -> let s,vl = type_sign_vl (push_rel_assum (n,t) env) d in - if not (is_info_scheme env t) then false::s, vl - else true::s, (next_ident_away (id_of_name n) vl) :: vl + if not (is_info_scheme env t) then Kill Kother::s, vl + else Keep::s, (next_ident_away (id_of_name n) vl) :: vl | _ -> [],[] let rec nb_default_params env c = @@ -126,8 +138,8 @@ let rec nb_default_params env c = let db_from_sign s = let rec make i acc = function | [] -> acc - | true :: l -> make (i+1) (i::acc) l - | false :: l -> make i (0::acc) l + | Keep :: l -> make (i+1) (i::acc) l + | Kill _ :: l -> make i (0::acc) l in make 1 [] s (*s Create a type variable context from indications taken from @@ -150,8 +162,8 @@ let rec db_from_ind dbmap i = let parse_ind_args si args relmax = let rec parse i j = function | [] -> Intmap.empty - | false :: s -> parse (i+1) j s - | true :: s -> + | Kill _ :: s -> parse (i+1) j s + | Keep :: s -> (match kind_of_term args.(i-1) with | Rel k -> Intmap.add (relmax+1-k) j (parse (i+1) (j+1) s) | _ -> parse (i+1) (j+1) s) @@ -167,6 +179,7 @@ let parse_ind_args si args relmax = (* [j] stands for the next ML type var. [j=0] means we do not generate ML type var anymore (in subterms for example). *) + let rec extract_type env db j c args = match kind_of_term (whd_betaiotazeta c) with | App (d, args') -> @@ -183,19 +196,24 @@ let rec extract_type env db j c args = | (Info, Default) -> (* Standard case: two [extract_type] ... *) let mld = extract_type env' (0::db) j d [] in - if type_eq (mlt_env env) mld Tdummy then Tdummy - else Tarr (extract_type env db 0 t [], mld) + (match expand env mld with + | Tdummy d -> Tdummy d + | _ -> Tarr (extract_type env db 0 t [], mld)) | (Info, TypeScheme) when j > 0 -> (* A new type var. *) let mld = extract_type env' (j::db) (j+1) d [] in - if type_eq (mlt_env env) mld Tdummy then Tdummy - else Tarr (Tdummy, mld) - | _ -> + (match expand env mld with + | Tdummy d -> Tdummy d + | _ -> Tarr (Tdummy Ktype, mld)) + | _,lvl -> let mld = extract_type env' (0::db) j d [] in - if type_eq (mlt_env env) mld Tdummy then Tdummy - else Tarr (Tdummy, mld)) - | Sort _ -> Tdummy (* The two logical cases. *) - | _ when sort_of env (applist (c, args)) = InProp -> Tdummy + (match expand env mld with + | Tdummy d -> Tdummy d + | _ -> + let reason = if lvl=TypeScheme then Ktype else Kother in + Tarr (Tdummy reason, mld))) + | Sort _ -> Tdummy Ktype (* The two logical cases. *) + | _ when sort_of env (applist (c, args)) = InProp -> Tdummy Kother | Rel n -> (match lookup_rel n env with | (_,Some t,_) -> extract_type env db j (lift n t) args @@ -222,7 +240,7 @@ let rec extract_type env db j c args = (* The more precise is [mlt'], extracted after reduction *) (* The shortest is [mlt], which use abbreviations *) (* If possible, we take [mlt], otherwise [mlt']. *) - if type_eq (mlt_env env) mlt mlt' then mlt else mlt') + if expand env mlt = expand env mlt' then mlt else mlt') | _ -> (* only other case here: Info, Default, i.e. not an ML type *) (match cb.const_body with | None -> Tunknown (* Brutal approximation ... *) @@ -242,7 +260,7 @@ let rec extract_type env db j c args = and extract_maybe_type env db c = let t = whd_betadeltaiota env none (type_of env c) in if isSort t then extract_type env db 0 c [] - else if sort_of env t = InProp then Tdummy else Tunknown + else if sort_of env t = InProp then Tdummy Kother else Tunknown (*s Auxiliary function dealing with type application. Precondition: [r] is a type scheme represented by the signature [s], @@ -251,7 +269,7 @@ and extract_maybe_type env db c = and extract_type_app env db (r,s) args = let ml_args = List.fold_right - (fun (b,c) a -> if b then + (fun (b,c) a -> if b=Keep then let p = List.length (fst (splay_prod env none (type_of env c))) in let db = iterate (fun l -> 0 :: l) p db in (extract_type_scheme env db c p) :: a @@ -301,9 +319,10 @@ and extract_ind env kn = (* kn is supposed to be in long form *) (* their type var list. *) let packets = Array.map - (fun mip -> - let b = mip.mind_sort <> (Prop Null) in - let s,v = if b then type_sign_vl env mip.mind_nf_arity else [],[] in + (fun mip -> + let b = snd (mind_arity mip) <> InProp in + let ar = Inductive.type_of_inductive (mib,mip) in + let s,v = if b then type_sign_vl env ar else [],[] in let t = Array.make (Array.length mip.mind_nf_lc) [] in { ip_typename = mip.mind_typename; ip_consnames = mip.mind_consnames; @@ -341,7 +360,7 @@ and extract_ind env kn = (* kn is supposed to be in long form *) if p.ip_logical then raise (I Standard); if Array.length p.ip_types <> 1 then raise (I Standard); let typ = p.ip_types.(0) in - let l = List.filter (type_neq (mlt_env env) Tdummy) typ in + let l = List.filter (fun t -> not (isDummy (expand env t))) typ in if List.length l = 1 && not (type_mem_kn kn (List.hd l)) then raise (I Singleton); if l = [] then raise (I Standard); @@ -365,14 +384,15 @@ and extract_ind env kn = (* kn is supposed to be in long form *) let rec select_fields l typs = match l,typs with | [],[] -> [] | (Name id)::l, typ::typs -> - if type_eq (mlt_env env) Tdummy typ then select_fields l typs + if isDummy (expand env typ) then select_fields l typs else let knp = make_con mp d (label_of_id id) in - if not (List.mem false (type_to_sign (mlt_env env) typ)) then + if not (List.exists isKill (type2signature env typ)) + then projs := Cset.add knp !projs; (ConstRef knp) :: (select_fields l typs) | Anonymous::l, typ::typs -> - if type_eq (mlt_env env) Tdummy typ then select_fields l typs + if isDummy (expand env typ) then select_fields l typs else error_record r | _ -> assert false in @@ -381,7 +401,8 @@ and extract_ind env kn = (* kn is supposed to be in long form *) (* Is this record officially declared with its projections ? *) (* If so, we use this information. *) begin try - let n = nb_default_params env mip0.mind_nf_arity in + let n = nb_default_params env (Inductive.type_of_inductive(mib,mip0)) + in List.iter (option_iter (fun kn -> if Cset.mem kn !projs then add_projection n kn)) @@ -439,9 +460,9 @@ and mlt_env env r = match r with | _ -> None)) | _ -> None -let type_expand env = type_expand (mlt_env env) -let type_neq env = type_neq (mlt_env env) -let type_to_sign env = type_to_sign (mlt_env env) +and expand env = type_expand (mlt_env env) +and type2signature env = type_to_signature (mlt_env env) +let type2sign env = type_to_sign (mlt_env env) let type_expunge env = type_expunge (mlt_env env) (*s Extraction of the type of a constant. *) @@ -478,10 +499,9 @@ let rec extract_term env mle mlt c args = in extract_term env mle mlt d' [] | [] -> let env' = push_rel_assum (Name id, t) env in - let id, a = - if is_default env t - then id, new_meta () - else dummy_name, Tdummy in + let id, a = try check_default env t; id, new_meta() + with NotDefault d -> dummy_name, Tdummy d + in let b = new_meta () in (* If [mlt] cannot be unified with an arrow type, then magic! *) let magic = needs_magic (mlt, Tarr (a, b)) in @@ -491,15 +511,16 @@ let rec extract_term env mle mlt c args = let id = id_of_name n in let env' = push_rel (Name id, Some c1, t1) env in let args' = List.map (lift 1) args in - if is_default env t1 then + (try + check_default env t1; let a = new_meta () in let c1' = extract_term env mle a c1 [] in (* The type of [c1'] is generalized and stored in [mle]. *) let mle' = Mlenv.push_gen mle a in MLletin (id, c1', extract_term env' mle' mlt c2 args') - else - let mle' = Mlenv.push_std_type mle Tdummy in - ast_pop (extract_term env' mle' mlt c2 args') + with NotDefault d -> + let mle' = Mlenv.push_std_type mle (Tdummy d) in + ast_pop (extract_term env' mle' mlt c2 args')) | Const kn -> extract_cst_app env mle mlt kn args | Construct cp -> @@ -521,8 +542,10 @@ let rec extract_term env mle mlt c args = (*s [extract_maybe_term] is [extract_term] for usual terms, else [MLdummy] *) and extract_maybe_term env mle mlt c = - if is_default env (type_of env c) then extract_term env mle mlt c [] - else put_magic (mlt, Tdummy) MLdummy + try check_default env (type_of env c); + extract_term env mle mlt c [] + with NotDefault d -> + put_magic (mlt, Tdummy d) MLdummy (*s Generic way to deal with an application. *) @@ -540,7 +563,7 @@ and extract_app env mle mlt mk_head args = and make_mlargs env e s args typs = let l = ref s in - let keep () = match !l with [] -> true | b :: s -> l:=s; b in + let keep () = match !l with [] -> true | b :: s -> l:=s; b=Keep in let rec f = function | [], [] -> [] | a::la, t::lt when keep() -> extract_maybe_term env e t a :: (f (la,lt)) @@ -553,19 +576,25 @@ and make_mlargs env e s args typs = and extract_cst_app env mle mlt kn args = (* First, the [ml_schema] of the constant, in expanded version. *) let nb,t = record_constant_type env kn None in - let schema = nb, type_expand env t in + let schema = nb, expand env t in + (* Can we instantiate types variables for this constant ? *) + (* In Ocaml, inside the definition of this constant, the answer is no. *) + let instantiated = + if lang () = Ocaml && List.mem kn !current_fixpoints then var2var' (snd schema) + else instantiation schema + in (* Then the expected type of this constant. *) - let metas = List.map new_meta args in + let a = new_meta () in (* We compare stored and expected types in two steps. *) (* First, can [kn] be applied to all args ? *) - let a = new_meta () in - let magic1 = needs_magic (type_recomp (metas, a), instantiation schema) in + let metas = List.map new_meta args in + let magic1 = needs_magic (type_recomp (metas, a), instantiated) in (* Second, is the resulting type compatible with the expected type [mlt] ? *) let magic2 = needs_magic (a, mlt) in (* The internal head receives a magic if [magic1] *) let head = put_magic_if magic1 (MLglob (ConstRef kn)) in (* Now, the extraction of the arguments. *) - let s = type_to_sign env (snd schema) in + let s = type2signature env (snd schema) in let ls = List.length s in let la = List.length args in let mla = make_mlargs env mle s args metas in @@ -580,8 +609,8 @@ and extract_cst_app env mle mlt kn args = in (* Different situations depending of the number of arguments: *) if ls = 0 then put_magic_if magic2 head - else if List.mem true s then - if la >= ls || not (List.mem false s) + else if List.mem Keep s then + if la >= ls || not (List.exists isKill s) then put_magic_if (magic2 && not magic1) (MLapp (head, mla)) else @@ -590,12 +619,17 @@ and extract_cst_app env mle mlt kn args = let s' = list_lastn ls' s in let mla = (List.map (ast_lift ls') mla) @ (eta_args_sign ls' s') in put_magic_if magic2 (anonym_or_dummy_lams (MLapp (head, mla)) s') - else + else if List.mem (Kill Kother) s then (* In the special case of always false signature, one dummy lam is left. *) (* So a [MLdummy] is left accordingly. *) if la >= ls then put_magic_if (magic2 && not magic1) (MLapp (head, MLdummy :: mla)) else put_magic_if magic2 (dummy_lams head (ls-la-1)) + else (* s is made only of [Kill Ktype] *) + if la >= ls + then put_magic_if (magic2 && not magic1) (MLapp (head, mla)) + else put_magic_if magic2 (dummy_lams head (ls-la)) + (*s Extraction of an inductive constructor applied to arguments. *) @@ -613,12 +647,12 @@ and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) args = let params_nb = mi.ind_nparams in let oi = mi.ind_packets.(i) in let nb_tvars = List.length oi.ip_vars - and types = List.map (type_expand env) oi.ip_types.(j-1) in + and types = List.map (expand env) oi.ip_types.(j-1) in let list_tvar = List.map (fun i -> Tvar i) (interval 1 nb_tvars) in let type_cons = type_recomp (types, Tglob (IndRef ip, list_tvar)) in let type_cons = instantiation (nb_tvars, type_cons) in (* Then, the usual variables [s], [ls], [la], ... *) - let s = List.map (type_neq env Tdummy) types in + let s = List.map (type2sign env) types in let ls = List.length s in let la = List.length args in assert (la <= ls + params_nb); @@ -671,8 +705,8 @@ and extract_case env mle ((kn,i) as ip,c,br) mlt = (* Logical singleton case: *) (* [match c with C i j k -> t] becomes [t'] *) assert (br_size = 1); - let s = iterate (fun l -> false :: l) ni.(0) [] in - let mlt = iterate (fun t -> Tarr (Tdummy, t)) ni.(0) mlt in + let s = iterate (fun l -> Kill Kother :: l) ni.(0) [] in + let mlt = iterate (fun t -> Tarr (Tdummy Kother, t)) ni.(0) mlt in let e = extract_maybe_term env mle mlt br.(0) in snd (case_expunge s e) end @@ -686,10 +720,10 @@ and extract_case env mle ((kn,i) as ip,c,br) mlt = (* The extraction of each branch. *) let extract_branch i = (* The types of the arguments of the corresponding constructor. *) - let f t = type_subst_vect metas (type_expand env t) in + let f t = type_subst_vect metas (expand env t) in let l = List.map f oi.ip_types.(i) in (* the corresponding signature *) - let s = List.map (type_neq env Tdummy) oi.ip_types.(i) in + let s = List.map (type2sign env) oi.ip_types.(i) in (* Extraction of the branch (in functional form). *) let e = extract_maybe_term env mle (type_recomp (l,mlt)) br.(i) in (* We suppress dummy arguments according to signature. *) @@ -745,8 +779,8 @@ let extract_std_constant env kn body typ = let t = snd (record_constant_type env kn (Some typ)) in (* The real type [t']: without head lambdas, expanded, *) (* and with [Tvar] translated to [Tvar'] (not instantiable). *) - let l,t' = type_decomp (type_expand env (var2var' t)) in - let s = List.map (type_neq env Tdummy) l in + let l,t' = type_decomp (expand env (var2var' t)) in + let s = List.map (type2sign env) l in (* The initial ML environment. *) let mle = List.fold_left Mlenv.push_std_type Mlenv.empty l in (* Decomposing the top level lambdas of [body]. *) @@ -762,10 +796,12 @@ let extract_std_constant env kn body typ = let extract_fixpoint env vkn (fi,ti,ci) = let n = Array.length vkn in - let types = Array.make n Tdummy + let types = Array.make n (Tdummy Kother) and terms = Array.make n MLdummy in + let kns = Array.to_list vkn in + current_fixpoints := kns; (* for replacing recursive calls [Rel ..] by the corresponding [Const]: *) - let sub = List.rev_map mkConst (Array.to_list vkn) in + let sub = List.rev_map mkConst kns in for i = 0 to n-1 do if sort_of env ti.(i) <> InProp then begin let e,t = extract_std_constant env vkn.(i) (substl sub ci.(i)) ti.(i) in @@ -773,6 +809,7 @@ let extract_fixpoint env vkn (fi,ti,ci) = types.(i) <- t; end done; + current_fixpoints := []; Dfix (Array.map (fun kn -> ConstRef kn) vkn, terms, types) let extract_constant env kn cb = @@ -790,12 +827,14 @@ let extract_constant env kn cb = if not (is_custom r) then warning_info_ax r; let t = snd (record_constant_type env kn (Some typ)) in Dterm (r, MLaxiom, type_expunge env t) - | (Logic,TypeScheme) -> warning_log_ax r; Dtype (r, [], Tdummy) - | (Logic,Default) -> warning_log_ax r; Dterm (r, MLdummy, Tdummy)) + | (Logic,TypeScheme) -> + warning_log_ax r; Dtype (r, [], Tdummy Ktype) + | (Logic,Default) -> + warning_log_ax r; Dterm (r, MLdummy, Tdummy Kother)) | Some body -> (match flag_of_type env typ with - | (Logic, Default) -> Dterm (r, MLdummy, Tdummy) - | (Logic, TypeScheme) -> Dtype (r, [], Tdummy) + | (Logic, Default) -> Dterm (r, MLdummy, Tdummy Kother) + | (Logic, TypeScheme) -> Dtype (r, [], Tdummy Ktype) | (Info, Default) -> let e,t = extract_std_constant env kn (force body) typ in Dterm (r,e,t) @@ -809,8 +848,8 @@ let extract_constant_spec env kn cb = let r = ConstRef kn in let typ = cb.const_type in match flag_of_type env typ with - | (Logic, TypeScheme) -> Stype (r, [], Some Tdummy) - | (Logic, Default) -> Sval (r, Tdummy) + | (Logic, TypeScheme) -> Stype (r, [], Some (Tdummy Ktype)) + | (Logic, Default) -> Sval (r, Tdummy Kother) | (Info, TypeScheme) -> let s,vl = type_sign_vl env typ in (match cb.const_body with @@ -826,7 +865,7 @@ let extract_constant_spec env kn cb = let extract_inductive env kn = let ind = extract_ind env kn in add_recursors env kn; - let f l = List.filter (type_neq env Tdummy) l in + let f l = List.filter (fun t -> not (isDummy (expand env t))) l in let packets = Array.map (fun p -> { p with ip_types = Array.map f p.ip_types }) ind.ind_packets @@ -853,19 +892,19 @@ let constant_kind env cb = (*s Is a [ml_decl] logical ? *) let logical_decl = function - | Dterm (_,MLdummy,Tdummy) -> true - | Dtype (_,[],Tdummy) -> true + | Dterm (_,MLdummy,Tdummy _) -> true + | Dtype (_,[],Tdummy _) -> true | Dfix (_,av,tv) -> (array_for_all ((=) MLdummy) av) && - (array_for_all ((=) Tdummy) tv) + (array_for_all isDummy tv) | Dind (_,i) -> array_for_all (fun ip -> ip.ip_logical) i.ind_packets | _ -> false (*s Is a [ml_spec] logical ? *) let logical_spec = function - | Stype (_, [], Some Tdummy) -> true - | Sval (_,Tdummy) -> true + | Stype (_, [], Some (Tdummy _)) -> true + | Sval (_,Tdummy _) -> true | Sind (_,i) -> array_for_all (fun ip -> ip.ip_logical) i.ind_packets | _ -> false diff --git a/contrib/extraction/haskell.ml b/contrib/extraction/haskell.ml index c4ed364a..f924396c 100644 --- a/contrib/extraction/haskell.ml +++ b/contrib/extraction/haskell.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: haskell.ml 7653 2005-12-16 04:12:26Z letouzey $ i*) +(*i $Id: haskell.ml 8930 2006-06-09 02:14:34Z letouzey $ i*) (*s Production of Haskell syntax. *) @@ -106,7 +106,7 @@ let rec pp_type par vl t = | Tarr (t1,t2) -> pp_par par (pp_rec true t1 ++ spc () ++ str "->" ++ spc () ++ pp_rec false t2) - | Tdummy -> str "()" + | Tdummy _ -> str "()" | Tunknown -> str "()" | Taxiom -> str "() -- AXIOM TO BE REALIZED\n" in @@ -210,7 +210,7 @@ and pp_function env f t = (f ++ pr_binding (List.rev bl) ++ str " =" ++ fnl () ++ str " " ++ hov 2 (pp_expr false env' [] t')) - + (*s Pretty-printing of inductive types declaration. *) let pp_comment s = str "-- " ++ s ++ fnl () @@ -289,12 +289,16 @@ let pp_decl mpl = else str "=" ++ spc () ++ pp_type false l t in hov 2 (str "type " ++ pp_global r ++ spc () ++ st) ++ fnl () ++ fnl () - | Dfix (rv, defs,_) -> - let ppv = Array.map pp_global rv in - prlist_with_sep (fun () -> fnl () ++ fnl ()) - (fun (pi,ti) -> pp_function (empty_env ()) pi ti) - (List.combine (Array.to_list ppv) (Array.to_list defs)) - ++ fnl () ++ fnl () + | Dfix (rv, defs, typs) -> + let max = Array.length rv in + let rec iter i = + if i = max then mt () + else + let e = pp_global rv.(i) in + e ++ str " :: " ++ pp_type false [] typs.(i) ++ fnl () + ++ pp_function (empty_env ()) e defs.(i) ++ fnl () ++ fnl () + ++ iter (i+1) + in iter 0 | Dterm (r, a, t) -> if is_inline_custom r then mt () else diff --git a/contrib/extraction/miniml.mli b/contrib/extraction/miniml.mli index cf722e4e..e34abe02 100644 --- a/contrib/extraction/miniml.mli +++ b/contrib/extraction/miniml.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: miniml.mli 6064 2004-09-06 07:49:51Z letouzey $ i*) +(*i $Id: miniml.mli 8724 2006-04-20 09:57:01Z letouzey $ i*) (*s Target language for extraction: a core ML called MiniML. *) @@ -18,11 +18,18 @@ open Libnames (* The [signature] type is used to know how many arguments a CIC object expects, and what these arguments will become in the ML object. *) + +(* We eliminate from terms: 1) types 2) logical parts. + [Kother] stands both for logical or unknown reason. *) + +type kill_reason = Ktype | Kother + +type sign = Keep | Kill of kill_reason + -(* Convention: outmost lambda/product gives the head of the list, - and [true] means that the argument is to be kept. *) +(* Convention: outmost lambda/product gives the head of the list. *) -type signature = bool list +type signature = sign list (*s ML type expressions. *) @@ -32,7 +39,7 @@ type ml_type = | Tvar of int | Tvar' of int (* same as Tvar, used to avoid clash *) | Tmeta of ml_meta (* used during ML type reconstruction *) - | Tdummy + | Tdummy of kill_reason | Tunknown | Taxiom diff --git a/contrib/extraction/mlutil.ml b/contrib/extraction/mlutil.ml index facab18e..6bfedce5 100644 --- a/contrib/extraction/mlutil.ml +++ b/contrib/extraction/mlutil.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: mlutil.ml 7574 2005-11-17 15:48:45Z letouzey $ i*) +(*i $Id: mlutil.ml 8886 2006-06-01 13:53:45Z letouzey $ i*) (*i*) open Pp @@ -111,7 +111,7 @@ let rec mgu = function List.iter mgu (List.combine l l') | Tvar i, Tvar j when i = j -> () | Tvar' i, Tvar' j when i = j -> () - | Tdummy, Tdummy -> () + | Tdummy _, Tdummy _ -> () | Tunknown, Tunknown -> () | _ -> raise Impossible @@ -252,7 +252,6 @@ type abbrev_map = global_reference -> ml_type option (*s Delta-reduction of type constants everywhere in a ML type [t]. [env] is a function of type [ml_type_env]. *) - let type_expand env t = let rec expand = function | Tmeta {contents = Some t} -> expand t @@ -281,34 +280,39 @@ let type_weak_expand env t = | a -> a in expand t -(*s Equality over ML types modulo delta-reduction *) - -let type_eq env t t' = (type_expand env t = type_expand env t') - -let type_neq env t t' = (type_expand env t <> type_expand env t') - (*s Generating a signature from a ML type. *) -let type_to_sign env t = +let type_to_sign env t = match type_expand env t with + | Tdummy d -> Kill d + | _ -> Keep + +let type_to_signature env t = let rec f = function | Tmeta {contents = Some t} -> f t - | Tarr (a,b) -> (Tdummy <> a) :: (f b) + | Tarr (Tdummy d, b) -> Kill d :: f b + | Tarr (_, b) -> Keep :: f b | _ -> [] in f (type_expand env t) +let isKill = function Kill _ -> true | _ -> false + +let isDummy = function Tdummy _ -> true | _ -> false + +let sign_of_id i = if i = dummy_name then Kill Kother else Keep + (*s Removing [Tdummy] from the top level of a ML type. *) let type_expunge env t = - let s = type_to_sign env t in + let s = type_to_signature env t in if s = [] then t - else if List.mem true s then + else if List.mem Keep s then let rec f t s = - if List.mem false s then + if List.exists isKill s then match t with | Tmeta {contents = Some t} -> f t s | Tarr (a,b) -> let t = f b (List.tl s) in - if List.hd s then Tarr (a, t) else t + if List.hd s = Keep then Tarr (a, t) else t | Tglob (r,l) -> (match env r with | Some mlt -> f (type_subst_list l mlt) s @@ -316,7 +320,9 @@ let type_expunge env t = | _ -> assert false else t in f t s - else Tarr (Tdummy, snd (type_decomp (type_weak_expand env t))) + else if List.mem (Kill Kother) s then + Tarr (Tdummy Kother, snd (type_decomp (type_weak_expand env t))) + else snd (type_decomp (type_weak_expand env t)) (*S Generic functions over ML ast terms. *) @@ -536,8 +542,8 @@ let rec dummy_lams a = function let rec anonym_or_dummy_lams a = function | [] -> a - | true :: s -> MLlam(anonymous, anonym_or_dummy_lams a s) - | false :: s -> MLlam(dummy_name, anonym_or_dummy_lams a s) + | Keep :: s -> MLlam(anonymous, anonym_or_dummy_lams a s) + | Kill _ :: s -> MLlam(dummy_name, anonym_or_dummy_lams a s) (*S Operations concerning eta. *) @@ -550,8 +556,8 @@ let rec eta_args n = let rec eta_args_sign n = function | [] -> [] - | true :: s -> (MLrel n) :: (eta_args_sign (n-1) s) - | false :: s -> eta_args_sign (n-1) s + | Keep :: s -> (MLrel n) :: (eta_args_sign (n-1) s) + | Kill _ :: s -> eta_args_sign (n-1) s (*s This one tests [MLrel (n+k); ... ;MLrel (1+k)] *) @@ -820,33 +826,33 @@ let rec post_simpl = function (*S Local prop elimination. *) (* We try to eliminate as many [prop] as possible inside an [ml_ast]. *) -(*s In a list, it selects only the elements corresponding to a [true] +(*s In a list, it selects only the elements corresponding to a [Keep] in the boolean list [l]. *) let rec select_via_bl l args = match l,args with | [],_ -> args - | true::l,a::args -> a :: (select_via_bl l args) - | false::l,a::args -> select_via_bl l args + | Keep::l,a::args -> a :: (select_via_bl l args) + | Kill _::l,a::args -> select_via_bl l args | _ -> assert false -(*s [kill_some_lams] removes some head lambdas according to the bool list [bl]. +(*s [kill_some_lams] removes some head lambdas according to the signature [bl]. This list is build on the identifier list model: outermost lambda - is on the right. [true] means "to keep" and [false] means "to eliminate". + is on the right. [Rels] corresponding to removed lambdas are supposed not to occur, and the other [Rels] are made correct via a [gen_subst]. Output is not directly a [ml_ast], compose with [named_lams] if needed. *) let kill_some_lams bl (ids,c) = let n = List.length bl in - let n' = List.fold_left (fun n b -> if b then (n+1) else n) 0 bl in + let n' = List.fold_left (fun n b -> if b=Keep then (n+1) else n) 0 bl in if n = n' then ids,c else if n' = 0 then [],ast_lift (-n) c else begin let v = Array.make n MLdummy in let rec parse_ids i j = function | [] -> () - | true :: l -> v.(i) <- MLrel j; parse_ids (i+1) (j+1) l - | false :: l -> parse_ids (i+1) j l + | Keep :: l -> v.(i) <- MLrel j; parse_ids (i+1) (j+1) l + | Kill _ :: l -> parse_ids (i+1) j l in parse_ids 0 1 bl ; select_via_bl bl ids, gen_subst v (n'-n) c end @@ -857,8 +863,8 @@ let kill_some_lams bl (ids,c) = let kill_dummy_lams c = let ids,c = collect_lams c in - let bl = List.map ((<>) dummy_name) ids in - if (List.mem true bl) && (List.mem false bl) then + let bl = List.map sign_of_id ids in + if (List.mem Keep bl) && (List.exists isKill bl) then let ids',c = kill_some_lams bl (ids,c) in ids, named_lams ids' c else raise Impossible @@ -866,7 +872,7 @@ let kill_dummy_lams c = (*s [eta_expansion_sign] takes a function [fun idn ... id1 -> c] and a signature [s] and builds a eta-long version. *) -(* For example, if [s = [true;true;false;true]] then the output is : +(* For example, if [s = [Keep;Keep;Kill Prop;Keep]] then the output is : [fun idn ... id1 x x _ x -> (c' 4 3 __ 1)] with [c' = lift 4 c] *) let eta_expansion_sign s (ids,c) = @@ -874,13 +880,13 @@ let eta_expansion_sign s (ids,c) = | [] -> let a = List.rev_map (function MLrel x -> MLrel (i-x) | a -> a) rels in ids, MLapp (ast_lift (i-1) c, a) - | true :: l -> abs (anonymous :: ids) (MLrel i :: rels) (i+1) l - | false :: l -> abs (dummy_name :: ids) (MLdummy :: rels) (i+1) l + | Keep :: l -> abs (anonymous :: ids) (MLrel i :: rels) (i+1) l + | Kill _ :: l -> abs (dummy_name :: ids) (MLdummy :: rels) (i+1) l in abs ids [] 1 s (*s If [s = [b1; ... ; bn]] then [case_expunge] decomposes [e] in [n] lambdas (with eta-expansion if needed) and removes all dummy lambdas - corresponding to [false] in [s]. *) + corresponding to [Del] in [s]. *) let case_expunge s e = let m = List.length s in @@ -892,13 +898,14 @@ let case_expunge s e = (*s [term_expunge] takes a function [fun idn ... id1 -> c] and a signature [s] and remove dummy lams. The difference with [case_expunge] is that we here leave one dummy lambda - if all lambdas are dummy. *) + if all lambdas are logical dummy. *) let term_expunge s (ids,c) = if s = [] then c else let ids,c = kill_some_lams (List.rev s) (ids,c) in - if ids = [] then MLlam (dummy_name, ast_lift 1 c) + if ids = [] && List.mem (Kill Kother) s then + MLlam (dummy_name, ast_lift 1 c) else named_lams ids c (*s [kill_dummy_args ids t0 t] looks for occurences of [t0] in [t] and @@ -907,7 +914,7 @@ let term_expunge s (ids,c) = let kill_dummy_args ids t0 t = let m = List.length ids in - let bl = List.rev_map ((<>) dummy_name) ids in + let bl = List.rev_map sign_of_id ids in let rec killrec n = function | MLapp(e, a) when e = ast_lift n t0 -> let k = max 0 (m - (List.length a)) in @@ -974,7 +981,8 @@ let general_optimize_fix f ids n args m c = let v = Array.make n 0 in for i=0 to (n-1) do v.(i)<-i done; let aux i = function - | MLrel j when v.(j-1)>=0 -> v.(j-1)<-(-i-1) + | MLrel j when v.(j-1)>=0 -> + if ast_occurs (j+1) c then raise Impossible else v.(j-1)<-(-i-1) | _ -> raise Impossible in list_iter_i aux args; let args_f = List.rev_map (fun i -> MLrel (i+m+1)) (Array.to_list v) in @@ -1001,8 +1009,7 @@ let optimize_fix a = -> a' | MLfix(_,[|f|],[|c|]) -> (try general_optimize_fix f ids n args m c - with Impossible -> - named_lams ids (MLapp (MLfix (0,[|f|],[|c|]),args))) + with Impossible -> a) | _ -> a) | _ -> a diff --git a/contrib/extraction/mlutil.mli b/contrib/extraction/mlutil.mli index 1ba1df64..a55caaf2 100644 --- a/contrib/extraction/mlutil.mli +++ b/contrib/extraction/mlutil.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: mlutil.mli 6303 2004-11-16 12:37:40Z sacerdot $ i*) +(*i $Id: mlutil.mli 8724 2006-04-20 09:57:01Z letouzey $ i*) open Util open Names @@ -62,13 +62,15 @@ val var2var' : ml_type -> ml_type type abbrev_map = global_reference -> ml_type option val type_expand : abbrev_map -> ml_type -> ml_type -val type_eq : abbrev_map -> ml_type -> ml_type -> bool -val type_neq : abbrev_map -> ml_type -> ml_type -> bool -val type_to_sign : abbrev_map -> ml_type -> bool list +val type_to_sign : abbrev_map -> ml_type -> sign +val type_to_signature : abbrev_map -> ml_type -> signature val type_expunge : abbrev_map -> ml_type -> ml_type -val case_expunge : bool list -> ml_ast -> identifier list * ml_ast -val term_expunge : bool list -> identifier list * ml_ast -> ml_ast +val isDummy : ml_type -> bool +val isKill : sign -> bool + +val case_expunge : signature -> ml_ast -> identifier list * ml_ast +val term_expunge : signature -> identifier list * ml_ast -> ml_ast (*s Special identifiers. [dummy_name] is to be used for dead code @@ -86,9 +88,9 @@ val collect_n_lams : int -> ml_ast -> identifier list * ml_ast val nb_lams : ml_ast -> int val dummy_lams : ml_ast -> int -> ml_ast -val anonym_or_dummy_lams : ml_ast -> bool list -> ml_ast +val anonym_or_dummy_lams : ml_ast -> signature -> ml_ast -val eta_args_sign : int -> bool list -> ml_ast list +val eta_args_sign : int -> signature -> ml_ast list (*s Utility functions over ML terms. *) diff --git a/contrib/extraction/modutil.ml b/contrib/extraction/modutil.ml index ff8daf46..46d4a5a6 100644 --- a/contrib/extraction/modutil.ml +++ b/contrib/extraction/modutil.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: modutil.ml 7632 2005-12-01 14:35:21Z letouzey $ i*) +(*i $Id: modutil.ml 8724 2006-04-20 09:57:01Z letouzey $ i*) open Names open Declarations @@ -252,40 +252,40 @@ let struct_get_references_list struc = exception Found -let rec ast_search t a = - if t a then raise Found else ast_iter (ast_search t) a +let rec ast_search f a = + if f a then raise Found else ast_iter (ast_search f) a -let decl_ast_search t = function - | Dterm (_,a,_) -> ast_search t a - | Dfix (_,c,_) -> Array.iter (ast_search t) c +let decl_ast_search f = function + | Dterm (_,a,_) -> ast_search f a + | Dfix (_,c,_) -> Array.iter (ast_search f) c | _ -> () -let struct_ast_search t s = - try struct_iter (decl_ast_search t) (fun _ -> ()) s; false +let struct_ast_search f s = + try struct_iter (decl_ast_search f) (fun _ -> ()) s; false with Found -> true -let rec type_search t = function - | Tarr (a,b) -> type_search t a; type_search t b - | Tglob (r,l) -> List.iter (type_search t) l - | u -> if t = u then raise Found +let rec type_search f = function + | Tarr (a,b) -> type_search f a; type_search f b + | Tglob (r,l) -> List.iter (type_search f) l + | u -> if f u then raise Found -let decl_type_search t = function +let decl_type_search f = function | Dind (_,{ind_packets=p}) -> Array.iter - (fun {ip_types=v} -> Array.iter (List.iter (type_search t)) v) p - | Dterm (_,_,u) -> type_search t u - | Dfix (_,_,v) -> Array.iter (type_search t) v - | Dtype (_,_,u) -> type_search t u + (fun {ip_types=v} -> Array.iter (List.iter (type_search f)) v) p + | Dterm (_,_,u) -> type_search f u + | Dfix (_,_,v) -> Array.iter (type_search f) v + | Dtype (_,_,u) -> type_search f u -let spec_type_search t = function +let spec_type_search f = function | Sind (_,{ind_packets=p}) -> Array.iter - (fun {ip_types=v} -> Array.iter (List.iter (type_search t)) v) p - | Stype (_,_,ot) -> option_iter (type_search t) ot - | Sval (_,u) -> type_search t u + (fun {ip_types=v} -> Array.iter (List.iter (type_search f)) v) p + | Stype (_,_,ot) -> option_iter (type_search f) ot + | Sval (_,u) -> type_search f u -let struct_type_search t s = - try struct_iter (decl_type_search t) (spec_type_search t) s; false +let struct_type_search f s = + try struct_iter (decl_type_search f) (spec_type_search f) s; false with Found -> true @@ -359,7 +359,7 @@ let dfix_to_mlfix rv av i = let rec optim prm s = function | [] -> [] - | (Dtype (r,_,Tdummy) | Dterm(r,MLdummy,_)) as d :: l -> + | (Dtype (r,_,Tdummy _) | Dterm(r,MLdummy,_)) as d :: l -> if List.mem r prm.to_appear then d :: (optim prm s l) else optim prm s l | Dterm (r,t,typ) :: l -> let t = normalize (ast_glob_subst !s t) in diff --git a/contrib/extraction/modutil.mli b/contrib/extraction/modutil.mli index f5208c0d..115a42ca 100644 --- a/contrib/extraction/modutil.mli +++ b/contrib/extraction/modutil.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: modutil.mli 7632 2005-12-01 14:35:21Z letouzey $ i*) +(*i $Id: modutil.mli 8724 2006-04-20 09:57:01Z letouzey $ i*) open Names open Declarations @@ -44,7 +44,7 @@ val add_labels_mp : module_path -> label list -> module_path (*s Functions upon ML modules. *) val struct_ast_search : (ml_ast -> bool) -> ml_structure -> bool -val struct_type_search : ml_type -> ml_structure -> bool +val struct_type_search : (ml_type -> bool) -> ml_structure -> bool type do_ref = global_reference -> unit diff --git a/contrib/extraction/ocaml.ml b/contrib/extraction/ocaml.ml index a0620d72..483da236 100644 --- a/contrib/extraction/ocaml.ml +++ b/contrib/extraction/ocaml.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ocaml.ml 7632 2005-12-01 14:35:21Z letouzey $ i*) +(*i $Id: ocaml.ml 8930 2006-06-09 02:14:34Z letouzey $ i*) (*s Production of Ocaml syntax. *) @@ -196,7 +196,7 @@ let rec pp_type par vl t = | Tarr (t1,t2) -> pp_par par (pp_rec true t1 ++ spc () ++ str "->" ++ spc () ++ pp_rec false t2) - | Tdummy -> str "__" + | Tdummy _ -> str "__" | Tunknown -> str "__" in hov 0 (pp_rec par t) @@ -343,13 +343,9 @@ and pp_pat env i pv = and pp_function env f t = let bl,t' = collect_lams t in let bl,env' = push_vars bl env in - let is_function pv = - let ktl = array_map_to_list (fun (_,l,t0) -> (List.length l,t0)) pv in - not (List.exists (fun (k,t0) -> ast_occurs (k+1) t0) ktl) - in match t' with - | MLcase(i,MLrel 1,pv) when i=Standard -> - if is_function pv then + | MLcase(i,MLrel 1,pv) when i=Standard -> + if not (ast_occurs 1 (MLcase(i,MLdummy,pv))) then (f ++ pr_binding (List.rev (List.tl bl)) ++ str " = function" ++ fnl () ++ v 0 (str " | " ++ pp_pat env' i pv)) @@ -358,7 +354,6 @@ and pp_function env f t = str " = match " ++ pr_id (List.hd bl) ++ str " with" ++ fnl () ++ v 0 (str " | " ++ pp_pat env' i pv)) - | _ -> (f ++ pr_binding (List.rev bl) ++ str " =" ++ fnl () ++ str " " ++ hov 2 (pp_expr false env' [] t')) diff --git a/contrib/extraction/test/.depend b/contrib/extraction/test/.depend index 641b50a7..31d46eeb 100644 --- a/contrib/extraction/test/.depend +++ b/contrib/extraction/test/.depend @@ -2,110 +2,318 @@ theories/Arith/arith.cmo: theories/Arith/arith.cmi theories/Arith/arith.cmx: theories/Arith/arith.cmi theories/Arith/between.cmo: theories/Arith/between.cmi theories/Arith/between.cmx: theories/Arith/between.cmi -theories/Arith/bool_nat.cmo: theories/Arith/compare_dec.cmi \ - theories/Init/datatypes.cmi theories/Arith/peano_dec.cmi \ - theories/Init/specif.cmi theories/Bool/sumbool.cmi \ +theories/Arith/bool_nat.cmo: theories/Bool/sumbool.cmi \ + theories/Init/specif.cmi theories/Arith/peano_dec.cmi \ + theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi \ theories/Arith/bool_nat.cmi -theories/Arith/bool_nat.cmx: theories/Arith/compare_dec.cmx \ - theories/Init/datatypes.cmx theories/Arith/peano_dec.cmx \ - theories/Init/specif.cmx theories/Bool/sumbool.cmx \ +theories/Arith/bool_nat.cmx: theories/Bool/sumbool.cmx \ + theories/Init/specif.cmx theories/Arith/peano_dec.cmx \ + theories/Init/datatypes.cmx theories/Arith/compare_dec.cmx \ theories/Arith/bool_nat.cmi -theories/Arith/compare_dec.cmo: theories/Init/datatypes.cmi \ - theories/Init/specif.cmi theories/Arith/compare_dec.cmi -theories/Arith/compare_dec.cmx: theories/Init/datatypes.cmx \ - theories/Init/specif.cmx theories/Arith/compare_dec.cmi -theories/Arith/compare.cmo: theories/Arith/compare_dec.cmi \ - theories/Init/datatypes.cmi theories/Init/specif.cmi \ +theories/Arith/compare_dec.cmo: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi +theories/Arith/compare_dec.cmx: theories/Init/specif.cmx \ + theories/Init/datatypes.cmx theories/Arith/compare_dec.cmi +theories/Arith/compare.cmo: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi \ theories/Arith/compare.cmi -theories/Arith/compare.cmx: theories/Arith/compare_dec.cmx \ - theories/Init/datatypes.cmx theories/Init/specif.cmx \ +theories/Arith/compare.cmx: theories/Init/specif.cmx \ + theories/Init/datatypes.cmx theories/Arith/compare_dec.cmx \ theories/Arith/compare.cmi -theories/Arith/div2.cmo: theories/Init/datatypes.cmi theories/Init/peano.cmi \ - theories/Init/specif.cmi theories/Arith/div2.cmi -theories/Arith/div2.cmx: theories/Init/datatypes.cmx theories/Init/peano.cmx \ - theories/Init/specif.cmx theories/Arith/div2.cmi -theories/Arith/eqNat.cmo: theories/Init/datatypes.cmi \ - theories/Init/specif.cmi theories/Arith/eqNat.cmi -theories/Arith/eqNat.cmx: theories/Init/datatypes.cmx \ - theories/Init/specif.cmx theories/Arith/eqNat.cmi -theories/Arith/euclid.cmo: theories/Arith/compare_dec.cmi \ - theories/Init/datatypes.cmi theories/Init/specif.cmi \ +theories/Arith/div2.cmo: theories/Init/specif.cmi theories/Init/peano.cmi \ + theories/Init/datatypes.cmi theories/Arith/div2.cmi +theories/Arith/div2.cmx: theories/Init/specif.cmx theories/Init/peano.cmx \ + theories/Init/datatypes.cmx theories/Arith/div2.cmi +theories/Arith/eqNat.cmo: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/Arith/eqNat.cmi +theories/Arith/eqNat.cmx: theories/Init/specif.cmx \ + theories/Init/datatypes.cmx theories/Arith/eqNat.cmi +theories/Arith/euclid.cmo: theories/Init/specif.cmi theories/Init/peano.cmi \ + theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi \ theories/Arith/euclid.cmi -theories/Arith/euclid.cmx: theories/Arith/compare_dec.cmx \ - theories/Init/datatypes.cmx theories/Init/specif.cmx \ +theories/Arith/euclid.cmx: theories/Init/specif.cmx theories/Init/peano.cmx \ + theories/Init/datatypes.cmx theories/Arith/compare_dec.cmx \ theories/Arith/euclid.cmi -theories/Arith/even.cmo: theories/Init/datatypes.cmi theories/Init/specif.cmi \ +theories/Arith/even.cmo: theories/Init/specif.cmi theories/Init/datatypes.cmi \ theories/Arith/even.cmi -theories/Arith/even.cmx: theories/Init/datatypes.cmx theories/Init/specif.cmx \ +theories/Arith/even.cmx: theories/Init/specif.cmx theories/Init/datatypes.cmx \ theories/Arith/even.cmi -theories/Arith/factorial.cmo: theories/Init/datatypes.cmi \ - theories/Init/peano.cmi theories/Arith/factorial.cmi -theories/Arith/factorial.cmx: theories/Init/datatypes.cmx \ - theories/Init/peano.cmx theories/Arith/factorial.cmi +theories/Arith/factorial.cmo: theories/Init/peano.cmi \ + theories/Init/datatypes.cmi theories/Arith/factorial.cmi +theories/Arith/factorial.cmx: theories/Init/peano.cmx \ + theories/Init/datatypes.cmx theories/Arith/factorial.cmi theories/Arith/gt.cmo: theories/Arith/gt.cmi theories/Arith/gt.cmx: theories/Arith/gt.cmi theories/Arith/le.cmo: theories/Arith/le.cmi theories/Arith/le.cmx: theories/Arith/le.cmi theories/Arith/lt.cmo: theories/Arith/lt.cmi theories/Arith/lt.cmx: theories/Arith/lt.cmi -theories/Arith/max.cmo: theories/Init/datatypes.cmi theories/Init/specif.cmi \ +theories/Arith/max.cmo: theories/Init/specif.cmi theories/Init/datatypes.cmi \ theories/Arith/max.cmi -theories/Arith/max.cmx: theories/Init/datatypes.cmx theories/Init/specif.cmx \ +theories/Arith/max.cmx: theories/Init/specif.cmx theories/Init/datatypes.cmx \ theories/Arith/max.cmi -theories/Arith/min.cmo: theories/Init/datatypes.cmi theories/Init/specif.cmi \ +theories/Arith/min.cmo: theories/Init/specif.cmi theories/Init/datatypes.cmi \ theories/Arith/min.cmi -theories/Arith/min.cmx: theories/Init/datatypes.cmx theories/Init/specif.cmx \ +theories/Arith/min.cmx: theories/Init/specif.cmx theories/Init/datatypes.cmx \ theories/Arith/min.cmi theories/Arith/minus.cmo: theories/Arith/minus.cmi theories/Arith/minus.cmx: theories/Arith/minus.cmi -theories/Arith/mult.cmo: theories/Init/datatypes.cmi theories/Arith/plus.cmi \ +theories/Arith/mult.cmo: theories/Arith/plus.cmi theories/Init/datatypes.cmi \ theories/Arith/mult.cmi -theories/Arith/mult.cmx: theories/Init/datatypes.cmx theories/Arith/plus.cmx \ +theories/Arith/mult.cmx: theories/Arith/plus.cmx theories/Init/datatypes.cmx \ theories/Arith/mult.cmi -theories/Arith/peano_dec.cmo: theories/Init/datatypes.cmi \ - theories/Init/specif.cmi theories/Arith/peano_dec.cmi -theories/Arith/peano_dec.cmx: theories/Init/datatypes.cmx \ - theories/Init/specif.cmx theories/Arith/peano_dec.cmi -theories/Arith/plus.cmo: theories/Init/datatypes.cmi theories/Init/specif.cmi \ +theories/Arith/peano_dec.cmo: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/Arith/peano_dec.cmi +theories/Arith/peano_dec.cmx: theories/Init/specif.cmx \ + theories/Init/datatypes.cmx theories/Arith/peano_dec.cmi +theories/Arith/plus.cmo: theories/Init/specif.cmi theories/Init/datatypes.cmi \ theories/Arith/plus.cmi -theories/Arith/plus.cmx: theories/Init/datatypes.cmx theories/Init/specif.cmx \ +theories/Arith/plus.cmx: theories/Init/specif.cmx theories/Init/datatypes.cmx \ theories/Arith/plus.cmi theories/Arith/wf_nat.cmo: theories/Init/datatypes.cmi \ theories/Arith/wf_nat.cmi theories/Arith/wf_nat.cmx: theories/Init/datatypes.cmx \ theories/Arith/wf_nat.cmi -theories/Bool/boolEq.cmo: theories/Init/datatypes.cmi \ - theories/Init/specif.cmi theories/Bool/boolEq.cmi -theories/Bool/boolEq.cmx: theories/Init/datatypes.cmx \ - theories/Init/specif.cmx theories/Bool/boolEq.cmi -theories/Bool/bool.cmo: theories/Init/datatypes.cmi theories/Init/specif.cmi \ +theories/Bool/boolEq.cmo: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/Bool/boolEq.cmi +theories/Bool/boolEq.cmx: theories/Init/specif.cmx \ + theories/Init/datatypes.cmx theories/Bool/boolEq.cmi +theories/Bool/bool.cmo: theories/Init/specif.cmi theories/Init/datatypes.cmi \ theories/Bool/bool.cmi -theories/Bool/bool.cmx: theories/Init/datatypes.cmx theories/Init/specif.cmx \ +theories/Bool/bool.cmx: theories/Init/specif.cmx theories/Init/datatypes.cmx \ theories/Bool/bool.cmi -theories/Bool/bvector.cmo: theories/Bool/bool.cmi theories/Init/datatypes.cmi \ - theories/Init/peano.cmi theories/Bool/bvector.cmi -theories/Bool/bvector.cmx: theories/Bool/bool.cmx theories/Init/datatypes.cmx \ - theories/Init/peano.cmx theories/Bool/bvector.cmi +theories/Bool/bvector.cmo: theories/Init/peano.cmi \ + theories/Init/datatypes.cmi theories/Bool/bool.cmi \ + theories/Bool/bvector.cmi +theories/Bool/bvector.cmx: theories/Init/peano.cmx \ + theories/Init/datatypes.cmx theories/Bool/bool.cmx \ + theories/Bool/bvector.cmi theories/Bool/decBool.cmo: theories/Init/specif.cmi theories/Bool/decBool.cmi theories/Bool/decBool.cmx: theories/Init/specif.cmx theories/Bool/decBool.cmi -theories/Bool/ifProp.cmo: theories/Init/datatypes.cmi \ - theories/Init/specif.cmi theories/Bool/ifProp.cmi -theories/Bool/ifProp.cmx: theories/Init/datatypes.cmx \ - theories/Init/specif.cmx theories/Bool/ifProp.cmi -theories/Bool/sumbool.cmo: theories/Init/datatypes.cmi \ - theories/Init/specif.cmi theories/Bool/sumbool.cmi -theories/Bool/sumbool.cmx: theories/Init/datatypes.cmx \ - theories/Init/specif.cmx theories/Bool/sumbool.cmi +theories/Bool/ifProp.cmo: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/Bool/ifProp.cmi +theories/Bool/ifProp.cmx: theories/Init/specif.cmx \ + theories/Init/datatypes.cmx theories/Bool/ifProp.cmi +theories/Bool/sumbool.cmo: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/Bool/sumbool.cmi +theories/Bool/sumbool.cmx: theories/Init/specif.cmx \ + theories/Init/datatypes.cmx theories/Bool/sumbool.cmi theories/Bool/zerob.cmo: theories/Init/datatypes.cmi theories/Bool/zerob.cmi theories/Bool/zerob.cmx: theories/Init/datatypes.cmx theories/Bool/zerob.cmi +theories/FSets/decidableTypeEx.cmo: theories/Init/specif.cmi \ + theories/FSets/orderedTypeEx.cmi theories/FSets/orderedType.cmi \ + theories/Init/datatypes.cmi theories/FSets/decidableTypeEx.cmi +theories/FSets/decidableTypeEx.cmx: theories/Init/specif.cmx \ + theories/FSets/orderedTypeEx.cmx theories/FSets/orderedType.cmx \ + theories/Init/datatypes.cmx theories/FSets/decidableTypeEx.cmi +theories/FSets/decidableType.cmo: theories/Init/specif.cmi \ + theories/FSets/decidableType.cmi +theories/FSets/decidableType.cmx: theories/Init/specif.cmx \ + theories/FSets/decidableType.cmi +theories/FSets/fMapAVL.cmo: theories/Init/wf.cmi theories/Init/specif.cmi \ + theories/FSets/orderedType.cmi theories/Lists/list.cmi \ + theories/FSets/int.cmi theories/FSets/fMapList.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/ZArith/binInt.cmi theories/FSets/fMapAVL.cmi +theories/FSets/fMapAVL.cmx: theories/Init/wf.cmx theories/Init/specif.cmx \ + theories/FSets/orderedType.cmx theories/Lists/list.cmx \ + theories/FSets/int.cmx theories/FSets/fMapList.cmx \ + theories/Init/datatypes.cmx theories/NArith/binPos.cmx \ + theories/ZArith/binInt.cmx theories/FSets/fMapAVL.cmi +theories/FSets/fMapFacts.cmo: theories/Init/specif.cmi \ + theories/FSets/orderedType.cmi theories/FSets/fMapInterface.cmi \ + theories/Init/datatypes.cmi theories/FSets/fMapFacts.cmi +theories/FSets/fMapFacts.cmx: theories/Init/specif.cmx \ + theories/FSets/orderedType.cmx theories/FSets/fMapInterface.cmx \ + theories/Init/datatypes.cmx theories/FSets/fMapFacts.cmi +theories/FSets/fMapInterface.cmo: theories/FSets/orderedType.cmi \ + theories/Lists/list.cmi theories/Init/datatypes.cmi \ + theories/FSets/fMapInterface.cmi +theories/FSets/fMapInterface.cmx: theories/FSets/orderedType.cmx \ + theories/Lists/list.cmx theories/Init/datatypes.cmx \ + theories/FSets/fMapInterface.cmi +theories/FSets/fMapIntMap.cmo: theories/Init/specif.cmi \ + theories/FSets/orderedType.cmi theories/NArith/ndigits.cmi \ + theories/IntMap/mapiter.cmi theories/IntMap/mapcanon.cmi \ + theories/IntMap/map.cmi theories/Lists/list.cmi \ + theories/FSets/fMapList.cmi theories/Init/datatypes.cmi \ + theories/NArith/binNat.cmi theories/FSets/fMapIntMap.cmi +theories/FSets/fMapIntMap.cmx: theories/Init/specif.cmx \ + theories/FSets/orderedType.cmx theories/NArith/ndigits.cmx \ + theories/IntMap/mapiter.cmx theories/IntMap/mapcanon.cmx \ + theories/IntMap/map.cmx theories/Lists/list.cmx \ + theories/FSets/fMapList.cmx theories/Init/datatypes.cmx \ + theories/NArith/binNat.cmx theories/FSets/fMapIntMap.cmi +theories/FSets/fMapList.cmo: theories/Init/specif.cmi \ + theories/FSets/orderedType.cmi theories/Lists/list.cmi \ + theories/Init/datatypes.cmi theories/FSets/fMapList.cmi +theories/FSets/fMapList.cmx: theories/Init/specif.cmx \ + theories/FSets/orderedType.cmx theories/Lists/list.cmx \ + theories/Init/datatypes.cmx theories/FSets/fMapList.cmi +theories/FSets/fMapPositive.cmo: theories/Init/specif.cmi \ + theories/FSets/orderedType.cmi theories/Lists/list.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/FSets/fMapPositive.cmi +theories/FSets/fMapPositive.cmx: theories/Init/specif.cmx \ + theories/FSets/orderedType.cmx theories/Lists/list.cmx \ + theories/Init/datatypes.cmx theories/NArith/binPos.cmx \ + theories/FSets/fMapPositive.cmi +theories/FSets/fMaps.cmo: theories/FSets/fMaps.cmi +theories/FSets/fMaps.cmx: theories/FSets/fMaps.cmi +theories/FSets/fMapWeakFacts.cmo: theories/Init/specif.cmi \ + theories/Lists/list.cmi theories/FSets/fMapWeakInterface.cmi \ + theories/Init/datatypes.cmi theories/FSets/fMapWeakFacts.cmi +theories/FSets/fMapWeakFacts.cmx: theories/Init/specif.cmx \ + theories/Lists/list.cmx theories/FSets/fMapWeakInterface.cmx \ + theories/Init/datatypes.cmx theories/FSets/fMapWeakFacts.cmi +theories/FSets/fMapWeakInterface.cmo: theories/Lists/list.cmi \ + theories/FSets/decidableType.cmi theories/Init/datatypes.cmi \ + theories/FSets/fMapWeakInterface.cmi +theories/FSets/fMapWeakInterface.cmx: theories/Lists/list.cmx \ + theories/FSets/decidableType.cmx theories/Init/datatypes.cmx \ + theories/FSets/fMapWeakInterface.cmi +theories/FSets/fMapWeakList.cmo: theories/Init/specif.cmi \ + theories/Lists/list.cmi theories/FSets/decidableType.cmi \ + theories/Init/datatypes.cmi theories/FSets/fMapWeakList.cmi +theories/FSets/fMapWeakList.cmx: theories/Init/specif.cmx \ + theories/Lists/list.cmx theories/FSets/decidableType.cmx \ + theories/Init/datatypes.cmx theories/FSets/fMapWeakList.cmi +theories/FSets/fMapWeak.cmo: theories/FSets/fMapWeak.cmi +theories/FSets/fMapWeak.cmx: theories/FSets/fMapWeak.cmi +theories/FSets/fSetAVL.cmo: theories/Init/wf.cmi theories/Init/specif.cmi \ + theories/Init/peano.cmi theories/FSets/orderedType.cmi \ + theories/Lists/list.cmi theories/FSets/int.cmi \ + theories/FSets/fSetList.cmi theories/Init/datatypes.cmi \ + theories/NArith/binPos.cmi theories/ZArith/binInt.cmi \ + theories/FSets/fSetAVL.cmi +theories/FSets/fSetAVL.cmx: theories/Init/wf.cmx theories/Init/specif.cmx \ + theories/Init/peano.cmx theories/FSets/orderedType.cmx \ + theories/Lists/list.cmx theories/FSets/int.cmx \ + theories/FSets/fSetList.cmx theories/Init/datatypes.cmx \ + theories/NArith/binPos.cmx theories/ZArith/binInt.cmx \ + theories/FSets/fSetAVL.cmi +theories/FSets/fSetBridge.cmo: theories/Init/specif.cmi \ + theories/FSets/orderedType.cmi theories/Lists/list.cmi \ + theories/FSets/fSetInterface.cmi theories/Init/datatypes.cmi \ + theories/FSets/fSetBridge.cmi +theories/FSets/fSetBridge.cmx: theories/Init/specif.cmx \ + theories/FSets/orderedType.cmx theories/Lists/list.cmx \ + theories/FSets/fSetInterface.cmx theories/Init/datatypes.cmx \ + theories/FSets/fSetBridge.cmi +theories/FSets/fSetEqProperties.cmo: theories/Init/specif.cmi \ + theories/Setoids/setoid.cmi theories/Init/peano.cmi \ + theories/FSets/orderedType.cmi theories/FSets/fSetProperties.cmi \ + theories/FSets/fSetInterface.cmi theories/Init/datatypes.cmi \ + theories/Bool/bool.cmi theories/FSets/fSetEqProperties.cmi +theories/FSets/fSetEqProperties.cmx: theories/Init/specif.cmx \ + theories/Setoids/setoid.cmx theories/Init/peano.cmx \ + theories/FSets/orderedType.cmx theories/FSets/fSetProperties.cmx \ + theories/FSets/fSetInterface.cmx theories/Init/datatypes.cmx \ + theories/Bool/bool.cmx theories/FSets/fSetEqProperties.cmi +theories/FSets/fSetFacts.cmo: theories/Init/specif.cmi \ + theories/Setoids/setoid.cmi theories/FSets/orderedType.cmi \ + theories/FSets/fSetInterface.cmi theories/Init/datatypes.cmi \ + theories/FSets/fSetFacts.cmi +theories/FSets/fSetFacts.cmx: theories/Init/specif.cmx \ + theories/Setoids/setoid.cmx theories/FSets/orderedType.cmx \ + theories/FSets/fSetInterface.cmx theories/Init/datatypes.cmx \ + theories/FSets/fSetFacts.cmi +theories/FSets/fSetInterface.cmo: theories/Init/specif.cmi \ + theories/FSets/orderedType.cmi theories/Lists/list.cmi \ + theories/Init/datatypes.cmi theories/FSets/fSetInterface.cmi +theories/FSets/fSetInterface.cmx: theories/Init/specif.cmx \ + theories/FSets/orderedType.cmx theories/Lists/list.cmx \ + theories/Init/datatypes.cmx theories/FSets/fSetInterface.cmi +theories/FSets/fSetList.cmo: theories/Init/specif.cmi \ + theories/FSets/orderedType.cmi theories/Lists/list.cmi \ + theories/Init/datatypes.cmi theories/FSets/fSetList.cmi +theories/FSets/fSetList.cmx: theories/Init/specif.cmx \ + theories/FSets/orderedType.cmx theories/Lists/list.cmx \ + theories/Init/datatypes.cmx theories/FSets/fSetList.cmi +theories/FSets/fSetProperties.cmo: theories/Init/specif.cmi \ + theories/Setoids/setoid.cmi theories/FSets/orderedType.cmi \ + theories/Lists/list.cmi theories/FSets/fSetInterface.cmi \ + theories/FSets/fSetFacts.cmi theories/Init/datatypes.cmi \ + theories/FSets/fSetProperties.cmi +theories/FSets/fSetProperties.cmx: theories/Init/specif.cmx \ + theories/Setoids/setoid.cmx theories/FSets/orderedType.cmx \ + theories/Lists/list.cmx theories/FSets/fSetInterface.cmx \ + theories/FSets/fSetFacts.cmx theories/Init/datatypes.cmx \ + theories/FSets/fSetProperties.cmi +theories/FSets/fSets.cmo: theories/FSets/fSets.cmi +theories/FSets/fSets.cmx: theories/FSets/fSets.cmi +theories/FSets/fSetToFiniteSet.cmo: theories/Init/specif.cmi \ + theories/Setoids/setoid.cmi theories/FSets/orderedTypeEx.cmi \ + theories/FSets/orderedType.cmi theories/Lists/list.cmi \ + theories/FSets/fSetProperties.cmi theories/Init/datatypes.cmi \ + theories/FSets/fSetToFiniteSet.cmi +theories/FSets/fSetToFiniteSet.cmx: theories/Init/specif.cmx \ + theories/Setoids/setoid.cmx theories/FSets/orderedTypeEx.cmx \ + theories/FSets/orderedType.cmx theories/Lists/list.cmx \ + theories/FSets/fSetProperties.cmx theories/Init/datatypes.cmx \ + theories/FSets/fSetToFiniteSet.cmi +theories/FSets/fSetWeakFacts.cmo: theories/Init/specif.cmi \ + theories/Setoids/setoid.cmi theories/FSets/fSetWeakInterface.cmi \ + theories/Init/datatypes.cmi theories/FSets/fSetWeakFacts.cmi +theories/FSets/fSetWeakFacts.cmx: theories/Init/specif.cmx \ + theories/Setoids/setoid.cmx theories/FSets/fSetWeakInterface.cmx \ + theories/Init/datatypes.cmx theories/FSets/fSetWeakFacts.cmi +theories/FSets/fSetWeakInterface.cmo: theories/Lists/list.cmi \ + theories/FSets/decidableType.cmi theories/Init/datatypes.cmi \ + theories/FSets/fSetWeakInterface.cmi +theories/FSets/fSetWeakInterface.cmx: theories/Lists/list.cmx \ + theories/FSets/decidableType.cmx theories/Init/datatypes.cmx \ + theories/FSets/fSetWeakInterface.cmi +theories/FSets/fSetWeakList.cmo: theories/Init/specif.cmi \ + theories/Lists/list.cmi theories/FSets/decidableType.cmi \ + theories/Init/datatypes.cmi theories/FSets/fSetWeakList.cmi +theories/FSets/fSetWeakList.cmx: theories/Init/specif.cmx \ + theories/Lists/list.cmx theories/FSets/decidableType.cmx \ + theories/Init/datatypes.cmx theories/FSets/fSetWeakList.cmi +theories/FSets/fSetWeak.cmo: theories/FSets/fSetWeak.cmi +theories/FSets/fSetWeak.cmx: theories/FSets/fSetWeak.cmi +theories/FSets/fSetWeakProperties.cmo: theories/Init/specif.cmi \ + theories/Setoids/setoid.cmi theories/Lists/list.cmi \ + theories/FSets/fSetWeakInterface.cmi theories/FSets/fSetWeakFacts.cmi \ + theories/Init/datatypes.cmi theories/FSets/fSetWeakProperties.cmi +theories/FSets/fSetWeakProperties.cmx: theories/Init/specif.cmx \ + theories/Setoids/setoid.cmx theories/Lists/list.cmx \ + theories/FSets/fSetWeakInterface.cmx theories/FSets/fSetWeakFacts.cmx \ + theories/Init/datatypes.cmx theories/FSets/fSetWeakProperties.cmi +theories/FSets/int.cmo: theories/ZArith/zmax.cmi \ + theories/ZArith/zArith_dec.cmi theories/Init/specif.cmi \ + theories/NArith/binPos.cmi theories/ZArith/binInt.cmi \ + theories/FSets/int.cmi +theories/FSets/int.cmx: theories/ZArith/zmax.cmx \ + theories/ZArith/zArith_dec.cmx theories/Init/specif.cmx \ + theories/NArith/binPos.cmx theories/ZArith/binInt.cmx \ + theories/FSets/int.cmi +theories/FSets/orderedTypeAlt.cmo: theories/Init/specif.cmi \ + theories/FSets/orderedType.cmi theories/Init/datatypes.cmi \ + theories/FSets/orderedTypeAlt.cmi +theories/FSets/orderedTypeAlt.cmx: theories/Init/specif.cmx \ + theories/FSets/orderedType.cmx theories/Init/datatypes.cmx \ + theories/FSets/orderedTypeAlt.cmi +theories/FSets/orderedTypeEx.cmo: theories/Init/specif.cmi \ + theories/FSets/orderedType.cmi theories/Init/datatypes.cmi \ + theories/Arith/compare_dec.cmi theories/NArith/binPos.cmi \ + theories/NArith/binNat.cmi theories/ZArith/binInt.cmi \ + theories/FSets/orderedTypeEx.cmi +theories/FSets/orderedTypeEx.cmx: theories/Init/specif.cmx \ + theories/FSets/orderedType.cmx theories/Init/datatypes.cmx \ + theories/Arith/compare_dec.cmx theories/NArith/binPos.cmx \ + theories/NArith/binNat.cmx theories/ZArith/binInt.cmx \ + theories/FSets/orderedTypeEx.cmi +theories/FSets/orderedType.cmo: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/FSets/orderedType.cmi +theories/FSets/orderedType.cmx: theories/Init/specif.cmx \ + theories/Init/datatypes.cmx theories/FSets/orderedType.cmi theories/Init/datatypes.cmo: theories/Init/datatypes.cmi theories/Init/datatypes.cmx: theories/Init/datatypes.cmi theories/Init/logic.cmo: theories/Init/logic.cmi theories/Init/logic.cmx: theories/Init/logic.cmi -theories/Init/logic_Type.cmo: theories/Init/datatypes.cmi \ - theories/Init/logic_Type.cmi -theories/Init/logic_Type.cmx: theories/Init/datatypes.cmx \ - theories/Init/logic_Type.cmi +theories/Init/logic_Type.cmo: theories/Init/logic_Type.cmi +theories/Init/logic_Type.cmx: theories/Init/logic_Type.cmi theories/Init/notations.cmo: theories/Init/notations.cmi theories/Init/notations.cmx: theories/Init/notations.cmi theories/Init/peano.cmo: theories/Init/datatypes.cmi theories/Init/peano.cmi @@ -116,152 +324,146 @@ theories/Init/specif.cmo: theories/Init/datatypes.cmi \ theories/Init/specif.cmi theories/Init/specif.cmx: theories/Init/datatypes.cmx \ theories/Init/specif.cmi +theories/Init/tactics.cmo: theories/Init/tactics.cmi +theories/Init/tactics.cmx: theories/Init/tactics.cmi theories/Init/wf.cmo: theories/Init/wf.cmi theories/Init/wf.cmx: theories/Init/wf.cmi -theories/IntMap/adalloc.cmo: theories/IntMap/addec.cmi \ - theories/IntMap/addr.cmi theories/NArith/binPos.cmi \ - theories/Init/datatypes.cmi theories/IntMap/map.cmi \ - theories/Init/specif.cmi theories/Bool/sumbool.cmi \ - theories/IntMap/adalloc.cmi -theories/IntMap/adalloc.cmx: theories/IntMap/addec.cmx \ - theories/IntMap/addr.cmx theories/NArith/binPos.cmx \ - theories/Init/datatypes.cmx theories/IntMap/map.cmx \ - theories/Init/specif.cmx theories/Bool/sumbool.cmx \ - theories/IntMap/adalloc.cmi -theories/IntMap/addec.cmo: theories/IntMap/addr.cmi \ - theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ - theories/Init/specif.cmi theories/Bool/sumbool.cmi \ - theories/IntMap/addec.cmi -theories/IntMap/addec.cmx: theories/IntMap/addr.cmx \ - theories/NArith/binPos.cmx theories/Init/datatypes.cmx \ - theories/Init/specif.cmx theories/Bool/sumbool.cmx \ - theories/IntMap/addec.cmi -theories/IntMap/addr.cmo: theories/NArith/binPos.cmi theories/Bool/bool.cmi \ - theories/Init/datatypes.cmi theories/Init/specif.cmi \ - theories/IntMap/addr.cmi -theories/IntMap/addr.cmx: theories/NArith/binPos.cmx theories/Bool/bool.cmx \ - theories/Init/datatypes.cmx theories/Init/specif.cmx \ - theories/IntMap/addr.cmi -theories/IntMap/adist.cmo: theories/IntMap/addr.cmi \ - theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ - theories/IntMap/adist.cmi -theories/IntMap/adist.cmx: theories/IntMap/addr.cmx \ - theories/NArith/binPos.cmx theories/Init/datatypes.cmx \ - theories/IntMap/adist.cmi +theories/IntMap/adalloc.cmo: theories/Bool/sumbool.cmi \ + theories/Init/specif.cmi theories/NArith/ndec.cmi theories/IntMap/map.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/NArith/binNat.cmi theories/IntMap/adalloc.cmi +theories/IntMap/adalloc.cmx: theories/Bool/sumbool.cmx \ + theories/Init/specif.cmx theories/NArith/ndec.cmx theories/IntMap/map.cmx \ + theories/Init/datatypes.cmx theories/NArith/binPos.cmx \ + theories/NArith/binNat.cmx theories/IntMap/adalloc.cmi theories/IntMap/allmaps.cmo: theories/IntMap/allmaps.cmi theories/IntMap/allmaps.cmx: theories/IntMap/allmaps.cmi -theories/IntMap/fset.cmo: theories/IntMap/addec.cmi theories/IntMap/addr.cmi \ - theories/Init/datatypes.cmi theories/IntMap/map.cmi \ - theories/Init/specif.cmi theories/IntMap/fset.cmi -theories/IntMap/fset.cmx: theories/IntMap/addec.cmx theories/IntMap/addr.cmx \ - theories/Init/datatypes.cmx theories/IntMap/map.cmx \ - theories/Init/specif.cmx theories/IntMap/fset.cmi -theories/IntMap/lsort.cmo: theories/IntMap/addec.cmi theories/IntMap/addr.cmi \ - theories/NArith/binPos.cmi theories/Bool/bool.cmi \ - theories/Init/datatypes.cmi theories/Lists/list.cmi \ - theories/IntMap/map.cmi theories/IntMap/mapiter.cmi \ - theories/Init/specif.cmi theories/Bool/sumbool.cmi \ - theories/IntMap/lsort.cmi -theories/IntMap/lsort.cmx: theories/IntMap/addec.cmx theories/IntMap/addr.cmx \ - theories/NArith/binPos.cmx theories/Bool/bool.cmx \ - theories/Init/datatypes.cmx theories/Lists/list.cmx \ - theories/IntMap/map.cmx theories/IntMap/mapiter.cmx \ - theories/Init/specif.cmx theories/Bool/sumbool.cmx \ - theories/IntMap/lsort.cmi +theories/IntMap/fset.cmo: theories/Init/specif.cmi \ + theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \ + theories/IntMap/map.cmi theories/Init/datatypes.cmi \ + theories/NArith/binNat.cmi theories/IntMap/fset.cmi +theories/IntMap/fset.cmx: theories/Init/specif.cmx \ + theories/NArith/ndigits.cmx theories/NArith/ndec.cmx \ + theories/IntMap/map.cmx theories/Init/datatypes.cmx \ + theories/NArith/binNat.cmx theories/IntMap/fset.cmi +theories/IntMap/lsort.cmo: theories/Bool/sumbool.cmi theories/Init/specif.cmi \ + theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \ + theories/IntMap/mapiter.cmi theories/IntMap/map.cmi \ + theories/Lists/list.cmi theories/Init/datatypes.cmi \ + theories/NArith/binNat.cmi theories/IntMap/lsort.cmi +theories/IntMap/lsort.cmx: theories/Bool/sumbool.cmx theories/Init/specif.cmx \ + theories/NArith/ndigits.cmx theories/NArith/ndec.cmx \ + theories/IntMap/mapiter.cmx theories/IntMap/map.cmx \ + theories/Lists/list.cmx theories/Init/datatypes.cmx \ + theories/NArith/binNat.cmx theories/IntMap/lsort.cmi theories/IntMap/mapaxioms.cmo: theories/IntMap/mapaxioms.cmi theories/IntMap/mapaxioms.cmx: theories/IntMap/mapaxioms.cmi -theories/IntMap/mapcanon.cmo: theories/IntMap/map.cmi \ - theories/Init/specif.cmi theories/IntMap/mapcanon.cmi -theories/IntMap/mapcanon.cmx: theories/IntMap/map.cmx \ - theories/Init/specif.cmx theories/IntMap/mapcanon.cmi -theories/IntMap/mapcard.cmo: theories/IntMap/addec.cmi \ - theories/IntMap/addr.cmi theories/Init/datatypes.cmi \ - theories/IntMap/map.cmi theories/Init/peano.cmi \ - theories/Arith/peano_dec.cmi theories/Arith/plus.cmi \ - theories/Init/specif.cmi theories/Bool/sumbool.cmi \ - theories/IntMap/mapcard.cmi -theories/IntMap/mapcard.cmx: theories/IntMap/addec.cmx \ - theories/IntMap/addr.cmx theories/Init/datatypes.cmx \ - theories/IntMap/map.cmx theories/Init/peano.cmx \ - theories/Arith/peano_dec.cmx theories/Arith/plus.cmx \ - theories/Init/specif.cmx theories/Bool/sumbool.cmx \ - theories/IntMap/mapcard.cmi +theories/IntMap/mapcanon.cmo: theories/Init/specif.cmi \ + theories/IntMap/map.cmi theories/IntMap/mapcanon.cmi +theories/IntMap/mapcanon.cmx: theories/Init/specif.cmx \ + theories/IntMap/map.cmx theories/IntMap/mapcanon.cmi +theories/IntMap/mapcard.cmo: theories/Bool/sumbool.cmi \ + theories/Init/specif.cmi theories/Arith/plus.cmi \ + theories/Arith/peano_dec.cmi theories/Init/peano.cmi \ + theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \ + theories/IntMap/map.cmi theories/Init/datatypes.cmi \ + theories/NArith/binNat.cmi theories/IntMap/mapcard.cmi +theories/IntMap/mapcard.cmx: theories/Bool/sumbool.cmx \ + theories/Init/specif.cmx theories/Arith/plus.cmx \ + theories/Arith/peano_dec.cmx theories/Init/peano.cmx \ + theories/NArith/ndigits.cmx theories/NArith/ndec.cmx \ + theories/IntMap/map.cmx theories/Init/datatypes.cmx \ + theories/NArith/binNat.cmx theories/IntMap/mapcard.cmi theories/IntMap/mapc.cmo: theories/IntMap/mapc.cmi theories/IntMap/mapc.cmx: theories/IntMap/mapc.cmi -theories/IntMap/mapfold.cmo: theories/IntMap/addr.cmi \ - theories/Init/datatypes.cmi theories/IntMap/fset.cmi \ - theories/IntMap/map.cmi theories/IntMap/mapiter.cmi \ - theories/Init/specif.cmi theories/IntMap/mapfold.cmi -theories/IntMap/mapfold.cmx: theories/IntMap/addr.cmx \ - theories/Init/datatypes.cmx theories/IntMap/fset.cmx \ - theories/IntMap/map.cmx theories/IntMap/mapiter.cmx \ - theories/Init/specif.cmx theories/IntMap/mapfold.cmi -theories/IntMap/mapiter.cmo: theories/IntMap/addec.cmi \ - theories/IntMap/addr.cmi theories/Init/datatypes.cmi \ - theories/Lists/list.cmi theories/IntMap/map.cmi theories/Init/specif.cmi \ - theories/Bool/sumbool.cmi theories/IntMap/mapiter.cmi -theories/IntMap/mapiter.cmx: theories/IntMap/addec.cmx \ - theories/IntMap/addr.cmx theories/Init/datatypes.cmx \ - theories/Lists/list.cmx theories/IntMap/map.cmx theories/Init/specif.cmx \ - theories/Bool/sumbool.cmx theories/IntMap/mapiter.cmi -theories/IntMap/maplists.cmo: theories/IntMap/addec.cmi \ - theories/IntMap/addr.cmi theories/Init/datatypes.cmi \ - theories/IntMap/fset.cmi theories/Lists/list.cmi theories/IntMap/map.cmi \ - theories/IntMap/mapiter.cmi theories/Init/specif.cmi \ - theories/Bool/sumbool.cmi theories/IntMap/maplists.cmi -theories/IntMap/maplists.cmx: theories/IntMap/addec.cmx \ - theories/IntMap/addr.cmx theories/Init/datatypes.cmx \ - theories/IntMap/fset.cmx theories/Lists/list.cmx theories/IntMap/map.cmx \ - theories/IntMap/mapiter.cmx theories/Init/specif.cmx \ - theories/Bool/sumbool.cmx theories/IntMap/maplists.cmi -theories/IntMap/map.cmo: theories/IntMap/addec.cmi theories/IntMap/addr.cmi \ - theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ - theories/Init/peano.cmi theories/Init/specif.cmi theories/IntMap/map.cmi -theories/IntMap/map.cmx: theories/IntMap/addec.cmx theories/IntMap/addr.cmx \ - theories/NArith/binPos.cmx theories/Init/datatypes.cmx \ - theories/Init/peano.cmx theories/Init/specif.cmx theories/IntMap/map.cmi -theories/IntMap/mapsubset.cmo: theories/Bool/bool.cmi \ - theories/Init/datatypes.cmi theories/IntMap/fset.cmi \ - theories/IntMap/map.cmi theories/IntMap/mapiter.cmi \ +theories/IntMap/mapfold.cmo: theories/Init/specif.cmi \ + theories/IntMap/mapiter.cmi theories/IntMap/map.cmi \ + theories/IntMap/fset.cmi theories/Init/datatypes.cmi \ + theories/IntMap/mapfold.cmi +theories/IntMap/mapfold.cmx: theories/Init/specif.cmx \ + theories/IntMap/mapiter.cmx theories/IntMap/map.cmx \ + theories/IntMap/fset.cmx theories/Init/datatypes.cmx \ + theories/IntMap/mapfold.cmi +theories/IntMap/mapiter.cmo: theories/Bool/sumbool.cmi \ + theories/Init/specif.cmi theories/NArith/ndigits.cmi \ + theories/NArith/ndec.cmi theories/IntMap/map.cmi theories/Lists/list.cmi \ + theories/Init/datatypes.cmi theories/NArith/binNat.cmi \ + theories/IntMap/mapiter.cmi +theories/IntMap/mapiter.cmx: theories/Bool/sumbool.cmx \ + theories/Init/specif.cmx theories/NArith/ndigits.cmx \ + theories/NArith/ndec.cmx theories/IntMap/map.cmx theories/Lists/list.cmx \ + theories/Init/datatypes.cmx theories/NArith/binNat.cmx \ + theories/IntMap/mapiter.cmi +theories/IntMap/maplists.cmo: theories/Bool/sumbool.cmi \ + theories/Init/specif.cmi theories/NArith/ndec.cmi \ + theories/IntMap/mapiter.cmi theories/IntMap/map.cmi \ + theories/Lists/list.cmi theories/IntMap/fset.cmi \ + theories/Init/datatypes.cmi theories/IntMap/maplists.cmi +theories/IntMap/maplists.cmx: theories/Bool/sumbool.cmx \ + theories/Init/specif.cmx theories/NArith/ndec.cmx \ + theories/IntMap/mapiter.cmx theories/IntMap/map.cmx \ + theories/Lists/list.cmx theories/IntMap/fset.cmx \ + theories/Init/datatypes.cmx theories/IntMap/maplists.cmi +theories/IntMap/map.cmo: theories/Init/specif.cmi theories/Init/peano.cmi \ + theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/NArith/binNat.cmi theories/IntMap/map.cmi +theories/IntMap/map.cmx: theories/Init/specif.cmx theories/Init/peano.cmx \ + theories/NArith/ndigits.cmx theories/NArith/ndec.cmx \ + theories/Init/datatypes.cmx theories/NArith/binPos.cmx \ + theories/NArith/binNat.cmx theories/IntMap/map.cmi +theories/IntMap/mapsubset.cmo: theories/IntMap/mapiter.cmi \ + theories/IntMap/map.cmi theories/IntMap/fset.cmi \ + theories/Init/datatypes.cmi theories/Bool/bool.cmi \ theories/IntMap/mapsubset.cmi -theories/IntMap/mapsubset.cmx: theories/Bool/bool.cmx \ - theories/Init/datatypes.cmx theories/IntMap/fset.cmx \ - theories/IntMap/map.cmx theories/IntMap/mapiter.cmx \ +theories/IntMap/mapsubset.cmx: theories/IntMap/mapiter.cmx \ + theories/IntMap/map.cmx theories/IntMap/fset.cmx \ + theories/Init/datatypes.cmx theories/Bool/bool.cmx \ theories/IntMap/mapsubset.cmi -theories/Lists/list.cmo: theories/Init/datatypes.cmi theories/Init/specif.cmi \ +theories/Lists/list.cmo: theories/Init/specif.cmi theories/Init/datatypes.cmi \ theories/Lists/list.cmi -theories/Lists/list.cmx: theories/Init/datatypes.cmx theories/Init/specif.cmx \ +theories/Lists/list.cmx: theories/Init/specif.cmx theories/Init/datatypes.cmx \ theories/Lists/list.cmi -theories/Lists/listSet.cmo: theories/Init/datatypes.cmi \ - theories/Lists/list.cmi theories/Init/specif.cmi \ - theories/Lists/listSet.cmi -theories/Lists/listSet.cmx: theories/Init/datatypes.cmx \ - theories/Lists/list.cmx theories/Init/specif.cmx \ - theories/Lists/listSet.cmi +theories/Lists/listSet.cmo: theories/Init/specif.cmi theories/Lists/list.cmi \ + theories/Init/datatypes.cmi theories/Lists/listSet.cmi +theories/Lists/listSet.cmx: theories/Init/specif.cmx theories/Lists/list.cmx \ + theories/Init/datatypes.cmx theories/Lists/listSet.cmi theories/Lists/monoList.cmo: theories/Init/datatypes.cmi \ theories/Lists/monoList.cmi theories/Lists/monoList.cmx: theories/Init/datatypes.cmx \ theories/Lists/monoList.cmi +theories/Lists/setoidList.cmo: theories/Init/specif.cmi \ + theories/Lists/list.cmi theories/Init/datatypes.cmi \ + theories/Lists/setoidList.cmi +theories/Lists/setoidList.cmx: theories/Init/specif.cmx \ + theories/Lists/list.cmx theories/Init/datatypes.cmx \ + theories/Lists/setoidList.cmi theories/Lists/streams.cmo: theories/Init/datatypes.cmi \ theories/Lists/streams.cmi theories/Lists/streams.cmx: theories/Init/datatypes.cmx \ theories/Lists/streams.cmi -theories/Lists/theoryList.cmo: theories/Init/datatypes.cmi \ - theories/Lists/list.cmi theories/Init/specif.cmi \ +theories/Lists/theoryList.cmo: theories/Init/specif.cmi \ + theories/Lists/list.cmi theories/Init/datatypes.cmi \ theories/Lists/theoryList.cmi -theories/Lists/theoryList.cmx: theories/Init/datatypes.cmx \ - theories/Lists/list.cmx theories/Init/specif.cmx \ +theories/Lists/theoryList.cmx: theories/Init/specif.cmx \ + theories/Lists/list.cmx theories/Init/datatypes.cmx \ theories/Lists/theoryList.cmi theories/Logic/berardi.cmo: theories/Logic/berardi.cmi theories/Logic/berardi.cmx: theories/Logic/berardi.cmi -theories/Logic/choiceFacts.cmo: theories/Logic/choiceFacts.cmi -theories/Logic/choiceFacts.cmx: theories/Logic/choiceFacts.cmi +theories/Logic/choiceFacts.cmo: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/Logic/choiceFacts.cmi +theories/Logic/choiceFacts.cmx: theories/Init/specif.cmx \ + theories/Init/datatypes.cmx theories/Logic/choiceFacts.cmi theories/Logic/classicalChoice.cmo: theories/Logic/classicalChoice.cmi theories/Logic/classicalChoice.cmx: theories/Logic/classicalChoice.cmi -theories/Logic/classicalDescription.cmo: \ - theories/Logic/classicalDescription.cmi -theories/Logic/classicalDescription.cmx: \ - theories/Logic/classicalDescription.cmi +theories/Logic/classicalDescription.cmo: theories/Init/specif.cmi \ + theories/Logic/choiceFacts.cmi theories/Logic/classicalDescription.cmi +theories/Logic/classicalDescription.cmx: theories/Init/specif.cmx \ + theories/Logic/choiceFacts.cmx theories/Logic/classicalDescription.cmi +theories/Logic/classicalEpsilon.cmo: theories/Init/specif.cmi \ + theories/Logic/choiceFacts.cmi theories/Logic/classicalEpsilon.cmi +theories/Logic/classicalEpsilon.cmx: theories/Init/specif.cmx \ + theories/Logic/choiceFacts.cmx theories/Logic/classicalEpsilon.cmi theories/Logic/classicalFacts.cmo: theories/Logic/classicalFacts.cmi theories/Logic/classicalFacts.cmx: theories/Logic/classicalFacts.cmi theories/Logic/classical.cmo: theories/Logic/classical.cmi @@ -272,38 +474,118 @@ theories/Logic/classical_Pred_Type.cmo: \ theories/Logic/classical_Pred_Type.cmi theories/Logic/classical_Pred_Type.cmx: \ theories/Logic/classical_Pred_Type.cmi -theories/Logic/classical_Prop.cmo: theories/Logic/classical_Prop.cmi -theories/Logic/classical_Prop.cmx: theories/Logic/classical_Prop.cmi +theories/Logic/classical_Prop.cmo: theories/Logic/eqdepFacts.cmi \ + theories/Logic/classical_Prop.cmi +theories/Logic/classical_Prop.cmx: theories/Logic/eqdepFacts.cmx \ + theories/Logic/classical_Prop.cmi theories/Logic/classical_Type.cmo: theories/Logic/classical_Type.cmi theories/Logic/classical_Type.cmx: theories/Logic/classical_Type.cmi +theories/Logic/classicalUniqueChoice.cmo: \ + theories/Logic/classicalUniqueChoice.cmi +theories/Logic/classicalUniqueChoice.cmx: \ + theories/Logic/classicalUniqueChoice.cmi theories/Logic/decidable.cmo: theories/Logic/decidable.cmi theories/Logic/decidable.cmx: theories/Logic/decidable.cmi -theories/Logic/diaconescu.cmo: theories/Logic/diaconescu.cmi -theories/Logic/diaconescu.cmx: theories/Logic/diaconescu.cmi -theories/Logic/eqdep_dec.cmo: theories/Logic/eqdep_dec.cmi -theories/Logic/eqdep_dec.cmx: theories/Logic/eqdep_dec.cmi -theories/Logic/eqdep.cmo: theories/Logic/eqdep.cmi -theories/Logic/eqdep.cmx: theories/Logic/eqdep.cmi +theories/Logic/diaconescu.cmo: theories/Init/specif.cmi \ + theories/Logic/diaconescu.cmi +theories/Logic/diaconescu.cmx: theories/Init/specif.cmx \ + theories/Logic/diaconescu.cmi +theories/Logic/eqdep_dec.cmo: theories/Init/specif.cmi \ + theories/Logic/eqdep_dec.cmi +theories/Logic/eqdep_dec.cmx: theories/Init/specif.cmx \ + theories/Logic/eqdep_dec.cmi +theories/Logic/eqdepFacts.cmo: theories/Logic/eqdepFacts.cmi +theories/Logic/eqdepFacts.cmx: theories/Logic/eqdepFacts.cmi +theories/Logic/eqdep.cmo: theories/Logic/eqdepFacts.cmi \ + theories/Logic/eqdep.cmi +theories/Logic/eqdep.cmx: theories/Logic/eqdepFacts.cmx \ + theories/Logic/eqdep.cmi theories/Logic/hurkens.cmo: theories/Logic/hurkens.cmi theories/Logic/hurkens.cmx: theories/Logic/hurkens.cmi theories/Logic/jMeq.cmo: theories/Logic/jMeq.cmi theories/Logic/jMeq.cmx: theories/Logic/jMeq.cmi -theories/Logic/proofIrrelevance.cmo: theories/Logic/proofIrrelevance.cmi -theories/Logic/proofIrrelevance.cmx: theories/Logic/proofIrrelevance.cmi +theories/Logic/proofIrrelevanceFacts.cmo: theories/Logic/eqdepFacts.cmi \ + theories/Logic/proofIrrelevanceFacts.cmi +theories/Logic/proofIrrelevanceFacts.cmx: theories/Logic/eqdepFacts.cmx \ + theories/Logic/proofIrrelevanceFacts.cmi +theories/Logic/proofIrrelevance.cmo: theories/Logic/proofIrrelevanceFacts.cmi \ + theories/Logic/proofIrrelevance.cmi +theories/Logic/proofIrrelevance.cmx: theories/Logic/proofIrrelevanceFacts.cmx \ + theories/Logic/proofIrrelevance.cmi theories/Logic/relationalChoice.cmo: theories/Logic/relationalChoice.cmi theories/Logic/relationalChoice.cmx: theories/Logic/relationalChoice.cmi -theories/NArith/binNat.cmo: theories/NArith/binPos.cmi \ - theories/Init/datatypes.cmi theories/NArith/binNat.cmi -theories/NArith/binNat.cmx: theories/NArith/binPos.cmx \ - theories/Init/datatypes.cmx theories/NArith/binNat.cmi -theories/NArith/binPos.cmo: theories/Init/datatypes.cmi \ - theories/Init/peano.cmi theories/NArith/binPos.cmi -theories/NArith/binPos.cmx: theories/Init/datatypes.cmx \ - theories/Init/peano.cmx theories/NArith/binPos.cmi +theories/NArith/binNat.cmo: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/NArith/binNat.cmi +theories/NArith/binNat.cmx: theories/Init/specif.cmx \ + theories/Init/datatypes.cmx theories/NArith/binPos.cmx \ + theories/NArith/binNat.cmi +theories/NArith/binPos.cmo: theories/Init/peano.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi +theories/NArith/binPos.cmx: theories/Init/peano.cmx \ + theories/Init/datatypes.cmx theories/NArith/binPos.cmi theories/NArith/nArith.cmo: theories/NArith/nArith.cmi theories/NArith/nArith.cmx: theories/NArith/nArith.cmi +theories/NArith/ndec.cmo: theories/Bool/sumbool.cmi theories/Init/specif.cmi \ + theories/NArith/nnat.cmi theories/NArith/ndigits.cmi \ + theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi \ + theories/NArith/binPos.cmi theories/NArith/binNat.cmi \ + theories/NArith/ndec.cmi +theories/NArith/ndec.cmx: theories/Bool/sumbool.cmx theories/Init/specif.cmx \ + theories/NArith/nnat.cmx theories/NArith/ndigits.cmx \ + theories/Init/datatypes.cmx theories/Arith/compare_dec.cmx \ + theories/NArith/binPos.cmx theories/NArith/binNat.cmx \ + theories/NArith/ndec.cmi +theories/NArith/ndigits.cmo: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/Bool/bvector.cmi \ + theories/Bool/bool.cmi theories/NArith/binPos.cmi \ + theories/NArith/binNat.cmi theories/NArith/ndigits.cmi +theories/NArith/ndigits.cmx: theories/Init/specif.cmx \ + theories/Init/datatypes.cmx theories/Bool/bvector.cmx \ + theories/Bool/bool.cmx theories/NArith/binPos.cmx \ + theories/NArith/binNat.cmx theories/NArith/ndigits.cmi +theories/NArith/ndist.cmo: theories/NArith/ndigits.cmi theories/Arith/min.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/NArith/binNat.cmi theories/NArith/ndist.cmi +theories/NArith/ndist.cmx: theories/NArith/ndigits.cmx theories/Arith/min.cmx \ + theories/Init/datatypes.cmx theories/NArith/binPos.cmx \ + theories/NArith/binNat.cmx theories/NArith/ndist.cmi +theories/NArith/nnat.cmo: theories/Init/datatypes.cmi \ + theories/NArith/binPos.cmi theories/NArith/binNat.cmi \ + theories/NArith/nnat.cmi +theories/NArith/nnat.cmx: theories/Init/datatypes.cmx \ + theories/NArith/binPos.cmx theories/NArith/binNat.cmx \ + theories/NArith/nnat.cmi theories/NArith/pnat.cmo: theories/NArith/pnat.cmi theories/NArith/pnat.cmx: theories/NArith/pnat.cmi +theories/QArith/qArith_base.cmo: theories/ZArith/zArith_dec.cmi \ + theories/Init/specif.cmi theories/Setoids/setoid.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/ZArith/binInt.cmi theories/QArith/qArith_base.cmi +theories/QArith/qArith_base.cmx: theories/ZArith/zArith_dec.cmx \ + theories/Init/specif.cmx theories/Setoids/setoid.cmx \ + theories/Init/datatypes.cmx theories/NArith/binPos.cmx \ + theories/ZArith/binInt.cmx theories/QArith/qArith_base.cmi +theories/QArith/qArith.cmo: theories/QArith/qArith.cmi +theories/QArith/qArith.cmx: theories/QArith/qArith.cmi +theories/QArith/qreals.cmo: theories/QArith/qArith_base.cmi \ + theories/ZArith/binInt.cmi theories/QArith/qreals.cmi +theories/QArith/qreals.cmx: theories/QArith/qArith_base.cmx \ + theories/ZArith/binInt.cmx theories/QArith/qreals.cmi +theories/QArith/qreduction.cmo: theories/ZArith/znumtheory.cmi \ + theories/Setoids/setoid.cmi theories/QArith/qArith_base.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/ZArith/binInt.cmi theories/QArith/qreduction.cmi +theories/QArith/qreduction.cmx: theories/ZArith/znumtheory.cmx \ + theories/Setoids/setoid.cmx theories/QArith/qArith_base.cmx \ + theories/Init/datatypes.cmx theories/NArith/binPos.cmx \ + theories/ZArith/binInt.cmx theories/QArith/qreduction.cmi +theories/QArith/qring.cmo: theories/Init/specif.cmi \ + theories/QArith/qArith_base.cmi theories/Init/datatypes.cmi \ + theories/QArith/qring.cmi +theories/QArith/qring.cmx: theories/Init/specif.cmx \ + theories/QArith/qArith_base.cmx theories/Init/datatypes.cmx \ + theories/QArith/qring.cmi theories/Relations/newman.cmo: theories/Relations/newman.cmi theories/Relations/newman.cmx: theories/Relations/newman.cmi theories/Relations/operators_Properties.cmo: \ @@ -314,16 +596,18 @@ theories/Relations/relation_Definitions.cmo: \ theories/Relations/relation_Definitions.cmi theories/Relations/relation_Definitions.cmx: \ theories/Relations/relation_Definitions.cmi -theories/Relations/relation_Operators.cmo: theories/Lists/list.cmi \ - theories/Init/specif.cmi theories/Relations/relation_Operators.cmi -theories/Relations/relation_Operators.cmx: theories/Lists/list.cmx \ - theories/Init/specif.cmx theories/Relations/relation_Operators.cmi +theories/Relations/relation_Operators.cmo: theories/Init/specif.cmi \ + theories/Lists/list.cmi theories/Relations/relation_Operators.cmi +theories/Relations/relation_Operators.cmx: theories/Init/specif.cmx \ + theories/Lists/list.cmx theories/Relations/relation_Operators.cmi theories/Relations/relations.cmo: theories/Relations/relations.cmi theories/Relations/relations.cmx: theories/Relations/relations.cmi theories/Relations/rstar.cmo: theories/Relations/rstar.cmi theories/Relations/rstar.cmx: theories/Relations/rstar.cmi -theories/Setoids/setoid.cmo: theories/Setoids/setoid.cmi -theories/Setoids/setoid.cmx: theories/Setoids/setoid.cmi +theories/Setoids/setoid.cmo: theories/Init/datatypes.cmi \ + theories/Setoids/setoid.cmi +theories/Setoids/setoid.cmx: theories/Init/datatypes.cmx \ + theories/Setoids/setoid.cmi theories/Sets/classical_sets.cmo: theories/Sets/classical_sets.cmi theories/Sets/classical_sets.cmx: theories/Sets/classical_sets.cmi theories/Sets/constructive_sets.cmo: theories/Sets/constructive_sets.cmi @@ -340,20 +624,18 @@ theories/Sets/image.cmo: theories/Sets/image.cmi theories/Sets/image.cmx: theories/Sets/image.cmi theories/Sets/infinite_sets.cmo: theories/Sets/infinite_sets.cmi theories/Sets/infinite_sets.cmx: theories/Sets/infinite_sets.cmi -theories/Sets/integers.cmo: theories/Init/datatypes.cmi \ - theories/Sets/partial_Order.cmi theories/Sets/integers.cmi -theories/Sets/integers.cmx: theories/Init/datatypes.cmx \ - theories/Sets/partial_Order.cmx theories/Sets/integers.cmi -theories/Sets/multiset.cmo: theories/Init/datatypes.cmi \ - theories/Init/peano.cmi theories/Init/specif.cmi \ - theories/Sets/multiset.cmi -theories/Sets/multiset.cmx: theories/Init/datatypes.cmx \ - theories/Init/peano.cmx theories/Init/specif.cmx \ - theories/Sets/multiset.cmi -theories/Sets/partial_Order.cmo: theories/Sets/ensembles.cmi \ - theories/Sets/relations_1.cmi theories/Sets/partial_Order.cmi -theories/Sets/partial_Order.cmx: theories/Sets/ensembles.cmx \ - theories/Sets/relations_1.cmx theories/Sets/partial_Order.cmi +theories/Sets/integers.cmo: theories/Sets/partial_Order.cmi \ + theories/Init/datatypes.cmi theories/Sets/integers.cmi +theories/Sets/integers.cmx: theories/Sets/partial_Order.cmx \ + theories/Init/datatypes.cmx theories/Sets/integers.cmi +theories/Sets/multiset.cmo: theories/Init/specif.cmi theories/Init/peano.cmi \ + theories/Init/datatypes.cmi theories/Sets/multiset.cmi +theories/Sets/multiset.cmx: theories/Init/specif.cmx theories/Init/peano.cmx \ + theories/Init/datatypes.cmx theories/Sets/multiset.cmi +theories/Sets/partial_Order.cmo: theories/Sets/relations_1.cmi \ + theories/Sets/ensembles.cmi theories/Sets/partial_Order.cmi +theories/Sets/partial_Order.cmx: theories/Sets/relations_1.cmx \ + theories/Sets/ensembles.cmx theories/Sets/partial_Order.cmi theories/Sets/permut.cmo: theories/Sets/permut.cmi theories/Sets/permut.cmx: theories/Sets/permut.cmi theories/Sets/powerset_Classical_facts.cmo: \ @@ -362,10 +644,10 @@ theories/Sets/powerset_Classical_facts.cmx: \ theories/Sets/powerset_Classical_facts.cmi theories/Sets/powerset_facts.cmo: theories/Sets/powerset_facts.cmi theories/Sets/powerset_facts.cmx: theories/Sets/powerset_facts.cmi -theories/Sets/powerset.cmo: theories/Sets/ensembles.cmi \ - theories/Sets/partial_Order.cmi theories/Sets/powerset.cmi -theories/Sets/powerset.cmx: theories/Sets/ensembles.cmx \ - theories/Sets/partial_Order.cmx theories/Sets/powerset.cmi +theories/Sets/powerset.cmo: theories/Sets/partial_Order.cmi \ + theories/Sets/ensembles.cmi theories/Sets/powerset.cmi +theories/Sets/powerset.cmx: theories/Sets/partial_Order.cmx \ + theories/Sets/ensembles.cmx theories/Sets/powerset.cmi theories/Sets/relations_1_facts.cmo: theories/Sets/relations_1_facts.cmi theories/Sets/relations_1_facts.cmx: theories/Sets/relations_1_facts.cmi theories/Sets/relations_1.cmo: theories/Sets/relations_1.cmi @@ -378,30 +660,46 @@ theories/Sets/relations_3_facts.cmo: theories/Sets/relations_3_facts.cmi theories/Sets/relations_3_facts.cmx: theories/Sets/relations_3_facts.cmi theories/Sets/relations_3.cmo: theories/Sets/relations_3.cmi theories/Sets/relations_3.cmx: theories/Sets/relations_3.cmi -theories/Sets/uniset.cmo: theories/Init/datatypes.cmi \ - theories/Init/specif.cmi theories/Sets/uniset.cmi -theories/Sets/uniset.cmx: theories/Init/datatypes.cmx \ - theories/Init/specif.cmx theories/Sets/uniset.cmi -theories/Sorting/heap.cmo: theories/Init/datatypes.cmi \ - theories/Lists/list.cmi theories/Sets/multiset.cmi \ - theories/Init/peano.cmi theories/Sorting/sorting.cmi \ - theories/Init/specif.cmi theories/Sorting/heap.cmi -theories/Sorting/heap.cmx: theories/Init/datatypes.cmx \ - theories/Lists/list.cmx theories/Sets/multiset.cmx \ - theories/Init/peano.cmx theories/Sorting/sorting.cmx \ - theories/Init/specif.cmx theories/Sorting/heap.cmi -theories/Sorting/permutation.cmo: theories/Init/datatypes.cmi \ - theories/Lists/list.cmi theories/Sets/multiset.cmi \ - theories/Init/peano.cmi theories/Init/specif.cmi \ +theories/Sets/uniset.cmo: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/Sets/uniset.cmi +theories/Sets/uniset.cmx: theories/Init/specif.cmx \ + theories/Init/datatypes.cmx theories/Sets/uniset.cmi +theories/Sorting/heap.cmo: theories/Init/specif.cmi \ + theories/Sorting/sorting.cmi theories/Init/peano.cmi \ + theories/Sets/multiset.cmi theories/Lists/list.cmi \ + theories/Init/datatypes.cmi theories/Sorting/heap.cmi +theories/Sorting/heap.cmx: theories/Init/specif.cmx \ + theories/Sorting/sorting.cmx theories/Init/peano.cmx \ + theories/Sets/multiset.cmx theories/Lists/list.cmx \ + theories/Init/datatypes.cmx theories/Sorting/heap.cmi +theories/Sorting/permutation.cmo: theories/Init/specif.cmi \ + theories/Init/peano.cmi theories/Sets/multiset.cmi \ + theories/Lists/list.cmi theories/Init/datatypes.cmi \ theories/Sorting/permutation.cmi -theories/Sorting/permutation.cmx: theories/Init/datatypes.cmx \ - theories/Lists/list.cmx theories/Sets/multiset.cmx \ - theories/Init/peano.cmx theories/Init/specif.cmx \ +theories/Sorting/permutation.cmx: theories/Init/specif.cmx \ + theories/Init/peano.cmx theories/Sets/multiset.cmx \ + theories/Lists/list.cmx theories/Init/datatypes.cmx \ theories/Sorting/permutation.cmi -theories/Sorting/sorting.cmo: theories/Lists/list.cmi \ - theories/Init/specif.cmi theories/Sorting/sorting.cmi -theories/Sorting/sorting.cmx: theories/Lists/list.cmx \ - theories/Init/specif.cmx theories/Sorting/sorting.cmi +theories/Sorting/permutEq.cmo: theories/Sorting/permutEq.cmi +theories/Sorting/permutEq.cmx: theories/Sorting/permutEq.cmi +theories/Sorting/permutSetoid.cmo: theories/Sorting/permutSetoid.cmi +theories/Sorting/permutSetoid.cmx: theories/Sorting/permutSetoid.cmi +theories/Sorting/sorting.cmo: theories/Init/specif.cmi \ + theories/Lists/list.cmi theories/Sorting/sorting.cmi +theories/Sorting/sorting.cmx: theories/Init/specif.cmx \ + theories/Lists/list.cmx theories/Sorting/sorting.cmi +theories/Strings/ascii.cmo: theories/Init/specif.cmi theories/Init/peano.cmi \ + theories/Init/datatypes.cmi theories/Bool/bool.cmi \ + theories/NArith/binPos.cmi theories/Strings/ascii.cmi +theories/Strings/ascii.cmx: theories/Init/specif.cmx theories/Init/peano.cmx \ + theories/Init/datatypes.cmx theories/Bool/bool.cmx \ + theories/NArith/binPos.cmx theories/Strings/ascii.cmi +theories/Strings/string.cmo: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/Strings/ascii.cmi \ + theories/Strings/string.cmi +theories/Strings/string.cmx: theories/Init/specif.cmx \ + theories/Init/datatypes.cmx theories/Strings/ascii.cmx \ + theories/Strings/string.cmi theories/Wellfounded/disjoint_Union.cmo: \ theories/Wellfounded/disjoint_Union.cmi theories/Wellfounded/disjoint_Union.cmx: \ @@ -434,280 +732,405 @@ theories/Wellfounded/well_Ordering.cmx: theories/Init/specif.cmx \ theories/Wellfounded/well_Ordering.cmi theories/ZArith/auxiliary.cmo: theories/ZArith/auxiliary.cmi theories/ZArith/auxiliary.cmx: theories/ZArith/auxiliary.cmi -theories/ZArith/binInt.cmo: theories/NArith/binNat.cmi \ - theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ +theories/ZArith/binInt.cmo: theories/Init/datatypes.cmi \ + theories/NArith/binPos.cmi theories/NArith/binNat.cmi \ theories/ZArith/binInt.cmi -theories/ZArith/binInt.cmx: theories/NArith/binNat.cmx \ - theories/NArith/binPos.cmx theories/Init/datatypes.cmx \ +theories/ZArith/binInt.cmx: theories/Init/datatypes.cmx \ + theories/NArith/binPos.cmx theories/NArith/binNat.cmx \ theories/ZArith/binInt.cmi -theories/ZArith/wf_Z.cmo: theories/ZArith/binInt.cmi \ - theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ - theories/Init/peano.cmi theories/Init/specif.cmi theories/ZArith/wf_Z.cmi -theories/ZArith/wf_Z.cmx: theories/ZArith/binInt.cmx \ - theories/NArith/binPos.cmx theories/Init/datatypes.cmx \ - theories/Init/peano.cmx theories/Init/specif.cmx theories/ZArith/wf_Z.cmi -theories/ZArith/zabs.cmo: theories/ZArith/binInt.cmi theories/Init/specif.cmi \ - theories/Bool/sumbool.cmi theories/ZArith/zabs.cmi -theories/ZArith/zabs.cmx: theories/ZArith/binInt.cmx theories/Init/specif.cmx \ - theories/Bool/sumbool.cmx theories/ZArith/zabs.cmi +theories/ZArith/wf_Z.cmo: theories/Init/specif.cmi theories/Init/peano.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/ZArith/binInt.cmi theories/ZArith/wf_Z.cmi +theories/ZArith/wf_Z.cmx: theories/Init/specif.cmx theories/Init/peano.cmx \ + theories/Init/datatypes.cmx theories/NArith/binPos.cmx \ + theories/ZArith/binInt.cmx theories/ZArith/wf_Z.cmi +theories/ZArith/zabs.cmo: theories/Init/specif.cmi theories/ZArith/binInt.cmi \ + theories/ZArith/zabs.cmi +theories/ZArith/zabs.cmx: theories/Init/specif.cmx theories/ZArith/binInt.cmx \ + theories/ZArith/zabs.cmi theories/ZArith/zArith_base.cmo: theories/ZArith/zArith_base.cmi theories/ZArith/zArith_base.cmx: theories/ZArith/zArith_base.cmi -theories/ZArith/zArith_dec.cmo: theories/ZArith/binInt.cmi \ - theories/Init/datatypes.cmi theories/Init/specif.cmi \ - theories/Bool/sumbool.cmi theories/ZArith/zArith_dec.cmi -theories/ZArith/zArith_dec.cmx: theories/ZArith/binInt.cmx \ - theories/Init/datatypes.cmx theories/Init/specif.cmx \ - theories/Bool/sumbool.cmx theories/ZArith/zArith_dec.cmi +theories/ZArith/zArith_dec.cmo: theories/Bool/sumbool.cmi \ + theories/Init/specif.cmi theories/Init/datatypes.cmi \ + theories/ZArith/binInt.cmi theories/ZArith/zArith_dec.cmi +theories/ZArith/zArith_dec.cmx: theories/Bool/sumbool.cmx \ + theories/Init/specif.cmx theories/Init/datatypes.cmx \ + theories/ZArith/binInt.cmx theories/ZArith/zArith_dec.cmi theories/ZArith/zArith.cmo: theories/ZArith/zArith.cmi theories/ZArith/zArith.cmx: theories/ZArith/zArith.cmi -theories/ZArith/zbinary.cmo: theories/ZArith/binInt.cmi \ - theories/NArith/binPos.cmi theories/Bool/bvector.cmi \ - theories/Init/datatypes.cmi theories/ZArith/zeven.cmi \ +theories/ZArith/zbinary.cmo: theories/ZArith/zeven.cmi \ + theories/Init/datatypes.cmi theories/Bool/bvector.cmi \ + theories/NArith/binPos.cmi theories/ZArith/binInt.cmi \ theories/ZArith/zbinary.cmi -theories/ZArith/zbinary.cmx: theories/ZArith/binInt.cmx \ - theories/NArith/binPos.cmx theories/Bool/bvector.cmx \ - theories/Init/datatypes.cmx theories/ZArith/zeven.cmx \ +theories/ZArith/zbinary.cmx: theories/ZArith/zeven.cmx \ + theories/Init/datatypes.cmx theories/Bool/bvector.cmx \ + theories/NArith/binPos.cmx theories/ZArith/binInt.cmx \ theories/ZArith/zbinary.cmi -theories/ZArith/zbool.cmo: theories/ZArith/binInt.cmi \ - theories/Init/datatypes.cmi theories/Init/specif.cmi \ - theories/Bool/sumbool.cmi theories/ZArith/zArith_dec.cmi \ - theories/ZArith/zeven.cmi theories/ZArith/zbool.cmi -theories/ZArith/zbool.cmx: theories/ZArith/binInt.cmx \ - theories/Init/datatypes.cmx theories/Init/specif.cmx \ - theories/Bool/sumbool.cmx theories/ZArith/zArith_dec.cmx \ - theories/ZArith/zeven.cmx theories/ZArith/zbool.cmi +theories/ZArith/zbool.cmo: theories/ZArith/zeven.cmi \ + theories/ZArith/zArith_dec.cmi theories/Bool/sumbool.cmi \ + theories/Init/specif.cmi theories/Init/datatypes.cmi \ + theories/ZArith/binInt.cmi theories/ZArith/zbool.cmi +theories/ZArith/zbool.cmx: theories/ZArith/zeven.cmx \ + theories/ZArith/zArith_dec.cmx theories/Bool/sumbool.cmx \ + theories/Init/specif.cmx theories/Init/datatypes.cmx \ + theories/ZArith/binInt.cmx theories/ZArith/zbool.cmi theories/ZArith/zcompare.cmo: theories/ZArith/zcompare.cmi theories/ZArith/zcompare.cmx: theories/ZArith/zcompare.cmi -theories/ZArith/zcomplements.cmo: theories/ZArith/binInt.cmi \ - theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ - theories/Lists/list.cmi theories/Init/specif.cmi theories/ZArith/wf_Z.cmi \ - theories/ZArith/zabs.cmi theories/ZArith/zcomplements.cmi -theories/ZArith/zcomplements.cmx: theories/ZArith/binInt.cmx \ - theories/NArith/binPos.cmx theories/Init/datatypes.cmx \ - theories/Lists/list.cmx theories/Init/specif.cmx theories/ZArith/wf_Z.cmx \ - theories/ZArith/zabs.cmx theories/ZArith/zcomplements.cmi -theories/ZArith/zdiv.cmo: theories/ZArith/binInt.cmi \ - theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ - theories/Init/specif.cmi theories/ZArith/zArith_dec.cmi \ - theories/ZArith/zbool.cmi theories/ZArith/zdiv.cmi -theories/ZArith/zdiv.cmx: theories/ZArith/binInt.cmx \ - theories/NArith/binPos.cmx theories/Init/datatypes.cmx \ - theories/Init/specif.cmx theories/ZArith/zArith_dec.cmx \ - theories/ZArith/zbool.cmx theories/ZArith/zdiv.cmi -theories/ZArith/zeven.cmo: theories/ZArith/binInt.cmi \ - theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ - theories/Init/specif.cmi theories/ZArith/zeven.cmi -theories/ZArith/zeven.cmx: theories/ZArith/binInt.cmx \ - theories/NArith/binPos.cmx theories/Init/datatypes.cmx \ - theories/Init/specif.cmx theories/ZArith/zeven.cmi +theories/ZArith/zcomplements.cmo: theories/ZArith/zabs.cmi \ + theories/ZArith/wf_Z.cmi theories/Init/specif.cmi theories/Lists/list.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/ZArith/binInt.cmi theories/ZArith/zcomplements.cmi +theories/ZArith/zcomplements.cmx: theories/ZArith/zabs.cmx \ + theories/ZArith/wf_Z.cmx theories/Init/specif.cmx theories/Lists/list.cmx \ + theories/Init/datatypes.cmx theories/NArith/binPos.cmx \ + theories/ZArith/binInt.cmx theories/ZArith/zcomplements.cmi +theories/ZArith/zdiv.cmo: theories/ZArith/zbool.cmi \ + theories/ZArith/zArith_dec.cmi theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/ZArith/binInt.cmi theories/ZArith/zdiv.cmi +theories/ZArith/zdiv.cmx: theories/ZArith/zbool.cmx \ + theories/ZArith/zArith_dec.cmx theories/Init/specif.cmx \ + theories/Init/datatypes.cmx theories/NArith/binPos.cmx \ + theories/ZArith/binInt.cmx theories/ZArith/zdiv.cmi +theories/ZArith/zeven.cmo: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/ZArith/binInt.cmi theories/ZArith/zeven.cmi +theories/ZArith/zeven.cmx: theories/Init/specif.cmx \ + theories/Init/datatypes.cmx theories/NArith/binPos.cmx \ + theories/ZArith/binInt.cmx theories/ZArith/zeven.cmi theories/ZArith/zhints.cmo: theories/ZArith/zhints.cmi theories/ZArith/zhints.cmx: theories/ZArith/zhints.cmi -theories/ZArith/zlogarithm.cmo: theories/ZArith/binInt.cmi \ - theories/NArith/binPos.cmi theories/ZArith/zlogarithm.cmi -theories/ZArith/zlogarithm.cmx: theories/ZArith/binInt.cmx \ - theories/NArith/binPos.cmx theories/ZArith/zlogarithm.cmi -theories/ZArith/zmin.cmo: theories/ZArith/binInt.cmi \ - theories/Init/datatypes.cmi theories/ZArith/zmin.cmi -theories/ZArith/zmin.cmx: theories/ZArith/binInt.cmx \ - theories/Init/datatypes.cmx theories/ZArith/zmin.cmi -theories/ZArith/zmisc.cmo: theories/ZArith/binInt.cmi \ - theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ +theories/ZArith/zlogarithm.cmo: theories/NArith/binPos.cmi \ + theories/ZArith/binInt.cmi theories/ZArith/zlogarithm.cmi +theories/ZArith/zlogarithm.cmx: theories/NArith/binPos.cmx \ + theories/ZArith/binInt.cmx theories/ZArith/zlogarithm.cmi +theories/ZArith/zmax.cmo: theories/Init/datatypes.cmi \ + theories/ZArith/binInt.cmi theories/ZArith/zmax.cmi +theories/ZArith/zmax.cmx: theories/Init/datatypes.cmx \ + theories/ZArith/binInt.cmx theories/ZArith/zmax.cmi +theories/ZArith/zminmax.cmo: theories/ZArith/zminmax.cmi +theories/ZArith/zminmax.cmx: theories/ZArith/zminmax.cmi +theories/ZArith/zmin.cmo: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/ZArith/binInt.cmi \ + theories/ZArith/zmin.cmi +theories/ZArith/zmin.cmx: theories/Init/specif.cmx \ + theories/Init/datatypes.cmx theories/ZArith/binInt.cmx \ + theories/ZArith/zmin.cmi +theories/ZArith/zmisc.cmo: theories/Init/datatypes.cmi \ + theories/NArith/binPos.cmi theories/ZArith/binInt.cmi \ theories/ZArith/zmisc.cmi -theories/ZArith/zmisc.cmx: theories/ZArith/binInt.cmx \ - theories/NArith/binPos.cmx theories/Init/datatypes.cmx \ +theories/ZArith/zmisc.cmx: theories/Init/datatypes.cmx \ + theories/NArith/binPos.cmx theories/ZArith/binInt.cmx \ theories/ZArith/zmisc.cmi theories/ZArith/znat.cmo: theories/ZArith/znat.cmi theories/ZArith/znat.cmx: theories/ZArith/znat.cmi -theories/ZArith/znumtheory.cmo: theories/ZArith/binInt.cmi \ - theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ - theories/Init/specif.cmi theories/ZArith/wf_Z.cmi \ - theories/ZArith/zArith_dec.cmi theories/ZArith/zdiv.cmi \ - theories/ZArith/zorder.cmi theories/ZArith/znumtheory.cmi -theories/ZArith/znumtheory.cmx: theories/ZArith/binInt.cmx \ - theories/NArith/binPos.cmx theories/Init/datatypes.cmx \ - theories/Init/specif.cmx theories/ZArith/wf_Z.cmx \ - theories/ZArith/zArith_dec.cmx theories/ZArith/zdiv.cmx \ - theories/ZArith/zorder.cmx theories/ZArith/znumtheory.cmi -theories/ZArith/zorder.cmo: theories/ZArith/binInt.cmi \ - theories/Init/datatypes.cmi theories/Init/specif.cmi \ +theories/ZArith/znumtheory.cmo: theories/ZArith/zorder.cmi \ + theories/ZArith/zdiv.cmi theories/ZArith/zArith_dec.cmi \ + theories/ZArith/wf_Z.cmi theories/Init/specif.cmi theories/Init/peano.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/ZArith/binInt.cmi theories/ZArith/znumtheory.cmi +theories/ZArith/znumtheory.cmx: theories/ZArith/zorder.cmx \ + theories/ZArith/zdiv.cmx theories/ZArith/zArith_dec.cmx \ + theories/ZArith/wf_Z.cmx theories/Init/specif.cmx theories/Init/peano.cmx \ + theories/Init/datatypes.cmx theories/NArith/binPos.cmx \ + theories/ZArith/binInt.cmx theories/ZArith/znumtheory.cmi +theories/ZArith/zorder.cmo: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/ZArith/binInt.cmi \ theories/ZArith/zorder.cmi -theories/ZArith/zorder.cmx: theories/ZArith/binInt.cmx \ - theories/Init/datatypes.cmx theories/Init/specif.cmx \ +theories/ZArith/zorder.cmx: theories/Init/specif.cmx \ + theories/Init/datatypes.cmx theories/ZArith/binInt.cmx \ theories/ZArith/zorder.cmi -theories/ZArith/zpower.cmo: theories/ZArith/binInt.cmi \ - theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ - theories/ZArith/zmisc.cmi theories/ZArith/zpower.cmi -theories/ZArith/zpower.cmx: theories/ZArith/binInt.cmx \ - theories/NArith/binPos.cmx theories/Init/datatypes.cmx \ - theories/ZArith/zmisc.cmx theories/ZArith/zpower.cmi -theories/ZArith/zsqrt.cmo: theories/ZArith/binInt.cmi \ - theories/NArith/binPos.cmi theories/Init/specif.cmi \ - theories/ZArith/zArith_dec.cmi theories/ZArith/zsqrt.cmi -theories/ZArith/zsqrt.cmx: theories/ZArith/binInt.cmx \ - theories/NArith/binPos.cmx theories/Init/specif.cmx \ - theories/ZArith/zArith_dec.cmx theories/ZArith/zsqrt.cmi +theories/ZArith/zpower.cmo: theories/ZArith/zmisc.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/ZArith/binInt.cmi theories/ZArith/zpower.cmi +theories/ZArith/zpower.cmx: theories/ZArith/zmisc.cmx \ + theories/Init/datatypes.cmx theories/NArith/binPos.cmx \ + theories/ZArith/binInt.cmx theories/ZArith/zpower.cmi +theories/ZArith/zsqrt.cmo: theories/ZArith/zArith_dec.cmi \ + theories/Init/specif.cmi theories/NArith/binPos.cmi \ + theories/ZArith/binInt.cmi theories/ZArith/zsqrt.cmi +theories/ZArith/zsqrt.cmx: theories/ZArith/zArith_dec.cmx \ + theories/Init/specif.cmx theories/NArith/binPos.cmx \ + theories/ZArith/binInt.cmx theories/ZArith/zsqrt.cmi theories/ZArith/zwf.cmo: theories/ZArith/zwf.cmi theories/ZArith/zwf.cmx: theories/ZArith/zwf.cmi -theories/Arith/bool_nat.cmi: theories/Arith/compare_dec.cmi \ - theories/Init/datatypes.cmi theories/Arith/peano_dec.cmi \ - theories/Init/specif.cmi theories/Bool/sumbool.cmi -theories/Arith/compare_dec.cmi: theories/Init/datatypes.cmi \ - theories/Init/specif.cmi -theories/Arith/compare.cmi: theories/Arith/compare_dec.cmi \ - theories/Init/datatypes.cmi theories/Init/specif.cmi -theories/Arith/div2.cmi: theories/Init/datatypes.cmi theories/Init/peano.cmi \ - theories/Init/specif.cmi -theories/Arith/eqNat.cmi: theories/Init/datatypes.cmi \ - theories/Init/specif.cmi -theories/Arith/euclid.cmi: theories/Arith/compare_dec.cmi \ - theories/Init/datatypes.cmi theories/Init/specif.cmi -theories/Arith/even.cmi: theories/Init/datatypes.cmi theories/Init/specif.cmi -theories/Arith/factorial.cmi: theories/Init/datatypes.cmi \ - theories/Init/peano.cmi -theories/Arith/max.cmi: theories/Init/datatypes.cmi theories/Init/specif.cmi -theories/Arith/min.cmi: theories/Init/datatypes.cmi theories/Init/specif.cmi -theories/Arith/mult.cmi: theories/Init/datatypes.cmi theories/Arith/plus.cmi -theories/Arith/peano_dec.cmi: theories/Init/datatypes.cmi \ - theories/Init/specif.cmi -theories/Arith/plus.cmi: theories/Init/datatypes.cmi theories/Init/specif.cmi +theories/Arith/bool_nat.cmi: theories/Bool/sumbool.cmi \ + theories/Init/specif.cmi theories/Arith/peano_dec.cmi \ + theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi +theories/Arith/compare_dec.cmi: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi +theories/Arith/compare.cmi: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi +theories/Arith/div2.cmi: theories/Init/specif.cmi theories/Init/peano.cmi \ + theories/Init/datatypes.cmi +theories/Arith/eqNat.cmi: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi +theories/Arith/euclid.cmi: theories/Init/specif.cmi theories/Init/peano.cmi \ + theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi +theories/Arith/even.cmi: theories/Init/specif.cmi theories/Init/datatypes.cmi +theories/Arith/factorial.cmi: theories/Init/peano.cmi \ + theories/Init/datatypes.cmi +theories/Arith/max.cmi: theories/Init/specif.cmi theories/Init/datatypes.cmi +theories/Arith/min.cmi: theories/Init/specif.cmi theories/Init/datatypes.cmi +theories/Arith/mult.cmi: theories/Arith/plus.cmi theories/Init/datatypes.cmi +theories/Arith/peano_dec.cmi: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi +theories/Arith/plus.cmi: theories/Init/specif.cmi theories/Init/datatypes.cmi theories/Arith/wf_nat.cmi: theories/Init/datatypes.cmi -theories/Bool/boolEq.cmi: theories/Init/datatypes.cmi \ - theories/Init/specif.cmi -theories/Bool/bool.cmi: theories/Init/datatypes.cmi theories/Init/specif.cmi -theories/Bool/bvector.cmi: theories/Bool/bool.cmi theories/Init/datatypes.cmi \ - theories/Init/peano.cmi +theories/Bool/boolEq.cmi: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi +theories/Bool/bool.cmi: theories/Init/specif.cmi theories/Init/datatypes.cmi +theories/Bool/bvector.cmi: theories/Init/peano.cmi \ + theories/Init/datatypes.cmi theories/Bool/bool.cmi theories/Bool/decBool.cmi: theories/Init/specif.cmi -theories/Bool/ifProp.cmi: theories/Init/datatypes.cmi \ - theories/Init/specif.cmi -theories/Bool/sumbool.cmi: theories/Init/datatypes.cmi \ - theories/Init/specif.cmi +theories/Bool/ifProp.cmi: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi +theories/Bool/sumbool.cmi: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/Bool/zerob.cmi: theories/Init/datatypes.cmi -theories/Init/logic_Type.cmi: theories/Init/datatypes.cmi +theories/FSets/decidableTypeEx.cmi: theories/Init/specif.cmi \ + theories/FSets/orderedTypeEx.cmi theories/FSets/orderedType.cmi \ + theories/Init/datatypes.cmi +theories/FSets/decidableType.cmi: theories/Init/specif.cmi +theories/FSets/fMapAVL.cmi: theories/Init/wf.cmi theories/Init/specif.cmi \ + theories/FSets/orderedType.cmi theories/Lists/list.cmi \ + theories/FSets/int.cmi theories/Init/datatypes.cmi \ + theories/NArith/binPos.cmi theories/ZArith/binInt.cmi +theories/FSets/fMapFacts.cmi: theories/Init/specif.cmi \ + theories/FSets/fMapInterface.cmi theories/Init/datatypes.cmi +theories/FSets/fMapInterface.cmi: theories/FSets/orderedType.cmi \ + theories/Lists/list.cmi theories/Init/datatypes.cmi +theories/FSets/fMapIntMap.cmi: theories/Init/specif.cmi \ + theories/FSets/orderedType.cmi theories/NArith/ndigits.cmi \ + theories/IntMap/mapiter.cmi theories/IntMap/mapcanon.cmi \ + theories/IntMap/map.cmi theories/Lists/list.cmi \ + theories/Init/datatypes.cmi theories/NArith/binNat.cmi +theories/FSets/fMapList.cmi: theories/Init/specif.cmi \ + theories/FSets/orderedType.cmi theories/Lists/list.cmi \ + theories/Init/datatypes.cmi +theories/FSets/fMapPositive.cmi: theories/Init/specif.cmi \ + theories/FSets/orderedType.cmi theories/Lists/list.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi +theories/FSets/fMapWeakFacts.cmi: theories/Init/specif.cmi \ + theories/Lists/list.cmi theories/FSets/fMapWeakInterface.cmi \ + theories/Init/datatypes.cmi +theories/FSets/fMapWeakInterface.cmi: theories/Lists/list.cmi \ + theories/FSets/decidableType.cmi theories/Init/datatypes.cmi +theories/FSets/fMapWeakList.cmi: theories/Init/specif.cmi \ + theories/Lists/list.cmi theories/FSets/decidableType.cmi \ + theories/Init/datatypes.cmi +theories/FSets/fSetAVL.cmi: theories/Init/wf.cmi theories/Init/specif.cmi \ + theories/Init/peano.cmi theories/FSets/orderedType.cmi \ + theories/Lists/list.cmi theories/FSets/int.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/ZArith/binInt.cmi +theories/FSets/fSetBridge.cmi: theories/Init/specif.cmi \ + theories/FSets/orderedType.cmi theories/Lists/list.cmi \ + theories/FSets/fSetInterface.cmi theories/Init/datatypes.cmi +theories/FSets/fSetEqProperties.cmi: theories/Init/specif.cmi \ + theories/Setoids/setoid.cmi theories/Init/peano.cmi \ + theories/FSets/fSetInterface.cmi theories/Init/datatypes.cmi \ + theories/Bool/bool.cmi +theories/FSets/fSetFacts.cmi: theories/Init/specif.cmi \ + theories/Setoids/setoid.cmi theories/FSets/fSetInterface.cmi \ + theories/Init/datatypes.cmi +theories/FSets/fSetInterface.cmi: theories/Init/specif.cmi \ + theories/FSets/orderedType.cmi theories/Lists/list.cmi \ + theories/Init/datatypes.cmi +theories/FSets/fSetList.cmi: theories/Init/specif.cmi \ + theories/FSets/orderedType.cmi theories/Lists/list.cmi \ + theories/Init/datatypes.cmi +theories/FSets/fSetProperties.cmi: theories/Init/specif.cmi \ + theories/Setoids/setoid.cmi theories/Lists/list.cmi \ + theories/FSets/fSetInterface.cmi theories/Init/datatypes.cmi +theories/FSets/fSetToFiniteSet.cmi: theories/Init/specif.cmi \ + theories/Setoids/setoid.cmi theories/FSets/orderedTypeEx.cmi \ + theories/FSets/orderedType.cmi theories/Lists/list.cmi \ + theories/Init/datatypes.cmi +theories/FSets/fSetWeakFacts.cmi: theories/Init/specif.cmi \ + theories/Setoids/setoid.cmi theories/FSets/fSetWeakInterface.cmi \ + theories/Init/datatypes.cmi +theories/FSets/fSetWeakInterface.cmi: theories/Lists/list.cmi \ + theories/FSets/decidableType.cmi theories/Init/datatypes.cmi +theories/FSets/fSetWeakList.cmi: theories/Init/specif.cmi \ + theories/Lists/list.cmi theories/FSets/decidableType.cmi \ + theories/Init/datatypes.cmi +theories/FSets/fSetWeakProperties.cmi: theories/Init/specif.cmi \ + theories/Setoids/setoid.cmi theories/Lists/list.cmi \ + theories/FSets/fSetWeakInterface.cmi theories/Init/datatypes.cmi +theories/FSets/int.cmi: theories/ZArith/zmax.cmi \ + theories/ZArith/zArith_dec.cmi theories/Init/specif.cmi \ + theories/NArith/binPos.cmi theories/ZArith/binInt.cmi +theories/FSets/orderedTypeAlt.cmi: theories/Init/specif.cmi \ + theories/FSets/orderedType.cmi theories/Init/datatypes.cmi +theories/FSets/orderedTypeEx.cmi: theories/Init/specif.cmi \ + theories/FSets/orderedType.cmi theories/Init/datatypes.cmi \ + theories/Arith/compare_dec.cmi theories/NArith/binPos.cmi \ + theories/NArith/binNat.cmi theories/ZArith/binInt.cmi +theories/FSets/orderedType.cmi: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/Init/peano.cmi: theories/Init/datatypes.cmi theories/Init/specif.cmi: theories/Init/datatypes.cmi -theories/IntMap/adalloc.cmi: theories/IntMap/addec.cmi \ - theories/IntMap/addr.cmi theories/NArith/binPos.cmi \ - theories/Init/datatypes.cmi theories/IntMap/map.cmi \ - theories/Init/specif.cmi theories/Bool/sumbool.cmi -theories/IntMap/addec.cmi: theories/IntMap/addr.cmi \ - theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ - theories/Init/specif.cmi theories/Bool/sumbool.cmi -theories/IntMap/addr.cmi: theories/NArith/binPos.cmi theories/Bool/bool.cmi \ - theories/Init/datatypes.cmi theories/Init/specif.cmi -theories/IntMap/adist.cmi: theories/IntMap/addr.cmi \ - theories/NArith/binPos.cmi theories/Init/datatypes.cmi -theories/IntMap/fset.cmi: theories/IntMap/addec.cmi theories/IntMap/addr.cmi \ - theories/Init/datatypes.cmi theories/IntMap/map.cmi \ - theories/Init/specif.cmi -theories/IntMap/lsort.cmi: theories/IntMap/addec.cmi theories/IntMap/addr.cmi \ - theories/NArith/binPos.cmi theories/Bool/bool.cmi \ - theories/Init/datatypes.cmi theories/Lists/list.cmi \ - theories/IntMap/map.cmi theories/IntMap/mapiter.cmi \ - theories/Init/specif.cmi theories/Bool/sumbool.cmi -theories/IntMap/mapcanon.cmi: theories/IntMap/map.cmi \ - theories/Init/specif.cmi -theories/IntMap/mapcard.cmi: theories/IntMap/addec.cmi \ - theories/IntMap/addr.cmi theories/Init/datatypes.cmi \ - theories/IntMap/map.cmi theories/Init/peano.cmi \ - theories/Arith/peano_dec.cmi theories/Arith/plus.cmi \ - theories/Init/specif.cmi theories/Bool/sumbool.cmi -theories/IntMap/mapfold.cmi: theories/IntMap/addr.cmi \ - theories/Init/datatypes.cmi theories/IntMap/fset.cmi \ - theories/IntMap/map.cmi theories/IntMap/mapiter.cmi \ - theories/Init/specif.cmi -theories/IntMap/mapiter.cmi: theories/IntMap/addec.cmi \ - theories/IntMap/addr.cmi theories/Init/datatypes.cmi \ - theories/Lists/list.cmi theories/IntMap/map.cmi theories/Init/specif.cmi \ - theories/Bool/sumbool.cmi -theories/IntMap/maplists.cmi: theories/IntMap/addec.cmi \ - theories/IntMap/addr.cmi theories/Init/datatypes.cmi \ - theories/IntMap/fset.cmi theories/Lists/list.cmi theories/IntMap/map.cmi \ - theories/IntMap/mapiter.cmi theories/Init/specif.cmi \ - theories/Bool/sumbool.cmi -theories/IntMap/map.cmi: theories/IntMap/addec.cmi theories/IntMap/addr.cmi \ - theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ - theories/Init/peano.cmi theories/Init/specif.cmi -theories/IntMap/mapsubset.cmi: theories/Bool/bool.cmi \ - theories/Init/datatypes.cmi theories/IntMap/fset.cmi \ - theories/IntMap/map.cmi theories/IntMap/mapiter.cmi -theories/Lists/list.cmi: theories/Init/datatypes.cmi theories/Init/specif.cmi -theories/Lists/listSet.cmi: theories/Init/datatypes.cmi \ - theories/Lists/list.cmi theories/Init/specif.cmi +theories/IntMap/adalloc.cmi: theories/Bool/sumbool.cmi \ + theories/Init/specif.cmi theories/NArith/ndec.cmi theories/IntMap/map.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/NArith/binNat.cmi +theories/IntMap/fset.cmi: theories/Init/specif.cmi \ + theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \ + theories/IntMap/map.cmi theories/Init/datatypes.cmi \ + theories/NArith/binNat.cmi +theories/IntMap/lsort.cmi: theories/Bool/sumbool.cmi theories/Init/specif.cmi \ + theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \ + theories/IntMap/mapiter.cmi theories/IntMap/map.cmi \ + theories/Lists/list.cmi theories/Init/datatypes.cmi \ + theories/NArith/binNat.cmi +theories/IntMap/mapcanon.cmi: theories/Init/specif.cmi \ + theories/IntMap/map.cmi +theories/IntMap/mapcard.cmi: theories/Bool/sumbool.cmi \ + theories/Init/specif.cmi theories/Arith/plus.cmi \ + theories/Arith/peano_dec.cmi theories/Init/peano.cmi \ + theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \ + theories/IntMap/map.cmi theories/Init/datatypes.cmi \ + theories/NArith/binNat.cmi +theories/IntMap/mapfold.cmi: theories/Init/specif.cmi \ + theories/IntMap/mapiter.cmi theories/IntMap/map.cmi \ + theories/IntMap/fset.cmi theories/Init/datatypes.cmi +theories/IntMap/mapiter.cmi: theories/Bool/sumbool.cmi \ + theories/Init/specif.cmi theories/NArith/ndigits.cmi \ + theories/NArith/ndec.cmi theories/IntMap/map.cmi theories/Lists/list.cmi \ + theories/Init/datatypes.cmi theories/NArith/binNat.cmi +theories/IntMap/maplists.cmi: theories/Bool/sumbool.cmi \ + theories/Init/specif.cmi theories/NArith/ndec.cmi \ + theories/IntMap/mapiter.cmi theories/IntMap/map.cmi \ + theories/Lists/list.cmi theories/IntMap/fset.cmi \ + theories/Init/datatypes.cmi +theories/IntMap/map.cmi: theories/Init/specif.cmi theories/Init/peano.cmi \ + theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/NArith/binNat.cmi +theories/IntMap/mapsubset.cmi: theories/IntMap/mapiter.cmi \ + theories/IntMap/map.cmi theories/IntMap/fset.cmi \ + theories/Init/datatypes.cmi theories/Bool/bool.cmi +theories/Lists/list.cmi: theories/Init/specif.cmi theories/Init/datatypes.cmi +theories/Lists/listSet.cmi: theories/Init/specif.cmi theories/Lists/list.cmi \ + theories/Init/datatypes.cmi theories/Lists/monoList.cmi: theories/Init/datatypes.cmi +theories/Lists/setoidList.cmi: theories/Init/specif.cmi \ + theories/Lists/list.cmi theories/Init/datatypes.cmi theories/Lists/streams.cmi: theories/Init/datatypes.cmi -theories/Lists/theoryList.cmi: theories/Init/datatypes.cmi \ - theories/Lists/list.cmi theories/Init/specif.cmi -theories/NArith/binNat.cmi: theories/NArith/binPos.cmi \ +theories/Lists/theoryList.cmi: theories/Init/specif.cmi \ + theories/Lists/list.cmi theories/Init/datatypes.cmi +theories/Logic/choiceFacts.cmi: theories/Init/specif.cmi \ theories/Init/datatypes.cmi -theories/NArith/binPos.cmi: theories/Init/datatypes.cmi \ - theories/Init/peano.cmi -theories/Relations/relation_Operators.cmi: theories/Lists/list.cmi \ - theories/Init/specif.cmi +theories/Logic/classicalDescription.cmi: theories/Init/specif.cmi \ + theories/Logic/choiceFacts.cmi +theories/Logic/classicalEpsilon.cmi: theories/Init/specif.cmi \ + theories/Logic/choiceFacts.cmi +theories/Logic/diaconescu.cmi: theories/Init/specif.cmi +theories/Logic/eqdep_dec.cmi: theories/Init/specif.cmi +theories/NArith/binNat.cmi: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi +theories/NArith/binPos.cmi: theories/Init/peano.cmi \ + theories/Init/datatypes.cmi +theories/NArith/ndec.cmi: theories/Bool/sumbool.cmi theories/Init/specif.cmi \ + theories/NArith/nnat.cmi theories/NArith/ndigits.cmi \ + theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi \ + theories/NArith/binPos.cmi theories/NArith/binNat.cmi +theories/NArith/ndigits.cmi: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/Bool/bvector.cmi \ + theories/Bool/bool.cmi theories/NArith/binPos.cmi \ + theories/NArith/binNat.cmi +theories/NArith/ndist.cmi: theories/NArith/ndigits.cmi theories/Arith/min.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/NArith/binNat.cmi +theories/NArith/nnat.cmi: theories/Init/datatypes.cmi \ + theories/NArith/binPos.cmi theories/NArith/binNat.cmi +theories/QArith/qArith_base.cmi: theories/ZArith/zArith_dec.cmi \ + theories/Init/specif.cmi theories/Setoids/setoid.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/ZArith/binInt.cmi +theories/QArith/qreals.cmi: theories/QArith/qArith_base.cmi \ + theories/ZArith/binInt.cmi +theories/QArith/qreduction.cmi: theories/ZArith/znumtheory.cmi \ + theories/Setoids/setoid.cmi theories/QArith/qArith_base.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/ZArith/binInt.cmi +theories/QArith/qring.cmi: theories/Init/specif.cmi \ + theories/QArith/qArith_base.cmi theories/Init/datatypes.cmi +theories/Relations/relation_Operators.cmi: theories/Init/specif.cmi \ + theories/Lists/list.cmi +theories/Setoids/setoid.cmi: theories/Init/datatypes.cmi theories/Sets/cpo.cmi: theories/Sets/partial_Order.cmi -theories/Sets/integers.cmi: theories/Init/datatypes.cmi \ - theories/Sets/partial_Order.cmi -theories/Sets/multiset.cmi: theories/Init/datatypes.cmi \ - theories/Init/peano.cmi theories/Init/specif.cmi -theories/Sets/partial_Order.cmi: theories/Sets/ensembles.cmi \ - theories/Sets/relations_1.cmi -theories/Sets/powerset.cmi: theories/Sets/ensembles.cmi \ - theories/Sets/partial_Order.cmi -theories/Sets/uniset.cmi: theories/Init/datatypes.cmi \ - theories/Init/specif.cmi -theories/Sorting/heap.cmi: theories/Init/datatypes.cmi \ - theories/Lists/list.cmi theories/Sets/multiset.cmi \ - theories/Init/peano.cmi theories/Sorting/sorting.cmi \ - theories/Init/specif.cmi -theories/Sorting/permutation.cmi: theories/Init/datatypes.cmi \ - theories/Lists/list.cmi theories/Sets/multiset.cmi \ - theories/Init/peano.cmi theories/Init/specif.cmi -theories/Sorting/sorting.cmi: theories/Lists/list.cmi \ - theories/Init/specif.cmi -theories/Wellfounded/well_Ordering.cmi: theories/Init/specif.cmi -theories/ZArith/binInt.cmi: theories/NArith/binNat.cmi \ - theories/NArith/binPos.cmi theories/Init/datatypes.cmi -theories/ZArith/wf_Z.cmi: theories/ZArith/binInt.cmi \ - theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ - theories/Init/peano.cmi theories/Init/specif.cmi -theories/ZArith/zabs.cmi: theories/ZArith/binInt.cmi theories/Init/specif.cmi \ - theories/Bool/sumbool.cmi -theories/ZArith/zArith_dec.cmi: theories/ZArith/binInt.cmi \ - theories/Init/datatypes.cmi theories/Init/specif.cmi \ - theories/Bool/sumbool.cmi -theories/ZArith/zbinary.cmi: theories/ZArith/binInt.cmi \ - theories/NArith/binPos.cmi theories/Bool/bvector.cmi \ - theories/Init/datatypes.cmi theories/ZArith/zeven.cmi -theories/ZArith/zbool.cmi: theories/ZArith/binInt.cmi \ - theories/Init/datatypes.cmi theories/Init/specif.cmi \ - theories/Bool/sumbool.cmi theories/ZArith/zArith_dec.cmi \ - theories/ZArith/zeven.cmi -theories/ZArith/zcomplements.cmi: theories/ZArith/binInt.cmi \ - theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ - theories/Lists/list.cmi theories/Init/specif.cmi theories/ZArith/wf_Z.cmi \ - theories/ZArith/zabs.cmi -theories/ZArith/zdiv.cmi: theories/ZArith/binInt.cmi \ - theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ - theories/Init/specif.cmi theories/ZArith/zArith_dec.cmi \ - theories/ZArith/zbool.cmi -theories/ZArith/zeven.cmi: theories/ZArith/binInt.cmi \ - theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ - theories/Init/specif.cmi -theories/ZArith/zlogarithm.cmi: theories/ZArith/binInt.cmi \ - theories/NArith/binPos.cmi -theories/ZArith/zmin.cmi: theories/ZArith/binInt.cmi \ +theories/Sets/integers.cmi: theories/Sets/partial_Order.cmi \ theories/Init/datatypes.cmi -theories/ZArith/zmisc.cmi: theories/ZArith/binInt.cmi \ - theories/NArith/binPos.cmi theories/Init/datatypes.cmi -theories/ZArith/znumtheory.cmi: theories/ZArith/binInt.cmi \ - theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ - theories/Init/specif.cmi theories/ZArith/wf_Z.cmi \ - theories/ZArith/zArith_dec.cmi theories/ZArith/zdiv.cmi \ - theories/ZArith/zorder.cmi -theories/ZArith/zorder.cmi: theories/ZArith/binInt.cmi \ - theories/Init/datatypes.cmi theories/Init/specif.cmi -theories/ZArith/zpower.cmi: theories/ZArith/binInt.cmi \ - theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ - theories/ZArith/zmisc.cmi -theories/ZArith/zsqrt.cmi: theories/ZArith/binInt.cmi \ - theories/NArith/binPos.cmi theories/Init/specif.cmi \ - theories/ZArith/zArith_dec.cmi +theories/Sets/multiset.cmi: theories/Init/specif.cmi theories/Init/peano.cmi \ + theories/Init/datatypes.cmi +theories/Sets/partial_Order.cmi: theories/Sets/relations_1.cmi \ + theories/Sets/ensembles.cmi +theories/Sets/powerset.cmi: theories/Sets/partial_Order.cmi \ + theories/Sets/ensembles.cmi +theories/Sets/uniset.cmi: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi +theories/Sorting/heap.cmi: theories/Init/specif.cmi \ + theories/Sorting/sorting.cmi theories/Init/peano.cmi \ + theories/Sets/multiset.cmi theories/Lists/list.cmi \ + theories/Init/datatypes.cmi +theories/Sorting/permutation.cmi: theories/Init/specif.cmi \ + theories/Init/peano.cmi theories/Sets/multiset.cmi \ + theories/Lists/list.cmi theories/Init/datatypes.cmi +theories/Sorting/sorting.cmi: theories/Init/specif.cmi \ + theories/Lists/list.cmi +theories/Strings/ascii.cmi: theories/Init/specif.cmi theories/Init/peano.cmi \ + theories/Init/datatypes.cmi theories/Bool/bool.cmi \ + theories/NArith/binPos.cmi +theories/Strings/string.cmi: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/Strings/ascii.cmi +theories/Wellfounded/well_Ordering.cmi: theories/Init/specif.cmi +theories/ZArith/binInt.cmi: theories/Init/datatypes.cmi \ + theories/NArith/binPos.cmi theories/NArith/binNat.cmi +theories/ZArith/wf_Z.cmi: theories/Init/specif.cmi theories/Init/peano.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/ZArith/binInt.cmi +theories/ZArith/zabs.cmi: theories/Init/specif.cmi theories/ZArith/binInt.cmi +theories/ZArith/zArith_dec.cmi: theories/Bool/sumbool.cmi \ + theories/Init/specif.cmi theories/Init/datatypes.cmi \ + theories/ZArith/binInt.cmi +theories/ZArith/zbinary.cmi: theories/ZArith/zeven.cmi \ + theories/Init/datatypes.cmi theories/Bool/bvector.cmi \ + theories/NArith/binPos.cmi theories/ZArith/binInt.cmi +theories/ZArith/zbool.cmi: theories/ZArith/zeven.cmi \ + theories/ZArith/zArith_dec.cmi theories/Bool/sumbool.cmi \ + theories/Init/specif.cmi theories/Init/datatypes.cmi \ + theories/ZArith/binInt.cmi +theories/ZArith/zcomplements.cmi: theories/ZArith/zabs.cmi \ + theories/ZArith/wf_Z.cmi theories/Init/specif.cmi theories/Lists/list.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/ZArith/binInt.cmi +theories/ZArith/zdiv.cmi: theories/ZArith/zbool.cmi \ + theories/ZArith/zArith_dec.cmi theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/ZArith/binInt.cmi +theories/ZArith/zeven.cmi: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/ZArith/binInt.cmi +theories/ZArith/zlogarithm.cmi: theories/NArith/binPos.cmi \ + theories/ZArith/binInt.cmi +theories/ZArith/zmax.cmi: theories/Init/datatypes.cmi \ + theories/ZArith/binInt.cmi +theories/ZArith/zmin.cmi: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/ZArith/binInt.cmi +theories/ZArith/zmisc.cmi: theories/Init/datatypes.cmi \ + theories/NArith/binPos.cmi theories/ZArith/binInt.cmi +theories/ZArith/znumtheory.cmi: theories/ZArith/zorder.cmi \ + theories/ZArith/zdiv.cmi theories/ZArith/zArith_dec.cmi \ + theories/ZArith/wf_Z.cmi theories/Init/specif.cmi theories/Init/peano.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/ZArith/binInt.cmi +theories/ZArith/zorder.cmi: theories/Init/specif.cmi \ + theories/Init/datatypes.cmi theories/ZArith/binInt.cmi +theories/ZArith/zpower.cmi: theories/ZArith/zmisc.cmi \ + theories/Init/datatypes.cmi theories/NArith/binPos.cmi \ + theories/ZArith/binInt.cmi +theories/ZArith/zsqrt.cmi: theories/ZArith/zArith_dec.cmi \ + theories/Init/specif.cmi theories/NArith/binPos.cmi \ + theories/ZArith/binInt.cmi diff --git a/contrib/extraction/test/Makefile b/contrib/extraction/test/Makefile index c9bb5623..65a54090 100644 --- a/contrib/extraction/test/Makefile +++ b/contrib/extraction/test/Makefile @@ -10,7 +10,7 @@ AXIOMSVO:= \ theories/Reals/% \ theories/Num/% -DIRS:= $(shell (cd $(TOPDIR);find theories -type d ! -name CVS)) +DIRS:= $(shell (cd $(TOPDIR);find theories -type d ! -path \*.svn\*)) INCL:= $(patsubst %,-I %,$(DIRS)) @@ -34,7 +34,7 @@ all: v2ml ml $(MLI) $(CMO) ml: $(ML) -depend: $(ML) +depend: #$(ML) rm -f .depend; ocamldep $(INCL) theories/*/*.ml theories/*/*.mli > .depend tree: diff --git a/contrib/extraction/test/custom/Adalloc b/contrib/extraction/test/custom/Adalloc index 0fb556aa..e7204838 100644 --- a/contrib/extraction/test/custom/Adalloc +++ b/contrib/extraction/test/custom/Adalloc @@ -1,2 +1,2 @@ -Require Import Addr. -Extraction NoInline ad_double ad_double_plus_un. +Require Import BinNat. +Extraction NoInline Ndouble Ndouble_plus_one. diff --git a/contrib/extraction/test/custom/Lsort b/contrib/extraction/test/custom/Lsort index 6a185683..22ab18e3 100644 --- a/contrib/extraction/test/custom/Lsort +++ b/contrib/extraction/test/custom/Lsort @@ -1,2 +1,2 @@ -Require Import Addr. -Extraction NoInline ad_double ad_double_plus_un. +Require Import BinNat. +Extraction NoInline Ndouble Ndouble_plus_one. diff --git a/contrib/extraction/test/custom/Map b/contrib/extraction/test/custom/Map index 3e464e39..f024dbd7 100644 --- a/contrib/extraction/test/custom/Map +++ b/contrib/extraction/test/custom/Map @@ -1,3 +1,3 @@ -Require Import Addr. -Extraction NoInline ad_double ad_double_plus_un. +Require Import BinNat. +Extraction NoInline Ndouble Ndouble_plus_one. diff --git a/contrib/extraction/test/custom/Mapcard b/contrib/extraction/test/custom/Mapcard index ca555aa3..5932cf7b 100644 --- a/contrib/extraction/test/custom/Mapcard +++ b/contrib/extraction/test/custom/Mapcard @@ -1,4 +1,4 @@ Require Import Plus. Extraction NoInline plus_is_one. -Require Import Addr. -Extraction NoInline ad_double ad_double_plus_un. +Require Import BinNat. +Extraction NoInline Ndouble Ndouble_plus_one. diff --git a/contrib/extraction/test/custom/Mapiter b/contrib/extraction/test/custom/Mapiter index 6a185683..22ab18e3 100644 --- a/contrib/extraction/test/custom/Mapiter +++ b/contrib/extraction/test/custom/Mapiter @@ -1,2 +1,2 @@ -Require Import Addr. -Extraction NoInline ad_double ad_double_plus_un. +Require Import BinNat. +Extraction NoInline Ndouble Ndouble_plus_one. diff --git a/contrib/field/Field_Compl.v b/contrib/field/Field_Compl.v index 774b3084..f018359e 100644 --- a/contrib/field/Field_Compl.v +++ b/contrib/field/Field_Compl.v @@ -6,56 +6,33 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Field_Compl.v 5920 2004-07-16 20:01:26Z herbelin $ *) +(* $Id: Field_Compl.v 8866 2006-05-28 16:21:04Z herbelin $ *) -Inductive listT (A:Type) : Type := - | nilT : listT A - | consT : A -> listT A -> listT A. - -Fixpoint appT (A:Type) (l m:listT A) {struct l} : listT A := - match l with - | nilT => m - | consT a l1 => consT A a (appT A l1 m) - end. - -Inductive prodT (A B:Type) : Type := - pairT : A -> B -> prodT A B. +Require Import List. Definition assoc_2nd := (fix assoc_2nd_rec (A:Type) (B:Set) (eq_dec:forall e1 e2:B, {e1 = e2} + {e1 <> e2}) - (lst:listT (prodT A B)) {struct lst} : + (lst:list (prod A B)) {struct lst} : B -> A -> A := fun (key:B) (default:A) => match lst with - | nilT => default - | consT (pairT v e) l => + | nil => default + | (v,e) :: l => match eq_dec e key with | left _ => v | right _ => assoc_2nd_rec A B eq_dec l key default end end). -Definition fstT (A B:Type) (c:prodT A B) := match c with - | pairT a _ => a - end. - -Definition sndT (A B:Type) (c:prodT A B) := match c with - | pairT _ a => a - end. - Definition mem := (fix mem (A:Set) (eq_dec:forall e1 e2:A, {e1 = e2} + {e1 <> e2}) - (a:A) (l:listT A) {struct l} : bool := + (a:A) (l:list A) {struct l} : bool := match l with - | nilT => false - | consT a1 l1 => + | nil => false + | a1 :: l1 => match eq_dec a a1 with | left _ => true | right _ => mem A eq_dec a l1 end end). - -Inductive field_rel_option (A:Type) : Type := - | Field_None : field_rel_option A - | Field_Some : (A -> A -> A) -> field_rel_option A.
\ No newline at end of file diff --git a/contrib/field/Field_Tactic.v b/contrib/field/Field_Tactic.v index afa0a814..8d727536 100644 --- a/contrib/field/Field_Tactic.v +++ b/contrib/field/Field_Tactic.v @@ -6,8 +6,9 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Field_Tactic.v 8134 2006-03-05 16:39:17Z herbelin $ *) +(* $Id: Field_Tactic.v 8866 2006-05-28 16:21:04Z herbelin $ *) +Require Import List. Require Import Ring. Require Export Field_Compl. Require Export Field_Theory. @@ -20,8 +21,8 @@ Ltac body_of s := eval cbv beta iota delta [s] in s. Ltac mem_assoc var lvar := match constr:lvar with - | (nilT _) => constr:false - | (consT _ ?X1 ?X2) => + | nil => constr:false + | ?X1 :: ?X2 => match constr:(X1 = var) with | (?X1 = ?X1) => constr:true | _ => mem_assoc var X2 @@ -31,10 +32,10 @@ Ltac mem_assoc var lvar := Ltac number lvar := let rec number_aux lvar cpt := match constr:lvar with - | (nilT ?X1) => constr:(nilT (prodT X1 nat)) - | (consT ?X1 ?X2 ?X3) => + | (@nil ?X1) => constr:(@nil (prod X1 nat)) + | ?X2 :: ?X3 => let l2 := number_aux X3 (S cpt) in - constr:(consT (prodT X1 nat) (pairT X1 nat X2 cpt) l2) + constr:((X2,cpt) :: l2) end in number_aux lvar 0. @@ -62,17 +63,17 @@ Ltac build_varlist FT trm := let res := mem_assoc X1 lvar in match constr:res with | true => lvar - | false => constr:(consT AT X1 lvar) + | false => constr:(X1 :: lvar) end end in let AT := get_component A FT in - let lvar := seek_var (nilT AT) trm in + let lvar := seek_var (@nil AT) trm in number lvar. Ltac assoc elt lst := match constr:lst with - | (nilT _) => fail - | (consT (prodT _ nat) (pairT _ nat ?X1 ?X2) ?X3) => + | nil => fail + | (?X1,?X2) :: ?X3 => match constr:(elt = X1) with | (?X1 = ?X1) => constr:X2 | _ => assoc elt X3 @@ -113,32 +114,31 @@ Ltac interp_A FT lvar trm := Ltac remove e l := match constr:l with - | (nilT _) => l - | (consT ?X1 e ?X2) => constr:X2 - | (consT ?X1 ?X2 ?X3) => let nl := remove e X3 in - constr:(consT X1 X2 nl) + | nil => l + | e :: ?X2 => constr:X2 + | ?X2 :: ?X3 => let nl := remove e X3 in constr:(X2 :: nl) end. Ltac union l1 l2 := match constr:l1 with - | (nilT _) => l2 - | (consT ?X1 ?X2 ?X3) => + | nil => l2 + | ?X2 :: ?X3 => let nl2 := remove X2 l2 in let nl := union X3 nl2 in - constr:(consT X1 X2 nl) + constr:(X2 :: nl) end. Ltac raw_give_mult trm := match constr:trm with - | (EAinv ?X1) => constr:(consT ExprA X1 (nilT ExprA)) + | (EAinv ?X1) => constr:(X1 :: nil) | (EAopp ?X1) => raw_give_mult X1 | (EAplus ?X1 ?X2) => let l1 := raw_give_mult X1 with l2 := raw_give_mult X2 in union l1 l2 | (EAmult ?X1 ?X2) => let l1 := raw_give_mult X1 with l2 := raw_give_mult X2 in - eval compute in (appT ExprA l1 l2) - | _ => constr:(nilT ExprA) + eval compute in (app l1 l2) + | _ => constr:(@nil ExprA) end. Ltac give_mult trm := @@ -254,13 +254,13 @@ Ltac apply_simplif sfun := Ltac unfolds FT := match get_component Aminus FT with - | (Field_Some _ ?X1) => unfold X1 in |- * + | Some ?X1 => unfold X1 in |- * | _ => idtac end; - match get_component Adiv FT with - | (Field_Some _ ?X1) => unfold X1 in |- * - | _ => idtac - end. + match get_component Adiv FT with + | Some ?X1 => unfold X1 in |- * + | _ => idtac + end. Ltac reduce FT := let AzeroT := get_component Azero FT @@ -304,11 +304,11 @@ Ltac field_gen FT := unfolds FT; (inverse_test FT; ring) || field_gen_aux FT. Ltac init_exp FT trm := let e := (match get_component Aminus FT with - | (Field_Some _ ?X1) => eval cbv beta delta [X1] in trm + | Some ?X1 => eval cbv beta delta [X1] in trm | _ => trm end) in match get_component Adiv FT with - | (Field_Some _ ?X1) => eval cbv beta delta [X1] in e + | Some ?X1 => eval cbv beta delta [X1] in e | _ => e end. @@ -341,21 +341,21 @@ Ltac simpl_inv trm := Ltac map_tactic fcn lst := match constr:lst with - | (nilT _) => lst - | (consT ?X1 ?X2 ?X3) => + | nil => lst + | ?X2 :: ?X3 => let r := fcn X2 with t := map_tactic fcn X3 in - constr:(consT X1 r t) + constr:(r :: t) end. Ltac build_monom_aux lst trm := match constr:lst with - | (nilT _) => eval compute in (assoc trm) - | (consT _ ?X1 ?X2) => build_monom_aux X2 (EAmult trm X1) + | nil => eval compute in (assoc trm) + | ?X1 :: ?X2 => build_monom_aux X2 (EAmult trm X1) end. Ltac build_monom lnum lden := let ildn := map_tactic ltac:(fun e => constr:(EAinv e)) lden in - let ltot := eval compute in (appT ExprA lnum ildn) in + let ltot := eval compute in (app lnum ildn) in let trm := build_monom_aux ltot EAone in match constr:trm with | (EAmult _ ?X1) => constr:X1 @@ -370,7 +370,7 @@ Ltac simpl_monom_aux lnum lden trm := | true => let newlnum := remove X1 lnum in simpl_monom_aux newlnum lden X2 - | false => simpl_monom_aux lnum (consT ExprA X1 lden) X2 + | false => simpl_monom_aux lnum (X1 :: lden) X2 end | (EAmult ?X1 ?X2) => let mma := mem_assoc X1 lden in @@ -378,7 +378,7 @@ Ltac simpl_monom_aux lnum lden trm := | true => let newlden := remove X1 lden in simpl_monom_aux lnum newlden X2 - | false => simpl_monom_aux (consT ExprA X1 lnum) lden X2 + | false => simpl_monom_aux (X1 :: lnum) lden X2 end | (EAinv ?X1) => let mma := mem_assoc X1 lnum in @@ -386,7 +386,7 @@ Ltac simpl_monom_aux lnum lden trm := | true => let newlnum := remove X1 lnum in build_monom newlnum lden - | false => build_monom lnum (consT ExprA X1 lden) + | false => build_monom lnum (X1 :: lden) end | ?X1 => let mma := mem_assoc X1 lden in @@ -394,11 +394,11 @@ Ltac simpl_monom_aux lnum lden trm := | true => let newlden := remove X1 lden in build_monom lnum newlden - | false => build_monom (consT ExprA X1 lnum) lden + | false => build_monom (X1 :: lnum) lden end end. -Ltac simpl_monom trm := simpl_monom_aux (nilT ExprA) (nilT ExprA) trm. +Ltac simpl_monom trm := simpl_monom_aux (@nil ExprA) (@nil ExprA) trm. Ltac simpl_all_monomials trm := match constr:trm with diff --git a/contrib/field/Field_Theory.v b/contrib/field/Field_Theory.v index 2c954652..fff3c414 100644 --- a/contrib/field/Field_Theory.v +++ b/contrib/field/Field_Theory.v @@ -6,8 +6,9 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Field_Theory.v 5920 2004-07-16 20:01:26Z herbelin $ *) +(* $Id: Field_Theory.v 8866 2006-05-28 16:21:04Z herbelin $ *) +Require Import List. Require Import Peano_dec. Require Import Ring. Require Import Field_Compl. @@ -21,8 +22,8 @@ Record Field_Theory : Type := Aopp : A -> A; Aeq : A -> A -> bool; Ainv : A -> A; - Aminus : field_rel_option A; - Adiv : field_rel_option A; + Aminus : option (A -> A -> A); + Adiv : option (A -> A -> A); RT : Ring_Theory Aplus Amult Aone Azero Aopp Aeq; Th_inv_def : forall n:A, n <> Azero -> Amult (Ainv n) n = Aone}. @@ -66,10 +67,10 @@ Definition eqExprA := Eval compute in eqExprA_O. (**** Generation of the multiplier ****) -Fixpoint mult_of_list (e:listT ExprA) : ExprA := +Fixpoint mult_of_list (e:list ExprA) : ExprA := match e with - | nilT => EAone - | consT e1 l1 => EAmult e1 (mult_of_list l1) + | nil => EAone + | e1 :: l1 => EAmult e1 (mult_of_list l1) end. Section Theory_of_fields. @@ -191,7 +192,7 @@ Qed. (**** ExprA --> A ****) -Fixpoint interp_ExprA (lvar:listT (prodT AT nat)) (e:ExprA) {struct e} : +Fixpoint interp_ExprA (lvar:list (AT * nat)) (e:ExprA) {struct e} : AT := match e with | EAzero => AzeroT @@ -257,7 +258,7 @@ Fixpoint assoc (e:ExprA) : ExprA := end. Lemma merge_mult_correct1 : - forall (e1 e2 e3:ExprA) (lvar:listT (prodT AT nat)), + forall (e1 e2 e3:ExprA) (lvar:list (AT * nat)), interp_ExprA lvar (merge_mult (EAmult e1 e2) e3) = interp_ExprA lvar (EAmult e1 (merge_mult e2 e3)). Proof. @@ -271,7 +272,7 @@ unfold merge_mult at 1 in |- *; fold merge_mult in |- *; Qed. Lemma merge_mult_correct : - forall (e1 e2:ExprA) (lvar:listT (prodT AT nat)), + forall (e1 e2:ExprA) (lvar:list (AT * nat)), interp_ExprA lvar (merge_mult e1 e2) = interp_ExprA lvar (EAmult e1 e2). Proof. simple induction e1; auto; intros. @@ -290,7 +291,7 @@ ring. Qed. Lemma assoc_mult_correct1 : - forall (e1 e2:ExprA) (lvar:listT (prodT AT nat)), + forall (e1 e2:ExprA) (lvar:list (AT * nat)), AmultT (interp_ExprA lvar (assoc_mult e1)) (interp_ExprA lvar (assoc_mult e2)) = interp_ExprA lvar (assoc_mult (EAmult e1 e2)). @@ -302,7 +303,7 @@ rewrite <- (H e0 lvar); simpl in |- *; rewrite merge_mult_correct; Qed. Lemma assoc_mult_correct : - forall (e:ExprA) (lvar:listT (prodT AT nat)), + forall (e:ExprA) (lvar:list (AT * nat)), interp_ExprA lvar (assoc_mult e) = interp_ExprA lvar e. Proof. simple induction e; auto; intros. @@ -325,7 +326,7 @@ simpl in |- *; rewrite (H0 lvar); auto. Qed. Lemma merge_plus_correct1 : - forall (e1 e2 e3:ExprA) (lvar:listT (prodT AT nat)), + forall (e1 e2 e3:ExprA) (lvar:list (AT * nat)), interp_ExprA lvar (merge_plus (EAplus e1 e2) e3) = interp_ExprA lvar (EAplus e1 (merge_plus e2 e3)). Proof. @@ -339,7 +340,7 @@ unfold merge_plus at 1 in |- *; fold merge_plus in |- *; Qed. Lemma merge_plus_correct : - forall (e1 e2:ExprA) (lvar:listT (prodT AT nat)), + forall (e1 e2:ExprA) (lvar:list (AT * nat)), interp_ExprA lvar (merge_plus e1 e2) = interp_ExprA lvar (EAplus e1 e2). Proof. simple induction e1; auto; intros. @@ -358,7 +359,7 @@ ring. Qed. Lemma assoc_plus_correct : - forall (e1 e2:ExprA) (lvar:listT (prodT AT nat)), + forall (e1 e2:ExprA) (lvar:list (AT * nat)), AplusT (interp_ExprA lvar (assoc e1)) (interp_ExprA lvar (assoc e2)) = interp_ExprA lvar (assoc (EAplus e1 e2)). Proof. @@ -369,7 +370,7 @@ rewrite <- (H e0 lvar); simpl in |- *; rewrite merge_plus_correct; Qed. Lemma assoc_correct : - forall (e:ExprA) (lvar:listT (prodT AT nat)), + forall (e:ExprA) (lvar:list (AT * nat)), interp_ExprA lvar (assoc e) = interp_ExprA lvar e. Proof. simple induction e; auto; intros. @@ -448,7 +449,7 @@ Fixpoint distrib_main (e:ExprA) : ExprA := Definition distrib (e:ExprA) : ExprA := distrib_main (distrib_EAopp e). Lemma distrib_mult_right_correct : - forall (e1 e2:ExprA) (lvar:listT (prodT AT nat)), + forall (e1 e2:ExprA) (lvar:list (AT * nat)), interp_ExprA lvar (distrib_mult_right e1 e2) = AmultT (interp_ExprA lvar e1) (interp_ExprA lvar e2). Proof. @@ -458,7 +459,7 @@ rewrite AmultT_sym; rewrite AmultT_AplusT_distr; rewrite (H e2 lvar); Qed. Lemma distrib_mult_left_correct : - forall (e1 e2:ExprA) (lvar:listT (prodT AT nat)), + forall (e1 e2:ExprA) (lvar:list (AT * nat)), interp_ExprA lvar (distrib_mult_left e1 e2) = AmultT (interp_ExprA lvar e1) (interp_ExprA lvar e2). Proof. @@ -480,7 +481,7 @@ rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_sym. Qed. Lemma distrib_correct : - forall (e:ExprA) (lvar:listT (prodT AT nat)), + forall (e:ExprA) (lvar:list (AT * nat)), interp_ExprA lvar (distrib e) = interp_ExprA lvar e. Proof. simple induction e; intros; auto. @@ -496,7 +497,7 @@ Qed. (**** Multiplication by the inverse product ****) Lemma mult_eq : - forall (e1 e2 a:ExprA) (lvar:listT (prodT AT nat)), + forall (e1 e2 a:ExprA) (lvar:list (AT * nat)), interp_ExprA lvar a <> AzeroT -> interp_ExprA lvar (EAmult a e1) = interp_ExprA lvar (EAmult a e2) -> interp_ExprA lvar e1 = interp_ExprA lvar e2. @@ -520,7 +521,7 @@ Definition multiply (e:ExprA) : ExprA := end. Lemma multiply_aux_correct : - forall (a e:ExprA) (lvar:listT (prodT AT nat)), + forall (a e:ExprA) (lvar:list (AT * nat)), interp_ExprA lvar (multiply_aux a e) = AmultT (interp_ExprA lvar a) (interp_ExprA lvar e). Proof. @@ -530,7 +531,7 @@ simple induction e; simpl in |- *; intros; try rewrite merge_mult_correct; Qed. Lemma multiply_correct : - forall (e:ExprA) (lvar:listT (prodT AT nat)), + forall (e:ExprA) (lvar:list (AT * nat)), interp_ExprA lvar (multiply e) = interp_ExprA lvar e. Proof. simple induction e; simpl in |- *; auto. @@ -578,7 +579,7 @@ Fixpoint inverse_simplif (a e:ExprA) {struct e} : ExprA := end. Lemma monom_remove_correct : - forall (e a:ExprA) (lvar:listT (prodT AT nat)), + forall (e a:ExprA) (lvar:list (AT * nat)), interp_ExprA lvar a <> AzeroT -> interp_ExprA lvar (monom_remove a e) = AmultT (interp_ExprA lvar a) (interp_ExprA lvar e). @@ -608,7 +609,7 @@ unfold monom_remove in |- *; case (eqExprA (EAvar n) (EAinv a)); intros; Qed. Lemma monom_simplif_rem_correct : - forall (a e:ExprA) (lvar:listT (prodT AT nat)), + forall (a e:ExprA) (lvar:list (AT * nat)), interp_ExprA lvar a <> AzeroT -> interp_ExprA lvar (monom_simplif_rem a e) = AmultT (interp_ExprA lvar a) (interp_ExprA lvar e). @@ -622,7 +623,7 @@ ring. Qed. Lemma monom_simplif_correct : - forall (e a:ExprA) (lvar:listT (prodT AT nat)), + forall (e a:ExprA) (lvar:list (AT * nat)), interp_ExprA lvar a <> AzeroT -> interp_ExprA lvar (monom_simplif a e) = interp_ExprA lvar e. Proof. @@ -633,7 +634,7 @@ simpl in |- *; trivial. Qed. Lemma inverse_correct : - forall (e a:ExprA) (lvar:listT (prodT AT nat)), + forall (e a:ExprA) (lvar:list (AT * nat)), interp_ExprA lvar a <> AzeroT -> interp_ExprA lvar (inverse_simplif a e) = interp_ExprA lvar e. Proof. @@ -642,4 +643,4 @@ simpl in |- *; rewrite (H0 a lvar H1); rewrite monom_simplif_correct; auto. unfold inverse_simplif in |- *; rewrite monom_simplif_correct; auto. Qed. -End Theory_of_fields.
\ No newline at end of file +End Theory_of_fields. diff --git a/contrib/field/field.ml4 b/contrib/field/field.ml4 index 35591f23..47e583fd 100644 --- a/contrib/field/field.ml4 +++ b/contrib/field/field.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: field.ml4 7837 2006-01-11 09:47:32Z herbelin $ *) +(* $Id: field.ml4 8866 2006-05-28 16:21:04Z herbelin $ *) open Names open Pp @@ -22,19 +22,22 @@ open Vernacinterp open Vernacexpr open Tacexpr open Mod_subst +open Coqlib (* Interpretation of constr's *) let constr_of c = Constrintern.interp_constr Evd.empty (Global.env()) c (* Construction of constants *) -let constant dir s = Coqlib.gen_constant "Field" ("field"::dir) s +let constant dir s = gen_constant "Field" ("field"::dir) s +let init_constant s = gen_constant_in_modules "Field" init_modules s (* To deal with the optional arguments *) let constr_of_opt a opt = let ac = constr_of a in + let ac3 = mkArrow ac (mkArrow ac ac) in match opt with - | None -> mkApp ((constant ["Field_Compl"] "Field_None"),[|ac|]) - | Some f -> mkApp ((constant ["Field_Compl"] "Field_Some"),[|ac;constr_of f|]) + | None -> mkApp (init_constant "None",[|ac3|]) + | Some f -> mkApp (init_constant "Some",[|ac3;constr_of f|]) (* Table of theories *) let th_tab = ref (Gmap.empty : (constr,constr) Gmap.t) diff --git a/contrib/first-order/g_ground.ml4 b/contrib/first-order/g_ground.ml4 index 0970d5db..f9c4cea2 100644 --- a/contrib/first-order/g_ground.ml4 +++ b/contrib/first-order/g_ground.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: g_ground.ml4 7909 2006-01-21 11:09:18Z herbelin $ *) +(* $Id: g_ground.ml4 8752 2006-04-27 19:37:33Z herbelin $ *) open Formula open Sequent @@ -83,14 +83,14 @@ let normalize_evaluables= TACTIC EXTEND firstorder [ "firstorder" tactic_opt(t) "with" ne_reference_list(l) ] -> - [ gen_ground_tac true (option_app eval_tactic t) (Ids l) ] + [ gen_ground_tac true (option_map eval_tactic t) (Ids l) ] | [ "firstorder" tactic_opt(t) "using" ne_preident_list(l) ] -> - [ gen_ground_tac true (option_app eval_tactic t) (Bases l) ] + [ gen_ground_tac true (option_map eval_tactic t) (Bases l) ] | [ "firstorder" tactic_opt(t) ] -> - [ gen_ground_tac true (option_app eval_tactic t) Void ] + [ gen_ground_tac true (option_map eval_tactic t) Void ] END TACTIC EXTEND gintuition [ "gintuition" tactic_opt(t) ] -> - [ gen_ground_tac false (option_app eval_tactic t) Void ] + [ gen_ground_tac false (option_map eval_tactic t) Void ] END diff --git a/contrib/first-order/rules.ml b/contrib/first-order/rules.ml index f6653b82..6c51eda3 100644 --- a/contrib/first-order/rules.ml +++ b/contrib/first-order/rules.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: rules.ml 7909 2006-01-21 11:09:18Z herbelin $ *) +(* $Id: rules.ml 8878 2006-05-30 16:44:25Z herbelin $ *) open Util open Names @@ -211,6 +211,6 @@ let normalize_evaluables= onAllClauses (function None->unfold_in_concl (Lazy.force defined_connectives) - | Some (id,_,_)-> + | Some ((_,id),_)-> unfold_in_hyp (Lazy.force defined_connectives) - (id,[],Tacexpr.InHypTypeOnly)) + (([],id),Tacexpr.InHypTypeOnly)) diff --git a/contrib/funind/functional_principles_proofs.ml b/contrib/funind/functional_principles_proofs.ml new file mode 100644 index 00000000..f0e986fb --- /dev/null +++ b/contrib/funind/functional_principles_proofs.ml @@ -0,0 +1,1538 @@ +open Printer +open Util +open Term +open Termops +open Names +open Declarations +open Pp +open Entries +open Hiddentac +open Evd +open Tacmach +open Proof_type +open Tacticals +open Tactics +open Indfun_common +open Libnames + +let msgnl = Pp.msgnl + +let do_observe () = + Tacinterp.get_debug () <> Tactic_debug.DebugOff + + +let observe strm = + if do_observe () + then Pp.msgnl strm + else () + +let observennl strm = + if do_observe () + then begin Pp.msg strm;Pp.pp_flush () end + else () + + + + +let do_observe_tac s tac g = + try let v = tac g in (* msgnl (goal ++ fnl () ++ (str s)++(str " ")++(str "finished")); *) v + with e -> + let goal = begin try (Printer.pr_goal (sig_it g)) with _ -> assert false end in + msgnl (str "observation "++ s++str " raised exception " ++ + Cerrors.explain_exn e ++ str " on goal " ++ goal ); + raise e;; + + +let observe_tac s tac g = + if do_observe () + then do_observe_tac (str s) tac g + else tac g + + +let tclTRYD tac = + if !Options.debug || do_observe () + then (fun g -> try (* do_observe_tac "" *)tac g with _ -> tclIDTAC g) + else tac + + +let list_chop ?(msg="") n l = + try + list_chop n l + with Failure (msg') -> + failwith (msg ^ msg') + + +let make_refl_eq type_of_t t = + let refl_equal_term = Lazy.force refl_equal in + mkApp(refl_equal_term,[|type_of_t;t|]) + + +type pte_info = + { + proving_tac : (identifier list -> Tacmach.tactic); + is_valid : constr -> bool + } + +type ptes_info = pte_info Idmap.t + +type 'a dynamic_info = + { + nb_rec_hyps : int; + rec_hyps : identifier list ; + eq_hyps : identifier list; + info : 'a + } + +type body_info = constr dynamic_info + + +let finish_proof dynamic_infos g = + observe_tac "finish" + ( h_assumption) + g + + +let refine c = + Tacmach.refine_no_check c + +let thin l = + Tacmach.thin_no_check l + + +let cut_replacing id t tac :tactic= + tclTHENS (cut t) + [ tclTHEN (thin_no_check [id]) (introduction_no_check id); + tac + ] + +let intro_erasing id = tclTHEN (thin [id]) (introduction id) + + + +let rec_hyp_id = id_of_string "rec_hyp" + +let is_trivial_eq t = + match kind_of_term t with + | App(f,[|_;t1;t2|]) when eq_constr f (Lazy.force eq) -> + eq_constr t1 t2 + | _ -> false + + +let rec incompatible_constructor_terms t1 t2 = + let c1,arg1 = decompose_app t1 + and c2,arg2 = decompose_app t2 + in + (not (eq_constr t1 t2)) && + isConstruct c1 && isConstruct c2 && + ( + not (eq_constr c1 c2) || + List.exists2 incompatible_constructor_terms arg1 arg2 + ) + +let is_incompatible_eq t = + match kind_of_term t with + | App(f,[|_;t1;t2|]) when eq_constr f (Lazy.force eq) -> + incompatible_constructor_terms t1 t2 + | _ -> false + +let change_hyp_with_using msg hyp_id t tac : tactic = + fun g -> + let prov_id = pf_get_new_id hyp_id g in + tclTHENS + (observe_tac msg (forward (Some (tclCOMPLETE tac)) (Genarg.IntroIdentifier prov_id) t)) + [tclTHENLIST + [ + observe_tac "change_hyp_with_using thin" (thin [hyp_id]); + observe_tac "change_hyp_with_using rename " (h_rename prov_id hyp_id) + ]] g + +exception TOREMOVE + + +let prove_trivial_eq h_id context (type_of_term,term) = + let nb_intros = List.length context in + tclTHENLIST + [ + tclDO nb_intros intro; (* introducing context *) + (fun g -> + let context_hyps = + fst (list_chop ~msg:"prove_trivial_eq : " nb_intros (pf_ids_of_hyps g)) + in + let context_hyps' = + (mkApp(Lazy.force refl_equal,[|type_of_term;term|])):: + (List.map mkVar context_hyps) + in + let to_refine = applist(mkVar h_id,List.rev context_hyps') in + refine to_refine g + ) + ] + + +let isAppConstruct t = + if isApp t + then isConstruct (fst (destApp t)) + else false + + +let nf_betaiotazeta = Reductionops.local_strong Reductionops.whd_betaiotazeta + + +let change_eq env sigma hyp_id (context:Sign.rel_context) x t end_of_type = + let nochange msg = + begin +(* observe (str ("Not treating ( "^msg^" )") ++ pr_lconstr t ); *) + failwith "NoChange"; + end + in + if not (noccurn 1 end_of_type) + then nochange "dependent"; (* if end_of_type depends on this term we don't touch it *) + if not (isApp t) then nochange "not an equality"; + let f_eq,args = destApp t in + if not (eq_constr f_eq (Lazy.force eq)) then nochange "not an equality"; + let t1 = args.(1) + and t2 = args.(2) + and t1_typ = args.(0) + in + if not (closed0 t1) then nochange "not a closed lhs"; + let rec compute_substitution sub t1 t2 = + if isRel t2 + then + let t2 = destRel t2 in + begin + try + let t1' = Intmap.find t2 sub in + if not (eq_constr t1 t1') then nochange "twice bound variable"; + sub + with Not_found -> + assert (closed0 t1); + Intmap.add t2 t1 sub + end + else if isAppConstruct t1 && isAppConstruct t2 + then + begin + let c1,args1 = destApp t1 + and c2,args2 = destApp t2 + in + if not (eq_constr c1 c2) then anomaly "deconstructing equation"; + array_fold_left2 compute_substitution sub args1 args2 + end + else + if (eq_constr t1 t2) then sub else nochange "cannot solve" + in + let sub = compute_substitution Intmap.empty t1 t2 in + let end_of_type_with_pop = pop end_of_type in (*the equation will be removed *) + let new_end_of_type = + (* Ugly hack to prevent Map.fold order change between ocaml-3.08.3 and ocaml-3.08.4 + Can be safely replaced by the next comment for Ocaml >= 3.08.4 + *) + let sub' = Intmap.fold (fun i t acc -> (i,t)::acc) sub [] in + let sub'' = List.sort (fun (x,_) (y,_) -> Pervasives.compare x y) sub' in + List.fold_left (fun end_of_type (i,t) -> lift 1 (substnl [t] (i-1) end_of_type)) + end_of_type_with_pop + sub'' + in + (* let new_end_of_type = *) + (* Intmap.fold *) + (* (fun i t end_of_type -> lift 1 (substnl [t] (i-1) end_of_type)) *) + (* sub *) + (* end_of_type_with_pop *) + (* in *) + let old_context_length = List.length context + 1 in + let witness_fun = + mkLetIn(Anonymous,make_refl_eq t1_typ t1,t, + mkApp(mkVar hyp_id,Array.init old_context_length (fun i -> mkRel (old_context_length - i))) + ) + in + let new_type_of_hyp,ctxt_size,witness_fun = + list_fold_left_i + (fun i (end_of_type,ctxt_size,witness_fun) ((x',b',t') as decl) -> + try + let witness = Intmap.find i sub in + if b' <> None then anomaly "can not redefine a rel!"; + (pop end_of_type,ctxt_size,mkLetIn(x',witness,t',witness_fun)) + with Not_found -> + (mkProd_or_LetIn decl end_of_type, ctxt_size + 1, mkLambda_or_LetIn decl witness_fun) + ) + 1 + (new_end_of_type,0,witness_fun) + context + in + let new_type_of_hyp = Reductionops.nf_betaiota new_type_of_hyp in + let new_ctxt,new_end_of_type = + Sign.decompose_prod_n_assum ctxt_size new_type_of_hyp + in + let prove_new_hyp : tactic = + tclTHEN + (tclDO ctxt_size intro) + (fun g -> + let all_ids = pf_ids_of_hyps g in + let new_ids,_ = list_chop ctxt_size all_ids in + let to_refine = applist(witness_fun,List.rev_map mkVar new_ids) in + refine to_refine g + ) + in + let simpl_eq_tac = + change_hyp_with_using "prove_pattern_simplification" hyp_id new_type_of_hyp prove_new_hyp + in +(* observe (str "In " ++ Ppconstr.pr_id hyp_id ++ *) +(* str "removing an equation " ++ fnl ()++ *) +(* str "old_typ_of_hyp :=" ++ *) +(* Printer.pr_lconstr_env *) +(* env *) +(* (it_mkProd_or_LetIn ~init:end_of_type ((x,None,t)::context)) *) +(* ++ fnl () ++ *) +(* str "new_typ_of_hyp := "++ *) +(* Printer.pr_lconstr_env env new_type_of_hyp ++ fnl () *) +(* ++ str "old context := " ++ pr_rel_context env context ++ fnl () *) +(* ++ str "new context := " ++ pr_rel_context env new_ctxt ++ fnl () *) +(* ++ str "old type := " ++ pr_lconstr end_of_type ++ fnl () *) +(* ++ str "new type := " ++ pr_lconstr new_end_of_type ++ fnl () *) +(* ); *) + new_ctxt,new_end_of_type,simpl_eq_tac + + +let is_property ptes_info t_x full_type_of_hyp = + if isApp t_x + then + let pte,args = destApp t_x in + if isVar pte && array_for_all closed0 args + then + try + let info = Idmap.find (destVar pte) ptes_info in + info.is_valid full_type_of_hyp + with Not_found -> false + else false + else false + +let isLetIn t = + match kind_of_term t with + | LetIn _ -> true + | _ -> false + + +let h_reduce_with_zeta = + h_reduce + (Rawterm.Cbv + {Rawterm.all_flags + with Rawterm.rDelta = false; + }) + + + +let rewrite_until_var arg_num eq_ids : tactic = + let test_var g = + let _,args = destApp (pf_concl g) in + not (isConstruct args.(arg_num)) + in + let rec do_rewrite eq_ids g = + if test_var g + then tclIDTAC g + else + match eq_ids with + | [] -> anomaly "Cannot find a way to prove recursive property"; + | eq_id::eq_ids -> + tclTHEN + (tclTRY (Equality.rewriteRL (mkVar eq_id))) + (do_rewrite eq_ids) + g + in + do_rewrite eq_ids + + +let rec_pte_id = id_of_string "Hrec" +let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = + let coq_False = Coqlib.build_coq_False () in + let coq_True = Coqlib.build_coq_True () in + let coq_I = Coqlib.build_coq_I () in + let rec scan_type context type_of_hyp : tactic = + if isLetIn type_of_hyp then + let real_type_of_hyp = it_mkProd_or_LetIn ~init:type_of_hyp context in + let reduced_type_of_hyp = nf_betaiotazeta real_type_of_hyp in + (* length of context didn't change ? *) + let new_context,new_typ_of_hyp = + Sign.decompose_prod_n_assum (List.length context) reduced_type_of_hyp + in + tclTHENLIST + [ + h_reduce_with_zeta + (Tacticals.onHyp hyp_id) + ; + scan_type new_context new_typ_of_hyp + + ] + else if isProd type_of_hyp + then + begin + let (x,t_x,t') = destProd type_of_hyp in + let actual_real_type_of_hyp = it_mkProd_or_LetIn ~init:t' context in + if is_property ptes_infos t_x actual_real_type_of_hyp then + begin + let pte,pte_args = (destApp t_x) in + let (* fix_info *) prove_rec_hyp = (Idmap.find (destVar pte) ptes_infos).proving_tac in + let popped_t' = pop t' in + let real_type_of_hyp = it_mkProd_or_LetIn ~init:popped_t' context in + let prove_new_type_of_hyp = + let context_length = List.length context in + tclTHENLIST + [ + tclDO context_length intro; + (fun g -> + let context_hyps_ids = + fst (list_chop ~msg:"rec hyp : context_hyps" + context_length (pf_ids_of_hyps g)) + in + let rec_pte_id = pf_get_new_id rec_pte_id g in + let to_refine = + applist(mkVar hyp_id, + List.rev_map mkVar (rec_pte_id::context_hyps_ids) + ) + in + observe_tac "rec hyp " + (tclTHENS + (assert_as true (Genarg.IntroIdentifier rec_pte_id) t_x) + [observe_tac "prove rec hyp" (prove_rec_hyp eq_hyps); + observe_tac "prove rec hyp" + (refine to_refine) + ]) + g + ) + ] + in + tclTHENLIST + [ + observe_tac "hyp rec" + (change_hyp_with_using "rec_hyp_tac" hyp_id real_type_of_hyp prove_new_type_of_hyp); + scan_type context popped_t' + ] + end + else if eq_constr t_x coq_False then + begin +(* observe (str "Removing : "++ Ppconstr.pr_id hyp_id++ *) +(* str " since it has False in its preconds " *) +(* ); *) + raise TOREMOVE; (* False -> .. useless *) + end + else if is_incompatible_eq t_x then raise TOREMOVE (* t_x := C1 ... = C2 ... *) + else if eq_constr t_x coq_True (* Trivial => we remove this precons *) + then +(* observe (str "In "++Ppconstr.pr_id hyp_id++ *) +(* str " removing useless precond True" *) +(* ); *) + let popped_t' = pop t' in + let real_type_of_hyp = + it_mkProd_or_LetIn ~init:popped_t' context + in + let prove_trivial = + let nb_intro = List.length context in + tclTHENLIST [ + tclDO nb_intro intro; + (fun g -> + let context_hyps = + fst (list_chop ~msg:"removing True : context_hyps "nb_intro (pf_ids_of_hyps g)) + in + let to_refine = + applist (mkVar hyp_id, + List.rev (coq_I::List.map mkVar context_hyps) + ) + in + refine to_refine g + ) + ] + in + tclTHENLIST[ + change_hyp_with_using "prove_trivial" hyp_id real_type_of_hyp + (observe_tac "prove_trivial" prove_trivial); + scan_type context popped_t' + ] + else if is_trivial_eq t_x + then (* t_x := t = t => we remove this precond *) + let popped_t' = pop t' in + let real_type_of_hyp = + it_mkProd_or_LetIn ~init:popped_t' context + in + let _,args = destApp t_x in + tclTHENLIST + [ + change_hyp_with_using + "prove_trivial_eq" + hyp_id + real_type_of_hyp + (observe_tac "prove_trivial_eq" (prove_trivial_eq hyp_id context (args.(0),args.(1)))); + scan_type context popped_t' + ] + else + begin + try + let new_context,new_t',tac = change_eq env sigma hyp_id context x t_x t' in + tclTHEN + tac + (scan_type new_context new_t') + with Failure "NoChange" -> + (* Last thing todo : push the rel in the context and continue *) + scan_type ((x,None,t_x)::context) t' + end + end + else + tclIDTAC + in + try + scan_type [] (Typing.type_of env sigma (mkVar hyp_id)), [hyp_id] + with TOREMOVE -> + thin [hyp_id],[] + + +let clean_goal_with_heq ptes_infos continue_tac dyn_infos = + fun g -> + let env = pf_env g + and sigma = project g + in + let tac,new_hyps = + List.fold_left ( + fun (hyps_tac,new_hyps) hyp_id -> + let hyp_tac,new_hyp = + clean_hyp_with_heq ptes_infos dyn_infos.eq_hyps hyp_id env sigma + in + (tclTHEN hyp_tac hyps_tac),new_hyp@new_hyps + ) + (tclIDTAC,[]) + dyn_infos.rec_hyps + in + let new_infos = + { dyn_infos with + rec_hyps = new_hyps; + nb_rec_hyps = List.length new_hyps + } + in + tclTHENLIST + [ + tac ; + (continue_tac new_infos) + ] + g + +let heq_id = id_of_string "Heq" + +let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = + fun g -> + let heq_id = pf_get_new_id heq_id g in + let nb_first_intro = nb_prod - 1 - dyn_infos.nb_rec_hyps in + tclTHENLIST + [ + (* We first introduce the variables *) + tclDO nb_first_intro (intro_avoiding dyn_infos.rec_hyps); + (* Then the equation itself *) + introduction_no_check heq_id; + (* Then the new hypothesis *) + tclMAP introduction_no_check dyn_infos.rec_hyps; + observe_tac "after_introduction" (fun g' -> + (* We get infos on the equations introduced*) + let new_term_value_eq = pf_type_of g' (mkVar heq_id) in + (* compute the new value of the body *) + let new_term_value = + match kind_of_term new_term_value_eq with + | App(f,[| _;_;args2 |]) -> args2 + | _ -> + observe (str "cannot compute new term value : " ++ pr_gls g' ++ fnl () ++ str "last hyp is" ++ + pr_lconstr_env (pf_env g') new_term_value_eq + ); + anomaly "cannot compute new term value" + in + let fun_body = + mkLambda(Anonymous, + pf_type_of g' term, + replace_term term (mkRel 1) dyn_infos.info + ) + in + let new_body = pf_nf_betaiota g' (mkApp(fun_body,[| new_term_value |])) in + let new_infos = + {dyn_infos with + info = new_body; + eq_hyps = heq_id::dyn_infos.eq_hyps + } + in + clean_goal_with_heq ptes_infos continue_tac new_infos g' + ) + ] + g + + +let instanciate_hyps_with_args (do_prove:identifier list -> tactic) hyps args_id = + let args = Array.of_list (List.map mkVar args_id) in + let instanciate_one_hyp hid = + tclORELSE + ( (* we instanciate the hyp if possible *) + fun g -> + let prov_hid = pf_get_new_id hid g in + tclTHENLIST[ + forward None (Genarg.IntroIdentifier prov_hid) (mkApp(mkVar hid,args)); + thin [hid]; + h_rename prov_hid hid + ] g + ) + ( (* + if not then we are in a mutual function block + and this hyp is a recursive hyp on an other function. + + We are not supposed to use it while proving this + principle so that we can trash it + + *) + (fun g -> +(* observe (str "Instanciation: removing hyp " ++ Ppconstr.pr_id hid); *) + thin [hid] g + ) + ) + in + if args_id = [] + then + tclTHENLIST [ + tclMAP (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) hyps; + do_prove hyps + ] + else + tclTHENLIST + [ + tclMAP (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) hyps; + tclMAP instanciate_one_hyp hyps; + (fun g -> + let all_g_hyps_id = + List.fold_right Idset.add (pf_ids_of_hyps g) Idset.empty + in + let remaining_hyps = + List.filter (fun id -> Idset.mem id all_g_hyps_id) hyps + in + do_prove remaining_hyps g + ) + ] + +let build_proof + (interactive_proof:bool) + (fnames:constant list) + ptes_infos + dyn_infos + : tactic = + let rec build_proof_aux do_finalize dyn_infos : tactic = + fun g -> + +(* observe (str "proving on " ++ Printer.pr_lconstr_env (pf_env g) term);*) + match kind_of_term dyn_infos.info with + | Case(_,_,t,_) -> + let g_nb_prod = nb_prod (pf_concl g) in + let type_of_term = pf_type_of g t in + let term_eq = + make_refl_eq type_of_term t + in + tclTHENSEQ + [ + h_generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps)); + thin dyn_infos.rec_hyps; + pattern_option [[-1],t] None; + h_simplest_case t; + (fun g' -> + let g'_nb_prod = nb_prod (pf_concl g') in + let nb_instanciate_partial = g'_nb_prod - g_nb_prod in + observe_tac "treat_new_case" + (treat_new_case + ptes_infos + nb_instanciate_partial + (build_proof do_finalize) + t + dyn_infos) + g' + ) + + ] g + | Lambda(n,t,b) -> + begin + match kind_of_term( pf_concl g) with + | Prod _ -> + tclTHEN + intro + (fun g' -> + let (id,_,_) = pf_last_hyp g' in + let new_term = + pf_nf_betaiota g' + (mkApp(dyn_infos.info,[|mkVar id|])) + in + let new_infos = {dyn_infos with info = new_term} in + let do_prove new_hyps = + build_proof do_finalize + {new_infos with + rec_hyps = new_hyps; + nb_rec_hyps = List.length new_hyps + } + in + observe_tac "Lambda" (instanciate_hyps_with_args do_prove new_infos.rec_hyps [id]) g' + (* build_proof do_finalize new_infos g' *) + ) g + | _ -> + do_finalize dyn_infos g + end + | Cast(t,_,_) -> + build_proof do_finalize {dyn_infos with info = t} g + | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ -> + do_finalize dyn_infos g + | App(_,_) -> + let f,args = decompose_app dyn_infos.info in + begin + match kind_of_term f with + | App _ -> assert false (* we have collected all the app in decompose_app *) + | Var _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ | Sort _ | Prod _ -> + let new_infos = + { dyn_infos with + info = (f,args) + } + in + build_proof_args do_finalize new_infos g + | Const c when not (List.mem c fnames) -> + let new_infos = + { dyn_infos with + info = (f,args) + } + in +(* Pp.msgnl (str "proving in " ++ pr_lconstr_env (pf_env g) dyn_infos.info); *) + build_proof_args do_finalize new_infos g + | Const _ -> + do_finalize dyn_infos g + | Lambda _ -> + let new_term = Reductionops.nf_beta dyn_infos.info in + build_proof do_finalize {dyn_infos with info = new_term} + g + | LetIn _ -> + let new_infos = + { dyn_infos with info = nf_betaiotazeta dyn_infos.info } + in + + tclTHENLIST + [tclMAP + (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) + dyn_infos.rec_hyps; + h_reduce_with_zeta Tacticals.onConcl; + build_proof do_finalize new_infos + ] + g + | Cast(b,_,_) -> + build_proof do_finalize {dyn_infos with info = b } g + | Case _ | Fix _ | CoFix _ -> + let new_finalize dyn_infos = + let new_infos = + { dyn_infos with + info = dyn_infos.info,args + } + in + build_proof_args do_finalize new_infos + in + build_proof new_finalize {dyn_infos with info = f } g + end + | Fix _ | CoFix _ -> + error ( "Anonymous local (co)fixpoints are not handled yet") + + | Prod _ -> error "Prod" + | LetIn _ -> + let new_infos = + { dyn_infos with + info = nf_betaiotazeta dyn_infos.info + } + in + + tclTHENLIST + [tclMAP + (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) + dyn_infos.rec_hyps; + h_reduce_with_zeta Tacticals.onConcl; + build_proof do_finalize new_infos + ] g + | Rel _ -> anomaly "Free var in goal conclusion !" + and build_proof do_finalize dyn_infos g = +(* observe (str "proving with "++Printer.pr_lconstr dyn_infos.info++ str " on goal " ++ pr_gls g); *) + (build_proof_aux do_finalize dyn_infos) g + and build_proof_args do_finalize dyn_infos (* f_args' args *) :tactic = + fun g -> +(* if Tacinterp.get_debug () <> Tactic_debug.DebugOff *) +(* then msgnl (str "build_proof_args with " ++ *) +(* pr_lconstr_env (pf_env g) f_args' *) +(* ); *) + let (f_args',args) = dyn_infos.info in + let tac : tactic = + fun g -> + match args with + | [] -> + do_finalize {dyn_infos with info = f_args'} g + | arg::args -> +(* observe (str "build_proof_args with arg := "++ pr_lconstr_env (pf_env g) arg++ *) +(* fnl () ++ *) +(* pr_goal (Tacmach.sig_it g) *) +(* ); *) + let do_finalize dyn_infos = + let new_arg = dyn_infos.info in + (* tclTRYD *) + (build_proof_args + do_finalize + {dyn_infos with info = (mkApp(f_args',[|new_arg|])), args} + ) + in + build_proof do_finalize + {dyn_infos with info = arg } + g + in + observe_tac "build_proof_args" (tac ) g + in + let do_finish_proof dyn_infos = + (* tclTRYD *) (clean_goal_with_heq + ptes_infos + finish_proof dyn_infos) + in + observe_tac "build_proof" + (build_proof do_finish_proof dyn_infos) + + + + + + + + + + + + +(* Proof of principles from structural functions *) +let is_pte_type t = + isSort (snd (decompose_prod t)) + +let is_pte (_,_,t) = is_pte_type t + + + + +type static_fix_info = + { + idx : int; + name : identifier; + types : types; + offset : int; + nb_realargs : int; + body_with_param : constr + } + + + +let prove_rec_hyp_for_struct fix_info = + (fun eq_hyps -> tclTHEN + (rewrite_until_var (fix_info.idx) eq_hyps) + (fun g -> + let _,pte_args = destApp (pf_concl g) in + let rec_hyp_proof = + mkApp(mkVar fix_info.name,array_get_start pte_args) + in + refine rec_hyp_proof g + )) + +let prove_rec_hyp fix_info = + { proving_tac = prove_rec_hyp_for_struct fix_info + ; + is_valid = fun _ -> true + } + + +exception Not_Rec + +let generalize_non_dep hyp g = + let hyps = [hyp] in + let env = Global.env () in + let hyp_typ = pf_type_of g (mkVar hyp) in + let to_revert,_ = + Environ. fold_named_context_reverse (fun (clear,keep) (hyp,_,_ as decl) -> + if List.mem hyp hyps + or List.exists (occur_var_in_decl env hyp) keep + or occur_var env hyp hyp_typ + or Termops.is_section_variable hyp (* should be dangerous *) + then (clear,decl::keep) + else (hyp::clear,keep)) + ~init:([],[]) (pf_env g) + in +(* observe (str "to_revert := " ++ prlist_with_sep spc Ppconstr.pr_id to_revert); *) + tclTHEN + (observe_tac "h_generalize" (h_generalize (List.map mkVar to_revert))) + (observe_tac "thin" (thin to_revert)) + g + +let id_of_decl (na,_,_) = (Nameops.out_name na) +let var_of_decl decl = mkVar (id_of_decl decl) +let revert idl = + tclTHEN + (generalize (List.map mkVar idl)) + (thin idl) + + +let do_replace params rec_arg_num rev_args_id fun_to_replace body = + fun g -> + let nb_intro_to_do = nb_prod (pf_concl g) in + tclTHEN + (tclDO nb_intro_to_do intro) + ( + fun g' -> + let just_introduced = nLastHyps nb_intro_to_do g' in + let just_introduced_id = List.map (fun (id,_,_) -> id) just_introduced in + let old_rev_args_id = rev_args_id in + let rev_args_id = just_introduced_id@rev_args_id in + let to_replace = + Reductionops.nf_betaiota (substl (List.map mkVar rev_args_id) fun_to_replace ) + and by = + Reductionops.nf_betaiota (applist(body,List.rev_map mkVar rev_args_id)) + in +(* observe (str "to_replace := " ++ pr_lconstr_env (pf_env g') to_replace); *) +(* observe (str "by := " ++ pr_lconstr_env (pf_env g') by); *) + let prove_replacement = + let rec_id = List.nth (List.rev old_rev_args_id) (rec_arg_num) in + observe_tac "prove_replacement" + (tclTHENSEQ + [ + revert just_introduced_id; + keep ((List.map id_of_decl params)@ old_rev_args_id); + generalize_non_dep rec_id; + observe_tac "h_case" (h_case(mkVar rec_id,Rawterm.NoBindings)); + intros_reflexivity + ] + ) + in + tclTHENS + (observe_tac "replacement" (Equality.replace to_replace by)) + [ revert just_introduced_id; + tclSOLVE [prove_replacement]] + g' + ) + g + + + +let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : tactic = + fun g -> + let princ_type = pf_concl g in + let princ_info = compute_elim_sig princ_type in + let fresh_id = + let avoid = ref (pf_ids_of_hyps g) in + (fun na -> + let new_id = + match na with + Name id -> fresh_id !avoid (string_of_id id) + | Anonymous -> fresh_id !avoid "H" + in + avoid := new_id :: !avoid; + (Name new_id) + ) + in + let fresh_decl = + (fun (na,b,t) -> + (fresh_id na,b,t) + ) + in + let princ_info : elim_scheme = + { princ_info with + params = List.map fresh_decl princ_info.params; + predicates = List.map fresh_decl princ_info.predicates; + branches = List.map fresh_decl princ_info.branches; + args = List.map fresh_decl princ_info.args + } + in + let get_body const = + match (Global.lookup_constant const ).const_body with + | Some b -> + let body = force b in + Tacred.cbv_norm_flags + (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]) + (Global.env ()) + (Evd.empty) + body + | None -> error ( "Cannot define a principle over an axiom ") + in + let fbody = get_body fnames.(fun_num) in + let f_ctxt,f_body = decompose_lam fbody in + let f_ctxt_length = List.length f_ctxt in + let diff_params = princ_info.nparams - f_ctxt_length in + let full_params,princ_params,fbody_with_full_params = + if diff_params > 0 + then + let princ_params,full_params = + list_chop diff_params princ_info.params + in + (full_params, (* real params *) + princ_params, (* the params of the principle which are not params of the function *) + substl (* function instanciated with real params *) + (List.map var_of_decl full_params) + f_body + ) + else + let f_ctxt_other,f_ctxt_params = + list_chop (- diff_params) f_ctxt in + let f_body = compose_lam f_ctxt_other f_body in + (princ_info.params, (* real params *) + [],(* all params are full params *) + substl (* function instanciated with real params *) + (List.map var_of_decl princ_info.params) + f_body + ) + in +(* observe (str "full_params := " ++ *) +(* prlist_with_sep spc (fun (na,_,_) -> Ppconstr.pr_id (Nameops.out_name na)) *) +(* full_params *) +(* ); *) +(* observe (str "princ_params := " ++ *) +(* prlist_with_sep spc (fun (na,_,_) -> Ppconstr.pr_id (Nameops.out_name na)) *) +(* princ_params *) +(* ); *) +(* observe (str "fbody_with_full_params := " ++ *) +(* pr_lconstr fbody_with_full_params *) +(* ); *) + let all_funs_with_full_params = + Array.map (fun f -> applist(f, List.rev_map var_of_decl full_params)) all_funs + in + let fix_offset = List.length princ_params in + let ptes_to_fix,infos = + match kind_of_term fbody_with_full_params with + | Fix((idxs,i),(names,typess,bodies)) -> + let bodies_with_all_params = + Array.map + (fun body -> + Reductionops.nf_betaiota + (applist(substl (List.rev (Array.to_list all_funs_with_full_params)) body, + List.rev_map var_of_decl princ_params)) + ) + bodies + in + let info_array = + Array.mapi + (fun i types -> + let types = prod_applist types (List.rev_map var_of_decl princ_params) in + { idx = idxs.(i) - fix_offset; + name = Nameops.out_name (fresh_id names.(i)); + types = types; + offset = fix_offset; + nb_realargs = + List.length + (fst (decompose_lam bodies.(i))) - fix_offset; + body_with_param = bodies_with_all_params.(i) + } + ) + typess + in + let pte_to_fix,rev_info = + list_fold_left_i + (fun i (acc_map,acc_info) (pte,_,_) -> + let infos = info_array.(i) in + let type_args,_ = decompose_prod infos.types in + let nargs = List.length type_args in + let f = applist(mkConst fnames.(i), List.rev_map var_of_decl princ_info.params) in + let first_args = Array.init nargs (fun i -> mkRel (nargs -i)) in + let app_f = mkApp(f,first_args) in + let pte_args = (Array.to_list first_args)@[app_f] in + let app_pte = applist(mkVar (Nameops.out_name pte),pte_args) in + let body_with_param = + let body = get_body fnames.(i) in + let body_with_full_params = + Reductionops.nf_betaiota ( + applist(body,List.rev_map var_of_decl full_params)) + in + match kind_of_term body_with_full_params with + | Fix((_,num),(_,_,bs)) -> + Reductionops.nf_betaiota + ( + (applist + (substl + (List.rev + (Array.to_list all_funs_with_full_params)) + bs.(num), + List.rev_map var_of_decl princ_params)) + ) + | _ -> error "Not a mutual block" + in + let info = + {infos with + types = compose_prod type_args app_pte; + body_with_param = body_with_param + } + in +(* observe (str "binding " ++ Ppconstr.pr_id (Nameops.out_name pte) ++ *) +(* str " to " ++ Ppconstr.pr_id info.name); *) + (Idmap.add (Nameops.out_name pte) info acc_map,info::acc_info) + ) + 0 + (Idmap.empty,[]) + (List.rev princ_info.predicates) + in + pte_to_fix,List.rev rev_info + | _ -> Idmap.empty,[] + in + let mk_fixes : tactic = + let pre_info,infos = list_chop fun_num infos in + match pre_info,infos with + | [],[] -> tclIDTAC + | _, this_fix_info::others_infos -> + let other_fix_infos = + List.map + (fun fi -> fi.name,fi.idx + 1 ,fi.types) + (pre_info@others_infos) + in + if other_fix_infos = [] + then + observe_tac ("h_fix") (h_fix (Some this_fix_info.name) (this_fix_info.idx +1)) + else + h_mutual_fix this_fix_info.name (this_fix_info.idx + 1) + other_fix_infos + | _ -> anomaly "Not a valid information" + in + let first_tac : tactic = (* every operations until fix creations *) + tclTHENSEQ + [ observe_tac "introducing params" (intros_using (List.rev_map id_of_decl princ_info.params)); + observe_tac "introducing predictes" (intros_using (List.rev_map id_of_decl princ_info.predicates)); + observe_tac "introducing branches" (intros_using (List.rev_map id_of_decl princ_info.branches)); + observe_tac "building fixes" mk_fixes; + ] + in + let intros_after_fixes : tactic = + fun gl -> + let ctxt,pte_app = (Sign.decompose_prod_assum (pf_concl gl)) in + let pte,pte_args = (decompose_app pte_app) in + try + let pte = try destVar pte with _ -> anomaly "Property is not a variable" in + let fix_info = Idmap.find pte ptes_to_fix in + let nb_args = fix_info.nb_realargs in + tclTHENSEQ + [ + observe_tac ("introducing args") (tclDO nb_args intro); + (fun g -> (* replacement of the function by its body *) + let args = nLastHyps nb_args g in + let fix_body = fix_info.body_with_param in +(* observe (str "fix_body := "++ pr_lconstr_env (pf_env gl) fix_body); *) + let args_id = List.map (fun (id,_,_) -> id) args in + let dyn_infos = + { + nb_rec_hyps = -100; + rec_hyps = []; + info = + Reductionops.nf_betaiota + (applist(fix_body,List.rev_map mkVar args_id)); + eq_hyps = [] + } + in + tclTHENSEQ + [ + observe_tac "do_replace" + (do_replace princ_info.params fix_info.idx args_id + (List.hd (List.rev pte_args)) fix_body); + let do_prove = + build_proof + interactive_proof + (Array.to_list fnames) + (Idmap.map prove_rec_hyp ptes_to_fix) + in + let prove_tac branches = + let dyn_infos = + {dyn_infos with + rec_hyps = branches; + nb_rec_hyps = List.length branches + } + in + clean_goal_with_heq + (Idmap.map prove_rec_hyp ptes_to_fix) + do_prove + dyn_infos + in +(* observe (str "branches := " ++ *) +(* prlist_with_sep spc (fun decl -> Ppconstr.pr_id (id_of_decl decl)) princ_info.branches); *) + observe_tac "instancing" (instanciate_hyps_with_args prove_tac + (List.rev_map id_of_decl princ_info.branches) + (List.rev args_id)) + ] + g + ); + ] gl + with Not_found -> + let nb_args = min (princ_info.nargs) (List.length ctxt) in + tclTHENSEQ + [ + tclDO nb_args intro; + (fun g -> (* replacement of the function by its body *) + let args = nLastHyps nb_args g in + let args_id = List.map (fun (id,_,_) -> id) args in + let dyn_infos = + { + nb_rec_hyps = -100; + rec_hyps = []; + info = + Reductionops.nf_betaiota + (applist(fbody_with_full_params, + (List.rev_map var_of_decl princ_params)@ + (List.rev_map mkVar args_id) + )); + eq_hyps = [] + } + in + let fname = destConst (fst (decompose_app (List.hd (List.rev pte_args)))) in + tclTHENSEQ + [unfold_in_concl [([],Names.EvalConstRef fname)]; + let do_prove = + build_proof + interactive_proof + (Array.to_list fnames) + (Idmap.map prove_rec_hyp ptes_to_fix) + in + let prove_tac branches = + let dyn_infos = + {dyn_infos with + rec_hyps = branches; + nb_rec_hyps = List.length branches + } + in + clean_goal_with_heq + (Idmap.map prove_rec_hyp ptes_to_fix) + do_prove + dyn_infos + in + instanciate_hyps_with_args prove_tac + (List.rev_map id_of_decl princ_info.branches) + (List.rev args_id) + ] + g + ) + ] + gl + in + tclTHEN + first_tac + intros_after_fixes + g + + + + + + +(* Proof of principles of general functions *) +let h_id = Recdef.h_id +and hrec_id = Recdef.hrec_id +and acc_inv_id = Recdef.acc_inv_id +and ltof_ref = Recdef.ltof_ref +and acc_rel = Recdef.acc_rel +and well_founded = Recdef.well_founded +and delayed_force = Recdef.delayed_force +and h_intros = Recdef.h_intros +and list_rewrite = Recdef.list_rewrite +and evaluable_of_global_reference = Recdef.evaluable_of_global_reference + +let prove_with_tcc tcc_lemma_constr eqs : tactic = + match !tcc_lemma_constr with + | None -> anomaly "No tcc proof !!" + | Some lemma -> + fun gls -> + let hid = next_global_ident_away true h_id (pf_ids_of_hyps gls) in + tclTHENSEQ + [ + generalize [lemma]; + h_intro hid; + Elim.h_decompose_and (mkVar hid); + tclTRY(list_rewrite true eqs); + Eauto.gen_eauto false (false,5) [] (Some []) + ] + gls + + +let backtrack_eqs_until_hrec hrec eqs : tactic = + fun gls -> + let rewrite = + tclFIRST (List.map Equality.rewriteRL eqs ) + in + let _,hrec_concl = decompose_prod (pf_type_of gls (mkVar hrec)) in + let f_app = array_last (snd (destApp hrec_concl)) in + let f = (fst (destApp f_app)) in + let rec backtrack : tactic = + fun g -> + let f_app = array_last (snd (destApp (pf_concl g))) in + match kind_of_term f_app with + | App(f',_) when eq_constr f' f -> tclIDTAC g + | _ -> tclTHEN rewrite backtrack g + in + backtrack gls + + + + + +let new_prove_with_tcc is_mes acc_inv hrec tcc_lemma_constr eqs : tactic = + match !tcc_lemma_constr with + | None -> tclIDTAC_MESSAGE (str "No tcc proof !!") + | Some lemma -> + fun gls -> + let hid = next_global_ident_away true Recdef.h_id (pf_ids_of_hyps gls) in + (tclTHENSEQ + [ + generalize [lemma]; + h_intro hid; + Elim.h_decompose_and (mkVar hid); + backtrack_eqs_until_hrec hrec eqs; + tclCOMPLETE (tclTHENS (* We must have exactly ONE subgoal !*) + (apply (mkVar hrec)) + [ tclTHENSEQ + [ + thin [hrec]; + apply (Lazy.force acc_inv); + (fun g -> + if is_mes + then + unfold_in_concl [([], evaluable_of_global_reference (delayed_force ltof_ref))] g + else tclIDTAC g + ); + tclTRY(Recdef.list_rewrite true eqs); + observe_tac "finishing" (tclCOMPLETE (Eauto.gen_eauto false (false,5) [] (Some []))) + ] + ] + ) + ]) + gls + + +let is_valid_hypothesis predicates_name = + let predicates_name = List.fold_right Idset.add predicates_name Idset.empty in + let is_pte typ = + if isApp typ + then + let pte,_ = destApp typ in + if isVar pte + then Idset.mem (destVar pte) predicates_name + else false + else false + in + let rec is_valid_hypothesis typ = + is_pte typ || + match kind_of_term typ with + | Prod(_,pte,typ') -> is_pte pte && is_valid_hypothesis typ' + | _ -> false + in + is_valid_hypothesis + +let fresh_id avoid na = + let id = + match na with + | Name id -> id + | Anonymous -> h_id + in + next_global_ident_away true id avoid + + +let prove_principle_for_gen + (f_ref,functional_ref,eq_ref) tcc_lemma_ref is_mes + rec_arg_num rec_arg_type relation = + fun g -> + let type_of_goal = pf_concl g in + let goal_ids = pf_ids_of_hyps g in + let goal_elim_infos = compute_elim_sig type_of_goal in + let params_names,ids = List.fold_left + (fun (params_names,avoid) (na,_,_) -> + let new_id = fresh_id avoid na in + (new_id::params_names,new_id::avoid) + ) + ([],goal_ids) + goal_elim_infos.params + in + let predicates_names,ids = + List.fold_left + (fun (predicates_names,avoid) (na,_,_) -> + let new_id = fresh_id avoid na in + (new_id::predicates_names,new_id::avoid) + ) + ([],ids) + goal_elim_infos.predicates + in + let branches_names,ids = + List.fold_left + (fun (branches_names,avoid) (na,_,_) -> + let new_id = fresh_id avoid na in + (new_id::branches_names,new_id::avoid) + ) + ([],ids) + goal_elim_infos.branches + in + let to_intro = params_names@predicates_names@branches_names in + let nparams = List.length params_names in + let rec_arg_num = rec_arg_num - nparams in + let tac_intro_static = h_intros to_intro in + let args_info = ref None in + let arg_tac g = (* introducing args *) + let ids = pf_ids_of_hyps g in + let func_body = def_of_const (mkConst functional_ref) in + (* let _ = Pp.msgnl (Printer.pr_lconstr func_body) in *) + let (f_name, _, body1) = destLambda func_body in + let f_id = + match f_name with + | Name f_id -> next_global_ident_away true f_id ids + | Anonymous -> anomaly "anonymous function" + in + let n_names_types,_ = decompose_lam body1 in + let n_ids,ids = + List.fold_left + (fun (n_ids,ids) (n_name,_) -> + match n_name with + | Name id -> + let n_id = next_global_ident_away true id ids in + n_id::n_ids,n_id::ids + | _ -> anomaly "anonymous argument" + ) + ([],(f_id::ids)) + n_names_types + in + let rec_arg_id = List.nth n_ids (rec_arg_num - 1 ) in + let args_ids = snd (list_chop nparams n_ids) in + args_info := Some (ids,args_ids,rec_arg_id); + h_intros args_ids g + in + let wf_tac = + if is_mes + then + Recdef.tclUSER_if_not_mes + else fun _ -> prove_with_tcc tcc_lemma_ref [] + in + let start_tac g = + let ids,args_ids,rec_arg_id = out_some !args_info in + let nargs = List.length args_ids in + let pre_rec_arg = + List.rev_map + mkVar + (fst (list_chop (rec_arg_num - 1) args_ids)) + in + let args_before_rec = pre_rec_arg@(List.map mkVar params_names) in + let relation = substl args_before_rec relation in + let input_type = substl args_before_rec rec_arg_type in + let wf_thm = next_global_ident_away true (id_of_string ("wf_R")) ids in + let wf_rec_arg = + next_global_ident_away true + (id_of_string ("Acc_"^(string_of_id rec_arg_id))) + (wf_thm::ids) + in + let hrec = next_global_ident_away true hrec_id (wf_rec_arg::wf_thm::ids) in + let acc_inv = + lazy ( + mkApp ( + delayed_force acc_inv_id, + [|input_type;relation;mkVar rec_arg_id|] + ) + ) + in + (tclTHENS + (observe_tac + "first assert" + (assert_tac + true (* the assert thm is in first subgoal *) + (Name wf_rec_arg) + (mkApp (delayed_force acc_rel, + [|input_type;relation;mkVar rec_arg_id|]) + ) + ) + ) + [ + (* accesibility proof *) + tclTHENS + (observe_tac + "second assert" + (assert_tac + true + (Name wf_thm) + (mkApp (delayed_force well_founded,[|input_type;relation|])) + ) + ) + [ + (* interactive proof of the well_foundness of the relation *) + wf_tac is_mes; + (* well_foundness -> Acc for any element *) + observe_tac + "apply wf_thm" + (h_apply ((mkApp(mkVar wf_thm, + [|mkVar rec_arg_id |])),Rawterm.NoBindings) + ) + ] + ; + (* rest of the proof *) + tclTHENSEQ + [ + observe_tac "generalize" (fun g -> + let to_thin = + fst (list_chop ( nargs + 1) (pf_ids_of_hyps g)) + in + let to_thin_c = List.rev_map mkVar to_thin in + tclTHEN (generalize to_thin_c) (observe_tac "thin" (h_clear false to_thin)) g + ); + observe_tac "h_fix" (h_fix (Some hrec) (nargs+1)); + h_intros args_ids; + h_intro wf_rec_arg; + Equality.rewriteLR (mkConst eq_ref); + (fun g' -> + let body = + let _,args = destApp (pf_concl g') in + array_last args + in + let body_info rec_hyps = + { + nb_rec_hyps = List.length rec_hyps; + rec_hyps = rec_hyps; + eq_hyps = []; + info = body + } + in + let acc_inv = lazy (mkApp(Lazy.force acc_inv, [|mkVar wf_rec_arg|]) ) in + let pte_info = + { proving_tac = + (fun eqs -> + observe_tac "prove_with_tcc" + (new_prove_with_tcc is_mes acc_inv hrec tcc_lemma_ref (List.map mkVar eqs)) + ); + is_valid = is_valid_hypothesis predicates_names + } + in + let ptes_info : pte_info Idmap.t = + List.fold_left + (fun map pte_id -> + Idmap.add pte_id + pte_info + map + ) + Idmap.empty + predicates_names + in + let make_proof rec_hyps = + build_proof + false + [f_ref] + ptes_info + (body_info rec_hyps) + in + instanciate_hyps_with_args + make_proof + branches_names + args_ids + g' + + ) + ] + ] + g + ) + in + tclTHENSEQ + [tac_intro_static; + arg_tac; + start_tac + ] g + + + + + + + + + + + + + + + diff --git a/contrib/funind/functional_principles_proofs.mli b/contrib/funind/functional_principles_proofs.mli new file mode 100644 index 00000000..35da5d50 --- /dev/null +++ b/contrib/funind/functional_principles_proofs.mli @@ -0,0 +1,20 @@ +open Names +open Term + +val prove_princ_for_struct : + bool -> + int -> constant array -> constr array -> int -> Tacmach.tactic + + +val prove_principle_for_gen : + constant*constant*constant -> (* name of the function, the fonctionnal and the fixpoint equation *) + constr option ref -> (* a pointer to the obligation proofs lemma *) + bool -> (* is that function uses measure *) + int -> (* the number of recursive argument *) + types -> (* the type of the recursive argument *) + constr -> (* the wf relation used to prove the function *) + Tacmach.tactic + + +val is_pte : rel_declaration -> bool +val do_observe : unit -> bool diff --git a/contrib/funind/functional_principles_types.ml b/contrib/funind/functional_principles_types.ml new file mode 100644 index 00000000..8ef13264 --- /dev/null +++ b/contrib/funind/functional_principles_types.ml @@ -0,0 +1,562 @@ +open Printer +open Util +open Term +open Termops +open Names +open Declarations +open Pp +open Entries +open Hiddentac +open Evd +open Tacmach +open Proof_type +open Tacticals +open Tactics +open Indfun_common +open Functional_principles_proofs + +exception Toberemoved_with_rel of int*constr +exception Toberemoved + + + + + +(* + Transform an inductive induction principle into + a functional one +*) +let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = + let princ_type_info = compute_elim_sig princ_type in + let env = Global.env () in + let change_predicate_sort i (x,_,t) = + let new_sort = sorts.(i) in + let args,_ = decompose_prod t in + let real_args = + if princ_type_info.indarg_in_concl + then List.tl args + else args + in + x,None,compose_prod real_args (mkSort new_sort) + in + let new_predicates = + list_map_i + change_predicate_sort + 0 + princ_type_info.predicates + in + let env_with_params_and_predicates = + Environ.push_rel_context + new_predicates + (Environ.push_rel_context + princ_type_info.params + env + ) + in + let rel_as_kn = + fst (match princ_type_info.indref with + | Some (Libnames.IndRef ind) -> ind + | _ -> failwith "Not a valid predicate" + ) + in + let pre_princ = + it_mkProd_or_LetIn + ~init: + (it_mkProd_or_LetIn + ~init:(option_fold_right + mkProd_or_LetIn + princ_type_info.indarg + princ_type_info.concl + ) + princ_type_info.args + ) + princ_type_info.branches + in + let is_dom c = + match kind_of_term c with + | Ind((u,_)) -> u = rel_as_kn + | Construct((u,_),_) -> u = rel_as_kn + | _ -> false + in + let get_fun_num c = + match kind_of_term c with + | Ind(_,num) -> num + | Construct((_,num),_) -> num + | _ -> assert false + in + let dummy_var = mkVar (id_of_string "________") in + let mk_replacement c i args = + let res = mkApp(rel_to_fun.(i),Array.map pop (array_get_start args)) in +(* observe (str "replacing " ++ pr_lconstr c ++ str " by " ++ pr_lconstr res); *) + res + in + let rec has_dummy_var t = + fold_constr + (fun b t -> b || (eq_constr t dummy_var) || (has_dummy_var t)) + false + t + in + let rec compute_new_princ_type remove env pre_princ : types*(constr list) = + let (new_princ_type,_) as res = + match kind_of_term pre_princ with + | Rel n -> + begin + try match Environ.lookup_rel n env with + | _,_,t when is_dom t -> raise Toberemoved + | _ -> pre_princ,[] with Not_found -> assert false + end + | Prod(x,t,b) -> + compute_new_princ_type_for_binder remove mkProd env x t b + | Lambda(x,t,b) -> + compute_new_princ_type_for_binder remove mkLambda env x t b + | Ind _ | Construct _ when is_dom pre_princ -> raise Toberemoved + | App(f,args) when is_dom f -> + let var_to_be_removed = destRel (array_last args) in + let num = get_fun_num f in + raise (Toberemoved_with_rel (var_to_be_removed,mk_replacement pre_princ num args)) + | App(f,args) -> + let is_pte = + match kind_of_term f with + | Rel n -> + is_pte (Environ.lookup_rel n env) + | _ -> false + in + let args = + if is_pte && remove + then array_get_start args + else args + in + let new_args,binders_to_remove = + Array.fold_right (compute_new_princ_type_with_acc remove env) + args + ([],[]) + in + let new_f,binders_to_remove_from_f = compute_new_princ_type remove env f in + applist(new_f, new_args), + list_union_eq eq_constr binders_to_remove_from_f binders_to_remove + | LetIn(x,v,t,b) -> + compute_new_princ_type_for_letin remove env x v t b + | _ -> pre_princ,[] + in +(* observennl ( *) +(* match kind_of_term pre_princ with *) +(* | Prod _ -> *) +(* str "compute_new_princ_type for "++ *) +(* pr_lconstr_env env pre_princ ++ *) +(* str" is "++ *) +(* pr_lconstr_env env new_princ_type ++ fnl () *) +(* | _ -> str "" *) +(* ); *) + res + + and compute_new_princ_type_for_binder remove bind_fun env x t b = + begin + try + let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in + let new_x : name = get_name (ids_of_context env) x in + let new_env = Environ.push_rel (x,None,t) env in + let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in + if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b + then (pop new_b),filter_map (eq_constr (mkRel 1)) pop binders_to_remove_from_b + else + ( + bind_fun(new_x,new_t,new_b), + list_union_eq + eq_constr + binders_to_remove_from_t + (List.map pop binders_to_remove_from_b) + ) + + with + | Toberemoved -> +(* msgnl (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) + let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b) in + new_b, List.map pop binders_to_remove_from_b + | Toberemoved_with_rel (n,c) -> +(* msgnl (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) + let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b) in + new_b, list_add_set_eq eq_constr (mkRel n) (List.map pop binders_to_remove_from_b) + end + and compute_new_princ_type_for_letin remove env x v t b = + begin + try + let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in + let new_v,binders_to_remove_from_v = compute_new_princ_type remove env v in + let new_x : name = get_name (ids_of_context env) x in + let new_env = Environ.push_rel (x,Some v,t) env in + let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in + if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b + then (pop new_b),filter_map (eq_constr (mkRel 1)) pop binders_to_remove_from_b + else + ( + mkLetIn(new_x,new_v,new_t,new_b), + list_union_eq + eq_constr + (list_union_eq eq_constr binders_to_remove_from_t binders_to_remove_from_v) + (List.map pop binders_to_remove_from_b) + ) + + with + | Toberemoved -> +(* msgnl (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) + let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b) in + new_b, List.map pop binders_to_remove_from_b + | Toberemoved_with_rel (n,c) -> +(* msgnl (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) + let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b) in + new_b, list_add_set_eq eq_constr (mkRel n) (List.map pop binders_to_remove_from_b) + end + and compute_new_princ_type_with_acc remove env e (c_acc,to_remove_acc) = + let new_e,to_remove_from_e = compute_new_princ_type remove env e + in + new_e::c_acc,list_union_eq eq_constr to_remove_from_e to_remove_acc + in +(* observe (str "Computing new principe from " ++ pr_lconstr_env env_with_params_and_predicates pre_princ); *) + let pre_res,_ = + compute_new_princ_type princ_type_info.indarg_in_concl env_with_params_and_predicates pre_princ in + it_mkProd_or_LetIn + ~init:(it_mkProd_or_LetIn ~init:pre_res new_predicates) + princ_type_info.params + + + +let change_property_sort toSort princ princName = + let princ_info = compute_elim_sig princ in + let change_sort_in_predicate (x,v,t) = + (x,None, + let args,_ = decompose_prod t in + compose_prod args (mkSort toSort) + ) + in + let princName_as_constr = Tacinterp.constr_of_id (Global.env ()) princName in + let init = + let nargs = (princ_info.nparams + (List.length princ_info.predicates)) in + mkApp(princName_as_constr, + Array.init nargs + (fun i -> mkRel (nargs - i ))) + in + it_mkLambda_or_LetIn + ~init: + (it_mkLambda_or_LetIn ~init + (List.map change_sort_in_predicate princ_info.predicates) + ) + princ_info.params + + +let pp_dur time time' = + str (string_of_float (System.time_difference time time')) + +(* End of things to be removed latter : just here to compare + saving proof with and without normalizing the proof +*) + +let qed () = Command.save_named true +let defined () = Command.save_named false +let generate_functional_principle + interactive_proof + old_princ_type sorts new_princ_name funs i proof_tac + = + let f = funs.(i) in + let type_sort = Termops.new_sort_in_family InType in + let new_sorts = + match sorts with + | None -> Array.make (Array.length funs) (type_sort) + | Some a -> a + in + (* First we get the type of the old graph principle *) + let mutr_nparams = (compute_elim_sig old_princ_type).nparams in + (* First we get the type of the old graph principle *) + let new_principle_type = + compute_new_princ_type_from_rel + (Array.map mkConst funs) + new_sorts + old_princ_type + in +(* observe (str "new_principle_type : " ++ pr_lconstr new_principle_type); *) + let base_new_princ_name,new_princ_name = + match new_princ_name with + | Some (id) -> id,id + | None -> + let id_of_f = id_of_label (con_label f) in + id_of_f,Indrec.make_elimination_ident id_of_f (family_of_sort type_sort) + in + let names = ref [new_princ_name] in + let hook _ _ = + if sorts = None + then +(* let id_of_f = id_of_label (con_label f) in *) + let register_with_sort fam_sort = + let s = Termops.new_sort_in_family fam_sort in + let name = Indrec.make_elimination_ident base_new_princ_name fam_sort in + let value = + change_property_sort s new_principle_type new_princ_name + in +(* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *) + let ce = + { const_entry_body = value; + const_entry_type = None; + const_entry_opaque = false; + const_entry_boxed = Options.boxed_definitions() + } + in + ignore( + Declare.declare_constant + name + (Entries.DefinitionEntry ce, + Decl_kinds.IsDefinition (Decl_kinds.Scheme) + ) + ); + names := name :: !names + in + register_with_sort InProp; + register_with_sort InSet + in + begin + Command.start_proof + new_princ_name + (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem)) + new_principle_type + hook + ; + try + let _tim1 = System.get_time () in + Pfedit.by (proof_tac (Array.map mkConst funs) mutr_nparams); + let _tim2 = System.get_time () in +(* begin *) +(* let dur1 = System.time_difference tim1 tim2 in *) +(* Pp.msgnl (str ("Time to compute proof: ") ++ str (string_of_float dur1)); *) +(* end; *) + let do_save = not (do_observe ()) && not interactive_proof in + let _ = + try +(* Vernacentries.show_script (); *) + Options.silently defined (); + let _dur2 = System.time_difference _tim2 (System.get_time ()) in +(* Pp.msgnl (str ("Time to check proof: ") ++ str (string_of_float dur2)); *) + Options.if_verbose + (fun () -> + Pp.msgnl ( + prlist_with_sep + (fun () -> str" is defined " ++ fnl ()) + Ppconstr.pr_id + (List.rev !names) ++ str" is defined " + ) + ) + () + with e when do_save -> + msg_warning + ( + Cerrors.explain_exn e + ); + if not (do_observe ()) + then begin Vernacentries.interp (Vernacexpr.VernacAbort None);raise e end + in + () + +(* let tim3 = Sys.time () in *) +(* Pp.msgnl (str ("Time to save proof: ") ++ str (string_of_float (tim3 -. tim2))); *) + + with + | e -> + msg_warning + ( + Cerrors.explain_exn e + ); + if not ( do_observe ()) + then begin Vernacentries.interp (Vernacexpr.VernacAbort None);raise e end + end + + + + +exception Not_Rec + +let get_funs_constant mp dp = + let rec get_funs_constant const e : (Names.constant*int) array = + match kind_of_term (snd (decompose_lam e)) with + | Fix((_,(na,_,_))) -> + Array.mapi + (fun i na -> + match na with + | Name id -> + let const = make_con mp dp (label_of_id id) in + const,i + | Anonymous -> + anomaly "Anonymous fix" + ) + na + | _ -> [|const,0|] + in + function const -> + let find_constant_body const = + match (Global.lookup_constant const ).const_body with + | Some b -> + let body = force b in + let body = Tacred.cbv_norm_flags + (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]) + (Global.env ()) + (Evd.empty) + body + in + body + | None -> error ( "Cannot define a principle over an axiom ") + in + let f = find_constant_body const in + let l_const = get_funs_constant const f in + (* + We need to check that all the functions found are in the same block + to prevent Reset stange thing + *) + let l_bodies = List.map find_constant_body (Array.to_list (Array.map fst l_const)) in + let l_params,l_fixes = List.split (List.map decompose_lam l_bodies) in + (* all the paremeter must be equal*) + let _check_params = + let first_params = List.hd l_params in + List.iter + (fun params -> + if not ((=) first_params params) + then error "Not a mutal recursive block" + ) + l_params + in + (* The bodies has to be very similar *) + let _check_bodies = + try + let extract_info is_first body = + match kind_of_term body with + | Fix((idxs,_),(na,ta,ca)) -> (idxs,na,ta,ca) + | _ -> + if is_first && (List.length l_bodies = 1) + then raise Not_Rec + else error "Not a mutal recursive block" + in + let first_infos = extract_info true (List.hd l_bodies) in + let check body = (* Hope this is correct *) + if not (first_infos = (extract_info false body)) + then error "Not a mutal recursive block" + in + List.iter check l_bodies + with Not_Rec -> () + in + l_const + +exception No_graph_found + +let make_scheme fas = + let env = Global.env () + and sigma = Evd.empty in + let id_to_constr id = + Tacinterp.constr_of_id env id + in + let funs = + List.map + (fun (_,f,_) -> + try id_to_constr f + with Not_found -> + Util.error ("Cannot find "^ string_of_id f) + ) + fas + in + let first_fun = destConst (List.hd funs) in + let funs_mp,funs_dp,first_fun_id = Names.repr_con first_fun in + let first_fun_rel_id = mk_rel_id (id_of_label first_fun_id) in + let first_fun_kn = + try + (* Fixme: take into account funs_mp and funs_dp *) + fst (destInd (id_to_constr first_fun_rel_id)) + with Not_found -> raise No_graph_found + in + let this_block_funs_indexes = get_funs_constant funs_mp funs_dp first_fun in + let this_block_funs = Array.map fst this_block_funs_indexes in + let prop_sort = InProp in + let funs_indexes = + let this_block_funs_indexes = Array.to_list this_block_funs_indexes in + List.map + (function const -> List.assoc (destConst const) this_block_funs_indexes) + funs + in + let ind_list = + List.map + (fun (idx) -> + let ind = first_fun_kn,idx in + let (mib,mip) = Global.lookup_inductive ind in + ind,mib,mip,true,prop_sort + ) + funs_indexes + in + let l_schemes = List.map (Typing.type_of env sigma ) (Indrec.build_mutual_indrec env sigma ind_list) in + let i = ref (-1) in + let sorts = + List.rev_map (fun (_,_,x) -> + Termops.new_sort_in_family (Pretyping.interp_elimination_sort x) + ) + fas + in + let princ_names = List.map (fun (x,_,_) -> x) fas in + let _ = List.map2 + (fun princ_name scheme_type -> + incr i; +(* observe (str "Generating " ++ Ppconstr.pr_id princ_name ++str " with " ++ *) +(* pr_lconstr scheme_type ++ str " and " ++ (fun a -> prlist_with_sep spc (fun c -> pr_lconstr (mkConst c)) (Array.to_list a)) this_block_funs *) +(* ); *) + generate_functional_principle + false + scheme_type + (Some (Array.of_list sorts)) + (Some princ_name) + this_block_funs + !i + (prove_princ_for_struct false !i (Array.of_list (List.map destConst funs))) + ) + princ_names + l_schemes + in + () + +let make_case_scheme fa = + let env = Global.env () + and sigma = Evd.empty in + let id_to_constr id = + Tacinterp.constr_of_id env id + in + let funs = (fun (_,f,_) -> id_to_constr f) fa in + let first_fun = destConst funs in + let funs_mp,funs_dp,first_fun_id = Names.repr_con first_fun in + let first_fun_rel_id = mk_rel_id (id_of_label first_fun_id) in + let first_fun_kn = + (* Fixme: take into accour funs_mp and funs_dp *) + fst (destInd (id_to_constr first_fun_rel_id)) + in + let this_block_funs_indexes = get_funs_constant funs_mp funs_dp first_fun in + let this_block_funs = Array.map fst this_block_funs_indexes in + let prop_sort = InProp in + let funs_indexes = + let this_block_funs_indexes = Array.to_list this_block_funs_indexes in + List.assoc (destConst funs) this_block_funs_indexes + in + let ind_fun = + let ind = first_fun_kn,funs_indexes in + ind,prop_sort + in + let scheme_type = (Typing.type_of env sigma ) ((fun (ind,sf) -> Indrec.make_case_gen env sigma ind sf) ind_fun) in + let sorts = + (fun (_,_,x) -> + Termops.new_sort_in_family (Pretyping.interp_elimination_sort x) + ) + fa + in + let princ_name = (fun (x,_,_) -> x) fa in + let _ = +(* observe (str "Generating " ++ Ppconstr.pr_id princ_name ++str " with " ++ *) +(* pr_lconstr scheme_type ++ str " and " ++ (fun a -> prlist_with_sep spc (fun c -> pr_lconstr (mkConst c)) (Array.to_list a)) this_block_funs *) +(* ); *) + generate_functional_principle + false + scheme_type + (Some ([|sorts|])) + (Some princ_name) + this_block_funs + 0 + (prove_princ_for_struct false 0 [|destConst funs|]) + in + () diff --git a/contrib/funind/functional_principles_types.mli b/contrib/funind/functional_principles_types.mli new file mode 100644 index 00000000..8b4faaf4 --- /dev/null +++ b/contrib/funind/functional_principles_types.mli @@ -0,0 +1,31 @@ +open Names +open Term +val generate_functional_principle : + (* do we accept interactive proving *) + bool -> + (* induction principle on rel *) + types -> + (* *) + sorts array option -> + (* Name of the new principle *) + (identifier) option -> + (* the compute functions to use *) + constant array -> + (* We prove the nth- principle *) + int -> + (* The tactic to use to make the proof w.r + the number of params + *) + (constr array -> int -> Tacmach.tactic) -> + unit + + + +val compute_new_princ_type_from_rel : constr array -> sorts array -> + types -> types + + +exception No_graph_found + +val make_scheme : (identifier*identifier*Rawterm.rawsort) list -> unit +val make_case_scheme : (identifier*identifier*Rawterm.rawsort) -> unit diff --git a/contrib/funind/indfun.ml b/contrib/funind/indfun.ml index 2fcdd3a7..f6d554a8 100644 --- a/contrib/funind/indfun.ml +++ b/contrib/funind/indfun.ml @@ -1,7 +1,6 @@ open Util open Names open Term - open Pp open Indfun_common open Libnames @@ -29,6 +28,11 @@ let interp_casted_constr_with_implicits sigma env impls c = Constrintern.intern_gen false sigma env ~impls:([],impls) ~allow_soapp:false ~ltacvars:([],[]) c + +(* + Construct a fixpoint as a Rawterm + and not as a constr +*) let build_newrecursive (lnameargsardef) = let env0 = Global.env() @@ -71,31 +75,43 @@ let compute_annot (name,annot,args,types,body) = | None -> if List.length names > 1 then user_err_loc - (dummy_loc,"GenFixpoint", + (dummy_loc,"Function", Pp.str "the recursive argument needs to be specified"); let new_annot = (id_of_name (List.hd names)) in (name,Struct new_annot,args,types,body) | Some r -> (name,r,args,types,body) - +(* Checks whether or not the mutual bloc is recursive *) let rec is_rec names = let names = List.fold_right Idset.add names Idset.empty in - let check_id id = Idset.mem id names in - let rec lookup = function - | RVar(_,id) -> check_id id + let check_id id names = Idset.mem id names in + let rec lookup names = function + | RVar(_,id) -> check_id id names | RRef _ | REvar _ | RPatVar _ | RSort _ | RHole _ | RDynamic _ -> false - | RCast(_,b,_,_) -> lookup b - | RRec _ -> assert false - | RIf _ -> failwith "Rif not implemented" - | RLetIn(_,_,t,b) | RLambda(_,_,t,b) | RProd(_,_,t,b) | RLetTuple(_,_,_,t,b) -> - lookup t || lookup b - | RApp(_,f,args) -> List.exists lookup (f::args) + | RCast(_,b,_,_) -> lookup names b + | RRec _ -> error "RRec not handled" + | RIf(_,b,_,lhs,rhs) -> + (lookup names b) || (lookup names lhs) || (lookup names rhs) + | RLetIn(_,na,t,b) | RLambda(_,na,t,b) | RProd(_,na,t,b) -> + lookup names t || lookup (Nameops.name_fold Idset.remove na names) b + | RLetTuple(_,nal,_,t,b) -> lookup names t || + lookup + (List.fold_left + (fun acc na -> Nameops.name_fold Idset.remove na acc) + names + nal + ) + b + | RApp(_,f,args) -> List.exists (lookup names) (f::args) | RCases(_,_,el,brl) -> - List.exists (fun (e,_) -> lookup e) el || - List.exists (fun (_,_,_,ret)-> lookup ret) brl + List.exists (fun (e,_) -> lookup names e) el || + List.exists (lookup_br names) brl + and lookup_br names (_,idl,_,rt) = + let new_names = List.fold_right Idset.remove idl names in + lookup new_names rt in - lookup + lookup names let prepare_body (name,annot,args,types,body) rt = let n = (Topconstr.local_binders_length args) in @@ -139,7 +155,7 @@ let generate_principle let princ_type = (Global.lookup_constant princ).Declarations.const_type in - New_arg_principle.generate_functional_principle + Functional_principles_types.generate_functional_principle interactive_proof princ_type None @@ -171,12 +187,12 @@ let register_struct is_rec fixpoint_exprl = | _ -> Command.build_recursive fixpoint_exprl (Options.boxed_definitions()) - -let generate_correction_proof_wf tcc_lemma_ref - is_mes f_ref eq_ref rec_arg_num rec_arg_type nb_args relation +let generate_correction_proof_wf f_ref tcc_lemma_ref + is_mes functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation (_: int) (_:Names.constant array) (_:Term.constr array) (_:int) : Tacmach.tactic = - Recdef.prove_principle tcc_lemma_ref - is_mes f_ref eq_ref rec_arg_num rec_arg_type nb_args relation + Functional_principles_proofs.prove_principle_for_gen + (f_ref,functional_ref,eq_ref) + tcc_lemma_ref is_mes rec_arg_num rec_arg_type relation let register_wf ?(is_mes=false) fname wf_rel_expr wf_arg args ret_type body @@ -214,11 +230,11 @@ let register_wf ?(is_mes=false) fname wf_rel_expr wf_arg args ret_type body [(f_app_args,None);(body,None)]) in let eq = Command.generalize_constr_expr unbounded_eq args in - let hook tcc_lemma_ref f_ref eq_ref rec_arg_num rec_arg_type nb_args relation = + let hook f_ref tcc_lemma_ref functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation = try pre_hook - (generate_correction_proof_wf tcc_lemma_ref is_mes - f_ref eq_ref rec_arg_num rec_arg_type nb_args relation + (generate_correction_proof_wf f_ref tcc_lemma_ref is_mes + functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation ); Command.save_named true with e -> @@ -317,7 +333,7 @@ let do_generate_principle register_built interactive_proof fixpoint_exprl = (Topconstr.names_of_local_assums args) in let annot = - try Util.list_index (Name id) names - 1, Topconstr.CStructRec + try Some (Util.list_index (Name id) names - 1), Topconstr.CStructRec with Not_found -> raise (UserError("",str "Cannot find argument " ++ Ppconstr.pr_id id)) in (name,annot,args,types,body),(None:Vernacexpr.decl_notation) @@ -325,10 +341,10 @@ let do_generate_principle register_built interactive_proof fixpoint_exprl = let names = (Topconstr.names_of_local_assums args) in if is_one_rec recdef && List.length names > 1 then Util.user_err_loc - (Util.dummy_loc,"GenFixpoint", - Pp.str "the recursive argument needs to be specified") + (Util.dummy_loc,"Function", + Pp.str "the recursive argument needs to be specified in Function") else - (name,(0, Topconstr.CStructRec),args,types,body),(None:Vernacexpr.decl_notation) + (name,(Some 0, Topconstr.CStructRec),args,types,body),(None:Vernacexpr.decl_notation) | (_,Some (Wf _),_,_,_),_ | (_,Some (Mes _),_,_,_),_-> error ("Cannot use mutual definition with well-founded recursion") @@ -347,12 +363,69 @@ let do_generate_principle register_built interactive_proof fixpoint_exprl = recdefs interactive_proof true - (New_arg_principle.prove_princ_for_struct interactive_proof); + (Functional_principles_proofs.prove_princ_for_struct interactive_proof); true in () +open Topconstr +let rec add_args id new_args b = + match b with + | CRef r -> + begin match r with + | Libnames.Ident(loc,fname) when fname = id -> + CAppExpl(dummy_loc,(None,r),new_args) + | _ -> b + end + | CFix _ | CCoFix _ -> anomaly "add_args : todo" + | CArrow(loc,b1,b2) -> + CArrow(loc,add_args id new_args b1, add_args id new_args b2) + | CProdN(loc,nal,b1) -> + CProdN(loc,List.map (fun (nal,b2) -> (nal,add_args id new_args b2)) nal, add_args id new_args b1) + | CLambdaN(loc,nal,b1) -> + CLambdaN(loc,List.map (fun (nal,b2) -> (nal,add_args id new_args b2)) nal, add_args id new_args b1) + | CLetIn(loc,na,b1,b2) -> + CLetIn(loc,na,add_args id new_args b1,add_args id new_args b2) + | CAppExpl(loc,(pf,r),exprl) -> + begin + match r with + | Libnames.Ident(loc,fname) when fname = id -> + CAppExpl(loc,(pf,r),new_args@(List.map (add_args id new_args) exprl)) + | _ -> CAppExpl(loc,(pf,r),List.map (add_args id new_args) exprl) + end + | CApp(loc,(pf,b),bl) -> + CApp(loc,(pf,add_args id new_args b), List.map (fun (e,o) -> add_args id new_args e,o) bl) + | CCases(loc,b_option,cel,cal) -> + CCases(loc,Util.option_map (add_args id new_args) b_option, + List.map (fun (b,(na,b_option)) -> add_args id new_args b,(na,Util.option_map (add_args id new_args) b_option)) cel, + List.map (fun (loc,cpl,e) -> (loc,cpl,add_args id new_args e)) cal + ) + | CLetTuple(loc,nal,(na,b_option),b1,b2) -> + CLetTuple(loc,nal,(na,Util.option_map (add_args id new_args) b_option), + add_args id new_args b1, + add_args id new_args b2 + ) + + | CIf(loc,b1,(na,b_option),b2,b3) -> + CIf(loc,add_args id new_args b1, + (na,Util.option_map (add_args id new_args) b_option), + add_args id new_args b2, + add_args id new_args b3 + ) + | CHole _ -> b + | CPatVar _ -> b + | CEvar _ -> b + | CSort _ -> b + | CCast(loc,b1,ck,b2) -> + CCast(loc,add_args id new_args b1,ck,add_args id new_args b2) + | CNotation _ -> anomaly "add_args : CNotation" + | CPrim _ -> b + | CDelimiters _ -> anomaly "add_args : CDelimiters" + | CDynamic _ -> anomaly "add_args : CDynamic" + + + let make_graph (id:identifier) = let c_body = try @@ -367,8 +440,6 @@ let make_graph (id:identifier) = | Some b -> let env = Global.env () in let body = (force b) in - - let extern_body,extern_type = let old_implicit_args = Impargs.is_implicit_args () and old_strict_implicit_args = Impargs.is_strict_implicit_args () @@ -400,68 +471,102 @@ let make_graph (id:identifier) = Options.raw_print := old_rawprint; raise e in + let rec get_args b t : Topconstr.local_binder list * + Topconstr.constr_expr * Topconstr.constr_expr = +(* Pp.msgnl (str "body: " ++Ppconstr.pr_lconstr_expr b); *) +(* Pp.msgnl (str "type: " ++ Ppconstr.pr_lconstr_expr t); *) +(* Pp.msgnl (fnl ()); *) + match b with + | Topconstr.CLambdaN (loc, (nal_ta), b') -> + begin + let n = + (List.fold_left (fun n (nal,_) -> + n+List.length nal) 0 nal_ta ) + in + let rec chop_n_arrow n t = + if n > 0 + then + match t with + | Topconstr.CArrow(_,_,t) -> chop_n_arrow (n-1) t + | Topconstr.CProdN(_,nal_ta',t') -> + let n' = + List.fold_left + (fun n (nal,t'') -> + n+List.length nal) n nal_ta' + in + assert (n'<= n); + chop_n_arrow (n - n') t' + | _ -> anomaly "Not enough products" + else t + in + let nal_tas,b'',t'' = get_args b' (chop_n_arrow n t) in + (List.map (fun (nal,ta) -> (Topconstr.LocalRawAssum (nal,ta))) nal_ta)@nal_tas, b'',t'' + end + | _ -> [],b,t + in + let (nal_tas,b,t) = get_args extern_body extern_type in let expr_list = - match extern_body with + match b with | Topconstr.CFix(loc,l_id,fixexprl) -> - let l = - List.map - (fun (id,(n,recexp),bl,t,b) -> - let nal = - List.flatten - (List.map - (function - | Topconstr.LocalRawDef (na,_)-> [] - | Topconstr.LocalRawAssum (nal,_) -> nal - ) - bl - ) - in - let rec_id = - match List.nth nal n with |(_,Name id) -> id | _ -> anomaly "" - in - (id, Some (Struct rec_id),bl,t,b) - ) - fixexprl - in - l - | _ -> - let rec get_args b t : Topconstr.local_binder list * - Topconstr.constr_expr * Topconstr.constr_expr = -(* Pp.msgnl (str "body: " ++Ppconstr.pr_lconstr_expr b); *) -(* Pp.msgnl (str "type: " ++ Ppconstr.pr_lconstr_expr t); *) -(* Pp.msgnl (fnl ()); *) - match b with - | Topconstr.CLambdaN (loc, (nal_ta), b') -> - begin - let n = - (List.fold_left (fun n (nal,_) -> - n+List.length nal) 0 nal_ta ) - in - let rec chop_n_arrow n t = - if n > 0 - then - match t with - | Topconstr.CArrow(_,_,t) -> chop_n_arrow (n-1) t - | Topconstr.CProdN(_,nal_ta',t') -> - let n' = - List.fold_left - (fun n (nal,t'') -> - n+List.length nal) n nal_ta' - in - assert (n'<= n); - chop_n_arrow (n - n') t' - | _ -> anomaly "Not enough products" - else t - in - let nal_tas,b'',t'' = get_args b' (chop_n_arrow n t) in - (List.map (fun (nal,ta) -> (Topconstr.LocalRawAssum (nal,ta))) nal_ta)@nal_tas, b'',t'' - end - | _ -> [],b,t + let l = + List.map + (fun (id,(n,recexp),bl,t,b) -> +(* let nal = *) +(* List.flatten *) +(* (List.map *) +(* (function *) +(* | Topconstr.LocalRawDef (na,_)-> [] *) +(* | Topconstr.LocalRawAssum (nal,_) -> nal *) +(* ) *) +(* (nal_tas@bl) *) +(* ) *) +(* in *) + let bl' = + List.flatten + (List.map + (function + | Topconstr.LocalRawDef (na,_)-> [] + | Topconstr.LocalRawAssum (nal,_) -> nal + ) + bl + ) + in + let rec_id = + match List.nth bl' (out_some n) with |(_,Name id) -> id | _ -> anomaly "" + in + let new_args = + List.flatten + (List.map + (function + | Topconstr.LocalRawDef (na,_)-> [] + | Topconstr.LocalRawAssum (nal,_) -> List.map (fun (loc,n) -> CRef(Libnames.Ident(loc, Nameops.out_name n))) nal + ) + nal_tas + ) + in + let b' = add_args id new_args b in + (id, Some (Struct rec_id),nal_tas@bl,t,b') + ) + fixexprl in - let nal_tas,b,t = get_args extern_body extern_type in + l + | _ -> [(id,None,nal_tas,t,b)] - in +(* List.iter (fun (id,rec_arg,bl,t,b) -> *) +(* Pp.msgnl *) +(* (Ppconstr.pr_id id ++ *) +(* Ppconstr.pr_binders bl ++ *) +(* begin match rec_arg with *) +(* | Some (Struct id) -> str " { struct " ++ Ppconstr.pr_id id ++ str " }" *) +(* | _ -> (mt ()) *) +(* end ++ *) +(* str " : " ++ Ppconstr.pr_lconstr_expr t ++ *) +(* str " := " ++ *) +(* Ppconstr.pr_lconstr_expr b *) +(* ) *) +(* ) *) +(* expr_list; *) do_generate_principle false false expr_list (* let make_graph _ = assert false *) diff --git a/contrib/funind/indfun_main.ml4 b/contrib/funind/indfun_main.ml4 index 7b3d8cbd..61f26d30 100644 --- a/contrib/funind/indfun_main.ml4 +++ b/contrib/funind/indfun_main.ml4 @@ -13,37 +13,72 @@ open Topconstr open Indfun_common open Indfun open Genarg +open Pcoq -TACTIC EXTEND newfuninv - [ "functional" "inversion" ident(hyp) ident(fname) ] -> - [ - Invfun.invfun hyp fname - ] -END +let pr_binding prc = function + | loc, Rawterm.NamedHyp id, c -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ cut () ++ prc c) + | loc, Rawterm.AnonHyp n, c -> hov 1 (int n ++ str " := " ++ cut () ++ prc c) + +let pr_bindings prc prlc = function + | Rawterm.ImplicitBindings l -> + brk (1,1) ++ str "with" ++ brk (1,1) ++ + Util.prlist_with_sep spc prc l + | Rawterm.ExplicitBindings l -> + brk (1,1) ++ str "with" ++ brk (1,1) ++ + Util.prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l + | Rawterm.NoBindings -> mt () + + +let pr_with_bindings prc prlc (c,bl) = + prc c ++ hv 0 (pr_bindings prc prlc bl) -let pr_fun_ind_using prc _ _ opt_c = - match opt_c with +let pr_fun_ind_using prc prlc _ opt_c = + match opt_c with | None -> mt () - | Some c -> spc () ++ hov 2 (str "using" ++ spc () ++ prc c) + | Some c -> spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings prc prlc c) ARGUMENT EXTEND fun_ind_using - TYPED AS constr_opt + TYPED AS constr_with_bindings_opt PRINTED BY pr_fun_ind_using -| [ "using" constr(c) ] -> [ Some c ] +| [ "using" constr_with_bindings(c) ] -> [ Some c ] | [ ] -> [ None ] END -let pr_intro_as_pat prc _ _ pat = - str "as" ++ spc () ++ pr_intro_pattern pat +TACTIC EXTEND newfuninv + [ "functional" "inversion" ident(hyp) ident(fname) fun_ind_using(princl)] -> + [ + fun g -> + let fconst = const_of_id fname in + let princ = + match princl with + | None -> + let f_ind_id = + ( + Indrec.make_elimination_ident + fname + (Tacticals.elimination_sort_of_goal g) + ) + in + let princ = const_of_id f_ind_id in + princ + | Some princ -> destConst (fst princ) + in + Invfun.invfun hyp fconst princ g + ] +END +let pr_intro_as_pat prc _ _ pat = + match pat with + | Some pat -> spc () ++ str "as" ++ spc () ++ pr_intro_pattern pat + | None -> mt () -ARGUMENT EXTEND with_names TYPED AS intro_pattern PRINTED BY pr_intro_as_pat -| [ "as" simple_intropattern(ipat) ] -> [ ipat ] -| [] ->[ IntroAnonymous ] +ARGUMENT EXTEND with_names TYPED AS intro_pattern_opt PRINTED BY pr_intro_as_pat +| [ "as" simple_intropattern(ipat) ] -> [ Some ipat ] +| [] ->[ None ] END @@ -61,16 +96,25 @@ let is_rec scheme_info = let choose_dest_or_ind scheme_info = if is_rec scheme_info then Tactics.new_induct - else - Tactics.new_destruct + else Tactics.new_destruct TACTIC EXTEND newfunind - ["new" "functional" "induction" constr(c) fun_ind_using(princl) with_names(pat)] -> + ["functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] -> [ + let pat = + match pat with + | None -> IntroAnonymous + | Some pat -> pat + in + let c = match cl with + | [] -> assert false + | [c] -> c + | c::cl -> applist(c,cl) + in let f,args = decompose_app c in fun g -> - let princ = + let princ,bindings = match princl with | None -> (* No principle is given let's find the good one *) let fname = @@ -86,7 +130,7 @@ TACTIC EXTEND newfunind (Tacticals.elimination_sort_of_goal g) ) in - mkConst(const_of_id princ_name ) + mkConst(const_of_id princ_name ),Rawterm.NoBindings | Some princ -> princ in let princ_type = Tacmach.pf_type_of g princ in @@ -98,12 +142,46 @@ TACTIC EXTEND newfunind in List.map (fun c -> Tacexpr.ElimOnConstr c) (args@c_list) in - let princ' = Some (princ,Rawterm.NoBindings) in - choose_dest_or_ind + let princ' = Some (princ,bindings) in + let princ_vars = + List.fold_right + (fun a acc -> + try Idset.add (destVar a) acc + with _ -> acc + ) + args + Idset.empty + in + let old_idl = List.fold_right Idset.add (Tacmach.pf_ids_of_hyps g) Idset.empty in + let old_idl = Idset.diff old_idl princ_vars in + let subst_and_reduce g = + let idl = + Util.map_succeed + (fun id -> + if Idset.mem id old_idl then failwith ""; + id + ) + (Tacmach.pf_ids_of_hyps g) + in + let flag = + Rawterm.Cbv + {Rawterm.all_flags + with Rawterm.rDelta = false; + } + in + Tacticals.tclTHEN + (Tacticals.tclMAP (fun id -> Tacticals.tclTRY (Equality.subst [id])) idl ) + (Hiddentac.h_reduce flag Tacticals.allClauses) + g + in + Tacticals.tclTHEN + (choose_dest_or_ind princ_infos args_as_induction_constr princ' - pat g + pat) + subst_and_reduce + g ] END @@ -111,7 +189,7 @@ END VERNAC ARGUMENT EXTEND rec_annotation2 [ "{" "struct" ident(id) "}"] -> [ Struct id ] | [ "{" "wf" constr(r) ident_opt(id) "}" ] -> [ Wf(r,id) ] -| [ "{" "mes" constr(r) ident_opt(id) "}" ] -> [ Mes(r,id) ] +| [ "{" "measure" constr(r) ident_opt(id) "}" ] -> [ Mes(r,id) ] END @@ -130,7 +208,7 @@ VERNAC ARGUMENT EXTEND rec_definition2 let check_one_name () = if List.length names > 1 then Util.user_err_loc - (Util.dummy_loc,"GenFixpoint", + (Util.dummy_loc,"Function", Pp.str "the recursive argument needs to be specified"); in let check_exists_args an = @@ -138,7 +216,7 @@ VERNAC ARGUMENT EXTEND rec_definition2 let id = match an with Struct id -> id | Wf(_,Some id) -> id | Mes(_,Some id) -> id | Wf(_,None) | Mes(_,None) -> failwith "check_exists_args" in (try ignore(Util.list_index (Name id) names - 1); annot with Not_found -> Util.user_err_loc - (Util.dummy_loc,"GenFixpoint", + (Util.dummy_loc,"Function", Pp.str "No argument named " ++ Nameops.pr_id id) ) with Failure "check_exists_args" -> check_one_name ();annot @@ -160,16 +238,11 @@ VERNAC ARGUMENT EXTEND rec_definitions2 END -VERNAC COMMAND EXTEND GenFixpoint - ["GenFixpoint" rec_definitions2(recsl)] -> +VERNAC COMMAND EXTEND Function + ["Function" rec_definitions2(recsl)] -> [ do_generate_principle false recsl] END -VERNAC COMMAND EXTEND IGenFixpoint - ["IGenFixpoint" rec_definitions2(recsl)] -> - [ do_generate_principle true recsl] -END - VERNAC ARGUMENT EXTEND fun_scheme_arg | [ ident(princ_name) ":=" "Induction" "for" ident(fun_name) "Sort" sort(s) ] -> [ (princ_name,fun_name,s) ] @@ -181,17 +254,28 @@ VERNAC ARGUMENT EXTEND fun_scheme_args END VERNAC COMMAND EXTEND NewFunctionalScheme - ["New" "Functional" "Scheme" fun_scheme_args(fas) ] -> + ["Functional" "Scheme" fun_scheme_args(fas) ] -> [ - New_arg_principle.make_scheme fas + try + Functional_principles_types.make_scheme fas + with Functional_principles_types.No_graph_found -> + match fas with + | (_,fun_name,_)::_ -> + begin + make_graph fun_name; + try Functional_principles_types.make_scheme fas + with Functional_principles_types.No_graph_found -> + Util.error ("Cannot generate induction principle(s)") + end + | _ -> assert false (* we can only have non empty list *) ] END VERNAC COMMAND EXTEND NewFunctionalCase - ["New" "Functional" "Case" fun_scheme_arg(fas) ] -> + ["Functional" "Case" fun_scheme_arg(fas) ] -> [ - New_arg_principle.make_case_scheme fas + Functional_principles_types.make_case_scheme fas ] END diff --git a/contrib/funind/invfun.ml b/contrib/funind/invfun.ml index 1f711297..2e5616f0 100644 --- a/contrib/funind/invfun.ml +++ b/contrib/funind/invfun.ml @@ -88,18 +88,9 @@ let gen_fargs fargs : tactic = g -let invfun (hypname:identifier) (fid:identifier) : tactic= +let invfun (hypname:identifier) fname princ : tactic= fun g -> let nprod_goal = nb_prod (pf_concl g) in - let f_ind_id = - ( - Indrec.make_elimination_ident - fid - (Tacticals.elimination_sort_of_goal g) - ) - in - let fname = const_of_id fid in - let princ = const_of_id f_ind_id in let princ_info = let princ_type = (try (match (Global.lookup_constant princ) with @@ -114,7 +105,7 @@ let invfun (hypname:identifier) (fid:identifier) : tactic= let frealargs = (snd (array_chop (List.length princ_info.params) fargs)) in let pat_args = - (List.map (fun e -> ([-1],e)) (Array.to_list frealargs)) @ [[],appf] + (List.map (fun e -> ([Rawterm.ArgArg (-1)],e)) (Array.to_list frealargs)) @ [[],appf] in tclTHENSEQ [ diff --git a/contrib/funind/new_arg_principle.ml b/contrib/funind/new_arg_principle.ml deleted file mode 100644 index 8ef23c48..00000000 --- a/contrib/funind/new_arg_principle.ml +++ /dev/null @@ -1,1770 +0,0 @@ -open Printer -open Util -open Term -open Termops -open Names -open Declarations -open Pp -open Entries -open Hiddentac -open Evd -open Tacmach -open Proof_type -open Tacticals -open Tactics -open Indfun_common - - -let msgnl = Pp.msgnl - -let do_observe () = - Tacinterp.get_debug () <> Tactic_debug.DebugOff - - -let observe strm = - if do_observe () - then Pp.msgnl strm - else () - -let observennl strm = - if do_observe () - then begin Pp.msg strm;Pp.pp_flush () end - else () - - - - -let do_observe_tac s tac g = - try let v = tac g in (* msgnl (goal ++ fnl () ++ (str s)++(str " ")++(str "finished")); *) v - with e -> - let goal = begin try (Printer.pr_goal (sig_it g)) with _ -> assert false end in - msgnl (str "observation "++str s++str " raised exception " ++ - Cerrors.explain_exn e ++ str "on goal " ++ goal ); - raise e;; - - -let observe_tac s tac g = - if do_observe () - then do_observe_tac s tac g - else tac g - - -let tclTRYD tac = - if !Options.debug || do_observe () - then (fun g -> try do_observe_tac "" tac g with _ -> tclIDTAC g) - else tac - - -let list_chop ?(msg="") n l = - try - list_chop n l - with Failure (msg') -> - failwith (msg ^ msg') - - -let make_refl_eq type_of_t t = - let refl_equal_term = Lazy.force refl_equal in - mkApp(refl_equal_term,[|type_of_t;t|]) - - -type static_fix_info = - { - idx : int; - name : identifier; - types : types - } - -type static_infos = - { - fixes_ids : identifier list; - ptes_to_fixes : static_fix_info Idmap.t - } - -type 'a dynamic_info = - { - nb_rec_hyps : int; - rec_hyps : identifier list ; - eq_hyps : identifier list; - info : 'a - } - -let finish_proof dynamic_infos g = - observe_tac "finish" - h_assumption - g - - -let refine c = - Tacmach.refine_no_check c - -let thin l = - Tacmach.thin_no_check l - - -let cut_replacing id t tac :tactic= - tclTHENS (cut t) - [ tclTHEN (thin_no_check [id]) (introduction_no_check id); - tac - ] - -let intro_erasing id = tclTHEN (thin [id]) (introduction id) - - - -let rec_hyp_id = id_of_string "rec_hyp" - -let is_trivial_eq t = - match kind_of_term t with - | App(f,[|_;t1;t2|]) when eq_constr f (Lazy.force eq) -> - eq_constr t1 t2 - | _ -> false - - -let rec incompatible_constructor_terms t1 t2 = - let c1,arg1 = decompose_app t1 - and c2,arg2 = decompose_app t2 - in - (not (eq_constr t1 t2)) && - isConstruct c1 && isConstruct c2 && - ( - not (eq_constr c1 c2) || - List.exists2 incompatible_constructor_terms arg1 arg2 - ) - -let is_incompatible_eq t = - match kind_of_term t with - | App(f,[|_;t1;t2|]) when eq_constr f (Lazy.force eq) -> - incompatible_constructor_terms t1 t2 - | _ -> false - -let change_hyp_with_using hyp_id t tac = - fun g -> - let prov_id = pf_get_new_id hyp_id g in - tclTHENLIST - [ - forward (Some tac) (Genarg.IntroIdentifier prov_id) t; - thin [hyp_id]; - h_rename prov_id hyp_id - ] g - -exception TOREMOVE - - -let prove_trivial_eq h_id context (type_of_term,term) = - let nb_intros = List.length context in - tclTHENLIST - [ - tclDO nb_intros intro; (* introducing context *) - (fun g -> - let context_hyps = - fst (list_chop ~msg:"prove_trivial_eq : " nb_intros (pf_ids_of_hyps g)) - in - let context_hyps' = - (mkApp(Lazy.force refl_equal,[|type_of_term;term|])):: - (List.map mkVar context_hyps) - in - let to_refine = applist(mkVar h_id,List.rev context_hyps') in - refine to_refine g - ) - ] - - -let isAppConstruct t = - if isApp t - then isConstruct (fst (destApp t)) - else false - - -let nf_betaoiotazeta = Reductionops.local_strong Reductionops.whd_betaiotazeta - -let remove_useless_rel env sigma hyp_id (context:Sign.rel_context) t end_of_type t1 t2 = - let rel_num = destRel t2 in - - let nb_kept = List.length context - rel_num - and nb_popped = rel_num - 1 - in - - (* We remove the equation *) - let new_end_of_type = pop end_of_type in - - let lt_relnum,ge_relnum = - list_chop - ~msg:("removing useless variable "^(string_of_int rel_num)^" :") - nb_popped - context - in - (* we rebuilt the type of hypothesis after the rel to remove *) - let hyp_type_lt_relnum = - it_mkProd_or_LetIn ~init:new_end_of_type lt_relnum - in - (* we replace Rel 1 by t1 *) - let new_hyp_type_lt_relnum = subst1 t1 hyp_type_lt_relnum in - (* we resplit the type of hyp_type *) - let new_lt_relnum,new_end_of_type = - Sign.decompose_prod_n_assum nb_popped new_hyp_type_lt_relnum - in - (* and rebuilt new context of hyp *) - let new_context = new_lt_relnum@(List.tl ge_relnum) in - let new_typ_of_hyp = - nf_betaoiotazeta (it_mkProd_or_LetIn ~init:new_end_of_type new_context) - in - let prove_simpl_eq = - tclTHENLIST - [ - tclDO (nb_popped + nb_kept) intro; - (fun g' -> - let new_hyps_ids = pf_ids_of_hyps g' in - let popped_ids,others = - list_chop ~msg:"removing useless variable pop :" - nb_popped new_hyps_ids in - let kept_ids,_ = - list_chop ~msg: " removing useless variable kept : " - nb_kept others - in - let rev_to_apply = - (mkApp(Lazy.force refl_equal,[|Typing.type_of env sigma t1;t1|])):: - ((List.map mkVar popped_ids)@ - (t1:: - (List.map mkVar kept_ids))) - in - let to_refine = applist(mkVar hyp_id,List.rev rev_to_apply) in - refine to_refine g' - ) - ] - in - let simpl_eq_tac = change_hyp_with_using hyp_id new_typ_of_hyp - (observe_tac "prove_simpl_eq" prove_simpl_eq) - in - let new_end_of_type = nf_betaoiotazeta new_end_of_type in - (new_context,new_end_of_type,simpl_eq_tac),new_typ_of_hyp, - (str " removing useless variable " ++ str (string_of_int rel_num) ) - - -let decompose_eq env sigma hyp_id (context:Sign.rel_context) t end_of_type t1 t2 = - let c1,args1 = destApp t1 - and c2,args2 = destApp t2 - in - (* This tactic must be used after is_incompatible_eq *) - assert (eq_constr c1 c2); - (* we remove this equation *) - let new_end_of_type = pop end_of_type in - let new_eqs = - array_map2_i - (fun i arg1 arg2 -> - let new_eq = - let type_of_arg = Typing.type_of env sigma arg1 in - mkApp(Lazy.force eq,[|type_of_arg;arg1;arg2|]) - in - Anonymous,None,lift i new_eq - ) - args1 - args2 - in - let nb_new_eqs = Array.length new_eqs in - (* we add the new equation *) - let new_end_of_type = lift nb_new_eqs new_end_of_type in - let local_context = - List.rev (Array.to_list new_eqs) in - let new_end_of_type = it_mkProd_or_LetIn ~init:new_end_of_type local_context in - let new_typ_of_hyp = - nf_betaoiotazeta (it_mkProd_or_LetIn ~init:new_end_of_type context) - in - let prove_pattern_simplification = - let context_length = List.length context in - tclTHENLIST - [ - tclDO (context_length + nb_new_eqs) intro ; - (fun g -> - let new_eqs,others = - list_chop ~msg:"simplifying pattern : new_eqs" nb_new_eqs (pf_hyps g) - in - let context_hyps,_ = list_chop ~msg:"simplifying pattern : context_hyps" - context_length others in - let eq_args = - List.rev_map - (fun (_,_, eq) -> let _,args = destApp eq in args.(1),args.(2)) - new_eqs - in - let lhs_args,rhs_args = List.split eq_args in - let lhs_eq = applist(c1,lhs_args) - and rhs_eq = applist(c1,rhs_args) - in - let type_of_eq = pf_type_of g lhs_eq in - let eq_to_assert = - mkApp(Lazy.force eq,[|type_of_eq;lhs_eq;rhs_eq|]) - in - let prove_new_eq = - tclTHENLIST [ - tclMAP - (fun (id,_,_) -> - (* The tclTRY here is used when trying to rewrite - on Set - eg (@cons A x l)=(@cons A x' l') generates 3 eqs - A=A -> x=x' -> l = l' ... - - *) - tclTRY (Equality.rewriteLR (mkVar id)) - ) - new_eqs; - reflexivity - ] - in - let new_eq_id = pf_get_new_id (id_of_string "H") g in - let create_new_eq = - forward - (Some (observe_tac "prove_new_eq" (prove_new_eq))) - (Genarg.IntroIdentifier new_eq_id) - eq_to_assert - in - let to_refine = - applist ( - mkVar hyp_id, - List.rev ((mkVar new_eq_id):: - (List.map (fun (id,_,_) -> mkVar id) context_hyps))) - in - tclTHEN - (observe_tac "create_new_eq" create_new_eq ) - (observe_tac "refine in decompose_eq " (refine to_refine)) - g - ) - ] - in - let simpl_eq_tac = - change_hyp_with_using hyp_id new_typ_of_hyp (observe_tac "prove_pattern_simplification " prove_pattern_simplification) - in - (context,nf_betaoiotazeta new_end_of_type,simpl_eq_tac),new_typ_of_hyp, - str "simplifying an equation " - -let change_eq env sigma hyp_id (context:Sign.rel_context) x t end_of_type = - if not (noccurn 1 end_of_type) - then (* if end_of_type depends on this term we don't touch it *) - begin - observe (str "Not treating " ++ pr_lconstr t ); - failwith "NoChange"; - end; - let res,new_typ_of_hyp,msg = - if not (isApp t) then failwith "NoChange"; - let f,args = destApp t in - if not (eq_constr f (Lazy.force eq)) then failwith "NoChange"; - let t1 = args.(1) - and t2 = args.(2) - in - if isRel t2 && closed0 t1 then (* closed_term = x with x bound in context *) - begin - remove_useless_rel env sigma hyp_id (context:Sign.rel_context) t end_of_type t1 t2 - end - else if isAppConstruct t1 && isAppConstruct t2 (* C .... = C .... *) - then decompose_eq env sigma hyp_id context t end_of_type t1 t2 - else failwith "NoChange" - in - observe (str "In " ++ Ppconstr.pr_id hyp_id ++ - msg ++ fnl ()++ - str "old_typ_of_hyp :=" ++ - Printer.pr_lconstr_env - env - (it_mkProd_or_LetIn ~init:end_of_type ((x,None,t)::context)) - ++ fnl () ++ - str "new_typ_of_hyp := "++ - Printer.pr_lconstr_env env new_typ_of_hyp ++ fnl ()); - (res:'a*'b*'c) - - - - -let is_property static_info t_x = - if isApp t_x - then - let pte,args = destApp t_x in - if isVar pte && array_for_all closed0 args - then Idmap.mem (destVar pte) static_info.ptes_to_fixes - else false - else false - -let isLetIn t = - match kind_of_term t with - | LetIn _ -> true - | _ -> false - - -let h_reduce_with_zeta = - h_reduce - (Rawterm.Cbv - {Rawterm.all_flags - with Rawterm.rDelta = false; - }) - -(* -let rewrite_until_var arg_num : tactic = - let constr_eq = Lazy.force eq in - let replace_if_unify arg (pat,cl,id,lhs) : tactic = - fun g -> - try - let (evd,matched) = - Unification.w_unify_to_subterm - (pf_env g) ~mod_delta:false (pat,arg) cl.Clenv.env - in - let cl' = {cl with Clenv.env = evd } in - let c2 = Clenv.clenv_nf_meta cl' lhs in - (Equality.replace matched c2) g - with _ -> tclFAIL 0 (str "") g - in - let rewrite_on_step equalities : tactic = - fun g -> - match kind_of_term (pf_concl g) with - | App(_,args) when (not (test_var args arg_num)) -> -(* tclFIRST (List.map (fun a -> observe_tac (str "replace_if_unify") (replace_if_unify args.(arg_num) a)) equalities) g *) - tclFIRST (List.map (replace_if_unify args.(arg_num)) equalities) g - | _ -> - raise (Util.UserError("", (str "No more rewrite" ++ - pr_lconstr_env (pf_env g) (pf_concl g)))) - in - fun g -> - let equalities = - List.filter - ( - fun (_,_,id_t) -> - match kind_of_term id_t with - | App(f,_) -> eq_constr f constr_eq - | _ -> false - ) - (pf_hyps g) - in - let f (id,_,ctype) = - let c = mkVar id in - let eqclause = Clenv.make_clenv_binding g (c,ctype) Rawterm.NoBindings in - let clause_type = Clenv.clenv_type eqclause in - let f,args = decompose_app (clause_type) in - let rec split_last_two = function - | [c1;c2] -> (c1, c2) - | x::y::z -> - split_last_two (y::z) - | _ -> - error ("The term provided is not an equivalence") - in - let (c1,c2) = split_last_two args in - (c2,eqclause,id,c1) - in - let matching_hyps = List.map f equalities in - tclTRY (tclREPEAT (tclPROGRESS (rewrite_on_step matching_hyps))) g - -*) - - -let rewrite_until_var arg_num eq_ids : tactic = - let test_var g = - let _,args = destApp (pf_concl g) in - isVar args.(arg_num) - in - let rec do_rewrite eq_ids g = - if test_var g - then tclIDTAC g - else - match eq_ids with - | [] -> anomaly "Cannot find a way to prove recursive property"; - | eq_id::eq_ids -> - tclTHEN - (tclTRY (Equality.rewriteRL (mkVar eq_id))) - (do_rewrite eq_ids) - g - in - do_rewrite eq_ids - -let prove_rec_hyp eq_hyps fix_info = - tclTHEN - (rewrite_until_var (fix_info.idx - 1) eq_hyps) - (fun g -> - let _,pte_args = destApp (pf_concl g) in - let rec_hyp_proof = - mkApp(mkVar fix_info.name,array_get_start pte_args) - in - refine rec_hyp_proof g - ) - - - - - -let rec_pte_id = id_of_string "Hrec" -let clean_hyp_with_heq static_infos eq_hyps hyp_id env sigma = - let coq_False = Coqlib.build_coq_False () in - let coq_True = Coqlib.build_coq_True () in - let coq_I = Coqlib.build_coq_I () in - let rec scan_type context type_of_hyp : tactic = - if isLetIn type_of_hyp then - let real_type_of_hyp = it_mkProd_or_LetIn ~init:type_of_hyp context in - let reduced_type_of_hyp = nf_betaoiotazeta real_type_of_hyp in - (* length of context didn't change ? *) - let new_context,new_typ_of_hyp = - Sign.decompose_prod_n_assum (List.length context) reduced_type_of_hyp - in - tclTHENLIST - [ - h_reduce_with_zeta - (Tacticals.onHyp hyp_id) - ; - scan_type new_context new_typ_of_hyp - - ] - else if isProd type_of_hyp - then - begin - let (x,t_x,t') = destProd type_of_hyp in - if is_property static_infos t_x then - begin - let pte,pte_args = (destApp t_x) in - let fix_info = Idmap.find (destVar pte) static_infos.ptes_to_fixes in - let popped_t' = pop t' in - let real_type_of_hyp = it_mkProd_or_LetIn ~init:popped_t' context in - let prove_new_type_of_hyp = - let context_length = List.length context in - tclTHENLIST - [ - tclDO context_length intro; - (fun g -> - let context_hyps_ids = - fst (list_chop ~msg:"rec hyp : context_hyps" - context_length (pf_ids_of_hyps g)) - in - let rec_pte_id = pf_get_new_id rec_pte_id g in - let to_refine = - applist(mkVar hyp_id, - List.rev_map mkVar (rec_pte_id::context_hyps_ids) - ) - in - tclTHENLIST - [ - forward - (Some (prove_rec_hyp eq_hyps fix_info)) - (Genarg.IntroIdentifier rec_pte_id) - t_x; - refine to_refine - ] - g - ) - ] - in - tclTHENLIST - [ - observe_tac "hyp rec" - (change_hyp_with_using hyp_id real_type_of_hyp prove_new_type_of_hyp); - scan_type context popped_t' - ] - end - else if eq_constr t_x coq_False then - begin - observe (str "Removing : "++ Ppconstr.pr_id hyp_id++ - str " since it has False in its preconds " - ); - raise TOREMOVE; (* False -> .. useless *) - end - else if is_incompatible_eq t_x then raise TOREMOVE (* t_x := C1 ... = C2 ... *) - else if eq_constr t_x coq_True (* Trivial => we remove this precons *) - then - let _ = - observe (str "In "++Ppconstr.pr_id hyp_id++ - str " removing useless precond True" - ) - in - let popped_t' = pop t' in - let real_type_of_hyp = - it_mkProd_or_LetIn ~init:popped_t' context - in - let prove_trivial = - let nb_intro = List.length context in - tclTHENLIST [ - tclDO nb_intro intro; - (fun g -> - let context_hyps = - fst (list_chop ~msg:"removing True : context_hyps "nb_intro (pf_ids_of_hyps g)) - in - let to_refine = - applist (mkVar hyp_id, - List.rev (coq_I::List.map mkVar context_hyps) - ) - in - refine to_refine g - ) - ] - in - tclTHENLIST[ - change_hyp_with_using hyp_id real_type_of_hyp (observe_tac "prove_trivial" prove_trivial); - scan_type context popped_t' - ] - else if is_trivial_eq t_x - then (* t_x := t = t => we remove this precond *) - let popped_t' = pop t' in - let real_type_of_hyp = - it_mkProd_or_LetIn ~init:popped_t' context - in - let _,args = destApp t_x in - tclTHENLIST - [ - change_hyp_with_using - hyp_id - real_type_of_hyp - (observe_tac "prove_trivial_eq" (prove_trivial_eq hyp_id context (args.(0),args.(1)))); - scan_type context popped_t' - ] - else - begin - try - let new_context,new_t',tac = change_eq env sigma hyp_id context x t_x t' in - tclTHEN - tac - (scan_type new_context new_t') - with Failure "NoChange" -> - (* Last thing todo : push the rel in the context and continue *) - scan_type ((x,None,t_x)::context) t' - end - end - else - tclIDTAC - in - try - scan_type [] (Typing.type_of env sigma (mkVar hyp_id)), [hyp_id] - with TOREMOVE -> - thin [hyp_id],[] - - -let clean_goal_with_heq static_infos continue_tac dyn_infos = - fun g -> - let env = pf_env g - and sigma = project g - in - let tac,new_hyps = - List.fold_left ( - fun (hyps_tac,new_hyps) hyp_id -> - let hyp_tac,new_hyp = - clean_hyp_with_heq static_infos dyn_infos.eq_hyps hyp_id env sigma - in - (tclTHEN hyp_tac hyps_tac),new_hyp@new_hyps - ) - (tclIDTAC,[]) - dyn_infos.rec_hyps - in - let new_infos = - { dyn_infos with - rec_hyps = new_hyps; - nb_rec_hyps = List.length new_hyps - } - in - tclTHENLIST - [ - tac ; - (continue_tac new_infos) - ] - g - -let heq_id = id_of_string "Heq" - -let treat_new_case static_infos nb_prod continue_tac term dyn_infos = - fun g -> - let heq_id = pf_get_new_id heq_id g in - let nb_first_intro = nb_prod - 1 - dyn_infos.nb_rec_hyps in - tclTHENLIST - [ - (* We first introduce the variables *) - tclDO nb_first_intro (intro_avoiding dyn_infos.rec_hyps); - (* Then the equation itself *) - introduction_no_check heq_id; - (* Then the new hypothesis *) - tclMAP introduction_no_check dyn_infos.rec_hyps; - observe_tac "after_introduction" (fun g' -> - (* We get infos on the equations introduced*) - let new_term_value_eq = pf_type_of g' (mkVar heq_id) in - (* compute the new value of the body *) - let new_term_value = - match kind_of_term new_term_value_eq with - | App(f,[| _;_;args2 |]) -> args2 - | _ -> - observe (pr_gls g' ++ fnl () ++ str "last hyp is" ++ - pr_lconstr_env (pf_env g') new_term_value_eq - ); - assert false - in - let fun_body = - mkLambda(Anonymous, - pf_type_of g' term, - replace_term term (mkRel 1) dyn_infos.info - ) - in - let new_body = pf_nf_betaiota g' (mkApp(fun_body,[| new_term_value |])) in - let new_infos = - {dyn_infos with - info = new_body; - eq_hyps = heq_id::dyn_infos.eq_hyps - } - in - clean_goal_with_heq static_infos continue_tac new_infos g' - ) - ] - g - -let do_prove_princ_for_struct - (interactive_proof:bool) - (fnames:constant list) - static_infos -(* (ptes:identifier list) *) -(* (fixes:(int*constr*identifier*constr) Idmap.t) *) -(* (hyps: identifier list) *) -(* (term:constr) *) - dyn_infos - : tactic = -(* let fixes_ids = Idmap.fold (fun _ (_,_,id,_) acc -> id::acc) fixes [] in *) - let rec do_prove_princ_for_struct_aux do_finalize dyn_infos : tactic = - fun g -> -(* observe (str "proving on " ++ Printer.pr_lconstr_env (pf_env g) term);*) - match kind_of_term dyn_infos.info with - | Case(_,_,t,_) -> - let g_nb_prod = nb_prod (pf_concl g) in - let type_of_term = pf_type_of g t in - let term_eq = - make_refl_eq type_of_term t - in - tclTHENSEQ - [ - h_generalize (term_eq::List.map mkVar dyn_infos.rec_hyps); - thin dyn_infos.rec_hyps; - pattern_option [[-1],t] None; - h_simplest_case t; - (fun g' -> - let g'_nb_prod = nb_prod (pf_concl g') in - let nb_instanciate_partial = g'_nb_prod - g_nb_prod in - observe_tac "treat_new_case" - (treat_new_case - static_infos - nb_instanciate_partial - (do_prove_princ_for_struct do_finalize) - t - dyn_infos) - g' - ) - - ] g - | Lambda(n,t,b) -> - begin - match kind_of_term( pf_concl g) with - | Prod _ -> - tclTHEN - intro - (fun g' -> - let (id,_,_) = pf_last_hyp g' in - let new_term = - pf_nf_betaiota g' - (mkApp(dyn_infos.info,[|mkVar id|])) - in - let new_infos = {dyn_infos with info = new_term} in - do_prove_princ_for_struct do_finalize new_infos g' - ) g - | _ -> - do_finalize dyn_infos g - end - | Cast(t,_,_) -> - do_prove_princ_for_struct do_finalize {dyn_infos with info = t} g - | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ -> - do_finalize dyn_infos g - | App(_,_) -> - let f,args = decompose_app dyn_infos.info in - begin - match kind_of_term f with - | Var _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ -> - let new_infos = - { dyn_infos with - info = (f,args) - } - in - do_prove_princ_for_struct_args do_finalize new_infos g - | Const c when not (List.mem c fnames) -> - let new_infos = - { dyn_infos with - info = (f,args) - } - in - do_prove_princ_for_struct_args do_finalize new_infos g - | Const _ -> - do_finalize dyn_infos g - | _ -> -(* observe *) -(* (str "Applied binders not yet implemented: in "++ fnl () ++ *) -(* pr_lconstr_env (pf_env g) term ++ fnl () ++ *) -(* pr_lconstr_env (pf_env g) f ++ spc () ++ str "is applied") ; *) - tclFAIL 0 (str "TODO : Applied binders not yet implemented") g - end - | Fix _ | CoFix _ -> - error ( "Anonymous local (co)fixpoints are not handled yet") - - | Prod _ -> assert false - | LetIn _ -> - let new_infos = - { dyn_infos with - info = nf_betaoiotazeta dyn_infos.info - } - in - - tclTHENLIST - [tclMAP - (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) - dyn_infos.rec_hyps; - h_reduce_with_zeta Tacticals.onConcl; - do_prove_princ_for_struct do_finalize new_infos - ] g - | _ -> - errorlabstrm "" (str "in do_prove_princ_for_struct found : "(* ++ *) -(* pr_lconstr_env (pf_env g) term *) - ) - and do_prove_princ_for_struct do_finalize dyn_infos g = -(* observe (str "proving with "++Printer.pr_lconstr term++ str " on goal " ++ pr_gls g); *) - do_prove_princ_for_struct_aux do_finalize dyn_infos g - and do_prove_princ_for_struct_args do_finalize dyn_infos (* f_args' args *) :tactic = - fun g -> -(* if Tacinterp.get_debug () <> Tactic_debug.DebugOff *) -(* then msgnl (str "do_prove_princ_for_struct_args with " ++ *) -(* pr_lconstr_env (pf_env g) f_args' *) -(* ); *) - let (f_args',args) = dyn_infos.info in - let tac = - match args with - | [] -> - do_finalize {dyn_infos with info = f_args'} - | arg::args -> - let do_finalize dyn_infos = - let new_arg = dyn_infos.info in - tclTRYD - (do_prove_princ_for_struct_args - do_finalize - {dyn_infos with info = (mkApp(f_args',[|new_arg|])), args} - ) - in - do_prove_princ_for_struct do_finalize - {dyn_infos with info = arg } - in - tclTRYD(tac ) g - in - let do_finish_proof dyn_infos = - clean_goal_with_heq - static_infos - finish_proof dyn_infos - in - observe_tac "do_prove_princ_for_struct" - (do_prove_princ_for_struct do_finish_proof dyn_infos) - -let is_pte_type t = - isSort (snd (decompose_prod t)) - -let is_pte (_,_,t) = is_pte_type t - -exception Not_Rec - - - -let instanciate_hyps_with_args (do_prove:identifier list -> tactic) hyps args_id = - let args = Array.of_list (List.map mkVar args_id) in - let instanciate_one_hyp hid = - tclORELSE - ( (* we instanciate the hyp if possible *) -(* tclTHENLIST *) -(* [h_generalize [mkApp(mkVar hid,args)]; *) -(* intro_erasing hid] *) - fun g -> - let prov_hid = pf_get_new_id hid g in - tclTHENLIST[ - forward None (Genarg.IntroIdentifier prov_hid) (mkApp(mkVar hid,args)); - thin [hid]; - h_rename prov_hid hid - ] g - ) - ( (* - if not then we are in a mutual function block - and this hyp is a recursive hyp on an other function. - - We are not supposed to use it while proving this - principle so that we can trash it - - *) - (fun g -> - observe (str "Instanciation: removing hyp " ++ Ppconstr.pr_id hid); - thin [hid] g - ) - ) - in - (* if no args then no instanciation ! *) - if args_id = [] - then - tclTHENLIST [ - tclMAP (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) hyps; - do_prove hyps - ] - else - tclTHENLIST - [ - tclMAP (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) hyps; - tclMAP instanciate_one_hyp hyps; - (fun g -> - let all_g_hyps_id = - List.fold_right Idset.add (pf_ids_of_hyps g) Idset.empty - in - let remaining_hyps = - List.filter (fun id -> Idset.mem id all_g_hyps_id) hyps - in - do_prove remaining_hyps g - ) - ] - - -let prove_princ_for_struct interactive_proof fun_num fnames all_funs _naprams : tactic = - fun goal -> -(* observe (str "Proving principle for "++ str (string_of_int fun_num) ++ str "th function : " ++ *) -(* pr_lconstr (mkConst fnames.(fun_num))); *) - let princ_type = pf_concl goal in - let princ_info = compute_elim_sig princ_type in - let get_body const = - match (Global.lookup_constant const ).const_body with - | Some b -> - let body = force b in - Tacred.cbv_norm_flags - (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]) - (Global.env ()) - (Evd.empty) - body - | None -> error ( "Cannot define a principle over an axiom ") - in - let fbody = get_body fnames.(fun_num) in - let params : identifier list ref = ref [] in - let predicates : identifier list ref = ref [] in - let args : identifier list ref = ref [] in - let branches : identifier list ref = ref [] in - let pte_to_fix = ref Idmap.empty in - let fbody_with_params = ref None in - let intro_with_remembrance ref number : tactic = - tclTHEN - ( tclDO number intro ) - (fun g -> - let last_n = list_chop number (pf_hyps g) in - ref := List.map (fun (id,_,_) -> id) (fst last_n)@ !ref; - tclIDTAC g - ) - in - let rec partial_combine body params = - match kind_of_term body,params with - | Lambda (x,t,b),param::params -> - partial_combine (subst1 param b) params - | Fix(infos),_ -> - body,params, Some (infos) - | _ -> body,params,None - in - let build_pte_to_fix (offset:int) params predicates - ((idxs,fix_num),(na,typearray,ca)) (avoid,_) = -(* let true_params,_ = list_chop offset params in *) - let true_params = List.rev params in - let avoid = ref avoid in - let res = list_fold_left_i - (fun i acc pte_id -> - let this_fix_id = fresh_id !avoid "fix___" in - avoid := this_fix_id::!avoid; -(* let this_body = substl (List.rev fnames_as_constr) ca.(i) in *) - let new_type = prod_applist typearray.(i) true_params in - let new_type_args,_ = decompose_prod new_type in - let nargs = List.length new_type_args in - let pte_args = - (* let rev_args = List.rev_map (fun (id,_,_) -> mkVar id) new_type_args in *) - let f = applist((* all_funs *)mkConst fnames.(i),true_params) in - let app_f = mkApp(f,Array.init nargs (fun i -> mkRel(nargs - i))) in - (Array.to_list (Array.init nargs (fun i -> mkRel(nargs - i))))@[app_f] - in - let app_pte = applist(mkVar pte_id,pte_args) in - let new_type = compose_prod new_type_args app_pte in - let fix_info = - { - idx = idxs.(i) - offset + 1; - name = this_fix_id; - types = new_type - } - in - pte_to_fix := Idmap.add pte_id fix_info !pte_to_fix; - fix_info::acc - ) - 0 - [] - predicates - in - !avoid,List.rev res - in - let mk_fixes : tactic = - fun g -> - let body_p,params',fix_infos = - partial_combine fbody (List.rev_map mkVar !params) - in - fbody_with_params := Some body_p; - let offset = List.length params' in - let not_real_param,true_params = - list_chop - ((List.length !params ) - offset) - !params - in - params := true_params; args := not_real_param; -(* observe (str "mk_fixes : params are "++ *) -(* prlist_with_sep spc *) -(* (fun id -> pr_lconstr (mkVar id)) *) -(* !params *) -(* ); *) - let new_avoid,infos = - option_fold_right - (build_pte_to_fix - offset - (List.map mkVar !params) - (List.rev !predicates) - ) - fix_infos - ((pf_ids_of_hyps g),[]) - in - let pre_info,infos = list_chop fun_num infos in - match pre_info,infos with - | [],[] -> tclIDTAC g - | _,this_fix_info::infos' -> - let other_fix_info = - List.map - (fun fix_info -> fix_info.name,fix_info.idx,fix_info.types) - (pre_info@infos') - in - tclORELSE - (h_mutual_fix this_fix_info.name this_fix_info.idx other_fix_info) - (tclFAIL 1000 (str "bad index" ++ - str (string_of_int this_fix_info.idx) ++ - str "offset := " ++ - (str (string_of_int offset)))) - g - | _,[] -> anomaly "Not a valid information" - in - let do_prove ptes_to_fixes args branches : tactic = - fun g -> - let static_infos = - { - ptes_to_fixes = ptes_to_fixes; - fixes_ids = - Idmap.fold - (fun _ fix_info acc -> fix_info.name::acc) - ptes_to_fixes [] - } - in - match kind_of_term (pf_concl g) with - | App(pte,pte_args) when isVar pte -> - begin - let pte = destVar pte in - try - if not (Idmap.mem pte ptes_to_fixes) then raise Not_Rec; - let nparams = List.length !params in - let args_as_constr = List.map mkVar args in - let rec_num,new_body = - let idx' = list_index pte (List.rev !predicates) - 1 in - let f = fnames.(idx') in - let body_with_params = match !fbody_with_params with Some f -> f | _ -> anomaly "" - in - let name_of_f = Name ( id_of_label (con_label f)) in - let ((rec_nums,_),(na,_,bodies)) = destFix body_with_params in - let idx'' = list_index name_of_f (Array.to_list na) - 1 in - let body = substl (List.rev (Array.to_list all_funs)) bodies.(idx'') in - let body = Reductionops.nf_beta (applist(body,(List.rev_map mkVar !params))) in - rec_nums.(idx'') - nparams ,body - in - let applied_body = - Reductionops.nf_beta - (applist(new_body,List.rev args_as_constr)) - in - let do_prove branches applied_body = - do_prove_princ_for_struct - interactive_proof - (Array.to_list fnames) - static_infos - branches - applied_body - in - let replace_and_prove = - tclTHENS - (fun g -> -(* observe (str "replacing " ++ *) -(* pr_lconstr_env (pf_env g) (array_last pte_args) ++ *) -(* str " with " ++ *) -(* pr_lconstr_env (pf_env g) applied_body ++ *) -(* str " rec_arg_num is " ++ str (string_of_int rec_num) *) -(* ); *) - (Equality.replace (array_last pte_args) applied_body) g - ) - [ - clean_goal_with_heq - static_infos do_prove - { - nb_rec_hyps = List.length branches; - rec_hyps = branches; - info = applied_body; - eq_hyps = []; - } ; - try - let id = List.nth (List.rev args_as_constr) (rec_num) in - (* observe (str "choosen var := "++ pr_lconstr id); *) - (tclTHENSEQ - [(h_simplest_case id); - Tactics.intros_reflexivity - ]) - with _ -> tclIDTAC - - ] - in - (observe_tac "doing replacement" ( replace_and_prove)) g - with Not_Rec -> - let fname = destConst (fst (decompose_app (array_last pte_args))) in - tclTHEN - (unfold_in_concl [([],Names.EvalConstRef fname)]) - (observe_tac "" - (fun g' -> - let body = array_last (snd (destApp (pf_concl g'))) in - let dyn_infos = - { nb_rec_hyps = List.length branches; - rec_hyps = branches; - info = body; - eq_hyps = [] - } - in - let do_prove = - do_prove_princ_for_struct - interactive_proof - (Array.to_list fnames) - static_infos - in - clean_goal_with_heq static_infos - do_prove dyn_infos g' - ) - ) - g - end - | _ -> assert false - in - tclTHENSEQ - [ - (fun g -> observe_tac "introducing params" (intro_with_remembrance params princ_info.nparams) g); - (fun g -> observe_tac "introducing predicate" (intro_with_remembrance predicates princ_info.npredicates) g); - (fun g -> observe_tac "introducing branches" (intro_with_remembrance branches princ_info.nbranches) g); - (fun g -> observe_tac "declaring fix(es)" mk_fixes g); - (fun g -> - let nb_prod_g = nb_prod (pf_concl g) in - tclTHENLIST [ - tclDO nb_prod_g intro; - (fun g' -> - let args = - fst (list_chop ~msg:"args" nb_prod_g (pf_ids_of_hyps g')) - in - let do_prove_on_branches branches : tactic = - observe_tac "proving" (do_prove !pte_to_fix args branches) - in - observe_tac "instanciating rec hyps" - (instanciate_hyps_with_args do_prove_on_branches !branches (List.rev args)) - g' - ) - ] - g - ) - ] - goal - - - - - - - - - - - - - - - - - - - - - - - -exception Toberemoved_with_rel of int*constr -exception Toberemoved - -let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = - let princ_type_info = compute_elim_sig princ_type in - let env = Global.env () in -(* let type_sort = (Termops.new_sort_in_family InType) in *) - let change_predicate_sort i (x,_,t) = - let new_sort = sorts.(i) in - let args,_ = decompose_prod t in - let real_args = - if princ_type_info.indarg_in_concl - then List.tl args - else args - in - x,None,compose_prod real_args (mkSort new_sort) - in - let new_predicates = - list_map_i - change_predicate_sort - 0 - princ_type_info.predicates - in - let env_with_params_and_predicates = - Environ.push_rel_context - new_predicates - (Environ.push_rel_context - princ_type_info.params - env - ) - in - let rel_as_kn = - fst (match princ_type_info.indref with - | Some (Libnames.IndRef ind) -> ind - | _ -> failwith "Not a valid predicate" - ) - in - let pre_princ = - it_mkProd_or_LetIn - ~init: - (it_mkProd_or_LetIn - ~init:(option_fold_right - mkProd_or_LetIn - princ_type_info.indarg - princ_type_info.concl - ) - princ_type_info.args - ) - princ_type_info.branches - in - let is_dom c = - match kind_of_term c with - | Ind((u,_)) -> u = rel_as_kn - | Construct((u,_),_) -> u = rel_as_kn - | _ -> false - in - let get_fun_num c = - match kind_of_term c with - | Ind(_,num) -> num - | Construct((_,num),_) -> num - | _ -> assert false - in - let dummy_var = mkVar (id_of_string "________") in - let mk_replacement c i args = - let res = mkApp(rel_to_fun.(i),Array.map pop (array_get_start args)) in -(* observe (str "replacing " ++ pr_lconstr c ++ str " by " ++ pr_lconstr res); *) - res - in - let rec has_dummy_var t = - fold_constr - (fun b t -> b || (eq_constr t dummy_var) || (has_dummy_var t)) - false - t - in - let rec compute_new_princ_type remove env pre_princ : types*(constr list) = - let (new_princ_type,_) as res = - match kind_of_term pre_princ with - | Rel n -> - begin - try match Environ.lookup_rel n env with - | _,_,t when is_dom t -> raise Toberemoved - | _ -> pre_princ,[] with Not_found -> assert false - end - | Prod(x,t,b) -> - compute_new_princ_type_for_binder remove mkProd env x t b - | Lambda(x,t,b) -> - compute_new_princ_type_for_binder remove mkLambda env x t b - | Ind _ | Construct _ when is_dom pre_princ -> raise Toberemoved - | App(f,args) when is_dom f -> - let var_to_be_removed = destRel (array_last args) in - let num = get_fun_num f in - raise (Toberemoved_with_rel (var_to_be_removed,mk_replacement pre_princ num args)) - | App(f,args) -> - let is_pte = - match kind_of_term f with - | Rel n -> - is_pte (Environ.lookup_rel n env) - | _ -> false - in - let args = - if is_pte && remove - then array_get_start args - else args - in - let new_args,binders_to_remove = - Array.fold_right (compute_new_princ_type_with_acc remove env) - args - ([],[]) - in - let new_f,binders_to_remove_from_f = compute_new_princ_type remove env f in - applist(new_f, new_args), - list_union_eq eq_constr binders_to_remove_from_f binders_to_remove - | LetIn(x,v,t,b) -> - compute_new_princ_type_for_letin remove env x v t b - | _ -> pre_princ,[] - in -(* observennl ( *) -(* match kind_of_term pre_princ with *) -(* | Prod _ -> *) -(* str "compute_new_princ_type for "++ *) -(* pr_lconstr_env env pre_princ ++ *) -(* str" is "++ *) -(* pr_lconstr_env env new_princ_type ++ fnl () *) -(* | _ -> str "" *) -(* ); *) - res - - and compute_new_princ_type_for_binder remove bind_fun env x t b = - begin - try - let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in - let new_x : name = get_name (ids_of_context env) x in - let new_env = Environ.push_rel (x,None,t) env in - let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in - if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b - then (pop new_b),filter_map (eq_constr (mkRel 1)) pop binders_to_remove_from_b - else - ( - bind_fun(new_x,new_t,new_b), - list_union_eq - eq_constr - binders_to_remove_from_t - (List.map pop binders_to_remove_from_b) - ) - - with - | Toberemoved -> -(* msgnl (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) - let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b) in - new_b, List.map pop binders_to_remove_from_b - | Toberemoved_with_rel (n,c) -> -(* msgnl (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) - let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b) in - new_b, list_add_set_eq eq_constr (mkRel n) (List.map pop binders_to_remove_from_b) - end - and compute_new_princ_type_for_letin remove env x v t b = - begin - try - let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in - let new_v,binders_to_remove_from_v = compute_new_princ_type remove env v in - let new_x : name = get_name (ids_of_context env) x in - let new_env = Environ.push_rel (x,Some v,t) env in - let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in - if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b - then (pop new_b),filter_map (eq_constr (mkRel 1)) pop binders_to_remove_from_b - else - ( - mkLetIn(new_x,new_v,new_t,new_b), - list_union_eq - eq_constr - (list_union_eq eq_constr binders_to_remove_from_t binders_to_remove_from_v) - (List.map pop binders_to_remove_from_b) - ) - - with - | Toberemoved -> -(* msgnl (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) - let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b) in - new_b, List.map pop binders_to_remove_from_b - | Toberemoved_with_rel (n,c) -> -(* msgnl (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) - let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b) in - new_b, list_add_set_eq eq_constr (mkRel n) (List.map pop binders_to_remove_from_b) - end - and compute_new_princ_type_with_acc remove env e (c_acc,to_remove_acc) = - let new_e,to_remove_from_e = compute_new_princ_type remove env e - in - new_e::c_acc,list_union_eq eq_constr to_remove_from_e to_remove_acc - in -(* observe (str "Computing new principe from " ++ pr_lconstr_env env_with_params_and_predicates pre_princ); *) - let pre_res,_ = - compute_new_princ_type princ_type_info.indarg_in_concl env_with_params_and_predicates pre_princ in - it_mkProd_or_LetIn - ~init:(it_mkProd_or_LetIn ~init:pre_res new_predicates) - princ_type_info.params - - - -let change_property_sort toSort princ princName = - let princ_info = compute_elim_sig princ in - let change_sort_in_predicate (x,v,t) = - (x,None, - let args,_ = decompose_prod t in - compose_prod args (mkSort toSort) - ) - in - let princName_as_constr = Tacinterp.constr_of_id (Global.env ()) princName in - let init = - let nargs = (princ_info.nparams + (List.length princ_info.predicates)) in - mkApp(princName_as_constr, - Array.init nargs - (fun i -> mkRel (nargs - i ))) - in - it_mkLambda_or_LetIn - ~init: - (it_mkLambda_or_LetIn ~init - (List.map change_sort_in_predicate princ_info.predicates) - ) - princ_info.params - - -let pp_dur time time' = - str (string_of_float (System.time_difference time time')) - -(* Things to be removed latter : just here to compare - saving proof with and without normalizing the proof -*) -let new_save id const (locality,kind) hook = - let {const_entry_body = pft; - const_entry_type = tpo; - const_entry_opaque = opacity } = const in - let l,r = match locality with - | Decl_kinds.Local when Lib.sections_are_opened () -> - let k = Decl_kinds.logical_kind_of_goal_kind kind in - let c = Declare.SectionLocalDef (pft, tpo, opacity) in - let _ = Declare.declare_variable id (Lib.cwd(), c, k) in - (Decl_kinds.Local, Libnames.VarRef id) - | Decl_kinds.Local -> - let k = Decl_kinds.logical_kind_of_goal_kind kind in - let kn = Declare.declare_constant id (DefinitionEntry const, k) in - (Decl_kinds.Global, Libnames.ConstRef kn) - | Decl_kinds.Global -> - let k = Decl_kinds.logical_kind_of_goal_kind kind in - let kn = Declare.declare_constant id (DefinitionEntry const, k) in - (Decl_kinds.Global, Libnames.ConstRef kn) in - let time1 = System.get_time () in - Pfedit.delete_current_proof (); - let time2 = System.get_time () in - hook l r; - time1,time2 -(* definition_message id *) - - - - - -let new_save_named opacity = -(* if do_observe () *) -(* then *) - let time1 = System.get_time () in - let id,(const,persistence,hook) = Pfedit.cook_proof () in - let time2 = System.get_time () in - let const = - { const with - const_entry_body = (* nf_betaoiotazeta *)const.const_entry_body ; - const_entry_opaque = opacity - } - in - let time3 = System.get_time () in - let time4,time5 = new_save id const persistence hook in - let time6 = System.get_time () in - Pp.msgnl - (str "cooking proof time : " ++ pp_dur time1 time2 ++ fnl () ++ - str "reducing proof time : " ++ pp_dur time2 time3 ++ fnl () ++ - str "saving proof time : " ++ pp_dur time3 time4 ++fnl () ++ - str "deleting proof time : " ++ pp_dur time4 time5 ++fnl () ++ - str "hook time :" ++ pp_dur time5 time6 - ) - -;; - -(* End of things to be removed latter : just here to compare - saving proof with and without normalizing the proof -*) - - -let generate_functional_principle - interactive_proof - old_princ_type sorts new_princ_name funs i proof_tac - = - let f = funs.(i) in - let type_sort = Termops.new_sort_in_family InType in - let new_sorts = - match sorts with - | None -> Array.make (Array.length funs) (type_sort) - | Some a -> a - in - (* First we get the type of the old graph principle *) - let mutr_nparams = (compute_elim_sig old_princ_type).nparams in - (* First we get the type of the old graph principle *) - let new_principle_type = - compute_new_princ_type_from_rel - (Array.map mkConst funs) - new_sorts - old_princ_type - in -(* observe (str "new_principle_type : " ++ pr_lconstr new_principle_type); *) - let base_new_princ_name,new_princ_name = - match new_princ_name with - | Some (id) -> id,id - | None -> - let id_of_f = id_of_label (con_label f) in - id_of_f,Indrec.make_elimination_ident id_of_f (family_of_sort type_sort) - in - let names = ref [new_princ_name] in - let hook _ _ = - if sorts = None - then -(* let id_of_f = id_of_label (con_label f) in *) - let register_with_sort fam_sort = - let s = Termops.new_sort_in_family fam_sort in - let name = Indrec.make_elimination_ident base_new_princ_name fam_sort in - let value = - change_property_sort s new_principle_type new_princ_name - in -(* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *) - let ce = - { const_entry_body = value; - const_entry_type = None; - const_entry_opaque = false; - const_entry_boxed = Options.boxed_definitions() - } - in - ignore( - Declare.declare_constant - name - (Entries.DefinitionEntry ce, - Decl_kinds.IsDefinition (Decl_kinds.Scheme) - ) - ); - names := name :: !names - in - register_with_sort InProp; - register_with_sort InSet - in - begin - Command.start_proof - new_princ_name - (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem)) - new_principle_type - hook - ; - try - let _tim1 = System.get_time () in - Pfedit.by (proof_tac (Array.map mkConst funs) mutr_nparams); - let _tim2 = System.get_time () in -(* begin *) -(* let dur1 = System.time_difference tim1 tim2 in *) -(* Pp.msgnl (str ("Time to compute proof: ") ++ str (string_of_float dur1)); *) -(* end; *) - let do_save = not (do_observe ()) && not interactive_proof in - let _ = - try - Options.silently Command.save_named true; - let _dur2 = System.time_difference _tim2 (System.get_time ()) in -(* Pp.msgnl (str ("Time to check proof: ") ++ str (string_of_float dur2)); *) - Options.if_verbose - (fun () -> - Pp.msgnl ( - prlist_with_sep - (fun () -> str" is defined " ++ fnl ()) - Ppconstr.pr_id - (List.rev !names) ++ str" is defined " - ) - ) - () - with e when do_save -> - msg_warning - ( - Cerrors.explain_exn e - ); - if not (do_observe ()) - then begin Vernacentries.interp (Vernacexpr.VernacAbort None);raise e end - in - () - -(* let tim3 = Sys.time () in *) -(* Pp.msgnl (str ("Time to save proof: ") ++ str (string_of_float (tim3 -. tim2))); *) - - with - | e -> - msg_warning - ( - Cerrors.explain_exn e - ); - if not ( do_observe ()) - then begin Vernacentries.interp (Vernacexpr.VernacAbort None);raise e end - end - - - - - - -let get_funs_constant mp dp = - let rec get_funs_constant const e : (Names.constant*int) array = - match kind_of_term (snd (decompose_lam e)) with - | Fix((_,(na,_,_))) -> - Array.mapi - (fun i na -> - match na with - | Name id -> - let const = make_con mp dp (label_of_id id) in - const,i - | Anonymous -> - anomaly "Anonymous fix" - ) - na - | _ -> [|const,0|] - in - function const -> - let find_constant_body const = - match (Global.lookup_constant const ).const_body with - | Some b -> - let body = force b in - let body = Tacred.cbv_norm_flags - (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]) - (Global.env ()) - (Evd.empty) - body - in - body - | None -> error ( "Cannot define a principle over an axiom ") - in - let f = find_constant_body const in - let l_const = get_funs_constant const f in - (* - We need to check that all the functions found are in the same block - to prevent Reset stange thing - *) - let l_bodies = List.map find_constant_body (Array.to_list (Array.map fst l_const)) in - let l_params,l_fixes = List.split (List.map decompose_lam l_bodies) in - (* all the paremeter must be equal*) - let _check_params = - let first_params = List.hd l_params in - List.iter - (fun params -> - if not ((=) first_params params) - then error "Not a mutal recursive block" - ) - l_params - in - (* The bodies has to be very similar *) - let _check_bodies = - try - let extract_info is_first body = - match kind_of_term body with - | Fix((idxs,_),(na,ta,ca)) -> (idxs,na,ta,ca) - | _ -> - if is_first && (List.length l_bodies = 1) - then raise Not_Rec - else error "Not a mutal recursive block" - in - let first_infos = extract_info true (List.hd l_bodies) in - let check body = (* Hope this is correct *) - if not (first_infos = (extract_info false body)) - then error "Not a mutal recursive block" - in - List.iter check l_bodies - with Not_Rec -> () - in - l_const - -let make_scheme fas = - let env = Global.env () - and sigma = Evd.empty in - let id_to_constr id = - Tacinterp.constr_of_id env id - in - let funs = List.map (fun (_,f,_) -> id_to_constr f) fas in - let first_fun = destConst (List.hd funs) in - let funs_mp,funs_dp,first_fun_id = Names.repr_con first_fun in - let first_fun_rel_id = mk_rel_id (id_of_label first_fun_id) in - let first_fun_kn = - (* Fixme: take into accour funs_mp and funs_dp *) - fst (destInd (id_to_constr first_fun_rel_id)) - in - let this_block_funs_indexes = get_funs_constant funs_mp funs_dp first_fun in - let this_block_funs = Array.map fst this_block_funs_indexes in - let prop_sort = InProp in - let funs_indexes = - let this_block_funs_indexes = Array.to_list this_block_funs_indexes in - List.map - (function const -> List.assoc (destConst const) this_block_funs_indexes) - funs - in - let ind_list = - List.map - (fun (idx) -> - let ind = first_fun_kn,idx in - let (mib,mip) = Global.lookup_inductive ind in - ind,mib,mip,true,prop_sort - ) - funs_indexes - in - let l_schemes = List.map (Typing.type_of env sigma ) (Indrec.build_mutual_indrec env sigma ind_list) in - let i = ref (-1) in - let sorts = - List.rev_map (fun (_,_,x) -> - Termops.new_sort_in_family (Pretyping.interp_elimination_sort x) - ) - fas - in - let princ_names = List.map (fun (x,_,_) -> x) fas in - let _ = List.map2 - (fun princ_name scheme_type -> - incr i; -(* observe (str "Generating " ++ Ppconstr.pr_id princ_name ++str " with " ++ *) -(* pr_lconstr scheme_type ++ str " and " ++ (fun a -> prlist_with_sep spc (fun c -> pr_lconstr (mkConst c)) (Array.to_list a)) this_block_funs *) -(* ); *) - generate_functional_principle - false - scheme_type - (Some (Array.of_list sorts)) - (Some princ_name) - this_block_funs - !i - (prove_princ_for_struct false !i (Array.of_list (List.map destConst funs))) - ) - princ_names - l_schemes - in - () - -let make_case_scheme fa = - let env = Global.env () - and sigma = Evd.empty in - let id_to_constr id = - Tacinterp.constr_of_id env id - in - let funs = (fun (_,f,_) -> id_to_constr f) fa in - let first_fun = destConst funs in - let funs_mp,funs_dp,first_fun_id = Names.repr_con first_fun in - let first_fun_rel_id = mk_rel_id (id_of_label first_fun_id) in - let first_fun_kn = - (* Fixme: take into accour funs_mp and funs_dp *) - fst (destInd (id_to_constr first_fun_rel_id)) - in - let this_block_funs_indexes = get_funs_constant funs_mp funs_dp first_fun in - let this_block_funs = Array.map fst this_block_funs_indexes in - let prop_sort = InProp in - let funs_indexes = - let this_block_funs_indexes = Array.to_list this_block_funs_indexes in - List.assoc (destConst funs) this_block_funs_indexes - in - let ind_fun = - let ind = first_fun_kn,funs_indexes in - ind,prop_sort - in - let scheme_type = (Typing.type_of env sigma ) ((fun (ind,sf) -> Indrec.make_case_gen env sigma ind sf) ind_fun) in - let sorts = - (fun (_,_,x) -> - Termops.new_sort_in_family (Pretyping.interp_elimination_sort x) - ) - fa - in - let princ_name = (fun (x,_,_) -> x) fa in - let _ = -(* observe (str "Generating " ++ Ppconstr.pr_id princ_name ++str " with " ++ *) -(* pr_lconstr scheme_type ++ str " and " ++ (fun a -> prlist_with_sep spc (fun c -> pr_lconstr (mkConst c)) (Array.to_list a)) this_block_funs *) -(* ); *) - generate_functional_principle - false - scheme_type - (Some ([|sorts|])) - (Some princ_name) - this_block_funs - 0 - (prove_princ_for_struct false 0 [|destConst funs|]) - in - () diff --git a/contrib/funind/new_arg_principle.mli b/contrib/funind/new_arg_principle.mli deleted file mode 100644 index cad68da6..00000000 --- a/contrib/funind/new_arg_principle.mli +++ /dev/null @@ -1,34 +0,0 @@ - -val generate_functional_principle : - (* do we accept interactive proving *) - bool -> - (* induction principle on rel *) - Term.types -> - (* *) - Term.sorts array option -> - (* Name of the new principle *) - (Names.identifier) option -> - (* the compute functions to use *) - Names.constant array -> - (* We prove the nth- principle *) - int -> - (* The tactic to use to make the proof w.r - the number of params - *) - (Term.constr array -> int -> Tacmach.tactic) -> - unit - - - -(* val my_reflexivity : Tacmach.tactic *) - -val prove_princ_for_struct : - bool -> - int -> Names.constant array -> Term.constr array -> int -> Tacmach.tactic - - -val compute_new_princ_type_from_rel : Term.constr array -> Term.sorts array -> - Term.types -> Term.types - -val make_scheme : (Names.identifier*Names.identifier*Rawterm.rawsort) list -> unit -val make_case_scheme : (Names.identifier*Names.identifier*Rawterm.rawsort) -> unit diff --git a/contrib/funind/rawterm_to_relation.ml b/contrib/funind/rawterm_to_relation.ml index 327198b9..b6f26dfd 100644 --- a/contrib/funind/rawterm_to_relation.ml +++ b/contrib/funind/rawterm_to_relation.ml @@ -17,18 +17,11 @@ let observennl strm = then Pp.msg strm else () -(* type binder_type = *) -(* | Lambda *) -(* | Prod *) -(* | LetIn *) - -(* type raw_context = (binder_type*name*rawconstr) list *) type binder_type = | Lambda of name | Prod of name | LetIn of name -(* | LetTuple of name list * name *) type raw_context = (binder_type*rawconstr) list @@ -44,8 +37,6 @@ let compose_raw_context = | Lambda n -> mkRLambda(n,t,acc) | Prod n -> mkRProd(n,t,acc) | LetIn n -> mkRLetIn(n,t,acc) -(* | LetTuple (nal,na) -> *) -(* RLetTuple(dummy_loc,nal,(na,None),t,acc) *) in List.fold_right compose_binder @@ -145,37 +136,6 @@ let rec replace_var_by_term_in_binder x_id term = function let add_bt_names bt = List.append (ids_of_binder bt) -(* let rec replace_var_by_term_in_binder x_id term = function *) -(* | [] -> [] *) -(* | (bt,Name id,t)::l when id_ord id x_id = 0 -> *) -(* (bt,Name id,replace_var_by_term x_id term t)::l *) -(* | (bt,na,t)::l -> *) -(* (bt,na,replace_var_by_term x_id term t)::(replace_var_by_term_in_binder x_id term l) *) - -(* let rec change_vars_in_binder mapping = function *) -(* | [] -> [] *) -(* | (bt,(Name id as na),t)::l when Idmap.mem id mapping -> *) -(* (bt,na,change_vars mapping t):: l *) -(* | (bt,na,t)::l -> *) -(* (bt,na,change_vars mapping t):: *) -(* (change_vars_in_binder mapping l) *) - - -(* let alpha_ctxt avoid b = *) -(* let rec alpha_ctxt = function *) -(* | [] -> [],b *) -(* | (bt,n,t)::ctxt -> *) -(* let new_ctxt,new_b = alpha_ctxt ctxt in *) -(* match n with *) -(* | Name id when List.mem id avoid -> *) -(* let new_id = Nameops.next_ident_away id avoid in *) -(* let mapping = Idmap.add id new_id Idmap.empty in *) -(* (bt,Name new_id,t):: *) -(* (change_vars_in_binder mapping new_ctxt), *) -(* change_vars mapping new_b *) -(* | _ -> (bt,n,t)::new_ctxt,new_b *) -(* in *) -(* alpha_ctxt *) let apply_args ctxt body args = let need_convert_id avoid id = List.exists (is_free_in id) args || List.mem id avoid @@ -183,11 +143,6 @@ let apply_args ctxt body args = let need_convert avoid bt = List.exists (need_convert_id avoid) (ids_of_binder bt) in -(* let add_name na avoid = *) -(* match na with *) -(* | Anonymous -> avoid *) -(* | Name id -> id::avoid *) -(* in *) let next_name_away (na:name) (mapping: identifier Idmap.t) (avoid: identifier list) = match na with | Name id when List.mem id avoid -> @@ -206,17 +161,6 @@ let apply_args ctxt body args = | Lambda na -> let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid in Lambda new_na,mapping,new_avoid -(* | LetTuple (nal,na) -> *) -(* let rev_new_nal,mapping,new_avoid = *) -(* List.fold_left *) -(* (fun (nal,mapping,(avoid:identifier list)) na -> *) -(* let new_na,new_mapping,new_avoid = next_name_away na mapping avoid in *) -(* (new_na::nal,new_mapping,new_avoid) *) -(* ) *) -(* ([],Idmap.empty,avoid) *) -(* nal *) -(* in *) -(* (LetTuple(List.rev rev_new_nal,na),mapping,new_avoid) *) in let rec do_apply avoid ctxt body args = match ctxt,args with @@ -292,11 +236,6 @@ let combine_prod n t b = let combine_letin n t b = { context = t.context@((LetIn n,t.value)::b.context); value = b.value} -(* let combine_tuple nal na b in_e = *) -(* { *) -(* context = b.context@(LetTuple(nal,na),b.value)::in_e.context; *) -(* value = in_e.value *) -(* } *) let mk_result ctxt value avoid = { @@ -402,6 +341,77 @@ let make_pattern_eq_precond id e pat = res +let build_constructors_of_type msg ind' argl = + let (mib,ind) = Inductive.lookup_mind_specif (Global.env()) ind' in + let npar = mib.Declarations.mind_nparams in + Array.mapi (fun i _ -> + let construct = ind',i+1 in + let constructref = ConstructRef(construct) in + let _implicit_positions_of_cst = + Impargs.implicits_of_global constructref + in + let cst_narg = + Inductiveops.mis_constructor_nargs_env + (Global.env ()) + construct + in + let argl = + if argl = [] + then + Array.to_list + (Array.init (cst_narg - npar) (fun _ -> mkRHole ()) + ) + else argl + in + let pat_as_term = + mkRApp(mkRRef (ConstructRef(ind',i+1)),argl) + in +(* Pp.msgnl (str "new constructor := " ++ Printer.pr_rawconstr pat_as_term); *) + cases_pattern_of_rawconstr Anonymous pat_as_term + ) + ind.Declarations.mind_consnames + +let find_constructors_of_raw_type msg t argl : Rawterm.cases_pattern array = + let ind,args = raw_decompose_app t in + match ind with + | RRef(_,IndRef ind') -> +(* let _,ind = Global.lookup_inductive ind' in *) + build_constructors_of_type msg ind' argl + | _ -> error msg + + + +let rec find_type_of nb b = + let f,_ = raw_decompose_app b in + match f with + | RRef(_,ref) -> + begin + let ind_type = + match ref with + | VarRef _ | ConstRef _ -> + let constr_of_ref = constr_of_global ref in + let type_of_ref = Typing.type_of (Global.env ()) Evd.empty constr_of_ref in + let (_,ret_type) = Reduction.dest_prod (Global.env ()) type_of_ref in + let ret_type,_ = decompose_app ret_type in + if not (isInd ret_type) then + begin +(* Pp.msgnl (str "not an inductive" ++ pr_lconstr ret_type); *) + raise (Invalid_argument "not an inductive") + end; + destInd ret_type + | IndRef ind -> ind + | ConstructRef c -> fst c + in + let _,ind_type_info = Inductive.lookup_mind_specif (Global.env()) ind_type in + if not (Array.length ind_type_info.Declarations.mind_consnames = nb ) + then raise (Invalid_argument "find_type_of : not a valid inductive"); + ind_type + end + | RCast(_,b,_,_) -> find_type_of nb b + | RApp _ -> assert false (* we have decomposed any application via raw_decompose_app *) + | _ -> raise (Invalid_argument "not a ref") + + let rec build_entry_lc funnames avoid rt : rawconstr build_entry_return = (* Pp.msgnl (str " Entering : " ++ Printer.pr_rawconstr rt); *) match rt with @@ -466,14 +476,13 @@ let rec build_entry_lc funnames avoid rt : rawconstr build_entry_return = funnames avoid (mkRLetIn(new_n,t,mkRApp(new_b,args))) - | RCases _ | RLambda _ -> + | RCases _ | RLambda _ | RIf _ | RLetTuple _ -> let f_res = build_entry_lc funnames args_res.to_avoid f in combine_results combine_app f_res args_res | RDynamic _ ->error "Not handled RDynamic" - | RCast _ -> error "Not handled RCast" + | RCast(_,b,_,_) -> + build_entry_lc funnames avoid (mkRApp(b,args)) | RRec _ -> error "Not handled RRec" - | RIf _ -> error "Not handled RIf" - | RLetTuple _ -> error "Not handled RLetTuple" | RProd _ -> error "Cannot apply a type" end | RLambda(_,n,t,b) -> @@ -496,16 +505,88 @@ let rec build_entry_lc funnames avoid rt : rawconstr build_entry_return = | RCases(_,_,el,brl) -> let make_discr = make_discr_match brl in build_entry_lc_from_case funnames make_discr el brl avoid - | RIf _ -> error "Not handled RIf" - | RLetTuple _ -> error "Not handled RLetTuple" + | RIf(_,b,(na,e_option),lhs,rhs) -> + begin + match b with + | RCast(_,b,_,t) -> + let msg = "If construction must be used with cast" in + let case_pat = find_constructors_of_raw_type msg t [] in + assert (Array.length case_pat = 2); + let brl = + list_map_i + (fun i x -> (dummy_loc,[],[case_pat.(i)],x)) + 0 + [lhs;rhs] + in + let match_expr = + mkRCases(None,[(b,(Anonymous,None))],brl) + in +(* Pp.msgnl (str "new case := " ++ Printer.pr_rawconstr match_expr); *) + build_entry_lc funnames avoid match_expr + | _ -> + try + let ind = find_type_of 2 b in + let case_pat = build_constructors_of_type (str "") ind [] in + let brl = + list_map_i + (fun i x -> (dummy_loc,[],[case_pat.(i)],x)) + 0 + [lhs;rhs] + in + let match_expr = + mkRCases(None,[(b,(Anonymous,None))],brl) + in + (* Pp.msgnl (str "new case := " ++ Printer.pr_rawconstr match_expr); *) + build_entry_lc funnames avoid match_expr + with Invalid_argument s -> + let msg = "If construction must be used with cast : "^ s in + error msg + + end + | RLetTuple(_,nal,_,b,e) -> + begin + let nal_as_rawconstr = + List.map + (function + Name id -> mkRVar id + | Anonymous -> mkRHole () + ) + nal + in + match b with + | RCast(_,b,_,t) -> + let case_pat = + find_constructors_of_raw_type + "LetTuple construction must be used with cast" t nal_as_rawconstr in + assert (Array.length case_pat = 1); + let br = + (dummy_loc,[],[case_pat.(0)],e) + in + let match_expr = mkRCases(None,[b,(Anonymous,None)],[br]) in + build_entry_lc funnames avoid match_expr + | _ -> + try + let ind = find_type_of 1 b in + let case_pat = + build_constructors_of_type + (str "LetTuple construction must be used with cast") ind nal_as_rawconstr in + let br = + (dummy_loc,[],[case_pat.(0)],e) + in + let match_expr = mkRCases(None,[b,(Anonymous,None)],[br]) in + build_entry_lc funnames avoid match_expr + with Invalid_argument s -> + let msg = "LetTuple construction must be used with cast : "^ s in + error msg + + end | RRec _ -> error "Not handled RRec" - | RCast _ -> error "Not handled RCast" + | RCast(_,b,_,_) -> + build_entry_lc funnames avoid b | RDynamic _ -> error "Not handled RDynamic" and build_entry_lc_from_case funname make_discr - (el:(Rawterm.rawconstr * - (Names.name * (loc * Names.inductive * Names.name list) option) ) - list) - (brl:(loc * identifier list * cases_pattern list * rawconstr) list) avoid : + (el:tomatch_tuple) + (brl:Rawterm.cases_clauses) avoid : rawconstr build_entry_return = match el with | [] -> assert false (* matched on Nothing !*) @@ -521,7 +602,7 @@ and build_entry_lc_from_case funname make_discr in let results = List.map - (build_entry_lc_from_case_term funname make_discr [] brl case_resl.to_avoid) + (build_entry_lc_from_case_term funname (make_discr (List.map fst el)) [] brl case_resl.to_avoid) case_resl.result in { @@ -567,7 +648,6 @@ and build_entry_lc_from_case_term funname make_discr patterns_to_prevent brl avo avoid matched_expr in -(* let ids = List.map (fun id -> Prod (Name id),mkRHole ()) idl in *) let those_pattern_preconds = ( List.flatten ( @@ -597,7 +677,7 @@ and build_entry_lc_from_case_term funname make_discr patterns_to_prevent brl avo List.for_all (fun x -> x) unif) patterns_to_prevent then let i = List.length patterns_to_prevent in - [(Prod Anonymous,make_discr (List.map pattern_to_term patl) i )] + [(Prod Anonymous,make_discr i )] else [] ) @@ -839,6 +919,7 @@ let rec rebuild_return_type rt = let build_inductive parametrize funnames (funsargs: (Names.name * rawconstr * bool) list list) returned_types (rtl:rawconstr list) = + let _time1 = System.get_time () in (* Pp.msgnl (prlist_with_sep fnl Printer.pr_rawconstr rtl); *) let funnames_as_set = List.fold_right Idset.add funnames Idset.empty in let funnames = Array.of_list funnames in @@ -975,14 +1056,25 @@ let build_inductive parametrize funnames (funsargs: (Names.name * rawconstr * bo Impargs.make_implicit_args false; Impargs.make_strict_implicit_args false; Impargs.make_contextual_implicit_args false; + let _time2 = System.get_time () in +(* Pp.msgnl (str "Bulding Inductive : " ++ str (string_of_float (System.time_difference time1 time2))); *) try Options.silently (Command.build_mutual rel_inds) true; + let _time3 = System.get_time () in +(* Pp.msgnl (str "Bulding Done: "++ str (string_of_float (System.time_difference time2 time3))); *) +(* let msg = *) +(* str "while trying to define"++ spc () ++ *) +(* Ppvernac.pr_vernac (Vernacexpr.VernacInductive(true,rel_inds)) ++ fnl () *) +(* in *) +(* Pp.msgnl msg; *) Impargs.make_implicit_args old_implicit_args; Impargs.make_strict_implicit_args old_strict_implicit_args; Impargs.make_contextual_implicit_args old_contextual_implicit_args; Options.raw_print := old_rawprint; with - | UserError(s,msg) -> + | UserError(s,msg) -> + let _time3 = System.get_time () in +(* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) Impargs.make_implicit_args old_implicit_args; Impargs.make_strict_implicit_args old_strict_implicit_args; Impargs.make_contextual_implicit_args old_contextual_implicit_args; @@ -996,6 +1088,8 @@ let build_inductive parametrize funnames (funsargs: (Names.name * rawconstr * bo raise (UserError(s, msg)) | e -> + let _time3 = System.get_time () in +(* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) Impargs.make_implicit_args old_implicit_args; Impargs.make_strict_implicit_args old_strict_implicit_args; Impargs.make_contextual_implicit_args old_contextual_implicit_args; @@ -1010,3 +1104,4 @@ let build_inductive parametrize funnames (funsargs: (Names.name * rawconstr * bo (UserError("",msg)) + diff --git a/contrib/funind/rawtermops.ml b/contrib/funind/rawtermops.ml index 99bf2bf1..c6406468 100644 --- a/contrib/funind/rawtermops.ml +++ b/contrib/funind/rawtermops.ml @@ -68,7 +68,10 @@ let rec raw_make_or_list = function | e::l -> raw_make_or e (raw_make_or_list l) - +let remove_name_from_mapping mapping na = + match na with + | Anonymous -> mapping + | Name id -> Idmap.remove id mapping let change_vars = let rec change_vars mapping rt = @@ -88,34 +91,31 @@ let change_vars = change_vars mapping rt', List.map (change_vars mapping) rtl ) - | RLambda(_,Name id,_,_) when Idmap.mem id mapping -> rt | RLambda(loc,name,t,b) -> RLambda(loc, name, change_vars mapping t, - change_vars mapping b + change_vars (remove_name_from_mapping mapping name) b ) - | RProd(_,Name id,_,_) when Idmap.mem id mapping -> rt | RProd(loc,name,t,b) -> RProd(loc, name, change_vars mapping t, - change_vars mapping b + change_vars (remove_name_from_mapping mapping name) b ) - | RLetIn(_,Name id,_,_) when Idmap.mem id mapping -> rt | RLetIn(loc,name,def,b) -> RLetIn(loc, name, change_vars mapping def, - change_vars mapping b + change_vars (remove_name_from_mapping mapping name) b ) - | RLetTuple(_,nal,(na,_),_,_) when List.exists (function Name id -> Idmap.mem id mapping | _ -> false) (na::nal) -> rt | RLetTuple(loc,nal,(na,rto),b,e) -> + let new_mapping = List.fold_left remove_name_from_mapping mapping nal in RLetTuple(loc, - nal, - (na, option_app (change_vars mapping) rto), - change_vars mapping b, - change_vars mapping e + nal, + (na, option_map (change_vars mapping) rto), + change_vars mapping b, + change_vars new_mapping e ) | RCases(loc,infos,el,brl) -> RCases(loc, @@ -123,8 +123,14 @@ let change_vars = List.map (fun (e,x) -> (change_vars mapping e,x)) el, List.map (change_vars_br mapping) brl ) - | RIf _ -> error "Not handled RIf" - | RRec _ -> error "Not handled RRec" + | RIf(loc,b,(na,e_option),lhs,rhs) -> + RIf(loc, + change_vars mapping b, + (na,option_map (change_vars mapping) e_option), + change_vars mapping lhs, + change_vars mapping rhs + ) + | RRec _ -> error "Local (co)fixes are not supported" | RSort _ -> rt | RHole _ -> rt | RCast(loc,b,k,t) -> @@ -230,7 +236,7 @@ let rec alpha_rt excluded rt = then t,b else let replace = change_vars (Idmap.add id new_id Idmap.empty) in - (replace t,replace b) + (t,replace b) in let new_excluded = new_id::excluded in let new_t = alpha_rt new_excluded t in @@ -244,7 +250,7 @@ let rec alpha_rt excluded rt = then t,b else let replace = change_vars (Idmap.add id new_id Idmap.empty) in - (replace t,replace b) + (t,replace b) in let new_t = alpha_rt new_excluded t in let new_b = alpha_rt new_excluded b in @@ -256,7 +262,7 @@ let rec alpha_rt excluded rt = then t,b else let replace = change_vars (Idmap.add id new_id Idmap.empty) in - (replace t,replace b) + (t,replace b) in let new_excluded = new_id::excluded in let new_t = alpha_rt new_excluded t in @@ -286,18 +292,23 @@ let rec alpha_rt excluded rt = if idmap_is_empty mapping then rto,t,b else let replace = change_vars mapping in - (option_app replace rto,replace t,replace b) + (option_map replace rto, t,replace b) in let new_t = alpha_rt new_excluded new_t in let new_b = alpha_rt new_excluded new_b in - let new_rto = option_app (alpha_rt new_excluded) new_rto in + let new_rto = option_map (alpha_rt new_excluded) new_rto in RLetTuple(loc,new_nal,(na,new_rto),new_t,new_b) | RCases(loc,infos,el,brl) -> let new_el = List.map (function (rt,i) -> alpha_rt excluded rt, i) el in RCases(loc,infos,new_el,List.map (alpha_br excluded) brl) - | RIf _ -> error "Not handled RIf" + | RIf(loc,b,(na,e_o),lhs,rhs) -> + RIf(loc,alpha_rt excluded b, + (na,option_map (alpha_rt excluded) e_o), + alpha_rt excluded lhs, + alpha_rt excluded rhs + ) | RRec _ -> error "Not handled RRec" | RSort _ -> rt | RHole _ -> rt @@ -439,7 +450,7 @@ let replace_var_by_term x_id term = | RLetTuple(loc,nal,(na,rto),def,b) -> RLetTuple(loc, nal, - (na,option_app replace_var_by_pattern rto), + (na,option_map replace_var_by_pattern rto), replace_var_by_pattern def, replace_var_by_pattern b ) @@ -449,7 +460,12 @@ let replace_var_by_term x_id term = List.map (fun (e,x) -> (replace_var_by_pattern e,x)) el, List.map replace_var_by_pattern_br brl ) - | RIf _ -> raise (UserError("",str "Not handled RIf")) + | RIf(loc,b,(na,e_option),lhs,rhs) -> + RIf(loc, replace_var_by_pattern b, + (na,option_map replace_var_by_pattern e_option), + replace_var_by_pattern lhs, + replace_var_by_pattern rhs + ) | RRec _ -> raise (UserError("",str "Not handled RRec")) | RSort _ -> rt | RHole _ -> rt diff --git a/contrib/funind/rawtermops.mli b/contrib/funind/rawtermops.mli index 92df0ec6..5dcdb15c 100644 --- a/contrib/funind/rawtermops.mli +++ b/contrib/funind/rawtermops.mli @@ -22,10 +22,7 @@ val mkRApp : rawconstr*(rawconstr list) -> rawconstr val mkRLambda : Names.name*rawconstr*rawconstr -> rawconstr val mkRProd : Names.name*rawconstr*rawconstr -> rawconstr val mkRLetIn : Names.name*rawconstr*rawconstr -> rawconstr -val mkRCases : rawconstr option * - (rawconstr * (Names.name * (Util.loc * Names.inductive * Names.name list) option)) list * - (Util.loc * Names.identifier list * cases_pattern list * rawconstr) list -> - rawconstr +val mkRCases : rawconstr option * tomatch_tuple * cases_clauses -> rawconstr val mkRSort : rawsort -> rawconstr val mkRHole : unit -> rawconstr (* we only build Evd.BinderType Anonymous holes *) diff --git a/contrib/funind/tacinv.ml4 b/contrib/funind/tacinv.ml4 index c2410d55..2c7e4d33 100644 --- a/contrib/funind/tacinv.ml4 +++ b/contrib/funind/tacinv.ml4 @@ -378,7 +378,7 @@ let rec proofPrinc mi: constr funind = (* <pcase> Cases b of arrPt end.*) | Case (cinfo, pcase, b, arrPt) -> let prod_pcase,_ = decompose_lam pcase in - let nmeb,_ = List.hd prod_pcase in + let _nmeb,_ = List.hd prod_pcase in let newb'= apply_leqtrpl_t b mi.lst_eqs in let type_of_b = Typing.type_of mi.env mi.sigma b in (* Replace the recursive calls to the function by calls to the constant *) @@ -428,7 +428,7 @@ let rec proofPrinc mi: constr funind = let varnames = List.map snd mi.lst_vars in let nb_vars = List.length varnames in let nb_eqs = List.length mi.lst_eqs in - let eqrels = List.map fst mi.lst_eqs in + let _eqrels = List.map fst mi.lst_eqs in (* [terms_recs]: appel rec du fixpoint, On concatčne les appels recs trouvés dans les let in et les Cases avec ceux trouves dans u (ie mi.mimick). *) @@ -772,11 +772,6 @@ let invfun_verif c l dorew gl = else error "wrong number of arguments for the function" -TACTIC EXTEND functional_induction - [ "functional" "induction" constr(c) ne_constr_list(l) ] - -> [ invfun_verif c l true ] -END - (* Construction of the functional scheme. *) @@ -847,15 +842,20 @@ let declareFunScheme f fname mutflist = +TACTIC EXTEND functional_induction + [ "old" "functional" "induction" constr(c) ne_constr_list(l) ] + -> [ invfun_verif c l true ] +END + VERNAC COMMAND EXTEND FunctionalScheme - [ "Functional" "Scheme" ident(na) ":=" "Induction" "for" + [ "Old" "Functional" "Scheme" ident(na) ":=" "Induction" "for" ident(c) "with" ne_ident_list(l) ] -> [ declareFunScheme c na l ] -| [ "Functional" "Scheme" ident(na) ":=" "Induction" "for" ident (c) ] +| [ "Old" "Functional" "Scheme" ident(na) ":=" "Induction" "for" ident (c) ] -> [ declareFunScheme c na [] ] END - + diff --git a/contrib/interface/ascent.mli b/contrib/interface/ascent.mli index fb71288a..8f880a76 100644 --- a/contrib/interface/ascent.mli +++ b/contrib/interface/ascent.mli @@ -685,8 +685,8 @@ and ct_TACTIC_COM = | CT_rename of ct_ID * ct_ID | CT_repeat of ct_TACTIC_COM | CT_replace_with of ct_FORMULA * ct_FORMULA * ct_ID_OPT * ct_TACTIC_OPT - | CT_rewrite_lr of ct_FORMULA * ct_SPEC_LIST * ct_ID_OPT - | CT_rewrite_rl of ct_FORMULA * ct_SPEC_LIST * ct_ID_OPT + | CT_rewrite_lr of ct_FORMULA * ct_SPEC_LIST * ct_CLAUSE + | CT_rewrite_rl of ct_FORMULA * ct_SPEC_LIST * ct_CLAUSE | CT_right of ct_SPEC_LIST | CT_ring of ct_FORMULA_LIST | CT_simple_user_tac of ct_ID * ct_TACTIC_ARG_LIST diff --git a/contrib/interface/blast.ml b/contrib/interface/blast.ml index 21f977f1..9e450068 100644 --- a/contrib/interface/blast.ml +++ b/contrib/interface/blast.ml @@ -86,7 +86,7 @@ let rec def_const_in_term_rec vl x = | Sort(c) -> c | Ind(ind) -> let (mib, mip) = Global.lookup_inductive ind in - mip.mind_sort + new_sort_in_family (inductive_sort_family mip) | Construct(c) -> def_const_in_term_rec vl (mkInd (inductive_of_constructor c)) | Case(_,x,t,a) diff --git a/contrib/interface/debug_tac.ml4 b/contrib/interface/debug_tac.ml4 index 56abfb82..e1b8e712 100644 --- a/contrib/interface/debug_tac.ml4 +++ b/contrib/interface/debug_tac.ml4 @@ -239,9 +239,9 @@ and checked_then: report_holder -> glob_tactic_expr -> glob_tactic_expr -> tacti by the list of integers given as extra arguments. *) -let rawwit_main_tactic = rawwit_tactic Pcoq.Tactic.tactic_main_level -let globwit_main_tactic = globwit_tactic Pcoq.Tactic.tactic_main_level -let wit_main_tactic = wit_tactic Pcoq.Tactic.tactic_main_level +let rawwit_main_tactic = Pcoq.rawwit_tactic Pcoq.tactic_main_level +let globwit_main_tactic = Pcoq.globwit_tactic Pcoq.tactic_main_level +let wit_main_tactic = Pcoq.wit_tactic Pcoq.tactic_main_level let on_then = function [t1;t2;l] -> diff --git a/contrib/interface/showproof.ml b/contrib/interface/showproof.ml index b7da5c1b..ce2ee1e7 100644 --- a/contrib/interface/showproof.ml +++ b/contrib/interface/showproof.ml @@ -719,7 +719,7 @@ let rec nsortrec vl x = | Sort(c) -> c | Ind(ind) -> let (mib,mip) = lookup_mind_specif vl ind in - mip.mind_sort + new_sort_in_family (inductive_sort_family mip) | Construct(c) -> nsortrec vl (mkInd (inductive_of_constructor c)) | Case(_,x,t,a) diff --git a/contrib/interface/vtp.ml b/contrib/interface/vtp.ml index 5a7ccc26..064d20ab 100644 --- a/contrib/interface/vtp.ml +++ b/contrib/interface/vtp.ml @@ -1717,12 +1717,12 @@ and fTACTIC_COM = function | CT_rewrite_lr(x1, x2, x3) -> fFORMULA x1; fSPEC_LIST x2; - fID_OPT x3; + fCLAUSE x3; fNODE "rewrite_lr" 3 | CT_rewrite_rl(x1, x2, x3) -> fFORMULA x1; fSPEC_LIST x2; - fID_OPT x3; + fCLAUSE x3; fNODE "rewrite_rl" 3 | CT_right(x1) -> fSPEC_LIST x1; diff --git a/contrib/interface/xlate.ml b/contrib/interface/xlate.ml index da87086e..ecb04e07 100644 --- a/contrib/interface/xlate.ml +++ b/contrib/interface/xlate.ml @@ -113,8 +113,16 @@ let nums_to_int_list_aux l = List.map (fun x -> CT_int x) l;; let nums_to_int_list l = CT_int_list(nums_to_int_list_aux l);; -let nums_to_int_ne_list n l = - CT_int_ne_list(CT_int n, nums_to_int_list_aux l);; +let num_or_var_to_int = function + | ArgArg x -> CT_int x + | _ -> xlate_error "TODO: nums_to_int_list_aux ArgVar";; + +let nums_or_var_to_int_list_aux l = List.map num_or_var_to_int l;; + +let nums_or_var_to_int_list l = CT_int_list(nums_or_var_to_int_list_aux l);; + +let nums_or_var_to_int_ne_list n l = + CT_int_ne_list(num_or_var_to_int n, nums_or_var_to_int_list_aux l);; type iTARG = Targ_command of ct_FORMULA | Targ_intropatt of ct_INTRO_PATT_LIST @@ -298,9 +306,11 @@ let rec decompose_last = function let make_fix_struct (n,bl) = let names = names_of_local_assums bl in let nn = List.length names in - if nn = 1 then ctv_ID_OPT_NONE - else if n < nn then xlate_id_opt(List.nth names n) - else xlate_error "unexpected result of parsing for Fixpoint";; + if nn = 1 || n = None then ctv_ID_OPT_NONE + else + let n = out_some n in + if n < nn then xlate_id_opt(List.nth names n) + else xlate_error "unexpected result of parsing for Fixpoint";; let rec xlate_binder = function @@ -417,7 +427,10 @@ and (xlate_formula:Topconstr.constr_expr -> Ascent.ct_FORMULA) = function | CFix (_, (_, id), lm::lmi) -> let strip_mutrec (fid, (n, ro), bl, arf, ardef) = let (struct_arg,bl,arf,ardef) = + (* Pierre L: could the case [n=None && bl=[]] happen ? Normally not *) + (* By the way, how could [bl = []] happen in V8 syntax ? *) if bl = [] then + let n = out_some n in let (bl,arf,ardef) = Ppconstr.split_fix (n+1) arf ardef in (xlate_id_opt(List.nth (names_of_local_assums bl) n),bl,arf,ardef) else (make_fix_struct (n, bl),bl,arf,ardef) in @@ -469,18 +482,19 @@ let xlate_hyp = function let xlate_hyp_location = function - | AI (_,id), nums, InHypTypeOnly -> - CT_intype(xlate_ident id, nums_to_int_list nums) - | AI (_,id), nums, InHypValueOnly -> - CT_invalue(xlate_ident id, nums_to_int_list nums) - | AI (_,id), [], InHyp -> + | (nums, AI (_,id)), InHypTypeOnly -> + CT_intype(xlate_ident id, nums_or_var_to_int_list nums) + | (nums, AI (_,id)), InHypValueOnly -> + CT_invalue(xlate_ident id, nums_or_var_to_int_list nums) + | ([], AI (_,id)), InHyp -> CT_coerce_UNFOLD_to_HYP_LOCATION (CT_coerce_ID_to_UNFOLD (xlate_ident id)) - | AI (_,id), a::l, InHyp -> + | (a::l, AI (_,id)), InHyp -> CT_coerce_UNFOLD_to_HYP_LOCATION (CT_unfold_occ (xlate_ident id, - CT_int_ne_list(CT_int a, nums_to_int_list_aux l))) - | MetaId _, _,_ -> + CT_int_ne_list(num_or_var_to_int a, + nums_or_var_to_int_list_aux l))) + | (_, MetaId _),_ -> xlate_error "MetaId not supported in xlate_hyp_location (should occur only in quotations)" let xlate_clause cls = @@ -661,13 +675,14 @@ let xlate_using = function let xlate_one_unfold_block = function ([],qid) -> CT_coerce_ID_to_UNFOLD(tac_qualid_to_ct_ID qid) | (n::nums, qid) -> - CT_unfold_occ(tac_qualid_to_ct_ID qid, nums_to_int_ne_list n nums);; + CT_unfold_occ(tac_qualid_to_ct_ID qid, nums_or_var_to_int_ne_list n nums) +;; let xlate_with_names = function IntroAnonymous -> CT_coerce_ID_OPT_to_INTRO_PATT_OPT ctv_ID_OPT_NONE | fp -> CT_coerce_INTRO_PATT_to_INTRO_PATT_OPT (xlate_intro_pattern fp) -let rawwit_main_tactic = rawwit_tactic Pcoq.Tactic.tactic_main_level +let rawwit_main_tactic = Pcoq.rawwit_tactic Pcoq.tactic_main_level let rec (xlate_tacarg:raw_tactic_arg -> ct_TACTIC_ARG) = function @@ -723,7 +738,7 @@ and xlate_red_tactic = CT_simpl (CT_coerce_PATTERN_to_PATTERN_OPT (CT_pattern_occ - (CT_int_list(List.map (fun n -> CT_int n) l), xlate_formula c))) + (CT_int_list(nums_or_var_to_int_list_aux l), xlate_formula c))) | Cbv flag_list -> let conv_flags, red_ids = get_flag flag_list in CT_cbv (CT_conversion_flag_list conv_flags, red_ids) @@ -740,7 +755,7 @@ and xlate_red_tactic = | Pattern l -> let pat_list = List.map (fun (nums,c) -> CT_pattern_occ - (CT_int_list (List.map (fun x -> CT_int x) nums), + (CT_int_list (nums_or_var_to_int_list_aux nums), xlate_formula c)) l in (match pat_list with | first :: others -> CT_pattern (CT_pattern_ne_list (first, others)) @@ -898,7 +913,7 @@ and xlate_tac = | TacChange (Some(l,c), f, b) -> (* TODO LATER: combine with other constructions of pattern_occ *) CT_change_local( - CT_pattern_occ(CT_int_list(List.map (fun n -> CT_int n) l), + CT_pattern_occ(CT_int_list(nums_or_var_to_int_list_aux l), xlate_formula c), xlate_formula f, xlate_clause b) @@ -973,19 +988,12 @@ and xlate_tac = CT_coerce_TACTIC_COM_to_TACTIC_OPT tac in CT_replace_with (c1, c2,id_opt,tac_opt) - | TacExtend (_,"rewrite", [b; cbindl]) -> - let b = out_gen Extraargs.rawwit_orient b in - let (c,bindl) = out_gen rawwit_constr_with_bindings cbindl in - let c = xlate_formula c and bindl = xlate_bindings bindl in - if b then CT_rewrite_lr (c, bindl, ctv_ID_OPT_NONE) - else CT_rewrite_rl (c, bindl, ctv_ID_OPT_NONE) - | TacExtend (_,"rewrite_in", [b; cbindl; id]) -> - let b = out_gen Extraargs.rawwit_orient b in - let (c,bindl) = out_gen rawwit_constr_with_bindings cbindl in - let c = xlate_formula c and bindl = xlate_bindings bindl in - let id = ctf_ID_OPT_SOME (xlate_ident (snd (out_gen rawwit_var id))) in - if b then CT_rewrite_lr (c, bindl, id) - else CT_rewrite_rl (c, bindl, id) + | TacRewrite(b,cbindl,cl) -> + let cl = xlate_clause cl + and c = xlate_formula (fst cbindl) + and bindl = xlate_bindings (snd cbindl) in + if b then CT_rewrite_lr (c, bindl, cl) + else CT_rewrite_rl (c, bindl, cl) | TacExtend (_,"conditional_rewrite", [t; b; cbindl]) -> let t = out_gen rawwit_main_tactic t in let b = out_gen Extraargs.rawwit_orient b in @@ -1094,7 +1102,7 @@ and xlate_tac = List.map (fun x -> CT_ident x) l)))) | TacExtend (_,"prolog", [cl; n]) -> let cl = List.map xlate_formula (out_gen (wit_list0 rawwit_constr) cl) in - (match out_gen wit_int_or_var n with + (match out_gen rawwit_int_or_var n with | ArgVar _ -> xlate_error "" | ArgArg n -> CT_prolog (CT_formula_list cl, CT_int n)) | TacExtend (_,"eapply", [cbindl]) -> @@ -1263,14 +1271,15 @@ and coerce_genarg_to_TARG x = (CT_coerce_FORMULA_to_SCOMMENT_CONTENT (xlate_formula (out_gen rawwit_constr x))) | ConstrMayEvalArgType -> xlate_error"TODO: generic constr-may-eval argument" | QuantHypArgType ->xlate_error"TODO: generic quantified hypothesis argument" - | TacticArgType n -> - let t = xlate_tactic (out_gen (rawwit_tactic n) x) in - CT_coerce_TACTIC_COM_to_TARG t | OpenConstrArgType b -> CT_coerce_SCOMMENT_CONTENT_to_TARG (CT_coerce_FORMULA_to_SCOMMENT_CONTENT(xlate_formula (snd (out_gen (rawwit_open_constr_gen b) x)))) + | ExtraArgType s as y when Pcoq.is_tactic_genarg y -> + let n = out_some (Pcoq.tactic_genarg_level s) in + let t = xlate_tactic (out_gen (Pcoq.rawwit_tactic n) x) in + CT_coerce_TACTIC_COM_to_TARG t | ConstrWithBindingsArgType -> xlate_error "TODO: generic constr with bindings" | BindingsArgType -> xlate_error "TODO: generic with bindings" | RedExprArgType -> xlate_error "TODO: generic red expr" @@ -1360,8 +1369,9 @@ let coerce_genarg_to_VARG x = (CT_coerce_FORMULA_to_FORMULA_OPT (xlate_formula (out_gen rawwit_constr x))) | ConstrMayEvalArgType -> xlate_error"TODO: generic constr-may-eval argument" | QuantHypArgType ->xlate_error"TODO: generic quantified hypothesis argument" - | TacticArgType n -> - let t = xlate_tactic (out_gen (rawwit_tactic n) x) in + | ExtraArgType s as y when Pcoq.is_tactic_genarg y -> + let n = out_some (Pcoq.tactic_genarg_level s) in + let t = xlate_tactic (out_gen (Pcoq.rawwit_tactic n) x) in CT_coerce_TACTIC_OPT_to_VARG (CT_coerce_TACTIC_COM_to_TACTIC_OPT t) | OpenConstrArgType _ -> xlate_error "TODO: generic open constr" | ConstrWithBindingsArgType -> xlate_error "TODO: generic constr with bindings" @@ -1813,7 +1823,7 @@ let rec xlate_vernac = CT_theorem_goal (CT_coerce_THM_to_DEFN_OR_THM (xlate_thm k), xlate_ident s, xlate_binder_list bl, xlate_formula c)) | VernacSuspend -> CT_suspend - | VernacResume idopt -> CT_resume (xlate_ident_opt (option_app snd idopt)) + | VernacResume idopt -> CT_resume (xlate_ident_opt (option_map snd idopt)) | VernacDefinition (k,(_,s),ProveBody (bl,typ),_) -> CT_coerce_THEOREM_GOAL_to_COMMAND (CT_theorem_goal @@ -1855,7 +1865,7 @@ let rec xlate_vernac = (_, (add_coercion, (_,s)), binders, c1, rec_constructor_or_none, field_list) -> let record_constructor = - xlate_ident_opt (option_app snd rec_constructor_or_none) in + xlate_ident_opt (option_map snd rec_constructor_or_none) in CT_record ((if add_coercion then CT_coercion_atm else CT_coerce_NONE_to_COERCION_OPT(CT_none)), @@ -1875,7 +1885,10 @@ let rec xlate_vernac = | VernacFixpoint ((lm :: lmi),boxed) -> let strip_mutrec ((fid, (n, ro), bl, arf, ardef), ntn) = let (struct_arg,bl,arf,ardef) = + (* Pierre L: could the case [n=None && bl=[]] happen ? Normally not *) + (* By the way, how could [bl = []] happen in V8 syntax ? *) if bl = [] then + let n = out_some n in let (bl,arf,ardef) = Ppconstr.split_fix (n+1) arf ardef in (xlate_id_opt(List.nth (names_of_local_assums bl) n),bl,arf,ardef) else (make_fix_struct (n, bl),bl,arf,ardef) in diff --git a/contrib/omega/coq_omega.ml b/contrib/omega/coq_omega.ml index ee3301d7..da0817d1 100644 --- a/contrib/omega/coq_omega.ml +++ b/contrib/omega/coq_omega.ml @@ -13,7 +13,7 @@ (* *) (**************************************************************************) -(* $Id: coq_omega.ml 7837 2006-01-11 09:47:32Z herbelin $ *) +(* $Id: coq_omega.ml 8934 2006-06-09 14:30:12Z herbelin $ *) open Util open Pp @@ -162,10 +162,12 @@ let hide_constr,find_constr,clear_tables,dump_tables = open Coqlib let logic_dir = ["Coq";"Logic";"Decidable"] +let init_arith_modules = init_modules @ arith_modules let coq_modules = - init_modules @ [logic_dir] @ arith_modules @ zarith_base_modules + init_arith_modules @ [logic_dir] @ zarith_base_modules @ [["Coq"; "omega"; "OmegaLemmas"]] +let init_arith_constant = gen_constant_in_modules "Omega" init_arith_modules let constant = gen_constant_in_modules "Omega" coq_modules (* Zarith *) @@ -268,17 +270,17 @@ let coq_Zge = lazy (constant "Zge") let coq_Zlt = lazy (constant "Zlt") (* Peano/Datatypes *) -let coq_le = lazy (constant "le") -let coq_lt = lazy (constant "lt") -let coq_ge = lazy (constant "ge") -let coq_gt = lazy (constant "gt") -let coq_minus = lazy (constant "minus") -let coq_plus = lazy (constant "plus") -let coq_mult = lazy (constant "mult") -let coq_pred = lazy (constant "pred") -let coq_nat = lazy (constant "nat") -let coq_S = lazy (constant "S") -let coq_O = lazy (constant "O") +let coq_le = lazy (init_arith_constant "le") +let coq_lt = lazy (init_arith_constant "lt") +let coq_ge = lazy (init_arith_constant "ge") +let coq_gt = lazy (init_arith_constant "gt") +let coq_minus = lazy (init_arith_constant "minus") +let coq_plus = lazy (init_arith_constant "plus") +let coq_mult = lazy (init_arith_constant "mult") +let coq_pred = lazy (init_arith_constant "pred") +let coq_nat = lazy (init_arith_constant "nat") +let coq_S = lazy (init_arith_constant "S") +let coq_O = lazy (init_arith_constant "O") (* Compare_dec/Peano_dec/Minus *) let coq_pred_of_minus = lazy (constant "pred_of_minus") diff --git a/contrib/recdef/recdef.ml4 b/contrib/recdef/recdef.ml4 index cf09e63a..ed2e5b5f 100644 --- a/contrib/recdef/recdef.ml4 +++ b/contrib/recdef/recdef.ml4 @@ -46,20 +46,35 @@ open Eauto open Genarg +let qed () = Command.save_named true +let defined () = Command.save_named false + +let pf_get_new_ids idl g = + let ids = pf_ids_of_hyps g in + List.fold_right + (fun id acc -> next_global_ident_away false id (acc@ids)::acc) + idl + [] + +let pf_get_new_id id g = + List.hd (pf_get_new_ids [id] g) + let h_intros l = tclMAP h_intro l let do_observe_tac s tac g = - let goal = begin try (Printer.pr_goal (sig_it g)) with _ -> assert false end in + let goal = begin (Printer.pr_goal (sig_it g)) end in try let v = tac g in msgnl (goal ++ fnl () ++ (str s)++(str " ")++(str "finished")); v with e -> msgnl (str "observation "++str s++str " raised exception " ++ - Cerrors.explain_exn e ++ str "on goal " ++ goal ); + Cerrors.explain_exn e ++ str " on goal " ++ goal ); raise e;; -let observe_tac s tac g = tac g - +let observe_tac s tac g = + if Tacinterp.get_debug () <> Tactic_debug.DebugOff + then do_observe_tac s tac g + else tac g let hyp_ids = List.map id_of_string ["x";"v";"k";"def";"p";"h";"n";"h'"; "anonymous"; "teq"; "rec_res"; @@ -96,8 +111,11 @@ let def_of_const t = (try (match (Global.lookup_constant sp) with {const_body=Some c} -> Declarations.force c |_ -> assert false) - with _ -> anomaly ("Cannot find definition of constant "^(string_of_id (id_of_label (con_label sp))))) - |_ -> assert false + with _ -> + anomaly ("Cannot find definition of constant "^ + (string_of_id (id_of_label (con_label sp)))) + ) + |_ -> assert false let type_of_const t = match (kind_of_term t) with @@ -121,7 +139,6 @@ let rec (find_call_occs: fun f expr -> match (kind_of_term expr) with App (g, args) when g = f -> - (* For now we suppose that the function takes only one argument. *) (fun l -> List.hd l), [Array.to_list args] | App (g, args) -> let (largs: constr list) = Array.to_list args in @@ -222,8 +239,8 @@ let lt = function () -> (coq_constant "lt") let mkCaseEq a : tactic = (fun g -> -(* commentaire de Yves: on pourra avoir des problemes si - a n'est pas bien type dans l'environnement du but *) + (* commentaire de Yves: on pourra avoir des problemes si + a n'est pas bien type dans l'environnement du but *) let type_of_a = pf_type_of g a in (tclTHEN (generalize [mkApp(delayed_force refl_equal, [| type_of_a; a|])]) (tclTHEN @@ -235,7 +252,6 @@ let mkCaseEq a : tactic = let rec mk_intros_and_continue (extra_eqn:bool) cont_function (eqs:constr list) (expr:constr) g = - let ids = pf_ids_of_hyps g in match kind_of_term expr with | Lambda (n, _, b) -> let n1 = @@ -243,15 +259,19 @@ let rec mk_intros_and_continue (extra_eqn:bool) Name x -> x | Anonymous -> ano_id in - let new_n = next_global_ident_away true n1 ids in + let new_n = pf_get_new_id n1 g in tclTHEN (h_intro new_n) (mk_intros_and_continue extra_eqn cont_function eqs (subst1 (mkVar new_n) b)) g | _ -> if extra_eqn then - let teq = next_global_ident_away true teq_id ids in - tclTHEN (h_intro teq) - (cont_function (mkVar teq::eqs) expr) g + let teq = pf_get_new_id teq_id g in + tclTHENLIST + [ h_intro teq; + tclMAP (fun eq -> tclTRY (Equality.general_rewrite_in true teq eq)) (List.rev eqs); + cont_function (mkVar teq::eqs) expr + ] + g else cont_function eqs expr g @@ -291,13 +311,15 @@ let list_rewrite (rev:bool) (eqs: constr list) = let base_leaf_terminate (func:global_reference) eqs expr = (* let _ = msgnl (str "entering base_leaf") in *) (fun g -> - let ids = pf_ids_of_hyps g in - let k' = next_global_ident_away true k_id ids in - let h = next_global_ident_away true h_id (k'::ids) in - tclTHENLIST [observe_tac "first split" (split (ImplicitBindings [expr])); - observe_tac "second split" (split (ImplicitBindings [delayed_force coq_O])); - observe_tac "intro k" (h_intro k'); - observe_tac "case on k" + let k',h = + match pf_get_new_ids [k_id;h_id] g with + [k';h] -> k',h + | _ -> assert false + in + tclTHENLIST [observe_tac "first split" (split (ImplicitBindings [expr])); + observe_tac "second split" (split (ImplicitBindings [delayed_force coq_O])); + observe_tac "intro k" (h_intro k'); + observe_tac "case on k" (tclTHENS (simplest_case (mkVar k')) [(tclTHEN (h_intro h) @@ -305,17 +327,17 @@ let base_leaf_terminate (func:global_reference) eqs expr = (mkApp (delayed_force gt_antirefl, [| delayed_force coq_O |]))) default_auto)); tclIDTAC ]); - intros; - - simpl_iter(); - unfold_constr func; - list_rewrite true eqs; - default_auto ] g);; + intros; + simpl_iter(); + unfold_constr func; + list_rewrite true eqs; + default_auto ] g);; (* La fonction est donnee en premier argument a la fonctionnelle suivie d'autres Lambdas et de Case ... Pour recuperer la fonction f a partir de la fonctionnelle *) + let get_f foncl = match (kind_of_term (def_of_const foncl)) with Lambda (Name f, _, _) -> f @@ -345,14 +367,15 @@ let rec list_cond_rewrite k def pmax cond_eqs le_proofs = match cond_eqs with [] -> tclIDTAC | eq::eqs -> - tclTHENS - (general_rewrite_bindings false - (mkVar eq, - ExplicitBindings[dummy_loc, NamedHyp k_id, mkVar k; - dummy_loc, NamedHyp def_id, mkVar def])) - [list_cond_rewrite k def pmax eqs le_proofs; - make_lt_proof pmax le_proofs];; - + (fun g -> + tclTHENS + (general_rewrite_bindings false + (mkVar eq, + ExplicitBindings[dummy_loc, NamedHyp k_id, mkVar k; + dummy_loc, NamedHyp def_id, mkVar def])) + [list_cond_rewrite k def pmax eqs le_proofs; + make_lt_proof pmax le_proofs] g + ) let rec introduce_all_equalities func eqs values specs bound le_proofs cond_eqs = @@ -371,16 +394,21 @@ let rec introduce_all_equalities func eqs values specs bound le_proofs observe_tac "introduce_all_equalities_final intro k" (h_intro k); tclTHENS (observe_tac "introduce_all_equalities_final case k" (simplest_case (mkVar k))) - [tclTHENLIST[h_intro h'; - simplest_elim(mkApp(delayed_force lt_n_O,[|s_max|])); - default_full_auto]; tclIDTAC]; + [ + tclTHENLIST[h_intro h'; + simplest_elim(mkApp(delayed_force lt_n_O,[|s_max|])); + default_full_auto]; + tclIDTAC + ]; observe_tac "clearing k " (clear [k]); - h_intros [k;h';def]; - simpl_iter(); - unfold_in_concl[([1],evaluable_of_global_reference func)]; - list_rewrite true eqs; - list_cond_rewrite k def bound cond_eqs le_proofs; - apply (delayed_force refl_equal)] g + observe_tac "intros k h' def" (h_intros [k;h';def]); + observe_tac "simple_iter" (simpl_iter()); + observe_tac "unfold functional" + (unfold_in_concl[([1],evaluable_of_global_reference func)]); + observe_tac "rewriting equations" + (list_rewrite true eqs); + observe_tac "cond rewrite" (list_cond_rewrite k def bound cond_eqs le_proofs); + observe_tac "refl equal" (apply (delayed_force refl_equal))] g | spec1::specs -> fun g -> let ids = ids_of_named_context (pf_hyps g) in @@ -406,19 +434,15 @@ let rec introduce_all_equalities func eqs values specs bound le_proofs let string_match s = try for i = 0 to 3 do - if String.get s i <> String.get "Acc_" i then failwith "" + if String.get s i <> String.get "Acc_" i then failwith "string_match" done; - with Invalid_argument _ -> failwith "" + with Invalid_argument _ -> failwith "string_match" let retrieve_acc_var g = (* Julien: I don't like this version .... *) let hyps = pf_ids_of_hyps g in map_succeed - (fun id -> - try - string_match (string_of_id id); - id - with _ -> failwith "") + (fun id -> string_match (string_of_id id);id) hyps let rec introduce_all_values is_mes acc_inv func context_fn @@ -426,8 +450,8 @@ let rec introduce_all_values is_mes acc_inv func context_fn (match args with [] -> tclTHENLIST - [split(ImplicitBindings - [context_fn (List.map mkVar (List.rev values))]); + [observe_tac "split" (split(ImplicitBindings + [context_fn (List.map mkVar (List.rev values))])); observe_tac "introduce_all_equalities" (introduce_all_equalities func eqs (List.rev values) (List.rev specs) (delayed_force coq_O) [] [])] | arg::args -> @@ -436,23 +460,25 @@ let rec introduce_all_values is_mes acc_inv func context_fn let rec_res = next_global_ident_away true rec_res_id ids in let ids = rec_res::ids in let hspec = next_global_ident_away true hspec_id ids in - let tac = introduce_all_values is_mes acc_inv func context_fn eqs - hrec args - (rec_res::values)(hspec::specs) in + let tac = + observe_tac "introduce_all_values" ( + introduce_all_values is_mes acc_inv func context_fn eqs + hrec args + (rec_res::values)(hspec::specs)) in (tclTHENS - (simplest_elim (mkApp(mkVar hrec, Array.of_list arg))) + (observe_tac "elim h_rec" (simplest_elim (mkApp(mkVar hrec, Array.of_list arg)))) [tclTHENLIST [h_intros [rec_res; hspec]; tac]; (tclTHENS - (apply (Lazy.force acc_inv)) - [ h_assumption + (observe_tac "acc_inv" (apply (Lazy.force acc_inv))) + [ observe_tac "h_assumption" h_assumption ; - (fun g -> - tclUSER - is_mes - (Some (hrec::hspec::(retrieve_acc_var g)@specs)) - g - ) + observe_tac "user proof" (fun g -> + tclUSER + is_mes + (Some (hrec::hspec::(retrieve_acc_var g)@specs)) + g + ) ] ) ]) g) @@ -466,48 +492,6 @@ let rec_leaf_terminate is_mes acc_inv hrec (func:global_reference) eqs expr = observe_tac "introduce_all_values" (introduce_all_values is_mes acc_inv func context_fn eqs hrec args [] []) -(* -let rec proveterminate is_mes acc_inv (hrec:identifier) - (f_constr:constr) (func:global_reference) (eqs:constr list) (expr:constr) = -try -(* let _ = msgnl (str "entering proveterminate") in *) - let v = - match (kind_of_term expr) with - Case (_, t, a, l) -> - (match find_call_occs f_constr a with - _,[] -> - tclTHENS (fun g -> -(* let _ = msgnl(str "entering mkCaseEq") in *) - let v = (mkCaseEq a) g in -(* let _ = msgnl (str "exiting mkCaseEq") in *) - v - ) - (List.map (mk_intros_and_continue true - (proveterminate is_mes acc_inv hrec f_constr func) - eqs) - (Array.to_list l)) - | _, _::_ -> - ( - match find_call_occs f_constr expr with - _,[] -> observe_tac "base_leaf" (base_leaf func eqs expr) - | _, _:: _ -> - observe_tac "rec_leaf" (rec_leaf is_mes acc_inv hrec func eqs expr) - ) - ) - | _ -> (match find_call_occs f_constr expr with - _,[] -> - (try - observe_tac "base_leaf" (base_leaf func eqs expr) - with e -> (msgerrnl (str "failure in base case");raise e )) - | _, _::_ -> - observe_tac "rec_leaf" (rec_leaf is_mes acc_inv hrec func eqs expr) - ) in - (* let _ = msgnl(str "exiting proveterminate") in *) - v -with e -> - msgerrnl(str "failure in proveterminate"); - raise e -*) let proveterminate is_mes acc_inv (hrec:identifier) (f_constr:constr) (func:global_reference) base_leaf rec_leaf = let rec proveterminate (eqs:constr list) (expr:constr) = @@ -551,8 +535,10 @@ let proveterminate is_mes acc_inv (hrec:identifier) (* let _ = msgnl(str "exiting proveterminate") in *) v with e -> - msgerrnl(str "failure in proveterminate"); - raise e + begin + msgerrnl(str "failure in proveterminate"); + raise e + end in proveterminate @@ -691,7 +677,7 @@ let whole_start is_mes func input_type relation rec_arg_num : tactic = let f_id = match f_name with | Name f_id -> next_global_ident_away true f_id ids - | Anonymous -> assert false + | Anonymous -> anomaly "Anonymous function" in let n_names_types,_ = decompose_lam body1 in let n_ids,ids = @@ -701,7 +687,7 @@ let whole_start is_mes func input_type relation rec_arg_num : tactic = | Name id -> let n_id = next_global_ident_away true id ids in n_id::n_ids,n_id::ids - | _ -> assert false + | _ -> anomaly "anonymous argument" ) ([],(f_id::ids)) n_names_types @@ -747,7 +733,7 @@ let build_and_l l = let mk_and p1 p2 = Term.mkApp(and_constr,[|p1;p2|]) in let rec f = function - | [] -> assert false + | [] -> failwith "empty list of subgoals!" | [p] -> p,tclIDTAC,1 | p1::pl -> let c,tac,nb = f pl in @@ -765,43 +751,6 @@ let build_new_goal_type () = res - -let interpretable_as_section_decl d1 d2 = match d1,d2 with - | (_,Some _,_), (_,None,_) -> false - | (_,Some b1,t1), (_,Some b2,t2) -> eq_constr b1 b2 & eq_constr t1 t2 - | (_,None,t1), (_,_,t2) -> eq_constr t1 t2 - - - - -(* let final_decompose lemma n : tactic = *) -(* fun gls -> *) -(* let hid = next_global_ident_away true h_id (pf_ids_of_hyps gls) in *) -(* tclTHENSEQ *) -(* [ *) -(* generalize [lemma]; *) -(* tclDO *) -(* n *) -(* (tclTHENSEQ *) -(* [h_intro hid; *) -(* h_case (mkVar hid,Rawterm.NoBindings); *) -(* clear [hid]; *) -(* intro_patterns [Genarg.IntroWildcard] *) -(* ] *) -(* ); *) -(* h_intro hid; *) -(* tclTRY *) -(* (tclTHENSEQ [h_case (mkVar hid,Rawterm.NoBindings); *) -(* clear [hid]; *) -(* h_intro hid; *) -(* intro_patterns [Genarg.IntroWildcard] *) -(* ]); *) -(* e_resolve_constr (mkVar hid); *) -(* e_assumption *) -(* ] *) -(* gls *) - - let prove_with_tcc lemma _ : tactic = fun gls -> @@ -823,25 +772,19 @@ let open_new_goal ref goal_name (gls_type,decompose_and_tac,nb_goal) = let name = match goal_name with | Some s -> s | None -> - try (add_suffix current_proof_name "_subproof") with _ -> assert false - + try (add_suffix current_proof_name "_subproof") + with _ -> anomaly "open_new_goal with an unamed theorem" in let sign = Global.named_context () in let sign = clear_proofs sign in let na = next_global_ident_away false name [] in if occur_existential gls_type then Util.error "\"abstract\" cannot handle existentials"; - (* let v = let lemme = mkConst (Lib.make_con na) in *) -(* Tactics.exact_no_check *) -(* (applist (lemme, *) -(* List.rev (Array.to_list (Sign.instance_from_named_context sign)))) *) -(* gls in *) - let hook _ _ = let lemma = mkConst (Lib.make_con na) in Array.iteri (fun i _ -> by (observe_tac "tac" (prove_with_tcc lemma i))) (Array.make nb_goal ()); ref := Some lemma ; - Command.save_named true; + defined (); in start_proof na @@ -850,9 +793,17 @@ let open_new_goal ref goal_name (gls_type,decompose_and_tac,nb_goal) = gls_type hook ; by (decompose_and_tac); - () + if Options.is_verbose () then (pp (Printer.pr_open_subgoals())) + -let com_terminate ref is_mes fonctional_ref input_type relation rec_arg_num +let com_terminate + tcc_lemma_name + tcc_lemma_ref + is_mes + fonctional_ref + input_type + relation + rec_arg_num thm_name hook = let (evmap, env) = Command.get_current_context() in start_proof thm_name @@ -860,10 +811,14 @@ let com_terminate ref is_mes fonctional_ref input_type relation rec_arg_num (hyp_terminates fonctional_ref) hook; by (observe_tac "whole_start" (whole_start is_mes fonctional_ref input_type relation rec_arg_num )); - open_new_goal ref - None - (build_new_goal_type ()) - + try + let new_goal_type = build_new_goal_type () in + open_new_goal tcc_lemma_ref + (Some tcc_lemma_name) + (new_goal_type) + with Failure "empty list of subgoals!" -> + (* a non recursive function declared with measure ! *) + defined () @@ -1111,13 +1066,14 @@ let (com_eqn : identifier -> ) ) ); - Command.save_named true);; + defined (); + );; -let recursive_definition is_mes f type_of_f r rec_arg_num eq +let recursive_definition is_mes function_name type_of_f r rec_arg_num eq generate_induction_principle : unit = let function_type = interp_constr Evd.empty (Global.env()) type_of_f in - let env = push_rel (Name f,None,function_type) (Global.env()) in + let env = push_rel (Name function_name,None,function_type) (Global.env()) in let res_vars,eq' = decompose_prod (interp_constr Evd.empty env eq) in let res = (* Pp.msgnl (str "res_var :=" ++ Printer.pr_lconstr_env (push_rel_context (List.map (function (x,t) -> (x,None,t)) res_vars) env) eq'); *) @@ -1125,17 +1081,16 @@ let recursive_definition is_mes f type_of_f r rec_arg_num eq (* Pp.msgnl (str "eq' := " ++ str (string_of_int rec_arg_num)); *) match kind_of_term eq' with | App(e,[|_;_;eq_fix|]) -> - mkLambda (Name f,function_type,compose_lam res_vars eq_fix) + mkLambda (Name function_name,function_type,compose_lam res_vars eq_fix) | _ -> failwith "Recursive Definition (res not eq)" in let pre_rec_args,function_type_before_rec_arg = decompose_prod_n (rec_arg_num - 1) function_type in let (_, rec_arg_type, _) = destProd function_type_before_rec_arg in let arg_types = List.rev_map snd (fst (decompose_prod_n (List.length res_vars) function_type)) in - let equation_id = add_suffix f "_equation" in - let functional_id = add_suffix f "_F" in - let term_id = add_suffix f "_terminate" in + let equation_id = add_suffix function_name "_equation" in + let functional_id = add_suffix function_name "_F" in + let term_id = add_suffix function_name "_terminate" in let functional_ref = declare_fun functional_id (IsDefinition Definition) res in -(* let _ = Pp.msgnl (str "res := " ++ Printer.pr_lconstr res) in *) let env_with_pre_rec_args = push_rel_context(List.map (function (x,t) -> (x,None,t)) pre_rec_args) env in let relation = interp_constr @@ -1143,242 +1098,66 @@ let recursive_definition is_mes f type_of_f r rec_arg_num eq env_with_pre_rec_args r in + let tcc_lemma_name = add_suffix function_name "_tcc" in let tcc_lemma_constr = ref None in (* let _ = Pp.msgnl (str "relation := " ++ Printer.pr_lconstr_env env_with_pre_rec_args relation) in *) let hook _ _ = let term_ref = Nametab.locate (make_short_qualid term_id) in - let f_ref = declare_f f (IsProof Lemma) arg_types term_ref in -(* let _ = message "start second proof" in *) - com_eqn equation_id functional_ref f_ref term_ref eq; - let eq_ref = Nametab.locate (make_short_qualid equation_id ) in - generate_induction_principle tcc_lemma_constr - functional_ref eq_ref rec_arg_num rec_arg_type (nb_prod res) relation; - () - - in - com_terminate - tcc_lemma_constr - is_mes functional_ref - rec_arg_type - relation rec_arg_num - term_id - hook -;; - - - -(* let observe_tac = do_observe_tac *) - -let base_leaf_princ eq_cst functional_ref eqs expr = - tclTHENSEQ - [rewriteLR (mkConst eq_cst); - tclTRY (list_rewrite true eqs); - gen_eauto(* default_eauto *) false (false,5) [] (Some []) - ] - - - -let prove_with_tcc tcc_lemma_constr eqs : tactic = - match !tcc_lemma_constr with - | None -> tclIDTAC_MESSAGE (str "No tcc proof !!") - | Some lemma -> - fun gls -> - let hid = next_global_ident_away true h_id (pf_ids_of_hyps gls) in - tclTHENSEQ - [ - generalize [lemma]; - h_intro hid; - Elim.h_decompose_and (mkVar hid); - tclTRY(list_rewrite true eqs); - gen_eauto(* default_eauto *) false (false,5) [] (Some []) - (* default_auto *) - ] - gls - - - -let finalize_rec_leaf_princ_with tcc_lemma_constr is_mes hrec acc_inv eqs br = - fun g -> - tclTHENSEQ [ - Eauto.e_resolve_constr (mkVar br); - tclFIRST - [ - e_assumption; - reflexivity; - tclTHEN (apply (mkVar hrec)) - (tclTHENS - (* (try *) (observe_tac "applying inversion" (apply (Lazy.force acc_inv))) -(* with e -> Pp.msgnl (Printer.pr_lconstr (Lazy.force acc_inv));raise e *) -(* ) *) - [ h_assumption - ; - tclTHEN - (fun g -> - tclUSER - is_mes - (Some (hrec::(retrieve_acc_var g))) - g - ) - (fun g -> prove_with_tcc tcc_lemma_constr eqs g) - ] - ); - gen_eauto(* default_eauto *) false (false,5) [] (Some []); - (fun g -> tclIDTAC_MESSAGE (str "here" ++ Printer.pr_goal (sig_it g)) g) - ] - ] - g - -let rec_leaf_princ - tcc_lemma_constr - eq_cst - branches_names - is_mes - acc_inv - hrec - (functional_ref:global_reference) - eqs - expr - = - fun g -> - tclTHENSEQ - [ rewriteLR (mkConst eq_cst); - list_rewrite true eqs; - tclFIRST - (List.map (finalize_rec_leaf_princ_with tcc_lemma_constr is_mes hrec acc_inv eqs) branches_names) - ] - g - -let fresh_id avoid na = - let id = - match na with - | Name id -> id - | Anonymous -> h_id - in - next_global_ident_away true id avoid - - - -let prove_principle tcc_lemma_ref is_mes functional_ref - eq_ref rec_arg_num rec_arg_type nb_args relation = -(* f_ref eq_ref rec_arg_num rec_arg_type nb_args relation *) - let eq_cst = - match eq_ref with - ConstRef sp -> sp - | _ -> assert false - in - fun g -> - let type_of_goal = pf_concl g in - let goal_ids = pf_ids_of_hyps g in - let goal_elim_infos = compute_elim_sig type_of_goal in - let params_names,ids = List.fold_left - (fun (params_names,avoid) (na,_,_) -> - let new_id = fresh_id avoid na in - (new_id::params_names,new_id::avoid) - ) - ([],goal_ids) - goal_elim_infos.params - in - let predicates_names,ids = - List.fold_left - (fun (predicates_names,avoid) (na,_,_) -> - let new_id = fresh_id avoid na in - (new_id::predicates_names,new_id::avoid) - ) - ([],ids) - goal_elim_infos.predicates - in - let branches_names,ids = - List.fold_left - (fun (branches_names,avoid) (na,_,_) -> - let new_id = fresh_id avoid na in - (new_id::branches_names,new_id::avoid) - ) - ([],ids) - goal_elim_infos.branches - in - let to_intro = params_names@predicates_names@branches_names in - let nparams = List.length params_names in - let rec_arg_num = rec_arg_num - nparams in + let f_ref = declare_f function_name (IsProof Lemma) arg_types term_ref in +(* message "start second proof"; *) begin - tclTHEN - (h_intros to_intro) - (observe_tac (string_of_int (rec_arg_num)) - (fun g -> - let ids = ids_of_named_context (pf_hyps g) in - let func_body = (def_of_const (constr_of_reference functional_ref)) in -(* let _ = Pp.msgnl (Printer.pr_lconstr func_body) in *) - let (f_name, _, body1) = destLambda func_body in - let f_id = - match f_name with - | Name f_id -> next_global_ident_away true f_id ids - | Anonymous -> assert false - in - let n_names_types,_ = decompose_lam body1 in - let n_ids,ids = - List.fold_left - (fun (n_ids,ids) (n_name,_) -> - match n_name with - | Name id -> - let n_id = next_global_ident_away true id ids in - n_id::n_ids,n_id::ids - | _ -> assert false + try com_eqn equation_id functional_ref f_ref term_ref eq + with e -> + begin + ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,functional_id) with _ -> ()); + anomaly "Cannot create equation Lemma" + end + end; + let eq_ref = Nametab.locate (make_short_qualid equation_id ) in + let f_ref = destConst (constr_of_reference f_ref) + and functional_ref = destConst (constr_of_reference functional_ref) + and eq_ref = destConst (constr_of_reference eq_ref) in + generate_induction_principle f_ref tcc_lemma_constr + functional_ref eq_ref rec_arg_num rec_arg_type (nb_prod res) relation; + if Options.is_verbose () + then msgnl (h 1 (Ppconstr.pr_id function_name ++ + spc () ++ str"is defined" )++ fnl () ++ + h 1 (Ppconstr.pr_id equation_id ++ + spc () ++ str"is defined" ) ) - ([],(f_id::ids)) - n_names_types - in - let rec_arg_id = List.nth n_ids (rec_arg_num - 1 ) in - let expr = - instantiate_lambda func_body - (mkVar f_id::(List.map mkVar n_ids)) - in - start - is_mes - rec_arg_type - ids - (snd (list_chop nparams n_ids)) - (substl (List.map mkVar params_names) relation) - (rec_arg_num) - rec_arg_id - (fun hrec acc_inv g -> - (proveterminate - is_mes - acc_inv - hrec - (mkVar f_id) - functional_ref - (base_leaf_princ eq_cst) - (rec_leaf_princ tcc_lemma_ref eq_cst branches_names) - [] - expr - ) - g - ) - (if is_mes - then - tclUSER_if_not_mes - else fun _ -> prove_with_tcc tcc_lemma_ref []) - - g - ) - ) + in + try + com_terminate + tcc_lemma_name + tcc_lemma_constr + is_mes functional_ref + rec_arg_type + relation rec_arg_num + term_id + hook + with e -> + begin + ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,functional_id) with _ -> ()); +(* anomaly "Cannot create termination Lemma" *) + raise e end - g - VERNAC COMMAND EXTEND RecursiveDefinition [ "Recursive" "Definition" ident(f) constr(type_of_f) constr(r) constr(wf) constr(proof) integer_opt(rec_arg_num) constr(eq) ] -> - [ ignore(proof);ignore(wf); + [ + warning "Recursive Definition is obsolete. Use Function instead"; + ignore(proof);ignore(wf); let rec_arg_num = match rec_arg_num with | None -> 1 | Some n -> n in - recursive_definition false f type_of_f r rec_arg_num eq (fun _ _ _ _ _ _ _ -> ())] + recursive_definition false f type_of_f r rec_arg_num eq (fun _ _ _ _ _ _ _ _ -> ())] | [ "Recursive" "Definition" ident(f) constr(type_of_f) constr(r) constr(wf) "[" ne_constr_list(proof) "]" constr(eq) ] -> - [ ignore(proof);ignore(wf);recursive_definition false f type_of_f r 1 eq (fun _ _ _ _ _ _ _ -> ())] + [ ignore(proof);ignore(wf);recursive_definition false f type_of_f r 1 eq (fun _ _ _ _ _ _ _ _ -> ())] END diff --git a/contrib/rtauto/Bintree.v b/contrib/rtauto/Bintree.v index 97d80a92..f4b24d4b 100644 --- a/contrib/rtauto/Bintree.v +++ b/contrib/rtauto/Bintree.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Bintree.v 7233 2005-07-15 12:34:56Z corbinea $ *) +(* $Id: Bintree.v 8881 2006-05-31 18:16:34Z jforest $ *) Require Export List. Require Export BinPos. @@ -18,7 +18,7 @@ Open Scope positive_scope. Ltac clean := try (simpl; congruence). Ltac caseq t := generalize (refl_equal t); pattern t at -1; case t. -Functional Scheme Pcompare_ind := Induction for Pcompare. +Functional Scheme Pcompare_ind := Induction for Pcompare Sort Prop. Lemma Prect : forall P : positive -> Type, P 1 -> @@ -31,13 +31,13 @@ Qed. Lemma Gt_Eq_Gt : forall p q cmp, (p ?= q) Eq = Gt -> (p ?= q) cmp = Gt. -apply (Pcompare_ind (fun p q cmp => (p ?= q) Eq = Gt -> (p ?= q) cmp = Gt)); +apply (Pcompare_ind (fun p q cmp _ => (p ?= q) Eq = Gt -> (p ?= q) cmp = Gt)); simpl;auto;congruence. Qed. Lemma Gt_Lt_Gt : forall p q cmp, (p ?= q) Lt = Gt -> (p ?= q) cmp = Gt. -apply (Pcompare_ind (fun p q cmp => (p ?= q) Lt = Gt -> (p ?= q) cmp = Gt)); +apply (Pcompare_ind (fun p q cmp _ => (p ?= q) Lt = Gt -> (p ?= q) cmp = Gt)); simpl;auto;congruence. Qed. diff --git a/contrib/setoid_ring/newring.ml4 b/contrib/setoid_ring/newring.ml4 index 7041d7e8..bc2bcb0c 100644 --- a/contrib/setoid_ring/newring.ml4 +++ b/contrib/setoid_ring/newring.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(*i $Id: newring.ml4 7974 2006-02-01 19:02:09Z barras $ i*) +(*i $Id: newring.ml4 8878 2006-05-30 16:44:25Z herbelin $ i*) open Pp open Util @@ -204,7 +204,7 @@ let protect_tac = Tactics.reduct_option (protect_red,DEFAULTcast) None ;; let protect_tac_in id = - Tactics.reduct_option (protect_red,DEFAULTcast) (Some(id,[],InHyp));; + Tactics.reduct_option (protect_red,DEFAULTcast) (Some(([],id),InHyp));; TACTIC EXTEND protect_fv @@ -442,10 +442,10 @@ let add_theory name rth eqth morphth cst_tac = | None -> (match kind with Some true -> - let t = Genarg.ArgArg(dummy_loc,Lazy.force ltac_inv_morphN) in + let t = ArgArg(dummy_loc,Lazy.force ltac_inv_morphN) in TacArg(TacCall(dummy_loc,t,List.map carg [zero;one;add;mul])) | Some false -> - let t = Genarg.ArgArg(dummy_loc, Lazy.force ltac_inv_morphZ) in + let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morphZ) in TacArg(TacCall(dummy_loc,t,List.map carg [zero;one;add;mul;opp])) | _ -> error"a tactic must be specified for an almost_ring") in let _ = @@ -495,7 +495,7 @@ let ring gl = spc()++str"\""++pr_constr req++str"\"") in Tacinterp.eval_tactic (TacArg(TacCall(dummy_loc, - Genarg.ArgArg(dummy_loc, Lazy.force ltac_setoid_ring), + ArgArg(dummy_loc, Lazy.force ltac_setoid_ring), Tacexp e.ring_cst_tac:: List.map carg [e.ring_lemma1;e.ring_lemma2;e.ring_req]))) gl @@ -512,7 +512,7 @@ let ring_rewrite rl = (lapp coq_nil [|ty|]) in Tacinterp.eval_tactic (TacArg(TacCall(dummy_loc, - Genarg.ArgArg(dummy_loc, Lazy.force ltac_setoid_ring_rewrite), + ArgArg(dummy_loc, Lazy.force ltac_setoid_ring_rewrite), Tacexp e.ring_cst_tac::List.map carg [e.ring_lemma2;e.ring_req;rl]))) let setoid_ring = function diff --git a/contrib/subtac/Utils.v b/contrib/subtac/Utils.v index 9acb10ae..db10cb2a 100644 --- a/contrib/subtac/Utils.v +++ b/contrib/subtac/Utils.v @@ -1,20 +1,17 @@ Set Implicit Arguments. +Notation "'fun' { x : A | P } => Q" := + (fun x:{x:A|P} => Q) + (at level 200, x ident, right associativity). + +Notation "( x & y )" := (@existS _ _ x y) : core_scope. + Definition ex_pi1 (A : Prop) (P : A -> Prop) (t : ex P) : A. intros. induction t. exact x. Defined. -Check proj1_sig. -Lemma subset_simpl : forall (A : Set) (P : A -> Prop) - (t : sig P), P (proj1_sig t). -Proof. -intros. -induction t. - simpl ; auto. -Qed. - Lemma ex_pi2 : forall (A : Prop) (P : A -> Prop) (t : ex P), P (ex_pi1 t). intros A P. @@ -23,12 +20,17 @@ simpl. exact p. Defined. + +Notation "` t" := (proj1_sig t) (at level 100) : core_scope. Notation "'forall' { x : A | P } , Q" := (forall x:{x:A|P}, Q) (at level 200, x ident, right associativity). -Notation "'fun' { x : A | P } => Q" := - (fun x:{x:A|P} => Q) - (at level 200, x ident, right associativity). +Lemma subset_simpl : forall (A : Set) (P : A -> Prop) + (t : sig P), P (` t). +Proof. +intros. +induction t. + simpl ; auto. +Qed. -Notation "( x & y )" := (@existS _ _ x y) : core_scope. diff --git a/contrib/subtac/eterm.ml b/contrib/subtac/eterm.ml index 5703c0ef..382ae2d5 100644 --- a/contrib/subtac/eterm.ml +++ b/contrib/subtac/eterm.ml @@ -47,9 +47,9 @@ let subst_evars evs n t = | Evar (k, args) -> (try let index, hyps = evar_info k in - trace (str "Evar " ++ int k ++ str " found, applied to " ++ int (Array.length args) ++ str "arguments," ++ - int (List.length hyps) ++ str " hypotheses"); - + (try trace (str "Evar " ++ int k ++ str " found, applied to " ++ int (Array.length args) ++ str "arguments," ++ + int (List.length hyps) ++ str " hypotheses"); with _ -> () ); + let ex = mkRel (index + depth) in (* Evar arguments are created in inverse order, and we must not apply to defined ones (i.e. LetIn's) @@ -128,7 +128,7 @@ let eterm_term evm t tycon = let anon_evar_bl = List.map (fun (_, x, y) -> (Anonymous, x, y)) evar_bl in (* Generalize over the existential variables *) let t'' = Termops.it_mkLambda_or_LetIn t' evar_bl - and tycon = option_app + and tycon = option_map (fun typ -> Termops.it_mkProd_wo_LetIn typ anon_evar_bl) tycon in let _declare_evar (id, c) = @@ -140,15 +140,17 @@ let eterm_term evm t tycon = let id = id_of_string ("Evar" ^ string_of_int id) in tclTHEN acc (Tactics.assert_tac false (Name id) c) in - trace (str "Term given to eterm" ++ spc () ++ - Termops.print_constr_env (Global.env ()) t); - trace (str "Term constructed in eterm" ++ spc () ++ - Termops.print_constr_env (Global.env ()) t''); - ignore(option_app - (fun typ -> - trace (str "Type :" ++ spc () ++ - Termops.print_constr_env (Global.env ()) typ)) - tycon); + (try + trace (str "Term given to eterm" ++ spc () ++ + Termops.print_constr_env (Global.env ()) t); + trace (str "Term constructed in eterm" ++ spc () ++ + Termops.print_constr_env (Global.env ()) t''); + ignore(option_map + (fun typ -> + trace (str "Type :" ++ spc () ++ + Termops.print_constr_env (Global.env ()) typ)) + tycon); + with _ -> ()); t'', tycon, evar_names let mkMetas n = diff --git a/contrib/subtac/g_subtac.ml4 b/contrib/subtac/g_subtac.ml4 index c3f2a24d..b56ecc3d 100644 --- a/contrib/subtac/g_subtac.ml4 +++ b/contrib/subtac/g_subtac.ml4 @@ -10,7 +10,7 @@ Syntax for the subtac terms and types. Elaborated from correctness/psyntax.ml4 by Jean-Christophe Filliātre *) -(* $Id: g_subtac.ml4 8688 2006-04-07 15:08:12Z msozeau $ *) +(* $Id: g_subtac.ml4 8917 2006-06-07 16:59:05Z herbelin $ *) (*i camlp4deps: "parsing/grammar.cma" i*) @@ -49,11 +49,11 @@ GEXTEND Gram ; END -type gallina_loc_argtype = (Vernacexpr.vernac_expr located, constr_expr, Tacexpr.raw_tactic_expr) Genarg.abstract_argument_type +type ('a,'b) gallina_loc_argtype = (Vernacexpr.vernac_expr located, 'a, 'b) Genarg.abstract_argument_type -let (wit_subtac_gallina_loc : gallina_loc_argtype), - (globwit_subtac_gallina_loc : gallina_loc_argtype), - (rawwit_subtac_gallina_loc : gallina_loc_argtype) = +let (wit_subtac_gallina_loc : (Genarg.tlevel, Proof_type.tactic) gallina_loc_argtype), + (globwit_subtac_gallina_loc : (Genarg.glevel, Tacexpr.glob_tactic_expr) gallina_loc_argtype), + (rawwit_subtac_gallina_loc : (Genarg.rlevel, Tacexpr.raw_tactic_expr) gallina_loc_argtype) = Genarg.create_arg "subtac_gallina_loc" VERNAC COMMAND EXTEND Subtac diff --git a/contrib/subtac/subtac.ml b/contrib/subtac/subtac.ml index 84b7d39b..cd2e7c43 100644 --- a/contrib/subtac/subtac.ml +++ b/contrib/subtac/subtac.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: subtac.ml 8688 2006-04-07 15:08:12Z msozeau $ *) +(* $Id: subtac.ml 8889 2006-06-01 20:23:56Z msozeau $ *) open Global open Pp @@ -48,8 +48,10 @@ let subtac_one_fixpoint env isevars (f, decl) = let ((id, n, bl, typ, body), decl) = Subtac_interp_fixpoint.rewrite_fixpoint env [] (f, decl) in - let _ = trace (str "Working on a single fixpoint rewritten as: " ++ spc () ++ - Ppconstr.pr_constr_expr body) + let _ = + try trace (str "Working on a single fixpoint rewritten as: " ++ spc () ++ + Ppconstr.pr_constr_expr body) + with _ -> () in ((id, n, bl, typ, body), decl) @@ -115,16 +117,44 @@ let subtac_end_proof = function *) +open Pp +open Ppconstr +open Decl_kinds + +let start_proof_com env isevars sopt kind (bl,t) hook = + let id = match sopt with + | Some id -> + (* We check existence here: it's a bit late at Qed time *) + if Nametab.exists_cci (Lib.make_path id) or is_section_variable id then + errorlabstrm "start_proof" (pr_id id ++ str " already exists"); + id + | None -> + next_global_ident_away false (id_of_string "Unnamed_thm") + (Pfedit.get_all_proof_names ()) + in + let evm, c, typ = + Subtac_pretyping.subtac_process env isevars id [] (Command.generalize_constr_expr t bl) None + in + let _ = Typeops.infer_type env c in + Command.start_proof id kind c hook + +let print_subgoals () = Options.if_verbose (fun () -> msg (Printer.pr_open_subgoals ())) () + +let start_proof_and_print env isevars idopt k t hook = + start_proof_com env isevars idopt k t hook; + print_subgoals () + (*if !pcoq <> None then (out_some !pcoq).start_proof ()*) + let subtac (loc, command) = check_required_library ["Coq";"Init";"Datatypes"]; check_required_library ["Coq";"Init";"Specif"]; require_library "Coq.subtac.FixSub"; require_library "Coq.subtac.Utils"; + let env = Global.env () in + let isevars = ref (create_evar_defs Evd.empty) in try match command with VernacDefinition (defkind, (locid, id), expr, hook) -> - let env = Global.env () in - let isevars = ref (create_evar_defs Evd.empty) in (match expr with ProveBody (bl, c) -> let evm, c, ctyp = Subtac_pretyping.subtac_process env isevars id bl c None in @@ -142,6 +172,19 @@ let subtac (loc, command) = | VernacFixpoint (l, b) -> let _ = trace (str "Building fixpoint") in ignore(Subtac_command.build_recursive l b) + + | VernacStartTheoremProof (thkind, (locid, id), (bl, t), lettop, hook) -> + if not(Pfedit.refining ()) then + if lettop then + errorlabstrm "Subtac_command.StartProof" + (str "Let declarations can only be used in proof editing mode"); + if Lib.is_modtype () then + errorlabstrm "Subtac_command.StartProof" + (str "Proof editing mode not supported in module types"); + start_proof_and_print env isevars (Some id) (Global, Proof thkind) (bl,t) hook + + + (*| VernacEndProof e -> subtac_end_proof e*) diff --git a/contrib/subtac/subtac_coercion.ml b/contrib/subtac/subtac_coercion.ml index 7c8ea2d6..7428e1ed 100644 --- a/contrib/subtac/subtac_coercion.ml +++ b/contrib/subtac/subtac_coercion.ml @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: subtac_coercion.ml 8695 2006-04-10 16:33:52Z msozeau $ *) +(* $Id: subtac_coercion.ml 8889 2006-06-01 20:23:56Z msozeau $ *) open Util open Names @@ -53,7 +53,8 @@ module Coercion = struct | _ -> None and disc_exist env x = - trace (str "Disc_exist: " ++ my_print_constr env x); + (try trace (str "Disc_exist: " ++ my_print_constr env x) + with _ -> ()); match kind_of_term x with | App (c, l) -> (match kind_of_term c with @@ -66,7 +67,8 @@ module Coercion = struct let disc_proj_exist env x = - trace (str "disc_proj_exist: " ++ my_print_constr env x); + (try trace (str "disc_proj_exist: " ++ my_print_constr env x); + with _ -> ()); match kind_of_term x with | App (c, l) -> (if Term.eq_constr c (Lazy.force sig_).proj1 @@ -97,30 +99,34 @@ module Coercion = struct app_opt f (mkApp ((Lazy.force sig_).proj1, [| u; p; x |]))), ct) - | None -> (None, t) + | None -> (None, v) in aux t and coerce loc env isevars (x : Term.constr) (y : Term.constr) : (Term.constr -> Term.constr) option = let x = nf_evar (evars_of !isevars) x and y = nf_evar (evars_of !isevars) y in - trace (str "Coerce called for " ++ (my_print_constr env x) ++ - str " and "++ my_print_constr env y ++ - str " with evars: " ++ spc () ++ - my_print_evardefs !isevars); + (try trace (str "Coerce called for " ++ (my_print_constr env x) ++ + str " and "++ my_print_constr env y ++ + str " with evars: " ++ spc () ++ + my_print_evardefs !isevars); + with _ -> ()); let rec coerce_unify env x y = - trace (str "coerce_unify from " ++ (my_print_constr env x) ++ - str " to "++ my_print_constr env y); + (try trace (str "coerce_unify from " ++ (my_print_constr env x) ++ + str " to "++ my_print_constr env y) + with _ -> ()); try isevars := the_conv_x_leq env x y !isevars; - trace (str "Unified " ++ (my_print_constr env x) ++ - str " and "++ my_print_constr env y); + (try (trace (str "Unified " ++ (my_print_constr env x) ++ + str " and "++ my_print_constr env y)); + with _ -> ()); None with Reduction.NotConvertible -> coerce' env (hnf env isevars x) (hnf env isevars y) and coerce' env x y : (Term.constr -> Term.constr) option = let subco () = subset_coerce env isevars x y in - trace (str "coerce' from " ++ (my_print_constr env x) ++ - str " to "++ my_print_constr env y); + (try trace (str "coerce' from " ++ (my_print_constr env x) ++ + str " to "++ my_print_constr env y); + with _ -> ()); match (kind_of_term x, kind_of_term y) with | Sort s, Sort s' -> (match s, s' with @@ -153,7 +159,7 @@ module Coercion = struct if i = Term.destInd existS.typ then begin - debug 1 (str "In coerce sigma types"); + trace (str "In coerce sigma types"); let (a, pb), (a', pb') = pair_of_array l, pair_of_array l' in @@ -244,7 +250,7 @@ module Coercion = struct let coerce_itf loc env isevars v t c1 = let evars = ref isevars in let coercion = coerce loc env evars t c1 in - !evars, option_app (app_opt coercion) v, t + !evars, option_map (app_opt coercion) v, t (* Taken from pretyping/coercion.ml *) @@ -339,6 +345,13 @@ module Coercion = struct | _ -> inh_tosort_force loc env isevars j + let inh_coerce_to_base loc env isevars j = + let typ = whd_betadeltaiota env (evars_of isevars) j.uj_type in + let ct, typ' = mu env isevars typ in + isevars, { uj_val = app_opt ct j.uj_val; + uj_type = typ' } + + let inh_coerce_to_fail env isevars c1 v t = let v', t' = try @@ -371,7 +384,7 @@ module Coercion = struct (match kind_of_term (whd_betadeltaiota env (evars_of isevars) t), kind_of_term (whd_betadeltaiota env (evars_of isevars) c1) with | Prod (_,t1,t2), Prod (name,u1,u2) -> - let v' = option_app (whd_betadeltaiota env (evars_of isevars)) v in + let v' = option_map (whd_betadeltaiota env (evars_of isevars)) v in let (evd',b) = match v' with Some v' -> @@ -387,7 +400,7 @@ module Coercion = struct let env1 = push_rel (x,None,v1) env in let (evd'', v2', t2') = inh_conv_coerce_to_fail loc env1 evd' (Some v2) t2 u2 in - (evd'', option_app (fun v2' -> mkLambda (x, v1, v2')) v2', + (evd'', option_map (fun v2' -> mkLambda (x, v1, v2')) v2', mkProd (x, v1, t2')) | None -> (* Mismatch on t1 and u1 or not a lambda: we eta-expand *) @@ -404,7 +417,7 @@ module Coercion = struct let (evd'', v2', t2') = let v2 = match v with - Some v -> option_app (fun v1' -> mkApp (lift 1 v, [|v1'|])) v1' + Some v -> option_map (fun v1' -> mkApp (lift 1 v, [|v1'|])) v1' | None -> None and evd', t2 = match v1' with @@ -415,7 +428,7 @@ module Coercion = struct in inh_conv_coerce_to_fail loc env1 evd' v2 t2 u2 in - (evd'', option_app (fun v2' -> mkLambda (name, u1, v2')) v2', + (evd'', option_map (fun v2' -> mkLambda (name, u1, v2')) v2', mkProd (name, u1, t2'))) | _ -> raise NoCoercion)) diff --git a/contrib/subtac/subtac_command.ml b/contrib/subtac/subtac_command.ml index 1b92c691..b09228c0 100644 --- a/contrib/subtac/subtac_command.ml +++ b/contrib/subtac/subtac_command.ml @@ -55,8 +55,8 @@ let interp_gen kind isevars env ?(impls=([],[])) ?(allow_soapp=false) ?(ltacvars=([],[])) c = let c' = Constrintern.intern_gen (kind=IsType) ~impls ~allow_soapp ~ltacvars (Evd.evars_of !isevars) env c in - let c' = Subtac_interp_fixpoint.rewrite_cases env c' in - msgnl (str "Pretyping " ++ my_print_constr_expr c); + let c' = Subtac_utils.rewrite_cases env c' in + (try trace (str "Pretyping " ++ my_print_constr_expr c) with _ -> ()); let c' = SPretyping.pretype_gen isevars env ([],[]) kind c' in evar_nf isevars c' @@ -200,15 +200,18 @@ let build_recursive (lnameargsardef:(fixpoint_expr * decl_notation) list) boxed let impls' =(recname,([],impl,compute_arguments_scope arity))::impls in (Environ.push_named (recname,None,arity) env, impls', (isevars, None, arity)::arl) | CWfRec r -> - let _ = trace (str "Rewriting fixpoint: " ++ Ppconstr.pr_id recname ++ - Ppconstr.pr_binders bl ++ str " : " ++ - Ppconstr.pr_constr_expr arityc ++ str " := " ++ spc () ++ - Ppconstr.pr_constr_expr body) + let n = out_some n in + let _ = + try trace (str "Rewriting fixpoint: " ++ Ppconstr.pr_id recname ++ + Ppconstr.pr_binders bl ++ str " : " ++ + Ppconstr.pr_constr_expr arityc ++ str " := " ++ spc () ++ + Ppconstr.pr_constr_expr body) + with _ -> () in let env', binders_rel = interp_context isevars env0 bl in let after, ((argname, _, argtyp) as arg), before = list_chop_hd n binders_rel in let argid = match argname with Name n -> n | _ -> assert(false) in - let after' = List.map (fun (n, c, t) -> (n, option_app (lift 1) c, lift 1 t)) after in + let after' = List.map (fun (n, c, t) -> (n, option_map (lift 1) c, lift 1 t)) after in let envwf = push_rel_context before env0 in let wf_rel = interp_constr isevars envwf r in let accarg_id = id_of_string ("Acc_" ^ string_of_id argid) in @@ -233,10 +236,11 @@ let build_recursive (lnameargsardef:(fixpoint_expr * decl_notation) list) boxed let _ = let pr c = my_print_constr env c in let prr = Printer.pr_rel_context env in - trace (str "Fun bl: " ++ prr fun_bl ++ spc () ++ - str "Intern bl" ++ prr intern_bl ++ spc () ++ - str "Extern bl" ++ prr new_bl ++ spc () ++ - str "Intern arity: " ++ pr intern_arity) + try trace (str "Fun bl: " ++ prr fun_bl ++ spc () ++ + str "Intern bl" ++ prr intern_bl ++ spc () ++ + str "Extern bl" ++ prr new_bl ++ spc () ++ + str "Intern arity: " ++ pr intern_arity) + with _ -> () in let impl = if Impargs.is_implicit_args() @@ -279,14 +283,15 @@ let build_recursive (lnameargsardef:(fixpoint_expr * decl_notation) list) boxed let (lnonrec,(namerec,defrec,arrec,nvrec)) = collect_non_rec env0 lrecnames recdef arityl nv in - let nvrec' = Array.map fst nvrec in(* ignore rec order *) + let nvrec' = Array.map (function (Some n,_) -> n | _ -> 0) nvrec in(* ignore rec order *) let declare arrec defrec = let recvec = Array.map (subst_vars (List.rev (Array.to_list namerec))) defrec in let recdecls = (Array.map (fun id -> Name id) namerec, arrec, recvec) in let rec declare i fi = - trace (str "Declaring: " ++ pr_id fi ++ spc () ++ - my_print_constr env0 (recvec.(i))); + (try trace (str "Declaring: " ++ pr_id fi ++ spc () ++ + my_print_constr env0 (recvec.(i))); + with _ -> ()); let ce = { const_entry_body = mkFix ((nvrec',i),recdecls); const_entry_type = Some arrec.(i); @@ -331,20 +336,20 @@ let build_recursive (lnameargsardef:(fixpoint_expr * decl_notation) list) boxed let rec collect_evars i acc = if i < recdefs then let (isevars, info, def) = defrec.(i) in - let _ = trace (str "In solve evars, isevars is: " ++ Evd.pr_evar_defs !isevars) in + let _ = try trace (str "In solve evars, isevars is: " ++ Evd.pr_evar_defs !isevars) with _ -> () in let def = evar_nf isevars def in let isevars = Evd.undefined_evars !isevars in - let _ = trace (str "In solve evars, undefined is: " ++ Evd.pr_evar_defs isevars) in + let _ = try trace (str "In solve evars, undefined is: " ++ Evd.pr_evar_defs isevars) with _ -> () in let evm = Evd.evars_of isevars in let _, _, typ = arrec.(i) in let id = namerec.(i) in - let evars_def, evars_typ, evars = Eterm.eterm_term evm def (Some typ) in (* Generalize by the recursive prototypes *) let def = Termops.it_mkNamedLambda_or_LetIn def (Environ.named_context rec_sign) and typ = Termops.it_mkNamedProd_or_LetIn typ (Environ.named_context rec_sign) in + let evars_def, evars_typ, evars = Eterm.eterm_term evm def (Some typ) in (*let evars_typ = match evars_typ with Some t -> t | None -> assert(false) in*) (*let fi = id_of_string (string_of_id id ^ "_evars") in*) (*let ce = @@ -357,10 +362,16 @@ let build_recursive (lnameargsardef:(fixpoint_expr * decl_notation) list) boxed trace (str (string_of_id fi) ++ str " is defined");*) let evar_sum = if evars = [] then None - else + else ( + (try trace (str "Building evars sum for : "); + List.iter + (fun (n, t) -> trace (str "Evar " ++ str (string_of_id n) ++ spc () ++ my_print_constr env0 t)) + evars; + with _ -> ()); let sum = Subtac_utils.build_dependent_sum evars in - trace (str "Evars sum: " ++ my_print_constr env0 (pi1 sum)); - Some sum + (try trace (str "Evars sum: " ++ my_print_constr env0 (snd sum)); + with _ -> ()); + Some sum) in collect_evars (succ i) ((id, evars_def, evar_sum) :: acc) else acc @@ -370,32 +381,34 @@ let build_recursive (lnameargsardef:(fixpoint_expr * decl_notation) list) boxed (* Solve evars then create the definitions *) let real_evars = filter_map (fun (id, kn, sum) -> - match sum with Some (sumg, sumtac, _) -> Some (id, kn, sumg, sumtac) | None -> None) + match sum with Some (sumtac, sumg) -> Some (id, kn, sumg, sumtac) | None -> None) defs in Subtac_utils.and_tac real_evars (fun f _ gr -> - let _ = trace (str "Got a proof of: " ++ pr_global gr) in + let _ = trace (str "Got a proof of: " ++ pr_global gr ++ + str "type: " ++ my_print_constr (Global.env ()) (Global.type_of_global gr)) in let constant = match gr with Libnames.ConstRef c -> c | _ -> assert(false) in try (*let value = Environ.constant_value (Global.env ()) constant in*) let pis = f (mkConst constant) in - trace (str "Accessors: " ++ - List.fold_right (fun (_, _, _, c) acc -> my_print_constr env0 c ++ spc () ++ acc) - pis (mt())); - trace (str "Applied existentials: " ++ - (List.fold_right - (fun (id, kn, sumg, pi) acc -> - let args = Subtac_utils.destruct_ex pi sumg in - my_print_constr env0 (mkApp (kn, Array.of_list args))) - pis (mt ()))); + (try (trace (str "Accessors: " ++ + List.fold_right (fun (_, _, _, c) acc -> my_print_constr env0 c ++ spc () ++ acc) + pis (mt())); + trace (str "Applied existentials: " ++ + (List.fold_right + (fun (id, kn, sumg, pi) acc -> + let args = Subtac_utils.destruct_ex pi sumg in + my_print_constr env0 (mkApp (kn, Array.of_list args))) + pis (mt ())))) + with _ -> ()); let rec aux pis acc = function (id, kn, sum) :: tl -> (match sum with None -> aux pis (kn :: acc) tl - | Some (sumg, _, _) -> + | Some (_, sumg) -> let (id, kn, sumg, pi), pis = List.hd pis, List.tl pis in let args = Subtac_utils.destruct_ex pi sumg in let args = diff --git a/contrib/subtac/subtac_interp_fixpoint.ml b/contrib/subtac/subtac_interp_fixpoint.ml index 599dbe39..858fad1a 100644 --- a/contrib/subtac/subtac_interp_fixpoint.ml +++ b/contrib/subtac/subtac_interp_fixpoint.ml @@ -110,7 +110,7 @@ let rewrite_fixpoint env l (f, decl) = let body = (* cast or we will loose some info at pretyping time as body is a function *) - CCast (dummy_loc, body, DEFAULTcast, typ) + CCast (dummy_loc, body, CastConv DEFAULTcast, typ) in let body' = (* body abstracted by rec call *) mkLambdaC ([(dummy_loc, Name id)], internal_type, body) @@ -151,69 +151,3 @@ let rewrite_fixpoint env l (f, decl) = Ppconstr.pr_constr_expr body') in (id, (succ n, ro), bl', typ, body'), decl -let list_mapi f = - let rec aux i = function - hd :: tl -> f i hd :: aux (succ i) tl - | [] -> [] - in aux 0 - -let rewrite_cases_aux (loc, po, tml, eqns) = - let tml = list_mapi (fun i (c, (n, opt)) -> c, - ((match n with - Name id -> (match c with - | RVar (_, id') when id = id' -> - Name (id_of_string (string_of_id id ^ "'")) - | _ -> n) - | Anonymous -> Name (id_of_string ("x" ^ string_of_int i))), - opt)) tml - in - let mkHole = RHole (dummy_loc, InternalHole) in - let mkeq c n = RApp (dummy_loc, RRef (dummy_loc, (Lazy.force eqind_ref)), - [mkHole; c; n]) - in - let eqs_types = - List.map - (fun (c, (n, _)) -> - let id = match n with Name id -> id | _ -> assert false in - let heqid = id_of_string ("Heq" ^ string_of_id id) in - Name heqid, mkeq c (RVar (dummy_loc, id))) - tml - in - let po = - List.fold_right - (fun (n,t) acc -> - RProd (dummy_loc, Anonymous, t, acc)) - eqs_types (match po with - Some e -> e - | None -> mkHole) - in - let eqns = - List.map (fun (loc, idl, cpl, c) -> - let c' = - List.fold_left - (fun acc (n, t) -> - RLambda (dummy_loc, n, mkHole, acc)) - c eqs_types - in (loc, idl, cpl, c')) - eqns - in - let mk_refl_equal c = RApp (dummy_loc, RRef (dummy_loc, Lazy.force refl_equal_ref), - [mkHole; c]) - in - let refls = List.map (fun (c, _) -> mk_refl_equal c) tml in - let case = RCases (loc,Some po,tml,eqns) in - let app = RApp (dummy_loc, case, refls) in - app - -let rec rewrite_cases c = - match c with - RCases _ -> let c' = map_rawconstr rewrite_cases c in - (match c' with - | RCases (x, y, z, w) -> rewrite_cases_aux (x,y,z,w) - | _ -> assert(false)) - | _ -> map_rawconstr rewrite_cases c - -let rewrite_cases env c = - let c' = rewrite_cases c in - let _ = trace (str "Rewrote cases: " ++ spc () ++ my_print_rawconstr env c') in - c' diff --git a/contrib/subtac/subtac_interp_fixpoint.mli b/contrib/subtac/subtac_interp_fixpoint.mli index b0de0641..fafbb2da 100644 --- a/contrib/subtac/subtac_interp_fixpoint.mli +++ b/contrib/subtac/subtac_interp_fixpoint.mli @@ -26,14 +26,3 @@ val rewrite_fixpoint : Topconstr.local_binder list * Topconstr.constr_expr * Topconstr.constr_expr) * 'c -val list_mapi : (int -> 'a -> 'b) -> 'a list -> 'b list -val rewrite_cases_aux : - Util.loc * Rawterm.rawconstr option * - (Rawterm.rawconstr * - (Names.name * (Util.loc * Names.inductive * Names.name list) option)) - list * - (Util.loc * Names.identifier list * Rawterm.cases_pattern list * - Rawterm.rawconstr) - list -> Rawterm.rawconstr - -val rewrite_cases : Environ.env -> Rawterm.rawconstr -> Rawterm.rawconstr diff --git a/contrib/subtac/subtac_pretyping.ml b/contrib/subtac/subtac_pretyping.ml index 104a0a58..261e0c5b 100644 --- a/contrib/subtac/subtac_pretyping.ml +++ b/contrib/subtac/subtac_pretyping.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: subtac_pretyping.ml 8688 2006-04-07 15:08:12Z msozeau $ *) +(* $Id: subtac_pretyping.ml 8889 2006-06-01 20:23:56Z msozeau $ *) open Global open Pp @@ -39,7 +39,7 @@ open Subtac_errors open Context open Eterm -module Pretyping = Pretyping.Pretyping_F(Subtac_coercion.Coercion) +module Pretyping = Subtac_pretyping_F.SubtacPretyping_F(Subtac_coercion.Coercion) open Pretyping @@ -116,24 +116,26 @@ let subtac_process env isevars id l c tycon = let evars () = evars_of !isevars in let _ = trace (str "Creating env with binders") in let env_binders, binders_rel = env_with_binders env isevars l in - let _ = trace (str "New env created:" ++ my_print_context env_binders) in + let _ = try (trace (str "New env created:" ++ my_print_context env_binders)) with _ -> () in let tycon = match tycon with None -> empty_tycon | Some t -> let t = coqintern !isevars env_binders t in - let _ = trace (str "Internalized specification: " ++ my_print_rawconstr env_binders t) in + let _ = try trace (str "Internalized specification: " ++ my_print_rawconstr env_binders t) with _ -> () in let coqt, ttyp = interp env_binders isevars t empty_tycon in - let _ = trace (str "Interpreted type: " ++ my_print_constr env_binders coqt) in + let _ = try trace (str "Interpreted type: " ++ my_print_constr env_binders coqt) with _ -> () in mk_tycon coqt in let c = coqintern !isevars env_binders c in - let _ = trace (str "Internalized term: " ++ my_print_rawconstr env c) in + let c = Subtac_utils.rewrite_cases env c in + let _ = try trace (str "Internalized term: " ++ my_print_rawconstr env c) with _ -> () in let coqc, ctyp = interp env_binders isevars c tycon in - let _ = trace (str "Interpreted term: " ++ my_print_constr env_binders coqc ++ spc () ++ + let _ = try trace (str "Interpreted term: " ++ my_print_constr env_binders coqc ++ spc () ++ str "Coq type: " ++ my_print_constr env_binders ctyp) + with _ -> () in - let _ = trace (str "Original evar map: " ++ Evd.pr_evar_map (evars ())) in + let _ = try trace (str "Original evar map: " ++ Evd.pr_evar_map (evars ())) with _ -> () in let fullcoqc = it_mkLambda_or_LetIn coqc binders_rel and fullctyp = it_mkProd_or_LetIn ctyp binders_rel @@ -141,10 +143,11 @@ let subtac_process env isevars id l c tycon = let fullcoqc = Evarutil.nf_evar (evars_of !isevars) fullcoqc in let fullctyp = Evarutil.nf_evar (evars_of !isevars) fullctyp in - let _ = trace (str "After evar normalization: " ++ spc () ++ + let _ = try trace (str "After evar normalization: " ++ spc () ++ str "Coq term: " ++ my_print_constr env fullcoqc ++ spc () ++ str "Coq type: " ++ my_print_constr env fullctyp) + with _ -> () in let evm = non_instanciated_map env isevars in - let _ = trace (str "Non instanciated evars map: " ++ Evd.pr_evar_map evm) in + let _ = try trace (str "Non instanciated evars map: " ++ Evd.pr_evar_map evm) with _ -> () in evm, fullcoqc, fullctyp diff --git a/contrib/subtac/subtac_pretyping_F.ml b/contrib/subtac/subtac_pretyping_F.ml new file mode 100644 index 00000000..65952750 --- /dev/null +++ b/contrib/subtac/subtac_pretyping_F.ml @@ -0,0 +1,639 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: subtac_pretyping_F.ml 8889 2006-06-01 20:23:56Z msozeau $ *) + +open Pp +open Util +open Names +open Sign +open Evd +open Term +open Termops +open Reductionops +open Environ +open Type_errors +open Typeops +open Libnames +open Nameops +open Classops +open List +open Recordops +open Evarutil +open Pretype_errors +open Rawterm +open Evarconv +open Pattern +open Dyn +open Pretyping + +(************************************************************************) +(* This concerns Cases *) +open Declarations +open Inductive +open Inductiveops + +module SubtacPretyping_F (Coercion : Coercion.S) = struct + + module Cases = Cases.Cases_F(Coercion) + + (* Allow references to syntaxically inexistent variables (i.e., if applied on an inductive) *) + let allow_anonymous_refs = ref true + + let evd_comb0 f isevars = + let (evd',x) = f !isevars in + isevars := evd'; + x + + let evd_comb1 f isevars x = + let (evd',y) = f !isevars x in + isevars := evd'; + y + + let evd_comb2 f isevars x y = + let (evd',z) = f !isevars x y in + isevars := evd'; + z + + let evd_comb3 f isevars x y z = + let (evd',t) = f !isevars x y z in + isevars := evd'; + t + + let mt_evd = Evd.empty + + let vect_lift_type = Array.mapi (fun i t -> type_app (lift i) t) + + (* Utilisé pour inférer le prédicat des Cases *) + (* Semble exagérement fort *) + (* Faudra préférer une unification entre les types de toutes les clauses *) + (* et autoriser des ? ą rester dans le résultat de l'unification *) + + let evar_type_fixpoint loc env isevars lna lar vdefj = + let lt = Array.length vdefj in + if Array.length lar = lt then + for i = 0 to lt-1 do + if not (e_cumul env isevars (vdefj.(i)).uj_type + (lift lt lar.(i))) then + error_ill_typed_rec_body_loc loc env (evars_of !isevars) + i lna vdefj lar + done + + let check_branches_message loc env isevars c (explft,lft) = + for i = 0 to Array.length explft - 1 do + if not (e_cumul env isevars lft.(i) explft.(i)) then + let sigma = evars_of !isevars in + error_ill_formed_branch_loc loc env sigma c i lft.(i) explft.(i) + done + + (* coerce to tycon if any *) + let inh_conv_coerce_to_tycon loc env isevars j = function + | None -> j + | Some t -> evd_comb2 (Coercion.inh_conv_coerce_to loc env) isevars j t + + let push_rels vars env = List.fold_right push_rel vars env + + (* + let evar_type_case isevars env ct pt lft p c = + let (mind,bty,rslty) = type_case_branches env (evars_of isevars) ct pt p c + in check_branches_message isevars env (c,ct) (bty,lft); (mind,rslty) + *) + + let strip_meta id = (* For Grammar v7 compatibility *) + let s = string_of_id id in + if s.[0]='$' then id_of_string (String.sub s 1 (String.length s - 1)) + else id + + let pretype_id loc env (lvar,unbndltacvars) id = + let id = strip_meta id in (* May happen in tactics defined by Grammar *) + try + let (n,typ) = lookup_rel_id id (rel_context env) in + { uj_val = mkRel n; uj_type = type_app (lift n) typ } + with Not_found -> + try + List.assoc id lvar + with Not_found -> + try + let (_,_,typ) = lookup_named id env in + { uj_val = mkVar id; uj_type = typ } + with Not_found -> + try (* To build a nicer ltac error message *) + match List.assoc id unbndltacvars with + | None -> user_err_loc (loc,"", + str "variable " ++ pr_id id ++ str " should be bound to a term") + | Some id0 -> Pretype_errors.error_var_not_found_loc loc id0 + with Not_found -> + error_var_not_found_loc loc id + + (* make a dependent predicate from an undependent one *) + + let make_dep_of_undep env (IndType (indf,realargs)) pj = + let n = List.length realargs in + let rec decomp n p = + if n=0 then p else + match kind_of_term p with + | Lambda (_,_,c) -> decomp (n-1) c + | _ -> decomp (n-1) (applist (lift 1 p, [mkRel 1])) + in + let sign,s = decompose_prod_n n pj.uj_type in + let ind = build_dependent_inductive env indf in + let s' = mkProd (Anonymous, ind, s) in + let ccl = lift 1 (decomp n pj.uj_val) in + let ccl' = mkLambda (Anonymous, ind, ccl) in + {uj_val=lam_it ccl' sign; uj_type=prod_it s' sign} + + (*************************************************************************) + (* Main pretyping function *) + + let pretype_ref isevars env ref = + let c = constr_of_global ref in + make_judge c (Retyping.get_type_of env Evd.empty c) + + let pretype_sort = function + | RProp c -> judge_of_prop_contents c + | RType _ -> judge_of_new_Type () + + (* [pretype tycon env isevars lvar lmeta cstr] attempts to type [cstr] *) + (* in environment [env], with existential variables [(evars_of isevars)] and *) + (* the type constraint tycon *) + let rec pretype (tycon : type_constraint) env isevars lvar = function + | RRef (loc,ref) -> + inh_conv_coerce_to_tycon loc env isevars + (pretype_ref isevars env ref) + tycon + + | RVar (loc, id) -> + inh_conv_coerce_to_tycon loc env isevars + (pretype_id loc env lvar id) + tycon + + | REvar (loc, ev, instopt) -> + (* Ne faudrait-il pas s'assurer que hyps est bien un + sous-contexte du contexte courant, et qu'il n'y a pas de Rel "caché" *) + let hyps = evar_context (Evd.find (evars_of !isevars) ev) in + let args = match instopt with + | None -> instance_from_named_context hyps + | Some inst -> failwith "Evar subtitutions not implemented" in + let c = mkEvar (ev, args) in + let j = (Retyping.get_judgment_of env (evars_of !isevars) c) in + inh_conv_coerce_to_tycon loc env isevars j tycon + + | RPatVar (loc,(someta,n)) -> + anomaly "Found a pattern variable in a rawterm to type" + + | RHole (loc,k) -> + let ty = + match tycon with + | Some (None, ty) -> ty + | None | Some _ -> + e_new_evar isevars env ~src:(loc,InternalHole) (new_Type ()) in + { uj_val = e_new_evar isevars env ~src:(loc,k) ty; uj_type = ty } + + | RRec (loc,fixkind,names,bl,lar,vdef) -> + let rec type_bl env ctxt = function + [] -> ctxt + | (na,None,ty)::bl -> + let ty' = pretype_type empty_valcon env isevars lvar ty in + let dcl = (na,None,ty'.utj_val) in + type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl + | (na,Some bd,ty)::bl -> + let ty' = pretype_type empty_valcon env isevars lvar ty in + let bd' = pretype (mk_tycon ty'.utj_val) env isevars lvar ty in + let dcl = (na,Some bd'.uj_val,ty'.utj_val) in + type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl in + let ctxtv = Array.map (type_bl env empty_rel_context) bl in + let larj = + array_map2 + (fun e ar -> + pretype_type empty_valcon (push_rel_context e env) isevars lvar ar) + ctxtv lar in + let lara = Array.map (fun a -> a.utj_val) larj in + let ftys = array_map2 (fun e a -> it_mkProd_or_LetIn a e) ctxtv lara in + let nbfix = Array.length lar in + let names = Array.map (fun id -> Name id) names in + (* Note: bodies are not used by push_rec_types, so [||] is safe *) + let newenv = push_rec_types (names,ftys,[||]) env in + let vdefj = + array_map2_i + (fun i ctxt def -> + (* we lift nbfix times the type in tycon, because of + * the nbfix variables pushed to newenv *) + let (ctxt,ty) = + decompose_prod_n_assum (rel_context_length ctxt) + (lift nbfix ftys.(i)) in + let nenv = push_rel_context ctxt newenv in + let j = pretype (mk_tycon ty) nenv isevars lvar def in + { uj_val = it_mkLambda_or_LetIn j.uj_val ctxt; + uj_type = it_mkProd_or_LetIn j.uj_type ctxt }) + ctxtv vdef in + evar_type_fixpoint loc env isevars names ftys vdefj; + let fixj = match fixkind with + | RFix (vn,i) -> + let guard_indexes = Array.mapi + (fun i (n,_) -> match n with + | Some n -> n + | None -> + (* Recursive argument was not given by the user : We + check that there is only one inductive argument *) + let ctx = ctxtv.(i) in + let isIndApp t = + isInd (fst (decompose_app (strip_head_cast t))) in + (* This could be more precise (e.g. do some delta) *) + let lb = List.rev_map (fun (_,_,t) -> isIndApp t) ctx in + try (list_unique_index true lb) - 1 + with Not_found -> + Util.user_err_loc + (loc,"pretype", + Pp.str "cannot guess decreasing argument of fix")) + vn + in + let fix = ((guard_indexes, i),(names,ftys,Array.map j_val vdefj)) in + (try check_fix env fix with e -> Stdpp.raise_with_loc loc e); + make_judge (mkFix fix) ftys.(i) + | RCoFix i -> + let cofix = (i,(names,ftys,Array.map j_val vdefj)) in + (try check_cofix env cofix with e -> Stdpp.raise_with_loc loc e); + make_judge (mkCoFix cofix) ftys.(i) in + inh_conv_coerce_to_tycon loc env isevars fixj tycon + + | RSort (loc,s) -> + inh_conv_coerce_to_tycon loc env isevars (pretype_sort s) tycon + + | RApp (loc,f,args) -> + let length = List.length args in + let ftycon = + match tycon with + None -> None + | Some (None, ty) -> mk_abstr_tycon length ty + | Some (Some (init, cur), ty) -> + Some (Some (length + init, length + cur), ty) + in + let fj = pretype ftycon env isevars lvar f in + let floc = loc_of_rawconstr f in + let rec apply_rec env n resj tycon = function + | [] -> resj + | c::rest -> + let argloc = loc_of_rawconstr c in + let resj = evd_comb1 (Coercion.inh_app_fun env) isevars resj in + let resty = whd_betadeltaiota env (evars_of !isevars) resj.uj_type in + match kind_of_term resty with + | Prod (na,c1,c2) -> + let hj = pretype (mk_tycon c1) env isevars lvar c in + let value, typ = applist (j_val resj, [j_val hj]), subst1 hj.uj_val c2 in + let typ' = nf_isevar !isevars typ in + let tycon = + option_map + (fun (abs, ty) -> + match abs with + None -> + isevars := Coercion.inh_conv_coerces_to loc env !isevars typ' + (abs, ty); + (abs, ty) + | Some (init, cur) -> + isevars := Coercion.inh_conv_coerces_to loc env !isevars typ' + (abs, ty); + (Some (init, pred cur), ty)) + tycon + in + apply_rec env (n+1) + { uj_val = nf_isevar !isevars value; + uj_type = nf_isevar !isevars typ' } + (option_map (fun (abs, c) -> abs, nf_isevar !isevars c) tycon) rest + + | _ -> + let hj = pretype empty_tycon env isevars lvar c in + error_cant_apply_not_functional_loc + (join_loc floc argloc) env (evars_of !isevars) + resj [hj] + in + let ftycon = option_map (lift_abstr_tycon_type (-1)) ftycon in + let resj = j_nf_evar (evars_of !isevars) (apply_rec env 1 fj ftycon args) in + let resj = + match kind_of_term resj.uj_val with + | App (f,args) when isInd f -> + let sigma = evars_of !isevars in + let t = Retyping.type_of_inductive_knowing_parameters env sigma (destInd f) args in + let s = snd (splay_arity env sigma t) in + on_judgment_type (set_inductive_level env s) resj + (* Rem: no need to send sigma: no head evar, it's an arity *) + | _ -> resj in + inh_conv_coerce_to_tycon loc env isevars resj tycon + + | RLambda(loc,name,c1,c2) -> + let (name',dom,rng) = evd_comb1 (split_tycon loc env) isevars tycon in + let dom_valcon = valcon_of_tycon dom in + let j = pretype_type dom_valcon env isevars lvar c1 in + let var = (name,None,j.utj_val) in + let j' = pretype rng (push_rel var env) isevars lvar c2 in + judge_of_abstraction env name j j' + + | RProd(loc,name,c1,c2) -> + let j = pretype_type empty_valcon env isevars lvar c1 in + let var = (name,j.utj_val) in + let env' = push_rel_assum var env in + let j' = pretype_type empty_valcon env' isevars lvar c2 in + let resj = + try judge_of_product env name j j' + with TypeError _ as e -> Stdpp.raise_with_loc loc e in + inh_conv_coerce_to_tycon loc env isevars resj tycon + + | RLetIn(loc,name,c1,c2) -> + let j = pretype empty_tycon env isevars lvar c1 in + let t = refresh_universes j.uj_type in + let var = (name,Some j.uj_val,t) in + let tycon = lift_tycon 1 tycon in + let j' = pretype tycon (push_rel var env) isevars lvar c2 in + { uj_val = mkLetIn (name, j.uj_val, t, j'.uj_val) ; + uj_type = subst1 j.uj_val j'.uj_type } + + | RLetTuple (loc,nal,(na,po),c,d) -> + let cj = pretype empty_tycon env isevars lvar c in + let (IndType (indf,realargs)) = + try find_rectype env (evars_of !isevars) cj.uj_type + with Not_found -> + let cloc = loc_of_rawconstr c in + error_case_not_inductive_loc cloc env (evars_of !isevars) cj + in + let cstrs = get_constructors env indf in + if Array.length cstrs <> 1 then + user_err_loc (loc,"",str "Destructing let is only for inductive types with one constructor"); + let cs = cstrs.(0) in + if List.length nal <> cs.cs_nargs then + user_err_loc (loc,"", str "Destructing let on this type expects " ++ int cs.cs_nargs ++ str " variables"); + let fsign = List.map2 (fun na (_,c,t) -> (na,c,t)) + (List.rev nal) cs.cs_args in + let env_f = push_rels fsign env in + (* Make dependencies from arity signature impossible *) + let arsgn = + let arsgn,_ = get_arity env indf in + if not !allow_anonymous_refs then + List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn + else arsgn + in + let psign = (na,None,build_dependent_inductive env indf)::arsgn in + let nar = List.length arsgn in + (match po with + | Some p -> + let env_p = push_rels psign env in + let pj = pretype_type empty_valcon env_p isevars lvar p in + let ccl = nf_evar (evars_of !isevars) pj.utj_val in + let psign = make_arity_signature env true indf in (* with names *) + let p = it_mkLambda_or_LetIn ccl psign in + let inst = + (Array.to_list cs.cs_concl_realargs) + @[build_dependent_constructor cs] in + let lp = lift cs.cs_nargs p in + let fty = hnf_lam_applist env (evars_of !isevars) lp inst in + let fj = pretype (mk_tycon fty) env_f isevars lvar d in + let f = it_mkLambda_or_LetIn fj.uj_val fsign in + let v = + let mis,_ = dest_ind_family indf in + let ci = make_default_case_info env LetStyle mis in + mkCase (ci, p, cj.uj_val,[|f|]) in + { uj_val = v; uj_type = substl (realargs@[cj.uj_val]) ccl } + + | None -> + let tycon = lift_tycon cs.cs_nargs tycon in + let fj = pretype tycon env_f isevars lvar d in + let f = it_mkLambda_or_LetIn fj.uj_val fsign in + let ccl = nf_evar (evars_of !isevars) fj.uj_type in + let ccl = + if noccur_between 1 cs.cs_nargs ccl then + lift (- cs.cs_nargs) ccl + else + error_cant_find_case_type_loc loc env (evars_of !isevars) + cj.uj_val in + let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in + let v = + let mis,_ = dest_ind_family indf in + let ci = make_default_case_info env LetStyle mis in + mkCase (ci, p, cj.uj_val,[|f|] ) + in + { uj_val = v; uj_type = ccl }) + + | RIf (loc,c,(na,po),b1,b2) -> + let cj = pretype empty_tycon env isevars lvar c in + let (IndType (indf,realargs)) = + try find_rectype env (evars_of !isevars) cj.uj_type + with Not_found -> + let cloc = loc_of_rawconstr c in + error_case_not_inductive_loc cloc env (evars_of !isevars) cj in + let cstrs = get_constructors env indf in + if Array.length cstrs <> 2 then + user_err_loc (loc,"", + str "If is only for inductive types with two constructors"); + + let arsgn = + let arsgn,_ = get_arity env indf in + if not !allow_anonymous_refs then + (* Make dependencies from arity signature impossible *) + List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn + else arsgn + in + let nar = List.length arsgn in + let psign = (na,None,build_dependent_inductive env indf)::arsgn in + let pred,p = match po with + | Some p -> + let env_p = push_rels psign env in + let pj = pretype_type empty_valcon env_p isevars lvar p in + let ccl = nf_evar (evars_of !isevars) pj.utj_val in + let pred = it_mkLambda_or_LetIn ccl psign in + let typ = lift (- nar) (beta_applist (pred,[cj.uj_val])) in + let jtyp = inh_conv_coerce_to_tycon loc env isevars {uj_val = pred; + uj_type = typ} tycon + in + jtyp.uj_val, jtyp.uj_type + | None -> + let p = match tycon with + | Some (None, ty) -> ty + | None | Some _ -> + e_new_evar isevars env ~src:(loc,InternalHole) (new_Type ()) + in + it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in + let pred = nf_evar (evars_of !isevars) pred in + let p = nf_evar (evars_of !isevars) p in + (* msgnl (str "Pred is: " ++ Termops.print_constr_env env pred);*) + let f cs b = + let n = rel_context_length cs.cs_args in + let pi = lift n pred in (* liftn n 2 pred ? *) + let pi = beta_applist (pi, [build_dependent_constructor cs]) in + let csgn = + if not !allow_anonymous_refs then + List.map (fun (_,b,t) -> (Anonymous,b,t)) cs.cs_args + else + List.map + (fun (n, b, t) -> + match n with + Name _ -> (n, b, t) + | Anonymous -> (Name (id_of_string "H"), b, t)) + cs.cs_args + in + let env_c = push_rels csgn env in +(* msgnl (str "Pi is: " ++ Termops.print_constr_env env_c pi); *) + let bj = pretype (mk_tycon pi) env_c isevars lvar b in + it_mkLambda_or_LetIn bj.uj_val cs.cs_args in + let b1 = f cstrs.(0) b1 in + let b2 = f cstrs.(1) b2 in + let v = + let mis,_ = dest_ind_family indf in + let ci = make_default_case_info env IfStyle mis in + mkCase (ci, pred, cj.uj_val, [|b1;b2|]) + in + { uj_val = v; uj_type = p } + + | RCases (loc,po,tml,eqns) -> + Cases.compile_cases loc + ((fun vtyc env -> pretype vtyc env isevars lvar),isevars) + tycon env (* loc *) (po,tml,eqns) + + | RCast(loc,c,k,t) -> + let cj = + match k with + CastCoerce -> + let cj = pretype empty_tycon env isevars lvar c in + evd_comb1 (Coercion.inh_coerce_to_base loc env) isevars cj + | CastConv k -> + let tj = pretype_type empty_valcon env isevars lvar t in + let cj = pretype (mk_tycon tj.utj_val) env isevars lvar c in + (* User Casts are for helping pretyping, experimentally not to be kept*) + (* ... except for Correctness *) + let v = mkCast (cj.uj_val, k, tj.utj_val) in + { uj_val = v; uj_type = tj.utj_val } + in + inh_conv_coerce_to_tycon loc env isevars cj tycon + + | RDynamic (loc,d) -> + if (tag d) = "constr" then + let c = constr_out d in + let j = (Retyping.get_judgment_of env (evars_of !isevars) c) in + j + (*inh_conv_coerce_to_tycon loc env isevars j tycon*) + else + user_err_loc (loc,"pretype",(str "Not a constr tagged Dynamic")) + + (* [pretype_type valcon env isevars lvar c] coerces [c] into a type *) + and pretype_type valcon env isevars lvar = function + | RHole loc -> + (match valcon with + | Some v -> + let s = + let sigma = evars_of !isevars in + let t = Retyping.get_type_of env sigma v in + match kind_of_term (whd_betadeltaiota env sigma t) with + | Sort s -> s + | Evar v when is_Type (existential_type sigma v) -> + evd_comb1 (define_evar_as_sort) isevars v + | _ -> anomaly "Found a type constraint which is not a type" + in + { utj_val = v; + utj_type = s } + | None -> + let s = new_Type_sort () in + { utj_val = e_new_evar isevars env ~src:loc (mkSort s); + utj_type = s}) + | c -> + let j = pretype empty_tycon env isevars lvar c in + let loc = loc_of_rawconstr c in + let tj = evd_comb1 (Coercion.inh_coerce_to_sort loc env) isevars j in + match valcon with + | None -> tj + | Some v -> + if e_cumul env isevars v tj.utj_val then tj + else + error_unexpected_type_loc + (loc_of_rawconstr c) env (evars_of !isevars) tj.utj_val v + + let pretype_gen isevars env lvar kind c = + let c' = match kind with + | OfType exptyp -> + let tycon = match exptyp with None -> empty_tycon | Some t -> mk_tycon t in + (pretype tycon env isevars lvar c).uj_val + | IsType -> + (pretype_type empty_valcon env isevars lvar c).utj_val in + nf_evar (evars_of !isevars) c' + + (* [check_evars] fails if some unresolved evar remains *) + (* it assumes that the defined existentials have already been substituted + (should be done in unsafe_infer and unsafe_infer_type) *) + + let check_evars env initial_sigma isevars c = + let sigma = evars_of !isevars in + let rec proc_rec c = + match kind_of_term c with + | Evar (ev,args) -> + assert (Evd.mem sigma ev); + if not (Evd.mem initial_sigma ev) then + let (loc,k) = evar_source ev !isevars in + error_unsolvable_implicit loc env sigma k + | _ -> iter_constr proc_rec c + in + proc_rec c(*; + let (_,pbs) = get_conv_pbs !isevars (fun _ -> true) in + if pbs <> [] then begin + pperrnl + (str"TYPING OF "++Termops.print_constr_env env c++fnl()++ + prlist_with_sep fnl + (fun (pb,c1,c2) -> + Termops.print_constr c1 ++ + (if pb=Reduction.CUMUL then str " <="++ spc() + else str" =="++spc()) ++ + Termops.print_constr c2) + pbs ++ fnl()) + end*) + + (* TODO: comment faire remonter l'information si le typage a resolu des + variables du sigma original. il faudrait que la fonction de typage + retourne aussi le nouveau sigma... + *) + + let understand_judgment sigma env c = + let isevars = ref (create_evar_defs sigma) in + let j = pretype empty_tycon env isevars ([],[]) c in + let j = j_nf_evar (evars_of !isevars) j in + check_evars env sigma isevars (mkCast(j.uj_val,DEFAULTcast, j.uj_type)); + j + + let understand_judgment_tcc isevars env c = + let j = pretype empty_tycon env isevars ([],[]) c in + let sigma = evars_of !isevars in + let j = j_nf_evar sigma j in + j + + (* Raw calls to the unsafe inference machine: boolean says if we must + fail on unresolved evars; the unsafe_judgment list allows us to + extend env with some bindings *) + + let ise_pretype_gen fail_evar sigma env lvar kind c = + let isevars = ref (Evd.create_evar_defs sigma) in + let c = pretype_gen isevars env lvar kind c in + if fail_evar then check_evars env sigma isevars c; + !isevars, c + + (** Entry points of the high-level type synthesis algorithm *) + + let understand_gen kind sigma env c = + snd (ise_pretype_gen true sigma env ([],[]) kind c) + + let understand sigma env ?expected_type:exptyp c = + snd (ise_pretype_gen true sigma env ([],[]) (OfType exptyp) c) + + let understand_type sigma env c = + snd (ise_pretype_gen true sigma env ([],[]) IsType c) + + let understand_ltac sigma env lvar kind c = + ise_pretype_gen false sigma env lvar kind c + + let understand_tcc_evars isevars env kind c = + pretype_gen isevars env ([],[]) kind c + + let understand_tcc sigma env ?expected_type:exptyp c = + let ev, t = ise_pretype_gen false sigma env ([],[]) (OfType exptyp) c in + Evd.evars_of ev, t +end + +module Default : S = SubtacPretyping_F(Coercion.Default) diff --git a/contrib/subtac/subtac_utils.ml b/contrib/subtac/subtac_utils.ml index 6c165dad..59c858a6 100644 --- a/contrib/subtac/subtac_utils.ml +++ b/contrib/subtac/subtac_utils.ml @@ -57,7 +57,7 @@ let natind = lazy (init_constant ["Init"; "Datatypes"] "nat") let intind = lazy (init_constant ["ZArith"; "binint"] "Z") let existSind = lazy (init_constant ["Init"; "Specif"] "sigS") -let existS = lazy (build_sigma_set ()) +let existS = lazy (build_sigma_type ()) let prod = lazy (build_prod ()) @@ -118,8 +118,8 @@ let print_args env args = let make_existential loc env isevars c = let evar = Evarutil.e_new_evar isevars env ~src:(loc, QuestionMark) c in let (key, args) = destEvar evar in - debug 2 (str "Constructed evar " ++ int key ++ str " applied to args: " ++ - print_args env args); + (try debug 2 (str "Constructed evar " ++ int key ++ str " applied to args: " ++ + print_args env args) with _ -> ()); evar let make_existential_expr loc env c = @@ -160,26 +160,27 @@ open Tactics open Tacticals let build_dependent_sum l = - let rec aux (acc, tac, typ) = function + let rec aux (tac, typ) = function (n, t) :: tl -> let t' = mkLambda (Name n, t, typ) in - trace (str ("treating " ^ string_of_id n) ++ - str "assert: " ++ my_print_constr (Global.env ()) t); + trace (spc () ++ str ("treating evar " ^ string_of_id n)); + (try trace (str " assert: " ++ my_print_constr (Global.env ()) t) + with _ -> ()); let tac' = - tclTHEN (assert_tac true (Name n) t) - (tclTHENLIST - [intros; - (tclTHENSEQ - [tclTRY (constructor_tac (Some 1) 1 - (Rawterm.ImplicitBindings [mkVar n])); - tac]); - ]) + tclTHENS (assert_tac true (Name n) t) + ([intros; + (tclTHENSEQ + [constructor_tac (Some 1) 1 + (Rawterm.ImplicitBindings [mkVar n]); + tac]); + ]) in - aux (mkApp (Lazy.force ex_ind, [| t; t'; |]), tac', t') tl - | [] -> acc, tac, typ + let newt = mkApp (Lazy.force ex_ind, [| t; t'; |]) in + aux (tac', newt) tl + | [] -> tac, typ in match l with - (_, hd) :: tl -> aux (hd, intros, hd) tl + (_, hd) :: tl -> aux (intros, hd) tl | [] -> raise (Invalid_argument "build_dependent_sum") open Proof_type @@ -218,7 +219,8 @@ let and_tac l hook = let and_proof_id, and_goal, and_tac, and_extract = match l with | [] -> raise (Invalid_argument "and_tac: empty list of goals") - | (hdid, x, hdg, hdt) :: tl -> aux (string_of_id hdid, hdg, hdt, [hdid, x, hdg, (fun c -> c)]) tl + | (hdid, x, hdg, hdt) :: tl -> + aux (string_of_id hdid, hdg, hdt, [hdid, x, hdg, (fun c -> c)]) tl in let and_proofid = id_of_string (and_proof_id ^ "_and_proof") in Command.start_proof and_proofid goal_kind and_goal @@ -238,9 +240,91 @@ let destruct_ex ext ex = try (args.(0), args.(1)) with _ -> assert(false) in - (mk_ex_pi1 dom rng acc) :: aux rng (mk_ex_pi2 dom rng acc) + let pi1 = (mk_ex_pi1 dom rng acc) in + let rng_body = + match kind_of_term rng with + Lambda (_, _, t) -> subst1 pi1 t + | t -> rng + in + pi1 :: aux rng_body (mk_ex_pi2 dom rng acc) | _ -> [acc]) | _ -> [acc] in aux ex ext +let list_mapi f = + let rec aux i = function + hd :: tl -> f i hd :: aux (succ i) tl + | [] -> [] + in aux 0 + +open Rawterm + +let rewrite_cases_aux (loc, po, tml, eqns) = + let tml' = list_mapi (fun i (c, (n, opt)) -> c, + ((match n with + Name id -> (match c with + | RVar (_, id') when id = id' -> + id, (id_of_string (string_of_id id ^ "Heq_id")) + | RVar (_, id') -> + id', id + | _ -> id_of_string (string_of_id id ^ "Heq_id"), id) + | Anonymous -> + let str = "Heq_id" ^ string_of_int i in + id_of_string str, id_of_string (str ^ "'")), + opt)) tml + in + let mkHole = RHole (dummy_loc, InternalHole) in + let mkCoerceCast c = RCast (dummy_loc, c, CastCoerce, mkHole) in + let mkeq c n = RApp (dummy_loc, RRef (dummy_loc, (Lazy.force eqind_ref)), + [mkHole; c; n]) + in + let eqs_types = + List.map + (fun (c, ((id, id'), _)) -> + let heqid = id_of_string ("Heq" ^ string_of_id id) in + Name heqid, mkeq (RVar (dummy_loc, id')) c) + tml' + in + let po = + List.fold_right + (fun (n,t) acc -> + RProd (dummy_loc, Anonymous, t, acc)) + eqs_types (match po with + Some e -> e + | None -> mkHole) + in + let eqns = + List.map (fun (loc, idl, cpl, c) -> + let c' = + List.fold_left + (fun acc (n, t) -> + RLambda (dummy_loc, n, mkHole, acc)) + c eqs_types + in (loc, idl, cpl, c')) + eqns + in + let mk_refl_equal c = RApp (dummy_loc, RRef (dummy_loc, Lazy.force refl_equal_ref), + [mkHole; c]) + in + let refls = List.map (fun (c, ((id, _), _)) -> mk_refl_equal (mkCoerceCast c)) tml' in + let tml'' = List.map (fun (c, ((id, id'), opt)) -> c, (Name id', opt)) tml' in + let case = RCases (loc,Some po,tml'',eqns) in + let app = RApp (dummy_loc, case, refls) in +(* let letapp = List.fold_left (fun acc (c, ((id, id'), opt)) -> RLetIn (dummy_loc, Name id, c, acc)) *) +(* app tml' *) +(* in *) + app + +let rec rewrite_cases c = + match c with + RCases _ -> let c' = map_rawconstr rewrite_cases c in + (match c' with + | RCases (x, y, z, w) -> rewrite_cases_aux (x,y,z,w) + | _ -> assert(false)) + | _ -> map_rawconstr rewrite_cases c + +let rewrite_cases env c = + let c' = rewrite_cases c in + let _ = trace (str "Rewrote cases: " ++ spc () ++ my_print_rawconstr env c') in + c' diff --git a/contrib/subtac/subtac_utils.mli b/contrib/subtac/subtac_utils.mli index 92a995c8..a90f281f 100644 --- a/contrib/subtac/subtac_utils.mli +++ b/contrib/subtac/subtac_utils.mli @@ -78,8 +78,10 @@ val mkProj1 : constr -> constr -> constr -> constr val mk_ex_pi1 : constr -> constr -> constr -> constr val mk_ex_pi1 : constr -> constr -> constr -> constr -val build_dependent_sum : (identifier * types) list -> constr * Proof_type.tactic * types +val build_dependent_sum : (identifier * types) list -> Proof_type.tactic * types val and_tac : (identifier * 'a * constr * Proof_type.tactic) list -> ((constr -> (identifier * 'a * constr * constr) list) -> Tacexpr.declaration_hook) -> unit val destruct_ex : constr -> constr -> constr list + +val rewrite_cases : Environ.env -> Rawterm.rawconstr -> Rawterm.rawconstr diff --git a/contrib/subtac/test/ListsTest.v b/contrib/subtac/test/ListsTest.v new file mode 100644 index 00000000..a29cd039 --- /dev/null +++ b/contrib/subtac/test/ListsTest.v @@ -0,0 +1,95 @@ +Require Import Coq.subtac.Utils. +Require Import List. + +Variable A : Set. + +Program Definition myhd : forall { l : list A | length l <> 0 }, A := + fun l => + match l with + | nil => _ + | hd :: tl => hd + end. +Proof. + destruct l ; simpl ; intro H ; rewrite <- H in n ; intuition. +Defined. + + +Extraction myhd. +Extraction Inline proj1_sig. + +Program Definition mytail : forall { l : list A | length l <> 0 }, list A := + fun l => + match l with + | nil => _ + | hd :: tl => tl + end. +Proof. +destruct l ; simpl ; intro H ; rewrite <- H in n ; intuition. +Defined. + +Extraction mytail. + +Variable a : A. + +Program Definition test_hd : A := myhd (cons a nil). +Proof. +simpl ; auto. +Defined. + +Extraction test_hd. + +(*Program Definition test_tail : list A := mytail nil.*) + + + + + +Program Fixpoint append (l : list A) (l' : list A) { struct l } : + { r : list A | length r = length l + length l' } := + match l with + | nil => l' + | hd :: tl => hd :: (append tl l') + end. +simpl. +subst ; auto. +simpl ; rewrite (subset_simpl (append tl0 l')). +simpl ; subst. +simpl ; auto. +Defined. + +Extraction append. + + +Program Lemma append_app' : forall l : list A, l = append nil l. +Proof. +simpl ; auto. +Qed. + +Program Lemma append_app : forall l : list A, l = append l nil. +Proof. +intros. +induction l ; simpl ; auto. +simpl in IHl. +rewrite <- IHl. +reflexivity. +Qed. + + + + + + + + + + + + + + + + + + + + diff --git a/contrib/subtac/test/Mutind.v b/contrib/subtac/test/Mutind.v new file mode 100644 index 00000000..ab200354 --- /dev/null +++ b/contrib/subtac/test/Mutind.v @@ -0,0 +1,7 @@ +Fixpoint f (a : nat) : nat := match a with 0 => 0 +| S a' => g a a' + end +with g (a b : nat) { struct b } : nat := + match b with 0 => 0 + | S b' => f b' + end.
\ No newline at end of file diff --git a/contrib/subtac/test/Test1.v b/contrib/subtac/test/Test1.v new file mode 100644 index 00000000..14b80854 --- /dev/null +++ b/contrib/subtac/test/Test1.v @@ -0,0 +1,16 @@ +Program Definition test (a b : nat) : { x : nat | x = a + b } := + ((a + b) : { x : nat | x = a + b }). +Proof. +intros. +reflexivity. +Qed. + +Print test. + +Require Import List. + +Program hd_opt (l : list nat) : { x : nat | x <> 0 } := + match l with + nil => 1 + | a :: l => a + end. diff --git a/contrib/subtac/test/euclid.v b/contrib/subtac/test/euclid.v new file mode 100644 index 00000000..481b6708 --- /dev/null +++ b/contrib/subtac/test/euclid.v @@ -0,0 +1,66 @@ + +Notation "( x & y )" := (@existS _ _ x y) : core_scope. +Unset Printing All. + +Definition t := fun (Evar46 : forall a : nat, (fun y : nat => @eq nat a y) a) (a : nat) => +@existS nat (fun x : nat => @sig nat (fun y : nat => @eq nat x y)) a + (@exist nat (fun y : nat => @eq nat a y) a (Evar46 a)). + +Program Definition testsig (a : nat) : { x : nat & { y : nat | x = y } } := + (a & a). +reflexivity. +Defined. + +Extraction testsig. +Extraction sigS. +Extract Inductive sigS => "" [ "" ]. +Extraction testsig. + +Require Import Coq.Arith.Compare_dec. + +Require Import Omega. + +Lemma minus_eq_add : forall x y z w, y <= x -> x - y = y * z + w -> x = y * S z + w. +intros. +assert(y * S z = y * z + y). +auto. +rewrite H1. +omega. +Qed. + +Program Fixpoint euclid (a : nat) (b : { b : nat | b <> O }) {wf a lt} : + { q : nat & { r : nat | a = b * q + r /\ r < b } } := + if le_lt_dec b a then let (q', r) := euclid (a - b) b in + (S q' & r) + else (O & a). +intro euclid. +simpl ; intros. +Print euclid_evars. +eapply euclid_evars with euclid. +refine (euclid_evars _ _ _ euclid a Acc_a b). +; simpl ; intros. +Show Existentials. + +induction b0 ; induction r. +simpl in H. +simpl. +simpl in p0. +destruct p0. +split. + +apply minus_eq_add. +omega. +auto with arith. +auto. +simpl. +induction b0 ; simpl. +split ; auto. +omega. +exact (euclid a0 Acc_a0 b0). + +exact (Acc_a). +auto. +auto. +Focus 1. + + diff --git a/contrib/subtac/test/id.v b/contrib/subtac/test/id.v new file mode 100644 index 00000000..9ae11088 --- /dev/null +++ b/contrib/subtac/test/id.v @@ -0,0 +1,46 @@ +Require Coq.Arith.Arith. + +Require Import Coq.subtac.Utils. +Program Fixpoint id (n : nat) : { x : nat | x = n } := + match n with + | O => O + | S p => S (id p) + end. +intros ; auto. + +pose (subset_simpl (id p)). +simpl in e. +unfold p0. +rewrite e. +auto. +Defined. + +Check id. +Print id. +Extraction id. + +Axiom le_gt_dec : forall n m, { n <= m } + { n > m }. +Require Import Omega. + +Program Fixpoint id_if (n : nat) { wf n lt }: { x : nat | x = n } := + if le_gt_dec n 0 then 0 + else S (id_if (pred n)). +intros. +auto with arith. +intros. +pose (subset_simpl (id_if (pred n))). +simpl in e. +rewrite e. +induction n ; auto with arith. +Defined. + +Print id_if_instance. +Extraction id_if_instance. + +Notation "( x & y )" := (@existS _ _ x y) : core_scope. + +Program Definition testsig ( a : nat ) : { x : nat & { y : nat | x = y }} := + (a & a). +intros. +auto. +Qed. diff --git a/contrib/subtac/test/rec.v b/contrib/subtac/test/rec.v new file mode 100644 index 00000000..aaefd8cc --- /dev/null +++ b/contrib/subtac/test/rec.v @@ -0,0 +1,65 @@ +Require Import Coq.Arith.Arith. +Require Import Lt. +Require Import Omega. + +Axiom lt_ge_dec : forall x y : nat, { x < y } + { x >= y }. +(*Proof. + intros. + elim (le_lt_dec y x) ; intros ; auto with arith. +Defined. +*) +Require Import Coq.subtac.FixSub. +Require Import Wf_nat. + +Lemma preda_lt_a : forall a, 0 < a -> pred a < a. +auto with arith. +Qed. + +Program Fixpoint id_struct (a : nat) : nat := + match a with + 0 => 0 + | S n => S (id_struct n) + end. + +Check struct_rec. + + if (lt_ge_dec O a) + then S (wfrec (pred a)) + else O. + +Program Fixpoint wfrec (a : nat) { wf a lt } : nat := + if (lt_ge_dec O a) + then S (wfrec (pred a)) + else O. +intros. +apply preda_lt_a ; auto. + +Defined. + +Extraction wfrec. +Extraction Inline proj1_sig. +Extract Inductive bool => "bool" [ "true" "false" ]. +Extract Inductive sumbool => "bool" [ "true" "false" ]. +Extract Inlined Constant lt_ge_dec => "<". + +Extraction wfrec. +Extraction Inline lt_ge_dec le_lt_dec. +Extraction wfrec. + + +Program Fixpoint structrec (a : nat) { wf a lt } : nat := + match a with + S n => S (structrec n) + | 0 => 0 + end. +intros. +unfold n0. +omega. +Defined. + +Print structrec. +Extraction structrec. +Extraction structrec. + +Definition structrec_fun (a : nat) : nat := structrec a (lt_wf a). +Print structrec_fun. diff --git a/contrib/xml/cic2acic.ml b/contrib/xml/cic2acic.ml index bac7ad7c..f217b037 100644 --- a/contrib/xml/cic2acic.ml +++ b/contrib/xml/cic2acic.ml @@ -64,7 +64,7 @@ let get_uri_of_var v pvars = in let rec search_in_open_sections = function - [] -> Util.error "Variable not found" + [] -> Util.error ("Variable "^v^" not found") | he::tl as modules -> let dirpath = N.make_dirpath modules in if List.mem (N.id_of_string v) (D.last_section_hyps dirpath) then @@ -167,10 +167,10 @@ let token_list_of_kernel_name tag = N.id_of_label (N.label kn), Lib.cwd () | Constant con -> N.id_of_label (N.con_label con), - Lib.library_part (LN.ConstRef con) + Lib.remove_section_part (LN.ConstRef con) | Inductive kn -> N.id_of_label (N.label kn), - Lib.library_part (LN.IndRef (kn,0)) + Lib.remove_section_part (LN.IndRef (kn,0)) in token_list_of_path dir id (etag_of_tag tag) ;; diff --git a/contrib/xml/doubleTypeInference.ml b/contrib/xml/doubleTypeInference.ml index 518f6c11..a3336817 100644 --- a/contrib/xml/doubleTypeInference.ml +++ b/contrib/xml/doubleTypeInference.ml @@ -93,7 +93,7 @@ let double_type_of env sigma cstr expectedty subterms_to_types = let jty = execute env sigma ty None in let jty = assumption_of_judgment env sigma jty in let evar_context = - E.named_context_of_val (Evd.map sigma n).Evd.evar_hyps in + E.named_context_of_val (Evd.find sigma n).Evd.evar_hyps in let rec iter actual_args evar_context = match actual_args,evar_context with [],[] -> () diff --git a/contrib/xml/proof2aproof.ml b/contrib/xml/proof2aproof.ml index dff546c9..678b650c 100644 --- a/contrib/xml/proof2aproof.ml +++ b/contrib/xml/proof2aproof.ml @@ -47,7 +47,7 @@ let nf_evar sigma ~preserve = | _ -> T.mkApp (c', l') ) | _ -> T.mkApp (c', l')) - | T.Evar (e,l) when Evd.in_dom sigma e & Evd.is_defined sigma e -> + | T.Evar (e,l) when Evd.mem sigma e & Evd.is_defined sigma e -> aux (Evd.existential_value sigma (e,l)) | T.Evar (e,l) -> T.mkEvar (e, Array.map aux l) | T.Case (ci,p,c,bl) -> T.mkCase (ci, aux p, aux c, Array.map aux bl) diff --git a/contrib/xml/xmlcommand.ml b/contrib/xml/xmlcommand.ml index 871a7f15..2235be4a 100644 --- a/contrib/xml/xmlcommand.ml +++ b/contrib/xml/xmlcommand.ml @@ -395,7 +395,7 @@ let mk_constant_obj id bo ty variables hyps = ty,params) ;; -let mk_inductive_obj sp packs variables nparams hyps finite = +let mk_inductive_obj sp mib packs variables nparams hyps finite = let module D = Declarations in let hyps = string_list_of_named_context_list hyps in let params = filter_params variables hyps in @@ -406,9 +406,9 @@ let mk_inductive_obj sp packs variables nparams hyps finite = (fun p i -> decr tyno ; let {D.mind_consnames=consnames ; - D.mind_typename=typename ; - D.mind_nf_arity=arity} = p + D.mind_typename=typename } = p in + let arity = Inductive.type_of_inductive (mib,p) in let lc = Inductiveops.arities_of_constructors (Global.env ()) (sp,!tyno) in let cons = (Array.fold_right (fun (name,lc) i -> (name,lc)::i) @@ -524,11 +524,12 @@ let print internal glob_ref kind xml_library_root = G.lookup_constant kn in Cic2acic.Constant kn,mk_constant_obj id val0 typ variables hyps | Ln.IndRef (kn,_) -> + let mib = G.lookup_mind kn in let {D.mind_nparams=nparams; D.mind_packets=packs ; D.mind_hyps=hyps; - D.mind_finite=finite} = G.lookup_mind kn in - Cic2acic.Inductive kn,mk_inductive_obj kn packs variables nparams hyps finite + D.mind_finite=finite} = mib in + Cic2acic.Inductive kn,mk_inductive_obj kn mib packs variables nparams hyps finite | Ln.ConstructRef _ -> Util.anomaly ("print: this should not happen") in |