From 300293c119981054c95182a90c829058530a6b6f Mon Sep 17 00:00:00 2001 From: Stephane Glondu Date: Sun, 25 Dec 2011 13:19:42 +0100 Subject: Imported Upstream version 8.3.pl3 --- plugins/cc/ccalgo.ml | 4 +- plugins/cc/ccalgo.mli | 4 +- plugins/cc/ccproof.ml | 4 +- plugins/cc/ccproof.mli | 4 +- plugins/cc/cctac.ml | 4 +- plugins/cc/cctac.mli | 4 +- plugins/cc/g_congruence.ml4 | 4 +- plugins/dp/g_dp.ml4 | 4 +- plugins/extraction/ExtrOcamlBasic.v | 2 +- plugins/extraction/ExtrOcamlBigIntConv.v | 2 +- plugins/extraction/ExtrOcamlIntConv.v | 2 +- plugins/extraction/ExtrOcamlNatBigInt.v | 2 +- plugins/extraction/ExtrOcamlNatInt.v | 2 +- plugins/extraction/ExtrOcamlString.v | 2 +- plugins/extraction/ExtrOcamlZBigInt.v | 2 +- plugins/extraction/ExtrOcamlZInt.v | 2 +- plugins/extraction/big.ml | 2 +- plugins/extraction/common.ml | 22 ++++++-- plugins/extraction/common.mli | 4 +- plugins/extraction/extract_env.ml | 22 ++++++-- plugins/extraction/extract_env.mli | 4 +- plugins/extraction/extraction.ml | 47 +++++++++------- plugins/extraction/extraction.mli | 4 +- plugins/extraction/g_extraction.ml4 | 2 +- plugins/extraction/haskell.ml | 8 ++- plugins/extraction/haskell.mli | 4 +- plugins/extraction/miniml.mli | 6 +- plugins/extraction/mlutil.ml | 57 ++++++++++++------- plugins/extraction/mlutil.mli | 6 +- plugins/extraction/modutil.ml | 6 +- plugins/extraction/modutil.mli | 4 +- plugins/extraction/ocaml.ml | 94 ++++++++++++++++++-------------- plugins/extraction/ocaml.mli | 4 +- plugins/extraction/scheme.ml | 4 +- plugins/extraction/scheme.mli | 4 +- plugins/extraction/table.ml | 34 +++++++++--- plugins/extraction/table.mli | 6 +- plugins/field/LegacyField.v | 4 +- plugins/field/LegacyField_Compl.v | 4 +- plugins/field/LegacyField_Tactic.v | 4 +- plugins/field/LegacyField_Theory.v | 4 +- plugins/field/field.ml4 | 4 +- plugins/firstorder/formula.ml | 4 +- plugins/firstorder/formula.mli | 4 +- plugins/firstorder/g_ground.ml4 | 4 +- plugins/firstorder/ground.ml | 4 +- plugins/firstorder/ground.mli | 4 +- plugins/firstorder/instances.ml | 4 +- plugins/firstorder/instances.mli | 4 +- plugins/firstorder/rules.ml | 4 +- plugins/firstorder/rules.mli | 4 +- plugins/firstorder/sequent.ml | 4 +- plugins/firstorder/sequent.mli | 4 +- plugins/firstorder/unify.ml | 4 +- plugins/firstorder/unify.mli | 4 +- plugins/fourier/Fourier.v | 4 +- plugins/fourier/Fourier_util.v | 4 +- plugins/fourier/fourier.ml | 4 +- plugins/fourier/fourierR.ml | 4 +- plugins/fourier/g_fourier.ml4 | 4 +- plugins/funind/Recdef.v | 2 +- plugins/funind/g_indfun.ml4 | 2 +- plugins/funind/invfun.ml | 11 +++- plugins/funind/merge.ml | 2 +- plugins/funind/rawterm_to_relation.ml | 79 ++++++++++++++++++++++++--- plugins/funind/recdef.ml | 4 +- plugins/micromega/CheckerMaker.v | 2 +- plugins/micromega/Env.v | 2 +- plugins/micromega/EnvRing.v | 2 +- plugins/micromega/MExtraction.v | 2 +- plugins/micromega/OrderedRing.v | 2 +- plugins/micromega/Psatz.v | 2 +- plugins/micromega/QMicromega.v | 2 +- plugins/micromega/RMicromega.v | 2 +- plugins/micromega/Refl.v | 2 +- plugins/micromega/RingMicromega.v | 2 +- plugins/micromega/Tauto.v | 2 +- plugins/micromega/VarMap.v | 2 +- plugins/micromega/ZCoeff.v | 2 +- plugins/micromega/ZMicromega.v | 2 +- plugins/micromega/certificate.ml | 2 +- plugins/micromega/coq_micromega.ml | 2 +- plugins/micromega/csdpcert.ml | 2 +- plugins/micromega/g_micromega.ml4 | 4 +- plugins/micromega/mutils.ml | 2 +- plugins/micromega/persistent_cache.ml | 2 +- plugins/micromega/sos.mli | 2 +- plugins/micromega/sos_types.ml | 2 +- plugins/nsatz/Nsatz.v | 2 +- plugins/nsatz/ideal.ml | 2 +- plugins/nsatz/nsatz.ml4 | 2 +- plugins/nsatz/polynom.ml | 2 +- plugins/nsatz/polynom.mli | 2 +- plugins/omega/Omega.v | 4 +- plugins/omega/OmegaPlugin.v | 4 +- plugins/omega/coq_omega.ml | 4 +- plugins/omega/g_omega.ml4 | 4 +- plugins/omega/omega.ml | 2 +- plugins/quote/Quote.v | 4 +- plugins/quote/g_quote.ml4 | 4 +- plugins/quote/quote.ml | 4 +- plugins/ring/LegacyArithRing.v | 4 +- plugins/ring/LegacyNArithRing.v | 4 +- plugins/ring/LegacyRing.v | 4 +- plugins/ring/LegacyRing_theory.v | 4 +- plugins/ring/LegacyZArithRing.v | 4 +- plugins/ring/Ring_abstract.v | 4 +- plugins/ring/Ring_normalize.v | 4 +- plugins/ring/Setoid_ring.v | 4 +- plugins/ring/Setoid_ring_normalize.v | 4 +- plugins/ring/Setoid_ring_theory.v | 4 +- plugins/ring/g_ring.ml4 | 4 +- plugins/ring/ring.ml | 4 +- plugins/rtauto/Bintree.v | 4 +- plugins/rtauto/Rtauto.v | 4 +- plugins/rtauto/g_rtauto.ml4 | 4 +- plugins/rtauto/proof_search.ml | 4 +- plugins/rtauto/proof_search.mli | 4 +- plugins/rtauto/refl_tauto.ml | 4 +- plugins/rtauto/refl_tauto.mli | 4 +- plugins/setoid_ring/ArithRing.v | 2 +- plugins/setoid_ring/BinList.v | 2 +- plugins/setoid_ring/Field.v | 2 +- plugins/setoid_ring/Field_tac.v | 2 +- plugins/setoid_ring/Field_theory.v | 2 +- plugins/setoid_ring/InitialRing.v | 2 +- plugins/setoid_ring/NArithRing.v | 2 +- plugins/setoid_ring/Ring.v | 2 +- plugins/setoid_ring/Ring_base.v | 2 +- plugins/setoid_ring/Ring_polynom.v | 2 +- plugins/setoid_ring/Ring_theory.v | 2 +- plugins/setoid_ring/ZArithRing.v | 2 +- plugins/setoid_ring/newring.ml4 | 4 +- plugins/subtac/eterm.mli | 4 +- plugins/subtac/g_subtac.ml4 | 4 +- plugins/subtac/subtac.ml | 4 +- plugins/subtac/subtac_cases.ml | 4 +- plugins/subtac/subtac_cases.mli | 4 +- plugins/subtac/subtac_classes.ml | 6 +- plugins/subtac/subtac_classes.mli | 4 +- plugins/subtac/subtac_coercion.ml | 4 +- plugins/subtac/subtac_pretyping.ml | 4 +- plugins/subtac/subtac_pretyping_F.ml | 4 +- plugins/subtac/subtac_utils.ml | 6 +- plugins/syntax/nat_syntax.ml | 4 +- plugins/syntax/numbers_syntax.ml | 4 +- plugins/syntax/r_syntax.ml | 4 +- plugins/syntax/z_syntax.ml | 4 +- plugins/xml/acic.ml | 2 +- plugins/xml/acic2Xml.ml4 | 2 +- plugins/xml/cic2acic.ml | 2 +- plugins/xml/doubleTypeInference.ml | 2 +- plugins/xml/doubleTypeInference.mli | 2 +- plugins/xml/dumptree.ml4 | 2 +- plugins/xml/proof2aproof.ml | 2 +- plugins/xml/proofTree2Xml.ml4 | 2 +- plugins/xml/unshare.ml | 2 +- plugins/xml/unshare.mli | 2 +- plugins/xml/xml.ml4 | 2 +- plugins/xml/xml.mli | 4 +- plugins/xml/xmlcommand.ml | 2 +- plugins/xml/xmlcommand.mli | 4 +- plugins/xml/xmlentries.ml4 | 4 +- 163 files changed, 515 insertions(+), 359 deletions(-) (limited to 'plugins') diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index 82b4143e..3c40cfb9 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -1,12 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Hashtbl.clear h); (Hashtbl.add h, Hashtbl.find h, fun () -> Hashtbl.clear h) +(* We might have built [global_reference] whose canonical part is + inaccurate. We must hence compare only the user part, + hence using a Hashtbl might be incorrect *) + +let mktable_ref autoclean = + let m = ref Refmap'.empty in + let clear () = m := Refmap'.empty in + if autoclean then register_cleanup clear; + (fun r v -> m := Refmap'.add r v !m), (fun r -> Refmap'.find r !m), clear + (* A table recording objects in the first level of all MPfile *) let add_mpfiles_content,get_mpfiles_content,clear_mpfiles_content = @@ -355,10 +365,10 @@ let ref_renaming_fun (k,r) = (* Cached version of the last function *) let ref_renaming = - let add,get,_ = mktable true in - fun x -> - try if is_mp_bound (base_mp (modpath_of_r (snd x))) then raise Not_found; get x - with Not_found -> let y = ref_renaming_fun x in add x y; y + let add,get,_ = mktable_ref true in + fun ((k,r) as x) -> + try if is_mp_bound (base_mp (modpath_of_r r)) then raise Not_found; get r + with Not_found -> let y = ref_renaming_fun x in add r y; y (* [visible_clash mp0 (k,s)] checks if [mp0-s] of kind [k] can be printed as [s] in the current context of visible diff --git a/plugins/extraction/common.mli b/plugins/extraction/common.mli index f6ff76ba..22bad6cd 100644 --- a/plugins/extraction/common.mli +++ b/plugins/extraction/common.mli @@ -1,12 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* ()) (fun _ -> ()) - else Pp_control.with_output_to (Option.default stdout file) + else + match file with + | Some f -> Pp_control.with_output_to f + | None -> Format.formatter_of_buffer buf in (* We never want to see ellipsis ... in extracted code *) Format.pp_set_max_boxes ft max_int; @@ -421,6 +429,7 @@ let formatter dry file = ft let print_structure_to_file (fn,si,mo) dry struc = + Buffer.clear buf; let d = descr () in reset_renaming_tables AllButExternal; let unsafe_needs = { @@ -463,7 +472,12 @@ let print_structure_to_file (fn,si,mo) dry struc = close_out cout; raise e end; info_file si) - (if dry then None else si) + (if dry then None else si); + (* Print the buffer content via Coq standard formatter (ok with coqide). *) + if Buffer.length buf <> 0 then begin + Pp.message (Buffer.contents buf); + Buffer.reset buf + end (*********************************************) diff --git a/plugins/extraction/extract_env.mli b/plugins/extraction/extract_env.mli index b4516898..145cd6b3 100644 --- a/plugins/extraction/extract_env.mli +++ b/plugins/extraction/extract_env.mli @@ -1,12 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* error_singleton_become_prop id -let sort_of env c = Retyping.get_sort_family_of env none (strip_outer_cast c) +let sort_of env c = + try + let polyprop = (lang() = Haskell) in + Retyping.get_sort_family_of ~polyprop env none (strip_outer_cast c) + with SingletonInductiveBecomesProp id -> error_singleton_become_prop id let is_axiom env kn = (Environ.lookup_constant kn env).const_body = None @@ -423,17 +431,16 @@ and extract_ind env kn = (* kn is supposed to be in long form *) let mp,d,_ = repr_mind kn in let rec select_fields l typs = match l,typs with | [],[] -> [] - | (Name id)::l, typ::typs -> - if isDummy (expand env typ) then select_fields l typs - else - let knp = make_con mp d (label_of_id id) in - if List.for_all ((=) Keep) (type2signature env typ) - then - projs := Cset.add knp !projs; - (ConstRef knp) :: (select_fields l typs) + | _::l, typ::typs when isDummy (expand env typ) -> + select_fields l typs | Anonymous::l, typ::typs -> - if isDummy (expand env typ) then select_fields l typs - else error_record r + None :: (select_fields l typs) + | Name id::l, typ::typs -> + let knp = make_con mp d (label_of_id id) in + (* Is it safe to use [id] for projections [foo.id] ? *) + if List.for_all ((=) Keep) (type2signature env typ) + then projs := Cset.add knp !projs; + Some (ConstRef knp) :: (select_fields l typs) | _ -> assert false in let field_glob = select_fields field_names typ @@ -444,10 +451,8 @@ and extract_ind env kn = (* kn is supposed to be in long form *) let n = nb_default_params env (Inductive.type_of_inductive env (mib,mip0)) in - List.iter - (Option.iter - (fun kn -> if Cset.mem kn !projs then add_projection n kn)) - (lookup_projections ip) + let check_proj kn = if Cset.mem kn !projs then add_projection n kn in + List.iter (Option.iter check_proj) (lookup_projections ip) with Not_found -> () end; Record field_glob @@ -561,7 +566,11 @@ let rec extract_term env mle mlt c args = 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 + let mle' = + if generalizable c1' + then Mlenv.push_gen mle a + else Mlenv.push_type mle a + in MLletin (Id id, c1', extract_term env' mle' mlt c2 args') with NotDefault d -> let mle' = Mlenv.push_std_type mle (Tdummy d) in diff --git a/plugins/extraction/extraction.mli b/plugins/extraction/extraction.mli index 0574b009..8a2125fe 100644 --- a/plugins/extraction/extraction.mli +++ b/plugins/extraction/extraction.mli @@ -1,12 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* b #ifdef __GLASGOW_HASKELL__ import qualified GHC.Base unsafeCoerce = GHC.Base.unsafeCoerce# @@ -57,7 +58,8 @@ unsafeCoerce = IOExts.unsafeCoerce #endif" ++ fnl2 ()) ++ (if not usf.mldummy then mt () - else str "__ = Prelude.error \"Logical or arity value used\"" ++ fnl2 ()) + else str "__ :: any" ++ fnl () ++ + str "__ = Prelude.error \"Logical or arity value used\"" ++ fnl2 ()) let pp_abst = function | [] -> (mt ()) diff --git a/plugins/extraction/haskell.mli b/plugins/extraction/haskell.mli index 0b68e73b..eb774db7 100644 --- a/plugins/extraction/haskell.mli +++ b/plugins/extraction/haskell.mli @@ -1,12 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* List.iter mgu (List.combine l l') + | (Tdummy _, _ | _, Tdummy _) when lang() = Haskell -> () | Tdummy _, Tdummy _ -> () | t, u when t = u -> () (* for Tvar, Tvar', Tunknown, Taxiom *) | _ -> raise Impossible @@ -129,6 +130,11 @@ let put_magic_if b a = if b && lang () <> Scheme then MLmagic a else a let put_magic p a = if needs_magic p && lang () <> Scheme then MLmagic a else a +let generalizable a = + lang () <> Ocaml || + match a with + | MLapp _ -> false + | _ -> true (* TODO, this is just an approximation for the moment *) (*S ML type env. *) @@ -961,10 +967,18 @@ let kill_some_lams bl (ids,c) = let kill_dummy_lams c = let ids,c = collect_lams c in 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 + if not (List.mem Keep bl) then raise Impossible; + let rec fst_kill n = function + | [] -> raise Impossible + | Kill _ :: bl -> n + | Keep :: bl -> fst_kill (n+1) bl + in + let skip = max 0 ((fst_kill 0 bl) - 1) in + let ids_skip, ids = list_chop skip ids in + let _, bl = list_chop skip bl in + let c = named_lams ids_skip c in + let ids',c = kill_some_lams bl (ids,c) in + ids, named_lams ids' c (*s [eta_expansion_sign] takes a function [fun idn ... id1 -> c] and a signature [s] and builds a eta-long version. *) @@ -1005,21 +1019,26 @@ let term_expunge s (ids,c) = MLlam (Dummy, ast_lift 1 c) else named_lams ids c -(*s [kill_dummy_args ids t0 t] looks for occurences of [t0] in [t] and - purge the args of [t0] corresponding to a [dummy_name]. +(*s [kill_dummy_args ids r t] looks for occurences of [MLrel r] in [t] and + purge the args of [MLrel r] corresponding to a [dummy_name]. It makes eta-expansion if needed. *) -let kill_dummy_args ids t0 t = +let kill_dummy_args ids r t = let m = List.length ids in let bl = List.rev_map sign_of_id ids in + let rec found n = function + | MLrel r' when r' = r + n -> true + | MLmagic e -> found n e + | _ -> false + in let rec killrec n = function - | MLapp(e, a) when e = ast_lift n t0 -> + | MLapp(e, a) when found n e -> let k = max 0 (m - (List.length a)) in let a = List.map (killrec n) a in let a = List.map (ast_lift k) a in let a = select_via_bl bl (a @ (eta_args k)) in named_lams (list_firstn k ids) (MLapp (ast_lift k e, a)) - | e when e = ast_lift n t0 -> + | e when found n e -> let a = select_via_bl bl (eta_args m) in named_lams ids (MLapp (ast_lift m e, a)) | e -> ast_map_lift killrec n e @@ -1031,28 +1050,28 @@ let rec kill_dummy = function | MLfix(i,fi,c) -> (try let ids,c = kill_dummy_fix i c in - ast_subst (MLfix (i,fi,c)) (kill_dummy_args ids (MLrel 1) (MLrel 1)) + ast_subst (MLfix (i,fi,c)) (kill_dummy_args ids 1 (MLrel 1)) with Impossible -> MLfix (i,fi,Array.map kill_dummy c)) | MLapp (MLfix (i,fi,c),a) -> let a = List.map kill_dummy a in (try let ids,c = kill_dummy_fix i c in let fake = MLapp (MLrel 1, List.map (ast_lift 1) a) in - let fake' = kill_dummy_args ids (MLrel 1) fake in + let fake' = kill_dummy_args ids 1 fake in ast_subst (MLfix (i,fi,c)) fake' with Impossible -> MLapp(MLfix(i,fi,Array.map kill_dummy c),a)) | MLletin(id, MLfix (i,fi,c),e) -> (try let ids,c = kill_dummy_fix i c in - let e = kill_dummy (kill_dummy_args ids (MLrel 1) e) in + let e = kill_dummy (kill_dummy_args ids 1 e) in MLletin(id, MLfix(i,fi,c),e) with Impossible -> MLletin(id, MLfix(i,fi,Array.map kill_dummy c),kill_dummy e)) | MLletin(id,c,e) -> (try let ids,c = kill_dummy_lams (kill_dummy_hd c) in - let e = kill_dummy (kill_dummy_args ids (MLrel 1) e) in - let c = eta_red (kill_dummy c) in + let e = kill_dummy (kill_dummy_args ids 1 e) in + let c = kill_dummy c in if is_atomic c then ast_subst c e else MLletin (id, c, e) with Impossible -> MLletin(id,kill_dummy c,kill_dummy e)) | a -> ast_map kill_dummy a @@ -1064,8 +1083,8 @@ and kill_dummy_hd = function | MLletin(id,c,e) -> (try let ids,c = kill_dummy_lams (kill_dummy_hd c) in - let e = kill_dummy_hd (kill_dummy_args ids (MLrel 1) e) in - let c = eta_red (kill_dummy c) in + let e = kill_dummy_hd (kill_dummy_args ids 1 e) in + let c = kill_dummy c in if is_atomic c then ast_subst c e else MLletin (id, c, e) with Impossible -> MLletin(id,kill_dummy c,kill_dummy_hd e)) | a -> a @@ -1075,7 +1094,7 @@ and kill_dummy_fix i c = let ids,ci = kill_dummy_lams (kill_dummy_hd c.(i)) in let c = Array.copy c in c.(i) <- ci; for j = 0 to (n-1) do - c.(j) <- kill_dummy (kill_dummy_args ids (MLrel (n-i)) c.(j)) + c.(j) <- kill_dummy (kill_dummy_args ids (n-i) c.(j)) done; ids,c diff --git a/plugins/extraction/mlutil.mli b/plugins/extraction/mlutil.mli index 6b0cd4f9..54a1baaa 100644 --- a/plugins/extraction/mlutil.mli +++ b/plugins/extraction/mlutil.mli @@ -1,12 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* bool val put_magic_if : bool -> ml_ast -> ml_ast val put_magic : ml_type * ml_type -> ml_ast -> ml_ast +val generalizable : ml_ast -> bool + (*s ML type environment. *) module Mlenv : sig diff --git a/plugins/extraction/modutil.ml b/plugins/extraction/modutil.ml index 23ec108a..ffa38def 100644 --- a/plugins/extraction/modutil.ml +++ b/plugins/extraction/modutil.ml @@ -1,12 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* unit let record_iter_references do_term = function - | Record l -> List.iter do_term l + | Record l -> List.iter (Option.iter do_term) l | _ -> () let type_iter_references do_type t = diff --git a/plugins/extraction/modutil.mli b/plugins/extraction/modutil.mli index bb405d60..26d07872 100644 --- a/plugins/extraction/modutil.mli +++ b/plugins/extraction/modutil.mli @@ -1,12 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* r + | ConstructRef (ind,_) -> IndRef ind + | _ -> assert false -let find_projections = function Record l -> l | _ -> raise NoRecord +let pp_one_field r i = function + | Some r -> pp_global Term r + | None -> pp_global Type (get_ind r) ++ str "__" ++ int i + +let pp_field r fields i = pp_one_field r i (List.nth fields i) + +let pp_fields r fields = list_map_i (pp_one_field r) 0 fields (*s Pretty-printing of types. [par] is a boolean indicating whether parentheses are needed or not. *) @@ -202,9 +211,9 @@ let rec pp_expr par env args = | MLcons (_,r,[]) -> assert (args=[]); pp_global Cons r - | MLcons ({c_kind = Record projs}, r, args') -> + | MLcons ({c_kind = Record fields}, r, args') -> assert (args=[]); - pp_record_pat (projs, List.map (pp_expr true env []) args') + pp_record_pat (pp_fields r fields, List.map (pp_expr true env []) args') | MLcons (_,r,[arg1;arg2]) when is_infix r -> assert (args=[]); pp_par par @@ -234,25 +243,25 @@ let rec pp_expr par env args = (pp_expr false env [] t) in (try - let projs = find_projections info.m_kind in - let (_, ids, c) = pv.(0) in + (* First, can this match be printed as a mere record projection ? *) + let fields = + match info.m_kind with Record f -> f | _ -> raise Impossible + in + let (r, ids, c) = pv.(0) in let n = List.length ids in + let free_of_patvar a = not (List.exists (ast_occurs_itvl 1 n) a) in + let proj_hd i = + pp_expr true env [] t ++ str "." ++ pp_field r fields i + in match c with - | MLrel i when i <= n -> - apply (pp_par par' (pp_expr true env [] t ++ str "." ++ - pp_global Term (List.nth projs (n-i)))) - | MLapp (MLrel i, a) when i <= n -> - if List.exists (ast_occurs_itvl 1 n) a - then raise NoRecord - else - let ids,env' = push_vars (List.rev_map id_of_mlid ids) env - in - (pp_apply - (pp_expr true env [] t ++ str "." ++ - pp_global Term (List.nth projs (n-i))) - par ((List.map (pp_expr true env' []) a) @ args)) - | _ -> raise NoRecord - with NoRecord -> + | MLrel i when i <= n -> apply (pp_par par' (proj_hd (n-i))) + | MLapp (MLrel i, a) when (i <= n) && (free_of_patvar a) -> + let ids,env' = push_vars (List.rev_map id_of_mlid ids) env in + (pp_apply (proj_hd (n-i)) + par ((List.map (pp_expr true env' []) a) @ args)) + | _ -> raise Impossible + with Impossible -> + (* Second, can this match be printed as a let-in ? *) if Array.length pv = 1 then let s1,s2 = pp_one_pat env info pv.(0) in apply @@ -263,6 +272,7 @@ let rec pp_expr par env args = ++ spc () ++ str "in") ++ spc () ++ hov 0 s2))) else + (* Otherwise, standard match *) apply (pp_par par' (try pp_ifthenelse par' env expr pv @@ -283,11 +293,11 @@ let rec pp_expr par env args = pp_par par (str "failwith \"AXIOM TO BE REALIZED\"") -and pp_record_pat (projs, args) = +and pp_record_pat (fields, args) = str "{ " ++ prlist_with_sep (fun () -> str ";" ++ spc ()) - (fun (r,a) -> pp_global Term r ++ str " =" ++ spc () ++ a) - (List.combine projs args) ++ + (fun (f,a) -> f ++ str " =" ++ spc () ++ a) + (List.combine fields args) ++ str " }" and pp_ifthenelse par env expr pv = match pv with @@ -304,18 +314,18 @@ and pp_ifthenelse par env expr pv = match pv with and pp_one_pat env info (r,ids,t) = let ids,env' = push_vars (List.rev_map id_of_mlid ids) env in let expr = pp_expr (expr_needs_par t) env' [] t in - try - let projs = find_projections info.m_kind in - pp_record_pat (projs, List.rev_map pr_id ids), expr - with NoRecord -> - (match List.rev ids with - | [i1;i2] when is_infix r -> pr_id i1 ++ str (get_infix r) ++ pr_id i2 - | [] -> pp_global Cons r - | ids -> + let patt = match info.m_kind with + | Record fields -> + pp_record_pat (pp_fields r fields, List.rev_map pr_id ids) + | _ -> match List.rev ids with + | [i1;i2] when is_infix r -> pr_id i1 ++ str (get_infix r) ++ pr_id i2 + | [] -> pp_global Cons r + | ids -> (* hack Extract Inductive prod *) (if str_global Cons r = "" then mt () else pp_global Cons r ++ spc ()) - ++ pp_boxed_tuple pr_id ids), - expr + ++ pp_boxed_tuple pr_id ids + in + patt, expr and pp_pat env info pv = let factor_br, factor_set = try match info.m_same with @@ -448,10 +458,11 @@ let pp_singleton kn packet = pp_comment (str "singleton inductive, whose constructor was " ++ pr_id packet.ip_consnames.(0))) -let pp_record kn projs ip_equiv packet = - let name = pp_global Type (IndRef (mind_of_kn kn,0)) in - let projnames = List.map (pp_global Term) projs in - let l = List.combine projnames packet.ip_types.(0) in +let pp_record kn fields ip_equiv packet = + let ind = IndRef (mind_of_kn kn,0) in + let name = pp_global Type ind in + let fieldnames = pp_fields ind fields in + let l = List.combine fieldnames packet.ip_types.(0) in let pl = rename_tvars keywords packet.ip_vars in str "type " ++ pp_parameters pl ++ name ++ pp_equiv pl name ip_equiv ++ str " = { "++ @@ -512,8 +523,7 @@ let pp_mind kn i = match i.ind_kind with | Singleton -> pp_singleton kn i.ind_packets.(0) | Coinductive -> pp_ind true kn i - | Record projs -> - pp_record kn projs (i.ind_equiv,0) i.ind_packets.(0) + | Record fields -> pp_record kn fields (i.ind_equiv,0) i.ind_packets.(0) | Standard -> pp_ind false kn i let pp_decl = function diff --git a/plugins/extraction/ocaml.mli b/plugins/extraction/ocaml.mli index 477b4351..c0b4e5b3 100644 --- a/plugins/extraction/ocaml.mli +++ b/plugins/extraction/ocaml.mli @@ -1,12 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* ConstRef(constant_of_kn(user_con con)) + | IndRef (kn,i) -> IndRef(mind_of_kn(user_mind kn),i) + | ConstructRef ((kn,i),j)-> ConstructRef((mind_of_kn(user_mind kn),i),j) + | VarRef id -> VarRef id + in + Pervasives.compare (make_name x) (make_name y) +end -module RefOrd = struct type t = global_reference let compare = compare end module Refmap' = Map.Make(RefOrd) module Refset' = Set.Make(RefOrd) @@ -316,6 +327,15 @@ let error_no_module_expr mp = ++ str "some Declare Module outside any Module Type.\n" ++ str "This situation is currently unsupported by the extraction.") +let error_singleton_become_prop id = + err (str "The informative inductive type " ++ pr_id id ++ + str " has a Prop instance.\n" ++ + str "This happens when a sort-polymorphic singleton inductive type\n" ++ + str "has logical parameters, such as (I,I) : (True * True) : Prop.\n" ++ + str "The Ocaml extraction cannot handle this situation yet.\n" ++ + str "Instead, use a sort-monomorphic type such as (True /\\ True)\n" ++ + str "or extract to Haskell.") + let error_unknown_module m = err (str "Module" ++ spc () ++ pr_qualid m ++ spc () ++ str "not found.") @@ -335,10 +355,6 @@ let error_MPfile_as_mod mp b = "Monolithic Extraction cannot deal with this situation.\n"^ "Please "^s2^"use (Recursive) Extraction Library instead.\n")) -let error_record r = - err (str "Record " ++ safe_pr_global r ++ str " has an anonymous field." ++ - fnl () ++ str "To help extraction, please use an explicit name.") - let msg_non_implicit r n id = let name = match id with | Anonymous -> "" diff --git a/plugins/extraction/table.mli b/plugins/extraction/table.mli index 2eafe1d8..b70d3efa 100644 --- a/plugins/extraction/table.mli +++ b/plugins/extraction/table.mli @@ -1,12 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 'a val error_nb_cons : unit -> 'a val error_module_clash : module_path -> module_path -> 'a val error_no_module_expr : module_path -> 'a +val error_singleton_become_prop : identifier -> 'a val error_unknown_module : qualid -> 'a val error_scheme : unit -> 'a val error_not_visible : global_reference -> 'a val error_MPfile_as_mod : module_path -> bool -> 'a -val error_record : global_reference -> 'a val check_inside_module : unit -> unit val check_inside_section : unit -> unit val check_loaded_modfile : module_path -> unit diff --git a/plugins/field/LegacyField.v b/plugins/field/LegacyField.v index 6c825353..9017f8d5 100644 --- a/plugins/field/LegacyField.v +++ b/plugins/field/LegacyField.v @@ -1,12 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* (Proof_type.goal Tacmach.sigma -> Sequent.t) -> Tacmach.tactic diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index 714604ae..4802aaa3 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -1,12 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* - let arg_res = build_entry_lc env funname avoid case_arg in - combine_results combine_args arg_res ctxt_argsl - ) - el + (fun (case_arg,_) ctxt_argsl -> + let arg_res = build_entry_lc env funname avoid case_arg in + combine_results combine_args arg_res ctxt_argsl + ) + el (mk_result [] [] avoid) in let types = @@ -876,6 +876,32 @@ let is_res id = with Invalid_argument _ -> false + +let same_raw_term rt1 rt2 = + match rt1,rt2 with + | RRef(_,r1), RRef (_,r2) -> r1=r2 + | RHole _, RHole _ -> true + | _ -> false +let decompose_raw_eq lhs rhs = + let rec decompose_raw_eq lhs rhs acc = + observe (str "decomposing eq for " ++ pr_rawconstr lhs ++ str " " ++ pr_rawconstr rhs); + let (rhd,lrhs) = raw_decompose_app rhs in + let (lhd,llhs) = raw_decompose_app lhs in + observe (str "lhd := " ++ pr_rawconstr lhd); + observe (str "rhd := " ++ pr_rawconstr rhd); + observe (str "llhs := " ++ int (List.length llhs)); + observe (str "lrhs := " ++ int (List.length lrhs)); + let sllhs = List.length llhs in + let slrhs = List.length lrhs in + if same_raw_term lhd rhd && sllhs = slrhs + then + (* let _ = assert false in *) + List.fold_right2 decompose_raw_eq llhs lrhs acc + else (lhs,rhs)::acc + in + decompose_raw_eq lhs rhs [] + + exception Continue (* The second phase which reconstruct the real type of the constructor. @@ -1032,6 +1058,41 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = mkRProd(n,t,new_b),id_to_exclude else new_b, Idset.add id id_to_exclude *) + | RApp(loc1,RRef(loc2,eq_as_ref),[ty;rt1;rt2]) + when eq_as_ref = Lazy.force Coqlib.coq_eq_ref && n = Anonymous + -> + begin + try + let l = decompose_raw_eq rt1 rt2 in + if List.length l > 1 + then + let new_rt = + List.fold_left + (fun acc (lhs,rhs) -> + mkRProd(Anonymous, + mkRApp(mkRRef(eq_as_ref),[mkRHole ();lhs;rhs]),acc) + ) + b + l + in + rebuild_cons env nb_args relname args crossed_types depth new_rt + else raise Continue + with Continue -> + observe (str "computing new type for prod : " ++ pr_rawconstr rt); + let t' = Pretyping.Default.understand Evd.empty env t in + let new_env = Environ.push_rel (n,None,t') env in + let new_b,id_to_exclude = + rebuild_cons new_env + nb_args relname + args new_crossed_types + (depth + 1) b + in + match n with + | Name id when Idset.mem id id_to_exclude && depth >= nb_args -> + new_b,Idset.remove id + (Idset.filter not_free_in_t id_to_exclude) + | _ -> mkRProd(n,t,new_b),Idset.filter not_free_in_t id_to_exclude + end | _ -> observe (str "computing new type for prod : " ++ pr_rawconstr rt); let t' = Pretyping.Default.understand Evd.empty env t in @@ -1122,12 +1183,12 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = (* debuging wrapper *) let rebuild_cons env nb_args relname args crossed_types rt = -(* observennl (str "rebuild_cons : rt := "++ pr_rawconstr rt ++ *) -(* str "nb_args := " ++ str (string_of_int nb_args)); *) + observe (str "rebuild_cons : rt := "++ pr_rawconstr rt ++ + str "nb_args := " ++ str (string_of_int nb_args)); let res = rebuild_cons env nb_args relname args crossed_types 0 rt in -(* observe (str " leads to "++ pr_rawconstr (fst res)); *) + observe (str " leads to "++ pr_rawconstr (fst res)); res @@ -1266,7 +1327,7 @@ let do_build_inductive (function result (* (args',concl') *) -> let rt = compose_raw_context result.context result.value in let nb_args = List.length funsargs.(i) in - (* with_full_print (fun rt -> Pp.msgnl (str "raw constr " ++ pr_rawconstr rt)) rt; *) + (* with_full_print (fun rt -> Pp.msgnl (str "raw constr " ++ pr_rawconstr rt)) rt; *) fst ( rebuild_cons env_with_graphs nb_args relnames.(i) [] diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 9c4cc78a..83868da9 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* let termtype = it_mkProd_or_LetIn cty ctx in diff --git a/plugins/subtac/subtac_classes.mli b/plugins/subtac/subtac_classes.mli index 57c7aa5b..73ca5581 100644 --- a/plugins/subtac/subtac_classes.mli +++ b/plugins/subtac/subtac_classes.mli @@ -1,12 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(*