From 97fefe1fcca363a1317e066e7f4b99b9c1e9987b Mon Sep 17 00:00:00 2001 From: Stephane Glondu Date: Thu, 12 Jan 2012 16:02:20 +0100 Subject: Imported Upstream version 8.4~beta --- toplevel/auto_ind_decl.ml | 92 +++---- toplevel/auto_ind_decl.mli | 13 +- toplevel/autoinstance.ml | 21 +- toplevel/autoinstance.mli | 16 +- toplevel/cerrors.ml | 152 ++++-------- toplevel/cerrors.mli | 19 +- toplevel/class.ml | 22 +- toplevel/class.mli | 18 +- toplevel/classes.ml | 131 +++++----- toplevel/classes.mli | 46 ++-- toplevel/command.ml | 90 +++---- toplevel/command.mli | 78 +++--- toplevel/coqinit.ml | 63 ++--- toplevel/coqinit.mli | 7 +- toplevel/coqtop.ml | 114 ++++----- toplevel/coqtop.mli | 15 +- toplevel/discharge.ml | 4 +- toplevel/discharge.mli | 4 +- toplevel/himsg.ml | 285 +++++++++++++++++----- toplevel/himsg.mli | 17 +- toplevel/ide_intf.ml | 434 +++++++++++++++++++++++++++++++++ toplevel/ide_intf.mli | 87 +++++++ toplevel/ide_slave.ml | 579 +++++++++++++++++++++++++++++++++++++++++++++ toplevel/ide_slave.mli | 17 ++ toplevel/ind_tables.ml | 29 ++- toplevel/ind_tables.mli | 16 +- toplevel/indschemes.ml | 27 ++- toplevel/indschemes.mli | 26 +- toplevel/interface.mli | 87 +++++++ toplevel/lemmas.ml | 57 +++-- toplevel/lemmas.mli | 23 +- toplevel/libtypes.ml | 4 +- toplevel/libtypes.mli | 20 +- toplevel/metasyntax.ml | 132 +++++------ toplevel/metasyntax.mli | 22 +- toplevel/mltop.ml4 | 41 ++-- toplevel/mltop.mli | 34 ++- toplevel/record.ml | 110 +++++---- toplevel/record.mli | 24 +- toplevel/search.ml | 45 ++-- toplevel/search.mli | 10 +- toplevel/toplevel.ml | 70 +++--- toplevel/toplevel.mli | 28 +-- toplevel/toplevel.mllib | 2 + toplevel/usage.ml | 141 +++++------ toplevel/usage.mli | 14 +- toplevel/vernac.ml | 78 +++--- toplevel/vernac.mli | 27 +-- toplevel/vernacentries.ml | 578 ++++++++++++++++++++++++++------------------ toplevel/vernacentries.mli | 31 ++- toplevel/vernacexpr.ml | 90 +++---- toplevel/vernacinterp.ml | 8 +- toplevel/vernacinterp.mli | 8 +- toplevel/whelp.ml4 | 52 ++-- toplevel/whelp.mli | 6 +- 55 files changed, 2754 insertions(+), 1410 deletions(-) create mode 100644 toplevel/ide_intf.ml create mode 100644 toplevel/ide_intf.mli create mode 100644 toplevel/ide_slave.ml create mode 100644 toplevel/ide_slave.mli create mode 100644 toplevel/interface.mli (limited to 'toplevel') diff --git a/toplevel/auto_ind_decl.ml b/toplevel/auto_ind_decl.ml index 16ceffed..f4dab15f 100644 --- a/toplevel/auto_ind_decl.ml +++ b/toplevel/auto_ind_decl.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* (Coqlib.build_bool_type()).Coqlib.andb +let induct_on c = + new_induct false + [Tacexpr.ElimOnConstr (Evd.empty,(c,Glob_term.NoBindings))] + None (None,None) None + +let destruct_on_using c id = + new_destruct false + [Tacexpr.ElimOnConstr (Evd.empty,(c,Glob_term.NoBindings))] + None + (None,Some (dl,Genarg.IntroOrAndPattern [ + [dl,Genarg.IntroAnonymous]; + [dl,Genarg.IntroIdentifier id]])) + None + +let destruct_on c = + new_destruct false + [Tacexpr.ElimOnConstr (Evd.empty,(c,Glob_term.NoBindings))] + None (None,None) None + (* reconstruct the inductive with the correct deBruijn indexes *) let mkFullInd ind n = let mib = Global.lookup_mind (fst ind) in @@ -329,13 +346,12 @@ let do_replace_lb lb_scheme_key aavoid narg gls p q = with Not_found -> (* spiwack: the format of this error message should probably be improved. *) - let err_msg = msg_with Format.str_formatter + let err_msg = string_of_ppcmds (str "Leibniz->boolean:" ++ str "You have to declare the" ++ str "decidability over " ++ Printer.pr_constr type_of_pq ++ - str " first."); - Format.flush_str_formatter () + str " first.") in error err_msg in let lb_args = Array.append (Array.append @@ -387,13 +403,12 @@ let do_replace_bl bl_scheme_key ind gls aavoid narg lft rgt = with Not_found -> (* spiwack: the format of this error message should probably be improved. *) - let err_msg = msg_with Format.str_formatter + let err_msg = string_of_ppcmds (str "boolean->Leibniz:" ++ str "You have to declare the" ++ str "decidability over " ++ Printer.pr_constr tt1 ++ - str " first."); - Format.flush_str_formatter () + str " first.") in error err_msg in let bl_args = @@ -513,17 +528,9 @@ let compute_bl_tact bl_scheme_key ind lnamesparrec nparrec gsig = avoid := freshz::(!avoid); tclTHENSEQ [ intros_using fresh_first_intros; intro_using freshn ; - new_induct false [ (Tacexpr.ElimOnConstr ((mkVar freshn), - Rawterm.NoBindings))] - None - (None,None) - None; + induct_on (mkVar freshn); intro_using freshm; - new_destruct false [ (Tacexpr.ElimOnConstr ((mkVar freshm), - Rawterm.NoBindings))] - None - (None,None) - None; + destruct_on (mkVar freshm); intro_using freshz; intros; tclTRY ( @@ -541,7 +548,7 @@ repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]). in avoid := fresht::(!avoid); (new_destruct false [Tacexpr.ElimOnConstr - ((mkVar freshz,Rawterm.NoBindings))] + (Evd.empty,((mkVar freshz,Glob_term.NoBindings)))] None (None, Some (dl,Genarg.IntroOrAndPattern [[ dl,Genarg.IntroIdentifier fresht; @@ -551,7 +558,7 @@ repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]). Ci a1 ... an = Ci b1 ... bn replace bi with ai; auto || replace bi with ai by apply typeofbi_prod ; auto *) - fun gls-> let gl = (gls.Evd.it).Evd.evar_concl in + fun gls-> let gl = pf_concl gls in match (kind_of_term gl) with | App (c,ca) -> ( match (kind_of_term c) with @@ -583,7 +590,7 @@ let make_bl_scheme mind = let nparrec = mib.mind_nparams_rec in let lnonparrec,lnamesparrec = context_chop (nparams-nparrec) mib.mind_params_ctxt in - [|Pfedit.build_by_tactic + [|Pfedit.build_by_tactic (Global.env()) (compute_bl_goal ind lnamesparrec nparrec) (compute_bl_tact (!bl_scheme_kind_aux()) ind lnamesparrec nparrec)|] @@ -651,30 +658,22 @@ let compute_lb_tact lb_scheme_key ind lnamesparrec nparrec gsig = avoid := freshz::(!avoid); tclTHENSEQ [ intros_using fresh_first_intros; intro_using freshn ; - new_induct false [Tacexpr.ElimOnConstr - ((mkVar freshn),Rawterm.NoBindings)] - None - (None,None) - None; + induct_on (mkVar freshn); intro_using freshm; - new_destruct false [Tacexpr.ElimOnConstr - ((mkVar freshm),Rawterm.NoBindings)] - None - (None,None) - None; + destruct_on (mkVar freshm); intro_using freshz; intros; tclTRY ( tclORELSE reflexivity (Equality.discr_tac false None) ); - Equality.inj [] false (mkVar freshz,Rawterm.NoBindings); + Equality.inj [] false (mkVar freshz,Glob_term.NoBindings); intros; simpl_in_concl; Auto.default_auto; tclREPEAT ( tclTHENSEQ [apply (andb_true_intro()); simplest_split ;Auto.default_auto ] ); - fun gls -> let gl = (gls.Evd.it).Evd.evar_concl in + fun gls -> let gl = pf_concl gls in (* assume the goal to be eq (eq_type ...) = true *) match (kind_of_term gl) with | App(c,ca) -> (match (kind_of_term ca.(1)) with @@ -703,7 +702,7 @@ let make_lb_scheme mind = let nparrec = mib.mind_nparams_rec in let lnonparrec,lnamesparrec = context_chop (nparams-nparrec) mib.mind_params_ctxt in - [|Pfedit.build_by_tactic + [|Pfedit.build_by_tactic (Global.env()) (compute_lb_goal ind lnamesparrec nparrec) (compute_lb_tact (!lb_scheme_kind_aux()) ind lnamesparrec nparrec)|] @@ -810,24 +809,11 @@ let compute_dec_tact ind lnamesparrec nparrec gsig = assert_by (Name freshH) ( mkApp(sumbool(),[|eqtrue eqbnm; eqfalse eqbnm|]) ) - (tclTHEN - (new_destruct false [Tacexpr.ElimOnConstr - (eqbnm,Rawterm.NoBindings)] - None - (None,None) - None) - Auto.default_auto); + (tclTHEN (destruct_on eqbnm) Auto.default_auto); (fun gsig -> let freshH2 = fresh_id (!avoid) (id_of_string "H") gsig in avoid := freshH2::(!avoid); - tclTHENS ( - new_destruct false [Tacexpr.ElimOnConstr - ((mkVar freshH),Rawterm.NoBindings)] - None - (None,Some (dl,Genarg.IntroOrAndPattern [ - [dl,Genarg.IntroAnonymous]; - [dl,Genarg.IntroIdentifier freshH2]])) None - ) [ + tclTHENS (destruct_on_using (mkVar freshH) freshH2) [ (* left *) tclTHENSEQ [ simplest_left; @@ -850,10 +836,10 @@ let compute_dec_tact ind lnamesparrec nparrec gsig = Auto.default_auto ]); Equality.general_rewrite_bindings_in true - all_occurrences false + all_occurrences true false (List.hd !avoid) ((mkVar (List.hd (List.tl !avoid))), - Rawterm.NoBindings + Glob_term.NoBindings ) true; Equality.discr_tac false None @@ -870,7 +856,7 @@ let make_eq_decidability mind = let nparrec = mib.mind_nparams_rec in let lnonparrec,lnamesparrec = context_chop (nparams-nparrec) mib.mind_params_ctxt in - [|Pfedit.build_by_tactic + [|Pfedit.build_by_tactic (Global.env()) (compute_dec_goal ind lnamesparrec nparrec) (compute_dec_tact ind lnamesparrec nparrec)|] diff --git a/toplevel/auto_ind_decl.mli b/toplevel/auto_ind_decl.mli index c791da28..076a946a 100644 --- a/toplevel/auto_ind_decl.mli +++ b/toplevel/auto_ind_decl.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* constr array -(* Build equivalence between boolean equality and Leibniz equality *) +(** {6 Build equivalence between boolean equality and Leibniz equality } *) val lb_scheme_kind : mutual scheme_kind val make_lb_scheme : mutual_inductive -> constr array @@ -35,7 +40,7 @@ val make_lb_scheme : mutual_inductive -> constr array val bl_scheme_kind : mutual scheme_kind val make_bl_scheme : mutual_inductive -> constr array -(* Build decidability of equality *) +(** {6 Build decidability of equality } *) val eq_dec_scheme_kind : mutual scheme_kind val make_eq_decidability : mutual_inductive -> constr array diff --git a/toplevel/autoinstance.ml b/toplevel/autoinstance.ml index 4a67ede4..9258a39f 100644 --- a/toplevel/autoinstance.ml +++ b/toplevel/autoinstance.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* msgnl (str"Error defining instance := "++pr_constr def++str" : "++pr_constr typ++str" "++Cerrors.explain_exn e) + with e -> msgnl (str"Error defining instance := "++pr_constr def++str" : "++pr_constr typ++str" "++Errors.print e) let rec iter_under_prod (f:rel_context->constr->unit) (ctx:rel_context) t = f ctx t; match kind_of_term t with @@ -255,7 +257,7 @@ let gen_sort_topo l evm = (* register real typeclass instance given a totally defined evd *) let declare_instance (k:global_reference -> rel_context -> constr list -> unit) (cl,gen,evm:signature) = - let evm = Evarutil.nf_evars evm in + let evm = Evarutil.nf_evar_map evm in let gen = gen_sort_topo gen evm in let (evm,gen) = List.fold_right (fun ev (evm,gen) -> @@ -310,6 +312,7 @@ let end_autoinstance () = let _ = Goptions.declare_bool_option { Goptions.optsync=true; + Goptions.optdepr=false; Goptions.optkey=["Autoinstance"]; Goptions.optname="automatic typeclass instance recognition"; Goptions.optread=(fun () -> !autoinstance_opt); diff --git a/toplevel/autoinstance.mli b/toplevel/autoinstance.mli index b9b1e3c2..dd50cda5 100644 --- a/toplevel/autoinstance.mli +++ b/toplevel/autoinstance.mli @@ -1,38 +1,34 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* rel_context -> constr list -> unit -(* [search_declaration gr] Search in the library if the (new) +(** [search_declaration gr] Search in the library if the (new) * declaration gr can form an instance of a registered record/class *) val search_declaration : global_reference -> unit -(* [search_record declf gr evm] Search the library for instances of +(** [search_record declf gr evm] Search the library for instances of the (new) record/class declaration [gr], and register them using [declf]. [evm] is the signature of the record (to avoid recomputing it) *) val search_record : instance_decl_function -> global_reference -> evar_map -> unit -(* Instance declaration for both scenarios *) +(** Instance declaration for both scenarios *) val declare_record_instance : instance_decl_function val declare_class_instance : instance_decl_function diff --git a/toplevel/cerrors.ml b/toplevel/cerrors.ml index 86057b4b..5f2c3dbb 100644 --- a/toplevel/cerrors.ml +++ b/toplevel/cerrors.ml @@ -1,20 +1,18 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* - hov 0 (anomaly_string () ++ str "uncaught Stream.Failure.") - | Stream.Error txt -> - hov 0 (str "Syntax error: " ++ str txt ++ str ".") - | Token.Error txt -> - hov 0 (str "Syntax error: " ++ str txt ++ str ".") - | Sys_error msg -> - hov 0 (anomaly_string () ++ str "uncaught exception Sys_error " ++ str (guill msg) ++ report_fn ()) - | UserError(s,pps) -> - hov 0 (str "Error: " ++ where s ++ pps) - | Out_of_memory -> - hov 0 (str "Out of memory.") - | Stack_overflow -> - hov 0 (str "Stack overflow.") - | Timeout -> - hov 0 (str "Timeout!") - | Anomaly (s,pps) -> - hov 0 (anomaly_string () ++ where s ++ pps ++ report_fn ()) - | AnomalyOnError (s,exc) -> - hov 0 (anomaly_string () ++ str s ++ str ". Received exception is:" ++ - fnl() ++ explain_exn_default_aux anomaly_string report_fn exc) - | Match_failure(filename,pos1,pos2) -> - hov 0 (anomaly_string () ++ str "Match failure in file " ++ str (guill filename) ++ - if Sys.ocaml_version = "3.06" then - (str " from character " ++ int pos1 ++ - str " to " ++ int pos2) - else - (str " at line " ++ int pos1 ++ - str " character " ++ int pos2) - ++ report_fn ()) - | Not_found -> - hov 0 (anomaly_string () ++ str "uncaught exception Not_found" ++ report_fn ()) - | Failure s -> - hov 0 (anomaly_string () ++ str "uncaught exception Failure " ++ str (guill s) ++ report_fn ()) - | Invalid_argument s -> - hov 0 (anomaly_string () ++ str "uncaught exception Invalid_argument " ++ str (guill s) ++ report_fn ()) - | Sys.Break -> - hov 0 (fnl () ++ str "User interrupt.") - | Lexer.Error Illegal_character -> - hov 0 (str "Syntax error: Illegal character.") - | Lexer.Error Unterminated_comment -> - hov 0 (str "Syntax error: Unterminated comment.") - | Lexer.Error Unterminated_string -> - hov 0 (str "Syntax error: Unterminated string.") - | Lexer.Error Undefined_token -> - hov 0 (str "Syntax error: Undefined token.") - | Lexer.Error (Bad_token s) -> - hov 0 (str "Syntax error: Bad token" ++ spc () ++ str s ++ str ".") - | Stdpp.Exc_located (loc,exc) -> +(** Registration of generic errors + Nota: explain_exn does NOT end with a newline anymore! +*) + +let explain_exn_default = function + (* Basic interaction exceptions *) + | Stream.Error txt -> hov 0 (str ("Syntax error: " ^ txt ^ ".")) + | Token.Error txt -> hov 0 (str ("Syntax error: " ^ txt ^ ".")) + | Lexer.Error.E err -> hov 0 (str (Lexer.Error.to_string err)) + | Sys_error msg -> hov 0 (str ("System error: " ^ guill msg)) + | Out_of_memory -> hov 0 (str "Out of memory.") + | Stack_overflow -> hov 0 (str "Stack overflow.") + | Timeout -> hov 0 (str "Timeout!") + | Sys.Break -> hov 0 (fnl () ++ str "User interrupt.") + (* Meta-exceptions *) + | Loc.Exc_located (loc,exc) -> hov 0 ((if loc = dummy_loc then (mt ()) else (str"At location " ++ print_loc loc ++ str":" ++ fnl ())) - ++ explain_exn_default_aux anomaly_string report_fn exc) - | Assert_failure (s,b,e) -> - hov 0 (anomaly_string () ++ str "assert failure" ++ spc () ++ - (if s <> "" then - if Sys.ocaml_version = "3.06" then - (str ("(file \"" ^ s ^ "\", characters ") ++ - int b ++ str "-" ++ int e ++ str ")") - else - (str ("(file \"" ^ s ^ "\", line ") ++ int b ++ - str ", characters " ++ int e ++ str "-" ++ - int (e+6) ++ str ")") - else - (mt ())) ++ - report_fn ()) - | EvaluatedError (msg,None) -> - msg - | EvaluatedError (msg,Some reraise) -> - msg ++ explain_exn_default_aux anomaly_string report_fn reraise - | reraise -> - hov 0 (anomaly_string () ++ str "Uncaught exception " ++ - str (Printexc.to_string reraise) ++ report_fn ()) + ++ Errors.print_no_anomaly exc) + | EvaluatedError (msg,None) -> msg + | EvaluatedError (msg,Some reraise) -> msg ++ Errors.print_no_anomaly reraise + (* Otherwise, not handled here *) + | _ -> raise Errors.Unhandled + +let _ = Errors.register_handler explain_exn_default + + +(** Pre-explain a vernac interpretation error *) let wrap_vernac_error strm = EvaluatedError (hov 0 (str "Error:" ++ spc () ++ strm), None) @@ -120,13 +69,17 @@ let rec process_vernac_interp_error = function mt() in wrap_vernac_error (str "Universe inconsistency" ++ msg ++ str ".") | TypeError(ctx,te) -> - wrap_vernac_error (Himsg.explain_type_error ctx te) - | PretypeError(ctx,te) -> - wrap_vernac_error (Himsg.explain_pretype_error ctx te) + wrap_vernac_error (Himsg.explain_type_error ctx Evd.empty te) + | PretypeError(ctx,sigma,te) -> + wrap_vernac_error (Himsg.explain_pretype_error ctx sigma te) | Typeclasses_errors.TypeClassError(env, te) -> wrap_vernac_error (Himsg.explain_typeclass_error env te) | InductiveError e -> wrap_vernac_error (Himsg.explain_inductive_error e) + | Modops.ModuleTypingError e -> + wrap_vernac_error (Himsg.explain_module_error e) + | Modintern.ModuleInternalizationError e -> + wrap_vernac_error (Himsg.explain_module_internalization_error e) | RecursionSchemeError e -> wrap_vernac_error (Himsg.explain_recursion_scheme_error e) | Cases.PatternMatchingError (env,e) -> @@ -145,10 +98,10 @@ let rec process_vernac_interp_error = function (str "No constant of this name:" ++ spc () ++ Libnames.pr_qualid q ++ str ".") | Refiner.FailError (i,s) -> - EvaluatedError (hov 0 (str "Error: Tactic failure" ++ - (if Lazy.force s <> mt() then str ":" ++ Lazy.force s else mt ()) ++ - if i=0 then str "." else str " (level " ++ int i ++ str")."), - None) + wrap_vernac_error + (str "Tactic failure" ++ + (if Lazy.force s <> mt() then str ":" ++ Lazy.force s else mt ()) ++ + if i=0 then str "." else str " (level " ++ int i ++ str").") | AlreadyDeclared msg -> wrap_vernac_error (msg ++ str ".") | Proof_type.LtacLocated (_,(Refiner.FailError (i,s) as exc)) when Lazy.force s <> mt () -> @@ -156,32 +109,13 @@ let rec process_vernac_interp_error = function | Proof_type.LtacLocated (s,exc) -> EvaluatedError (hov 0 (Himsg.explain_ltac_call_trace s ++ fnl()), Some (process_vernac_interp_error exc)) - | Stdpp.Exc_located (loc,exc) -> - Stdpp.Exc_located (loc,process_vernac_interp_error exc) + | Loc.Exc_located (loc,exc) -> + Loc.Exc_located (loc,process_vernac_interp_error exc) | exc -> exc -let anomaly_string () = str "Anomaly: " - -let report () = (str "." ++ spc () ++ str "Please report.") - -let explain_exn_default = - explain_exn_default_aux anomaly_string report - -let raise_if_debug e = - if !Flags.debug then raise e - let _ = Tactic_debug.explain_logic_error := - (fun e -> explain_exn_default (process_vernac_interp_error e)) + (fun e -> Errors.print (process_vernac_interp_error e)) let _ = Tactic_debug.explain_logic_error_no_anomaly := - (fun e -> - explain_exn_default_aux (fun () -> mt()) (fun () -> str ".") - (process_vernac_interp_error e)) - -let explain_exn_function = ref explain_exn_default - -let explain_exn e = !explain_exn_function e - -let explain_exn_no_anomaly e = - explain_exn_default_aux (fun () -> raise e) mt e + (fun e -> Errors.print_no_report (process_vernac_interp_error e)) diff --git a/toplevel/cerrors.mli b/toplevel/cerrors.mli index e1f7c035..da9d3590 100644 --- a/toplevel/cerrors.mli +++ b/toplevel/cerrors.mli @@ -1,35 +1,24 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* std_ppcmds -val explain_exn : exn -> std_ppcmds - -(** Precompute errors raised during vernac interpretation *) - -val explain_exn_no_anomaly : exn -> std_ppcmds - (** Pre-explain a vernac interpretation error *) val process_vernac_interp_error : exn -> exn -(** For debugging purpose (?), the explain function can be twicked *) +(** General explain function. Should not be used directly now, + see instead function [Errors.print] and variants *) -val explain_exn_function : (exn -> std_ppcmds) ref val explain_exn_default : exn -> std_ppcmds -val raise_if_debug : exn -> unit diff --git a/toplevel/class.ml b/toplevel/class.ml index 09ce84e0..ebaa19b6 100644 --- a/toplevel/class.ml +++ b/toplevel/class.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* true - | (n,t::l) -> (strip_outer_cast t = mkRel n) & (aux ((n-1),l)) + | (n,t::l) -> + let t = strip_outer_cast t in + isRel t && destRel t = n && aux ((n-1),l) | _ -> false in aux (nargs,lt) @@ -126,7 +126,7 @@ let get_source lp source = let (cl1,lv1) = match lp with | [] -> raise Not_found - | t1::_ -> find_class_type (Global.env()) Evd.empty t1 + | t1::_ -> find_class_type Evd.empty t1 in (cl1,lv1,1) | Some cl -> @@ -134,7 +134,7 @@ let get_source lp source = | [] -> raise Not_found | t1::lt -> try - let cl1,lv1 = find_class_type (Global.env()) Evd.empty t1 in + let cl1,lv1 = find_class_type Evd.empty t1 in if cl = cl1 then cl1,lv1,(List.length lt+1) else raise Not_found with Not_found -> aux lt @@ -144,7 +144,7 @@ let get_target t ind = if (ind > 1) then CL_FUN else - fst (find_class_type (Global.env()) Evd.empty t) + fst (find_class_type Evd.empty t) let prods_of t = let rec aux acc d = match kind_of_term d with @@ -212,16 +212,16 @@ let build_id_coercion idf_opt source = match idf_opt with | Some idf -> idf | None -> - let cl,_ = find_class_type (Global.env()) Evd.empty t in + let cl,_ = find_class_type Evd.empty t in id_of_string ("Id_"^(ident_key_of_class source)^"_"^ (ident_key_of_class cl)) in let constr_entry = (* Cast is necessary to express [val_f] is identity *) DefinitionEntry { const_entry_body = mkCast (val_f, DEFAULTcast, typ_f); + const_entry_secctx = None; const_entry_type = Some typ_f; - const_entry_opaque = false; - const_entry_boxed = Flags.boxed_definitions()} in + const_entry_opaque = false } in let kn = declare_constant idf (constr_entry,IsDefinition IdentityCoercion) in ConstRef kn @@ -266,7 +266,7 @@ let add_new_coercion_core coef stre source target isid = check_arity cls; check_arity clt; let stre' = get_strength stre coef cls clt in - declare_coercion coef stre' isid cls clt (List.length lvs) + declare_coercion coef stre' ~isid ~src:cls ~target:clt ~params:(List.length lvs) let try_add_new_coercion_core ref b c d e = try add_new_coercion_core ref b c d e diff --git a/toplevel/class.mli b/toplevel/class.mli index b05f38e7..2cc8c453 100644 --- a/toplevel/class.mli +++ b/toplevel/class.mli @@ -1,14 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* locality -> source:cl_typ -> target:cl_typ -> unit -(* [try_add_new_coercion ref s] declares [ref], assumed to be of type +(** [try_add_new_coercion ref s] declares [ref], assumed to be of type [(x1:T1)...(xn:Tn)src->tg], as a coercion from [src] to [tg] *) val try_add_new_coercion : global_reference -> locality -> unit -(* [try_add_new_coercion_subclass cst s] expects that [cst] denotes a +(** [try_add_new_coercion_subclass cst s] expects that [cst] denotes a transparent constant which unfolds to some class [tg]; it declares an identity coercion from [cst] to [tg], named something like ["Id_cst_tg"] *) val try_add_new_coercion_subclass : cl_typ -> locality -> unit -(* [try_add_new_coercion_with_source ref s src] declares [ref] as a coercion +(** [try_add_new_coercion_with_source ref s src] declares [ref] as a coercion from [src] to [tg] where the target is inferred from the type of [ref] *) val try_add_new_coercion_with_source : global_reference -> locality -> source:cl_typ -> unit -(* [try_add_new_identity_coercion id s src tg] enriches the +(** [try_add_new_identity_coercion id s src tg] enriches the environment with a new definition of name [id] declared as an identity coercion from [src] to [tg] *) val try_add_new_identity_coercion : identifier -> locality -> diff --git a/toplevel/classes.ml b/toplevel/classes.ml index 28c1ab75..1e83e4b8 100644 --- a/toplevel/classes.ml +++ b/toplevel/classes.ml @@ -1,19 +1,15 @@ -(* -*- compile-command: "make -C .. bin/coqtop.byte" -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* + (fun inst local pri -> + let path = try Auto.PathHints [global_of_constr inst] with _ -> Auto.PathAny in Flags.silently (fun () -> - Auto.add_hints false [typeclasses_db] + Auto.add_hints local [typeclasses_db] (Auto.HintsResolveEntry - [pri, false, constr_of_global inst])) ()); - Typeclasses.register_set_typeclass_transparency set_typeclass_transparency + [pri, false, path, inst])) ()); + Typeclasses.register_set_typeclass_transparency set_typeclass_transparency; + Typeclasses.register_classes_transparent_state + (fun () -> Auto.Hint_db.transparent_state (Auto.searchtable_map typeclasses_db)) let declare_class g = match global g with @@ -54,12 +53,13 @@ let declare_class g = | _ -> user_err_loc (loc_of_reference g, "declare_class", Pp.str"Unsupported class type, only constants and inductives are allowed") -let declare_instance glob g = +(** TODO: add subinstances *) +let existing_instance glob g = let c = global g in let instance = Typing.type_of (Global.env ()) Evd.empty (constr_of_global c) in let _, r = decompose_prod_assum instance in match class_of_constr r with - | Some tc -> add_instance (new_instance tc None glob c) + | Some (_, (tc, _)) -> add_instance (new_instance tc None glob c) | None -> user_err_loc (loc_of_reference g, "declare_instance", Pp.str "Constant does not build instances of a declared type class.") @@ -68,13 +68,6 @@ let mismatched_props env n m = mismatched_ctx_inst env Properties n m type binder_list = (identifier located * bool * constr_expr) list -(* Calls to interpretation functions. *) - -let interp_type_evars evdref env ?(impls=empty_internalization_env) typ = - let typ' = intern_gen true ~impls !evdref env typ in - let imps = Implicit_quantifiers.implicits_of_rawterm typ' in - imps, Pretyping.Default.understand_tcc_evars evdref env Pretyping.IsType typ' - (* Declare everything in the parameters as implicit, and the class instance as well *) open Topconstr @@ -108,19 +101,18 @@ open Pp let ($$) g f = fun x -> g (f x) let instance_hook k pri global imps ?hook cst = - let inst = Typeclasses.new_instance k pri global cst in - Impargs.maybe_declare_manual_implicits false cst ~enriching:false imps; - Typeclasses.add_instance inst; - (match hook with Some h -> h cst | None -> ()) + Impargs.maybe_declare_manual_implicits false cst ~enriching:false imps; + Typeclasses.declare_instance pri (not global) cst; + (match hook with Some h -> h cst | None -> ()) let declare_instance_constant k pri global imps ?hook id term termtype = let cdecl = let kind = IsDefinition Instance in let entry = { const_entry_body = term; + const_entry_secctx = None; const_entry_type = Some termtype; - const_entry_opaque = false; - const_entry_boxed = false } + const_entry_opaque = false } in DefinitionEntry entry, kind in let kn = Declare.declare_constant id cdecl in @@ -148,8 +140,8 @@ let new_instance ?(abstract=false) ?(global=false) ctx (instid, bk, cl) props in let tclass = if generalize then CGeneralization (dummy_loc, Implicit, Some AbsPi, tclass) else tclass in let k, cty, ctx', ctx, len, imps, subst = - let (env', ctx), imps = interp_context_evars evars env ctx in - let c', imps' = interp_type_evars_impls ~evdref:evars ~fail_evar:false env' tclass in + let impls, ((env', ctx), imps) = interp_context_evars evars env ctx in + let c', imps' = interp_type_evars_impls ~impls ~evdref:evars ~fail_evar:false env' tclass in let len = List.length ctx in let imps = imps @ Impargs.lift_implicits len imps' in let ctx', c = decompose_prod_assum c' in @@ -190,26 +182,29 @@ let new_instance ?(abstract=false) ?(global=false) ctx (instid, bk, cl) props Evarutil.nf_evar !evars t in Evarutil.check_evars env Evd.empty !evars termtype; - let cst = Declare.declare_internal_constant id - (Entries.ParameterEntry (termtype,false), Decl_kinds.IsAssumption Decl_kinds.Logical) - in instance_hook k None false imps ?hook (ConstRef cst); id + let cst = Declare.declare_constant ~internal:Declare.KernelSilent id + (Entries.ParameterEntry + (None,termtype,None), Decl_kinds.IsAssumption Decl_kinds.Logical) + in instance_hook k None global imps ?hook (ConstRef cst); id end else begin let props = match props with - | CRecord (loc, _, fs) -> + | Some (CRecord (loc, _, fs)) -> if List.length fs > List.length k.cl_props then mismatched_props env' (List.map snd fs) k.cl_props; - Inl fs - | _ -> Inr props + Some (Inl fs) + | Some t -> Some (Inr t) + | None -> None in let subst = match props with - | Inr term -> + | None -> if k.cl_props = [] then Some (Inl subst) else None + | Some (Inr term) -> let c = interp_casted_constr_evars evars env' term cty in - Inr (c, subst) - | Inl props -> + Some (Inr (c, subst)) + | Some (Inl props) -> let get_id = function | Ident id' -> id' @@ -223,7 +218,10 @@ let new_instance ?(abstract=false) ?(global=false) ctx (instid, bk, cl) props let (loc_mid, c) = List.find (fun (id', _) -> Name (snd (get_id id')) = id) rest in let rest' = List.filter (fun (id', _) -> Name (snd (get_id id')) <> id) rest in let (loc, mid) = get_id loc_mid in - Option.iter (fun x -> Dumpglob.add_glob loc (ConstRef x)) (List.assoc mid k.cl_projs); + List.iter (fun (n, _, x) -> + if n = Name mid then + Option.iter (fun x -> Dumpglob.add_glob loc (ConstRef x)) x) + k.cl_projs; c :: props, rest' with Not_found -> (CHole (Util.dummy_loc, None) :: props), rest @@ -233,12 +231,14 @@ let new_instance ?(abstract=false) ?(global=false) ctx (instid, bk, cl) props if rest <> [] then unbound_method env' k.cl_impl (get_id (fst (List.hd rest))) else - Inl (type_ctx_instance evars (push_rel_context ctx' env') k.cl_props props subst) + Some (Inl (type_ctx_instance evars (push_rel_context ctx' env') k.cl_props props subst)) in evars := Evarutil.nf_evar_map !evars; let term, termtype = match subst with - | Inl subst -> + | None -> let termtype = it_mkProd_or_LetIn cty ctx in + None, termtype + | Some (Inl subst) -> let subst = List.fold_left2 (fun subst' s (_, b, _) -> if b = None then s :: subst' else subst') [] subst (k.cl_props @ snd k.cl_context) @@ -246,26 +246,25 @@ let new_instance ?(abstract=false) ?(global=false) ctx (instid, bk, cl) props let app, ty_constr = instance_constructor k subst in let termtype = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in let term = Termops.it_mkLambda_or_LetIn (Option.get app) (ctx' @ ctx) in - term, termtype - | Inr (def, subst) -> + Some term, termtype + | Some (Inr (def, subst)) -> let termtype = it_mkProd_or_LetIn cty ctx in let term = Termops.it_mkLambda_or_LetIn def ctx in - term, termtype + Some term, termtype in let termtype = Evarutil.nf_evar !evars termtype in - let term = Evarutil.nf_evar !evars term in + let term = Option.map (Evarutil.nf_evar !evars) term in let evm = undefined_evars !evars in Evarutil.check_evars env Evd.empty !evars termtype; - if Evd.is_empty evm then - declare_instance_constant k pri global imps ?hook id term termtype + if Evd.is_empty evm && term <> None then + declare_instance_constant k pri global imps ?hook id (Option.get term) termtype else begin evars := Typeclasses.resolve_typeclasses ~onlyargs:true ~fail:true env !evars; let kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Instance in Flags.silently (fun () -> Lemmas.start_proof id kind termtype (fun _ -> instance_hook k pri global imps ?hook); - if props <> Inl [] then - Pfedit.by (* (Refiner.tclTHEN (Refiner.tclEVARS ( !isevars)) *) - (!refine_ref (evm, term)) + if term <> None then + Pfedit.by (!refine_ref (evm, Option.get term)) else if Flags.is_auto_intros () then Pfedit.by (Refiner.tclDO len Tactics.intro); (match tac with Some tac -> Pfedit.by tac | None -> ())) (); @@ -284,18 +283,13 @@ let named_of_rel_context l = l ([], []) in ctx -let push_named_context = List.fold_right push_named - -let rec list_filter_map f = function - | [] -> [] - | hd :: tl -> match f hd with - | None -> list_filter_map f tl - | Some x -> x :: list_filter_map f tl - -let context ?(hook=fun _ -> ()) l = +let string_of_global r = + string_of_qualid (Nametab.shortest_qualid_of_global Idset.empty r) + +let context l = let env = Global.env() in let evars = ref Evd.empty in - let (env', fullctx), impls = interp_context_evars evars env l in + let _, ((env', fullctx), impls) = interp_context_evars evars env l in let fullctx = Evarutil.nf_rel_context_evar !evars fullctx in let ce t = Evarutil.check_evars env Evd.empty !evars t in List.iter (fun (n, b, t) -> Option.iter ce b; ce t) fullctx; @@ -304,13 +298,13 @@ let context ?(hook=fun _ -> ()) l = in let fn (id, _, t) = if Lib.is_modtype () && not (Lib.sections_are_opened ()) then - let cst = Declare.declare_internal_constant id - (ParameterEntry (t,false), IsAssumption Logical) + let cst = Declare.declare_constant ~internal:Declare.KernelSilent id + (ParameterEntry (None,t,None), IsAssumption Logical) in match class_of_constr t with - | Some tc -> - add_instance (Typeclasses.new_instance tc None false (ConstRef cst)); - hook (ConstRef cst) + | Some (rels, (tc, args) as _cl) -> + add_instance (Typeclasses.new_instance tc None false (ConstRef cst)) + (* declare_subclasses (ConstRef cst) cl *) | None -> () else ( let impl = List.exists @@ -318,9 +312,6 @@ let context ?(hook=fun _ -> ()) l = match x with ExplByPos (_, Some id') -> id = id' | _ -> false) impls in Command.declare_assumption false (Local (* global *), Definitional) t - [] impl (* implicit *) false (* inline *) (dummy_loc, id); - match class_of_constr t with - | None -> () - | Some tc -> hook (VarRef id)) + [] impl (* implicit *) None (* inline *) (dummy_loc, id)) in List.iter fn (List.rev ctx) - + diff --git a/toplevel/classes.mli b/toplevel/classes.mli index 69e4dd8b..68a93a74 100644 --- a/toplevel/classes.mli +++ b/toplevel/classes.mli @@ -1,14 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* constr_expr list -> rel_context -> 'a val mismatched_props : env -> constr_expr list -> rel_context -> 'a -(* Post-hoc class declaration. *) +(** Post-hoc class declaration. *) val declare_class : reference -> unit -(* Instance declaration *) +(** Instance declaration *) -val declare_instance : bool -> reference -> unit +val existing_instance : bool -> reference -> unit val declare_instance_constant : typeclass -> - int option -> (* priority *) - bool -> (* globality *) - Impargs.manual_explicitation list -> (* implicits *) + int option -> (** priority *) + bool -> (** globality *) + Impargs.manual_explicitation list -> (** implicits *) ?hook:(Libnames.global_reference -> unit) -> - identifier -> (* name *) - Term.constr -> (* body *) - Term.types -> (* type *) + identifier -> (** name *) + Term.constr -> (** body *) + Term.types -> (** type *) Names.identifier val new_instance : - ?abstract:bool -> (* Not abstract by default. *) - ?global:bool -> (* Not global by default. *) + ?abstract:bool -> (** Not abstract by default. *) + ?global:bool -> (** Not global by default. *) local_binder list -> typeclass_constraint -> - constr_expr -> + constr_expr option -> ?generalize:bool -> ?tac:Proof_type.tactic -> ?hook:(Libnames.global_reference -> unit) -> int option -> identifier -(* Setting opacity *) +(** Setting opacity *) -val set_typeclass_transparency : evaluable_global_reference -> bool -> unit +val set_typeclass_transparency : evaluable_global_reference -> bool -> bool -> unit -(* For generation on names based on classes only *) +(** For generation on names based on classes only *) val id_of_class : typeclass -> identifier -(* Context command *) +(** Context command *) -val context : ?hook:(Libnames.global_reference -> unit) -> - local_binder list -> unit +val context : local_binder list -> unit -(* Forward ref for refine *) +(** Forward ref for refine *) val refine_ref : (open_constr -> Proof_type.tactic) ref - diff --git a/toplevel/command.ml b/toplevel/command.ml index 1112ac6d..eca53ae7 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* let body = ce.const_entry_body in { ce with const_entry_body = - under_binders (Global.env()) (fst (reduction_of_red_expr red)) n body } + under_binders (Global.env()) (fst (reduction_of_red_expr red)) n body } -let interp_definition boxed bl red_option c ctypopt = +let interp_definition bl red_option c ctypopt = let env = Global.env() in let evdref = ref Evd.empty in - let (env_bl, ctx), imps1 = interp_context_evars evdref env bl in + let impls, ((env_bl, ctx), imps1) = interp_context_evars evdref env bl in + let nb_args = List.length ctx in let imps,ce = match ctypopt with None -> - let c, imps2 = interp_constr_evars_impls ~evdref ~fail_evar:false env_bl c in + let c, imps2 = interp_constr_evars_impls ~impls ~evdref ~fail_evar:false env_bl c in let body = nf_evar !evdref (it_mkLambda_or_LetIn c ctx) in check_evars env Evd.empty !evdref body; - imps1@imps2, + imps1@(Impargs.lift_implicits nb_args imps2), { const_entry_body = body; + const_entry_secctx = None; const_entry_type = None; - const_entry_opaque = false; - const_entry_boxed = boxed } + const_entry_opaque = false } | Some ctyp -> - let ty, impls = interp_type_evars_impls ~evdref ~fail_evar:false env_bl ctyp in - let c, imps2 = interp_casted_constr_evars_impls ~evdref ~fail_evar:false env_bl c ty in + let ty, impsty = interp_type_evars_impls ~impls ~evdref ~fail_evar:false env_bl ctyp in + let c, imps2 = interp_casted_constr_evars_impls ~impls ~evdref ~fail_evar:false env_bl c ty in let body = nf_evar !evdref (it_mkLambda_or_LetIn c ctx) in let typ = nf_evar !evdref (it_mkProd_or_LetIn ty ctx) in check_evars env Evd.empty !evdref body; check_evars env Evd.empty !evdref typ; - imps1@imps2, + imps1@(Impargs.lift_implicits nb_args imps2), { const_entry_body = body; + const_entry_secctx = None; const_entry_type = Some typ; - const_entry_opaque = false; - const_entry_boxed = boxed } + const_entry_opaque = false } in red_constant_entry (rel_context_length ctx) ce red_option, imps @@ -115,11 +114,11 @@ let declare_definition ident (local,k) ce imps hook = let r = match local with | Local when Lib.sections_are_opened () -> let c = - SectionLocalDef(ce.const_entry_body,ce.const_entry_type,false) in + SectionLocalDef(ce.const_entry_body ,ce.const_entry_type,false) in let _ = declare_variable ident (Lib.cwd(),c,IsDefinition k) in definition_message ident; if Pfedit.refining () then - Flags.if_verbose msg_warning + Flags.if_warn msg_warning (str"Local definition " ++ pr_id ident ++ str" is not visible from current goals"); VarRef ident @@ -139,10 +138,12 @@ let declare_assumption is_coe (local,kind) c imps impl nl (_,ident) = if is_verbose () & Pfedit.refining () then msgerrnl (str"Warning: Variable " ++ pr_id ident ++ str" is not visible from current goals"); - VarRef ident + let r = VarRef ident in + Typeclasses.declare_instance None true r; r | (Global|Local) -> let kn = - declare_constant ident (ParameterEntry (c,nl), IsAssumption kind) in + declare_constant ident + (ParameterEntry (None,c,nl), IsAssumption kind) in let gr = ConstRef kn in maybe_declare_manual_implicits false gr imps; assumption_message ident; @@ -150,8 +151,10 @@ let declare_assumption is_coe (local,kind) c imps impl nl (_,ident) = msg_warning (pr_id ident ++ str" is declared as a parameter" ++ str" because it is at a global level"); Autoinstance.search_declaration (ConstRef kn); - gr in - if is_coe then Class.try_add_new_coercion r local + Typeclasses.declare_instance None false gr; + gr + in + if is_coe then Class.try_add_new_coercion r local let declare_assumptions_hook = ref ignore let set_declare_assumptions_hook = (:=) declare_assumptions_hook @@ -225,7 +228,7 @@ let interp_mutual_inductive (paramsl,indl) notations finite = check_all_names_different indl; let env0 = Global.env() in let evdref = ref Evd.empty in - let (env_params, ctx_params), userimpls = + let _, ((env_params, ctx_params), userimpls) = interp_context_evars evdref env0 paramsl in let indnames = List.map (fun ind -> ind.ind_name) indl in @@ -321,7 +324,7 @@ let extract_params indl = let extract_inductive indl = List.map (fun ((_,indname),_,ar,lc) -> { ind_name = indname; - ind_arity = Option.cata (fun x -> x) (CSort (dummy_loc, Rawterm.RType None)) ar; + ind_arity = Option.cata (fun x -> x) (CSort (dummy_loc, Glob_term.GType None)) ar; ind_lc = List.map (fun (_,((_,id),t)) -> (id,t)) lc }) indl @@ -335,7 +338,7 @@ let extract_mutual_inductive_declaration_components indl = let declare_mutual_inductive_with_eliminations isrecord mie impls = let names = List.map (fun e -> e.mind_entry_typename) mie.mind_entry_inds in let (_,kn) = declare_mind isrecord mie in - let mind = Global.mind_of_delta (mind_of_kn kn) in + let mind = Global.mind_of_delta_kn kn in list_iter_i (fun i (indimpls, constrimpls) -> let ind = (mind,i) in Autoinstance.search_declaration (IndRef ind); @@ -442,7 +445,7 @@ let check_mutuality env isfix fixl = let po = partial_order preorder in match List.filter (function (_,Inr _) -> true | _ -> false) po with | (x,Inr xge)::(y,Inr yge)::rest -> - if_verbose msg_warning (non_full_mutual_message x xge y yge isfix rest) + if_warn msg_warning (non_full_mutual_message x xge y yge isfix rest) | _ -> () type structured_fixpoint_expr = { @@ -455,8 +458,8 @@ type structured_fixpoint_expr = { let interp_fix_context evdref env isfix fix = let before, after = if isfix then split_at_annot fix.fix_binders fix.fix_annot else [], fix.fix_binders in - let (env', ctx), imps = interp_context_evars evdref env before in - let (env'', ctx'), imps' = interp_context_evars evdref env' after in + let impl_env, ((env', ctx), imps) = interp_context_evars evdref env before in + let _, ((env'', ctx'), imps') = interp_context_evars ~impl_env evdref env' after in let annot = Option.map (fun _ -> List.length (assums_of_rel_context ctx)) fix.fix_annot in ((env'', ctx' @ ctx), imps @ imps', annot) @@ -471,13 +474,13 @@ let interp_fix_body evdref env_rec impls (_,ctx) fix ccl = let build_fix_type (_,ctx) ccl = it_mkProd_or_LetIn ccl ctx -let declare_fix boxed kind f def t imps = +let declare_fix kind f def t imps = let ce = { const_entry_body = def; + const_entry_secctx = None; const_entry_type = Some t; - const_entry_opaque = false; - const_entry_boxed = boxed - } in + const_entry_opaque = false } + in let kn = declare_constant f (DefinitionEntry ce,IsDefinition kind) in let gr = ConstRef kn in Autoinstance.search_declaration (ConstRef kn); @@ -547,7 +550,7 @@ let interp_recursive isfix fixl notations = let interp_fixpoint = interp_recursive true let interp_cofixpoint = interp_recursive false -let declare_fixpoint boxed ((fixnames,fixdefs,fixtypes),fiximps) indexes ntns = +let declare_fixpoint ((fixnames,fixdefs,fixtypes),fiximps) indexes ntns = if List.mem None fixdefs then (* Some bodies to define by proof *) let thms = @@ -565,14 +568,14 @@ let declare_fixpoint boxed ((fixnames,fixdefs,fixtypes),fiximps) indexes ntns = let fiximps = List.map (fun (n,r,p) -> r) fiximps in let fixdecls = list_map_i (fun i _ -> mkFix ((indexes,i),fixdecls)) 0 fixnames in - ignore (list_map4 (declare_fix boxed Fixpoint) fixnames fixdecls fixtypes fiximps); + ignore (list_map4 (declare_fix Fixpoint) fixnames fixdecls fixtypes fiximps); (* Declare the recursive definitions *) fixpoint_message (Some indexes) fixnames; end; (* Declare notations *) List.iter Metasyntax.add_notation_interpretation ntns -let declare_cofixpoint boxed ((fixnames,fixdefs,fixtypes),fiximps) ntns = +let declare_cofixpoint ((fixnames,fixdefs,fixtypes),fiximps) ntns = if List.mem None fixdefs then (* Some bodies to define by proof *) let thms = @@ -588,22 +591,23 @@ let declare_cofixpoint boxed ((fixnames,fixdefs,fixtypes),fiximps) ntns = let fixdecls = prepare_recursive_declaration fixnames fixtypes fixdefs in let fixdecls = list_map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 fixnames in let fiximps = List.map (fun (len,imps,idx) -> imps) fiximps in - ignore (list_map4 (declare_fix boxed CoFixpoint) fixnames fixdecls fixtypes fiximps); + ignore (list_map4 (declare_fix CoFixpoint) fixnames fixdecls fixtypes fiximps); (* Declare the recursive definitions *) cofixpoint_message fixnames end; (* Declare notations *) List.iter Metasyntax.add_notation_interpretation ntns -let extract_decreasing_argument = function +let extract_decreasing_argument limit = function | (na,CStructRec) -> na + | (na,_) when not limit -> na | _ -> error "Only structural decreasing is supported for a non-Program Fixpoint" -let extract_fixpoint_components l = +let extract_fixpoint_components limit l = let fixl, ntnl = List.split l in let fixl = List.map (fun ((_,id),ann,bl,typ,def) -> - let ann = extract_decreasing_argument ann in + let ann = extract_decreasing_argument limit ann in {fix_name = id; fix_annot = ann; fix_binders = bl; fix_body = def; fix_type = typ}) fixl in fixl, List.flatten ntnl @@ -613,13 +617,13 @@ let extract_cofixpoint_components l = {fix_name = id; fix_annot = None; fix_binders = bl; fix_body = def; fix_type = typ}) fixl, List.flatten ntnl -let do_fixpoint l b = - let fixl,ntns = extract_fixpoint_components l in +let do_fixpoint l = + let fixl,ntns = extract_fixpoint_components true l in let fix = interp_fixpoint fixl ntns in let possible_indexes = List.map compute_possible_guardness_evidences (snd fix) in - declare_fixpoint b fix possible_indexes ntns + declare_fixpoint fix possible_indexes ntns -let do_cofixpoint l b = +let do_cofixpoint l = let fixl,ntns = extract_cofixpoint_components l in - declare_cofixpoint b (interp_cofixpoint fixl ntns) ntns + declare_cofixpoint (interp_cofixpoint fixl ntns) ntns diff --git a/toplevel/command.mli b/toplevel/command.mli index af89b59a..8ffdbdec 100644 --- a/toplevel/command.mli +++ b/toplevel/command.mli @@ -1,14 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* unit) -> unit val get_declare_definition_hook : unit -> (definition_entry -> unit) val set_declare_assumptions_hook : (types -> unit) -> unit -(*************************************************************************) -(* Definitions/Let *) +(** {6 Definitions/Let} *) val interp_definition : - boxed_flag -> local_binder list -> red_expr option -> constr_expr -> - constr_expr option -> definition_entry * manual_implicits + local_binder list -> red_expr option -> constr_expr -> + constr_expr option -> definition_entry * Impargs.manual_implicits val declare_definition : identifier -> locality * definition_object_kind -> - definition_entry -> manual_implicits -> declaration_hook -> unit + definition_entry -> Impargs.manual_implicits -> declaration_hook -> unit -(*************************************************************************) -(* Parameters/Assumptions *) +(** {6 Parameters/Assumptions} *) val interp_assumption : - local_binder list -> constr_expr -> types * manual_implicits + local_binder list -> constr_expr -> types * Impargs.manual_implicits val declare_assumption : coercion_flag -> assumption_kind -> types -> - manual_implicits -> - bool (* implicit *) -> bool (* inline *) -> variable located -> unit + Impargs.manual_implicits -> + bool (** implicit *) -> Entries.inline -> variable located -> unit val declare_assumptions : variable located list -> - coercion_flag -> assumption_kind -> types -> manual_implicits -> - bool -> bool -> unit + coercion_flag -> assumption_kind -> types -> Impargs.manual_implicits -> + bool -> Entries.inline -> unit -(*************************************************************************) -(* Inductive and coinductive types *) +(** {6 Inductive and coinductive types} *) -(* Extracting the semantical components out of the raw syntax of mutual +(** Extracting the semantical components out of the raw syntax of mutual inductive declarations *) type structured_one_inductive_expr = { @@ -75,30 +68,29 @@ val extract_mutual_inductive_declaration_components : (one_inductive_expr * decl_notation list) list -> structured_inductive_expr * (*coercions:*) qualid list * decl_notation list -(* Typing mutual inductive definitions *) +(** Typing mutual inductive definitions *) type one_inductive_impls = - Impargs.manual_explicitation list (* for inds *)* - Impargs.manual_explicitation list list (* for constrs *) + Impargs.manual_implicits (** for inds *)* + Impargs.manual_implicits list (** for constrs *) val interp_mutual_inductive : structured_inductive_expr -> decl_notation list -> bool -> mutual_inductive_entry * one_inductive_impls list -(* Registering a mutual inductive definition together with its +(** Registering a mutual inductive definition together with its associated schemes *) val declare_mutual_inductive_with_eliminations : Declare.internal_flag -> mutual_inductive_entry -> one_inductive_impls list -> mutual_inductive -(* Entry points for the vernacular commands Inductive and CoInductive *) +(** Entry points for the vernacular commands Inductive and CoInductive *) val do_mutual_inductive : (one_inductive_expr * decl_notation list) list -> bool -> unit -(*************************************************************************) -(* Fixpoints and cofixpoints *) +(** {6 Fixpoints and cofixpoints} *) type structured_fixpoint_expr = { fix_name : identifier; @@ -108,10 +100,10 @@ type structured_fixpoint_expr = { fix_type : constr_expr } -(* Extracting the semantical components out of the raw syntax of +(** Extracting the semantical components out of the raw syntax of (co)fixpoints declarations *) -val extract_fixpoint_components : +val extract_fixpoint_components : bool -> (fixpoint_expr * decl_notation list) list -> structured_fixpoint_expr list * decl_notation list @@ -119,40 +111,40 @@ val extract_cofixpoint_components : (cofixpoint_expr * decl_notation list) list -> structured_fixpoint_expr list * decl_notation list -(* Typing global fixpoints and cofixpoint_expr *) +(** Typing global fixpoints and cofixpoint_expr *) type recursive_preentry = identifier list * constr option list * types list val interp_fixpoint : structured_fixpoint_expr list -> decl_notation list -> - recursive_preentry * (name list * manual_implicits * int option) list + recursive_preentry * (name list * Impargs.manual_implicits * int option) list val interp_cofixpoint : structured_fixpoint_expr list -> decl_notation list -> - recursive_preentry * (name list * manual_implicits * int option) list + recursive_preentry * (name list * Impargs.manual_implicits * int option) list -(* Registering fixpoints and cofixpoints in the environment *) +(** Registering fixpoints and cofixpoints in the environment *) val declare_fixpoint : - bool -> recursive_preentry * (name list * manual_implicits * int option) list -> + recursive_preentry * (name list * Impargs.manual_implicits * int option) list -> lemma_possible_guards -> decl_notation list -> unit val declare_cofixpoint : - bool -> recursive_preentry * (name list * manual_implicits * int option) list -> + recursive_preentry * (name list * Impargs.manual_implicits * int option) list -> decl_notation list -> unit -(* Entry points for the vernacular commands Fixpoint and CoFixpoint *) +(** Entry points for the vernacular commands Fixpoint and CoFixpoint *) val do_fixpoint : - (fixpoint_expr * decl_notation list) list -> bool -> unit + (fixpoint_expr * decl_notation list) list -> unit val do_cofixpoint : - (cofixpoint_expr * decl_notation list) list -> bool -> unit + (cofixpoint_expr * decl_notation list) list -> unit -(* Utils *) +(** Utils *) val check_mutuality : Environ.env -> bool -> (identifier * types) list -> unit -val declare_fix : bool -> definition_object_kind -> identifier -> - constr -> types -> Impargs.manual_explicitation list -> global_reference +val declare_fix : definition_object_kind -> identifier -> + constr -> types -> Impargs.manual_implicits -> global_reference diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml index 210507e1..e4cfcb3f 100644 --- a/toplevel/coqinit.ml +++ b/toplevel/coqinit.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* () (* Flags.if_verbose - mSGNL (str ("No .coqrc or .coqrc."^Coq_config.version^ + mSGNL (str ("No coqrc or coqrc."^Coq_config.version^ " found. Skipping rcfile loading.")) *) with e -> @@ -52,9 +53,9 @@ let load_rcfile() = Flags.if_verbose msgnl (str"Skipping rcfile loading.") (* Puts dir in the path of ML and in the LoadPath *) -let coq_add_path d s = - Mltop.add_path d (Names.make_dirpath [Nameops.coq_root;Names.id_of_string s]) -let coq_add_rec_path s = Mltop.add_rec_path s (Names.make_dirpath [Nameops.coq_root]) +let coq_add_path unix_path s = + Mltop.add_path ~unix_path ~coq_root:(Names.make_dirpath [Nameops.coq_root;Names.id_of_string s]) +let coq_add_rec_path unix_path = Mltop.add_rec_path ~unix_path ~coq_root:(Names.make_dirpath [Nameops.coq_root]) (* By the option -include -I or -R of the command line *) let includes = ref [] @@ -75,10 +76,12 @@ let theories_dirs_map = [ "theories/Sets", "Sets" ; "theories/Structures", "Structures" ; "theories/Lists", "Lists" ; + "theories/Vectors", "Vectors" ; "theories/Wellfounded", "Wellfounded" ; "theories/Relations", "Relations" ; "theories/Numbers", "Numbers" ; "theories/QArith", "QArith" ; + "theories/PArith", "PArith" ; "theories/NArith", "NArith" ; "theories/ZArith", "ZArith" ; "theories/Arith", "Arith" ; @@ -91,24 +94,31 @@ let theories_dirs_map = [ let init_load_path () = let coqlib = Envars.coqlib () in let user_contrib = coqlib/"user-contrib" in + let xdg_dirs = Envars.xdg_dirs in + let coqpath = Envars.coqpath in let dirs = ["states";"plugins"] in - (* first user-contrib *) - if Sys.file_exists user_contrib then - Mltop.add_rec_path user_contrib Nameops.default_root_prefix; - (* then states, theories and dev *) - List.iter (fun s -> coq_add_rec_path (coqlib/s)) dirs; - (* developer specific directory to open *) + (* NOTE: These directories are searched from last to first *) + (* first, developer specific directory to open *) if Coq_config.local then coq_add_path (coqlib/"dev") "dev"; (* then standard library *) List.iter - (fun (s,alias) -> Mltop.add_rec_path (coqlib/s) (Names.make_dirpath [Names.id_of_string alias; Nameops.coq_root])) + (fun (s,alias) -> Mltop.add_rec_path ~unix_path:(coqlib/s) ~coq_root:(Names.make_dirpath [Names.id_of_string alias; Nameops.coq_root])) theories_dirs_map; + (* then states and plugins *) + List.iter (fun s -> coq_add_rec_path (coqlib/s)) dirs; + (* then user-contrib *) + if Sys.file_exists user_contrib then + Mltop.add_rec_path ~unix_path:user_contrib ~coq_root:Nameops.default_root_prefix; + (* then directories in XDG_DATA_DIRS and XDG_DATA_HOME *) + List.iter (fun s -> Mltop.add_rec_path ~unix_path:s ~coq_root:Nameops.default_root_prefix) xdg_dirs; + (* then directories in COQPATH *) + List.iter (fun s -> Mltop.add_rec_path ~unix_path:s ~coq_root:Nameops.default_root_prefix) coqpath; (* then current directory *) - Mltop.add_path "." Nameops.default_root_prefix; + Mltop.add_path ~unix_path:"." ~coq_root:Nameops.default_root_prefix; (* additional loadpath, given with -I -include -R options *) List.iter - (fun (s,alias,reci) -> - if reci then Mltop.add_rec_path s alias else Mltop.add_path s alias) + (fun (unix_path, coq_root, reci) -> + if reci then Mltop.add_rec_path ~unix_path ~coq_root else Mltop.add_path ~unix_path ~coq_root) (List.rev !includes) let init_library_roots () = @@ -117,9 +127,8 @@ let init_library_roots () = (* Initialises the Ocaml toplevel before launching it, so that it can find the "include" file in the *source* directory *) let init_ocaml_path () = - let coqsrc = Coq_config.coqsrc in let add_subdir dl = - Mltop.add_ml_dir (List.fold_left (/) coqsrc dl) + Mltop.add_ml_dir (List.fold_left (/) Envars.coqroot dl) in Mltop.add_ml_dir (Envars.coqlib ()); List.iter add_subdir diff --git a/toplevel/coqinit.mli b/toplevel/coqinit.mli index c0f59a56..43b1556d 100644 --- a/toplevel/coqinit.mli +++ b/toplevel/coqinit.mli @@ -1,19 +1,16 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* unit val set_rcfile : string -> unit -val set_rcuser : string -> unit val no_load_rc : unit -> unit val load_rcfile : unit -> unit diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 7887a060..76e9c2fe 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* compat_version := Some V8_3 | "8.2" -> compat_version := Some V8_2 | "8.1" -> warning "Compatibility with version 8.1 not supported." | "8.0" -> warning "Compatibility with version 8.0 not supported." | s -> error ("Unknown compatibility version \""^s^"\".") -let re_exec_version = ref "" -let set_byte () = re_exec_version := "byte" -let set_opt () = re_exec_version := "opt" - -(* Re-exec Coq in bytecode or native code if necessary. [s] is either - ["byte"] or ["opt"]. Notice that this is possible since the nature of - the toplevel has already been set in [Mltop] by the main file created - by coqmktop (see scripts/coqmktop.ml). *) - -let re_exec is_ide = - let s = !re_exec_version in - let is_native = Mltop.is_native in - (* Unix.readlink is not implemented on Windows architectures :-( - let prog = - try Unix.readlink "/proc/self/exe" - with Unix.Unix_error _ -> Sys.argv.(0) in - *) - let prog = Sys.argv.(0) in - if (is_native && s = "byte") || ((not is_native) && s = "opt") - then begin - let s = if s = "" then if is_native then "opt" else "byte" else s in - let newprog = - let dir = Filename.dirname prog in - let coqtop = if is_ide then "coqide." else "coqtop." in - let com = coqtop ^ s ^ Coq_config.exec_extension in - if dir <> "." then Filename.concat dir com else com - in - Sys.argv.(0) <- newprog; - Unix.handle_unix_error (Unix.execvp newprog) Sys.argv - end - (*s options for the virtual machine *) let boxed_val = ref false -let boxed_def = ref false let use_vm = ref false let set_vm_opt () = Vm.set_transp_values (not !boxed_val); - Flags.set_boxed_definitions !boxed_def; Vconv.set_use_vm !use_vm (*s Parsing of the command line. @@ -183,12 +149,13 @@ let usage () = let warning s = msg_warning (str s) +let ide_slave = ref false +let filter_opts = ref false -let ide_args = ref [] -let parse_args is_ide = +let parse_args arglist = let glob_opt = ref false in let rec parse = function - | [] -> () + | [] -> [] | "-with-geoproof" :: s :: rem -> if s = "yes" then Coq_config.with_geoproof := true else if s = "no" then Coq_config.with_geoproof := false @@ -216,14 +183,15 @@ let parse_args is_ide = | "-notop" :: rem -> unset_toplevel_name (); parse rem | "-q" :: rem -> no_load_rc (); parse rem - | "-opt" :: rem -> set_opt(); parse rem - | "-byte" :: rem -> set_byte(); parse rem + | "-opt" :: rem -> warning "option -opt deprecated, call with .opt suffix\n"; parse rem + | "-byte" :: rem -> warning "option -byte deprecated, call with .byte suffix\n"; parse rem | "-full" :: rem -> warning "option -full deprecated\n"; parse rem | "-batch" :: rem -> set_batch_mode (); parse rem | "-boot" :: rem -> boot := true; no_load_rc (); parse rem | "-quality" :: rem -> term_quality := true; no_load_rc (); parse rem - | "-outputstate" :: s :: rem -> set_outputstate s; parse rem + | "-outputstate" :: s :: rem -> + Flags.load_proofs := Flags.Force; set_outputstate s; parse rem | "-outputstate" :: [] -> usage () | "-nois" :: rem -> set_inputstate ""; parse rem @@ -264,7 +232,9 @@ let parse_args is_ide = | "-compile-verbose" :: f :: rem -> add_compile true f; if not !glob_opt then Dumpglob.dump_to_dotglob (); parse rem | "-compile-verbose" :: [] -> usage () - | "-dont-load-proofs" :: rem -> Flags.dont_load_proofs := true; parse rem + | "-force-load-proofs" :: rem -> Flags.load_proofs := Flags.Force; parse rem + | "-lazy-load-proofs" :: rem -> Flags.load_proofs := Flags.Lazy; parse rem + | "-dont-load-proofs" :: rem -> Flags.load_proofs := Flags.Dont; parse rem | "-beautify" :: rem -> make_beautify true; parse rem @@ -278,30 +248,28 @@ let parse_args is_ide = | "-vm" :: rem -> use_vm := true; parse rem | "-emacs" :: rem -> Flags.print_emacs := true; Pp.make_pp_emacs(); parse rem - | "-emacs-U" :: rem -> Flags.print_emacs := true; - Flags.print_emacs_safechar := true; Pp.make_pp_emacs(); parse rem + | "-emacs-U" :: rem -> + warning "Obsolete option \"-emacs-U\", use -emacs instead."; + Flags.print_emacs := true; Pp.make_pp_emacs(); parse rem | "-unicode" :: rem -> add_require "Utf8_core"; parse rem | "-coqlib" :: d :: rem -> Flags.coqlib_spec:=true; Flags.coqlib:=d; parse rem | "-coqlib" :: [] -> usage () - | "-where" :: _ -> print_endline (Envars.coqlib ()); exit 0 + | "-where" :: _ -> print_endline (Envars.coqlib ()); exit (if !filter_opts then 2 else 0) - | ("-config"|"--config") :: _ -> Usage.print_config (); exit 0 + | ("-config"|"--config") :: _ -> Usage.print_config (); exit (if !filter_opts then 2 else 0) | ("-quiet"|"-silent") :: rem -> Flags.make_silent true; parse rem | ("-?"|"-h"|"-H"|"-help"|"--help") :: _ -> usage () - | ("-v"|"--version") :: _ -> Usage.version () + | ("-v"|"--version") :: _ -> Usage.version (if !filter_opts then 2 else 0) | "-init-file" :: f :: rem -> set_rcfile f; parse rem | "-init-file" :: [] -> usage () - | "-user" :: u :: rem -> set_rcuser u; parse rem - | "-user" :: [] -> usage () - | "-notactics" :: rem -> warning "Obsolete option \"-notactics\"."; remove_top_ml (); parse rem @@ -320,32 +288,41 @@ let parse_args is_ide = | "-no-hash-consing" :: rem -> Flags.hash_cons_proofs := false; parse rem + | "-ideslave" :: rem -> ide_slave := true; parse rem + + | "-filteropts" :: rem -> filter_opts := true; parse rem + | s :: rem -> - if is_ide then begin - ide_args := s :: !ide_args; - parse rem - end else begin - prerr_endline ("Don't know what to do with " ^ s); usage () - end + if !filter_opts then + s :: (parse rem) + else + (prerr_endline ("Don't know what to do with " ^ s); usage ()) in try - parse (List.tl (Array.to_list Sys.argv)) + parse arglist with | UserError(_,s) as e -> begin try Stream.empty s; exit 1 with Stream.Failure -> - msgnl (Cerrors.explain_exn e); exit 1 + msgnl (Errors.print e); exit 1 end - | e -> begin msgnl (Cerrors.explain_exn e); exit 1 end + | e -> begin msgnl (Errors.print e); exit 1 end -let init is_ide = +let init arglist = Sys.catch_break false; (* Ctrl-C is fatal during the initialisation *) Lib.init(); + (* Default Proofb Mode starts with an alternative default. *) + Goptions.set_string_option_value ["Default";"Proof";"Mode"] "Classic"; begin try - parse_args is_ide; - re_exec is_ide; + let foreign_args = parse_args arglist in + if !filter_opts then + (print_string (String.concat "\n" foreign_args); exit 0); + if !ide_slave then begin + Flags.make_silent true; + Ide_slave.init_stdout () + end; if_verbose print_header (); init_load_path (); inputstate (); @@ -374,13 +351,14 @@ let init is_ide = exit 0); Lib.declare_initial_state () -let init_toplevel () = init false - -let init_ide () = init true; List.rev !ide_args +let init_toplevel = init let start () = - init_toplevel (); - Toplevel.loop(); + init_toplevel (List.tl (Array.to_list Sys.argv)); + if !ide_slave then + Ide_slave.loop () + else + Toplevel.loop(); (* Initialise and launch the Ocaml toplevel *) Coqinit.init_ocaml_path(); Mltop.ocaml_toploop(); diff --git a/toplevel/coqtop.mli b/toplevel/coqtop.mli index ef730915..16d2b874 100644 --- a/toplevel/coqtop.mli +++ b/toplevel/coqtop.mli @@ -1,23 +1,16 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* unit - -(* [init_ide] is to be used by the Coq IDE. - It does everything [start] does, except launching the toplevel loop. - It returns the list of Coq files given on the command line. *) - -val init_ide : unit -> string list +val init_toplevel : string list -> unit +val start : unit -> unit diff --git a/toplevel/discharge.ml b/toplevel/discharge.ml index 58122e11..bab711ea 100644 --- a/toplevel/discharge.ml +++ b/toplevel/discharge.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* str "Recursive definition on" ++ spc () ++ pr_lconstr_env env c ++ spc () ++ str "which should be an inductive type" - | RecursionOnIllegalTerm(j,arg,le,lt) -> + | RecursionOnIllegalTerm(j,(arg_env, arg),le,lt) -> + let arg_env = make_all_name_different arg_env in let called = match names.(j) with Name id -> pr_id id @@ -247,7 +262,7 @@ let explain_ill_formed_rec_body env err names i fixenv vdefj = prlist_with_sep pr_spc pr_db lt in str "Recursive call to " ++ called ++ spc () ++ strbrk "has principal argument equal to" ++ spc () ++ - pr_lconstr_env env arg ++ strbrk " instead of " ++ vars + pr_lconstr_env arg_env arg ++ strbrk " instead of " ++ vars | NotEnoughArgumentsForFixCall j -> let called = @@ -274,12 +289,12 @@ let explain_ill_formed_rec_body env err names i fixenv vdefj = str "Recursive call forbidden in the type of a recursive definition" ++ spc () ++ pr_lconstr_env env c | RecCallInCaseFun c -> - str "Recursive call in a branch of" ++ spc () ++ pr_lconstr_env env c + str "Invalid recursive call in a branch of" ++ spc () ++ pr_lconstr_env env c | RecCallInCaseArg c -> - str "Recursive call in the argument of cases in" ++ spc () ++ + str "Invalid recursive call in the argument of \"match\" in" ++ spc () ++ pr_lconstr_env env c | RecCallInCasePred c -> - str "Recursive call in the type of cases in" ++ spc () ++ + str "Invalid recursive call in the \"return\" clause of \"match\" in" ++ spc () ++ pr_lconstr_env env c | NotGuardedForm c -> str "Sub-expression " ++ pr_lconstr_env env c ++ @@ -295,7 +310,9 @@ let explain_ill_formed_rec_body env err names i fixenv vdefj = str"Recursive definition is:" ++ spc () ++ pvd ++ str "." with _ -> mt ()) -let explain_ill_typed_rec_body env i names vdefj vargs = +let explain_ill_typed_rec_body env sigma i names vdefj vargs = + let vdefj = jv_nf_evar sigma vdefj in + let vargs = Array.map (nf_evar sigma) vargs in let env = make_all_name_different env in let pvd,pvdt = pr_ljudge_env env (vdefj.(i)) in let pv = pr_lconstr_env env vargs.(i) in @@ -305,12 +322,14 @@ let explain_ill_typed_rec_body env i names vdefj vargs = str "has type" ++ spc () ++ pvdt ++ spc () ++ str "while it should be" ++ spc () ++ pv ++ str "." -let explain_cant_find_case_type env c = +let explain_cant_find_case_type env sigma c = + let c = nf_evar sigma c in let env = make_all_name_different env in let pe = pr_lconstr_env env c in str "Cannot infer type of pattern-matching on" ++ ws 1 ++ pe ++ str "." -let explain_occur_check env ev rhs = +let explain_occur_check env sigma ev rhs = + let rhs = nf_evar sigma rhs in let env = make_all_name_different env in let id = Evd.string_of_existential ev in let pt = pr_lconstr_env env rhs in @@ -354,7 +373,8 @@ let explain_hole_kind env evi = function | MatchingVar _ -> assert false -let explain_not_clean env ev t k = +let explain_not_clean env sigma ev t k = + let t = nf_evar sigma t in let env = make_all_name_different env in let id = Evd.string_of_existential ev in let var = pr_lconstr_env env t in @@ -401,13 +421,15 @@ let explain_wrong_case_info env ind ci = str "was given to a pattern-matching expression on the inductive type" ++ spc () ++ pc ++ str "." -let explain_cannot_unify env m n = +let explain_cannot_unify env sigma m n = + let m = nf_evar sigma m in + let n = nf_evar sigma n in let pm = pr_lconstr_env env m in let pn = pr_lconstr_env env n in str "Impossible to unify" ++ brk(1,1) ++ pm ++ spc () ++ str "with" ++ brk(1,1) ++ pn ++ str "." -let explain_cannot_unify_local env m n subn = +let explain_cannot_unify_local env sigma m n subn = let pm = pr_lconstr_env env m in let pn = pr_lconstr_env env n in let psubn = pr_lconstr_env env subn in @@ -449,7 +471,7 @@ let explain_non_linear_unification env m t = strbrk " which would require to abstract twice on " ++ pr_lconstr_env env t ++ str "." -let explain_type_error env err = +let explain_type_error env sigma err = let env = make_all_name_different env in match err with | UnboundRel n -> @@ -457,7 +479,7 @@ let explain_type_error env err = | UnboundVar v -> explain_unbound_var env v | NotAType j -> - explain_not_type env j + explain_not_type env sigma j | BadAssumption c -> explain_bad_assumption env c | ReferenceVariables id -> @@ -465,38 +487,39 @@ let explain_type_error env err = | ElimArity (ind, aritylst, c, pj, okinds) -> explain_elim_arity env ind aritylst c pj okinds | CaseNotInductive cj -> - explain_case_not_inductive env cj + explain_case_not_inductive env sigma cj | NumberBranches (cj, n) -> - explain_number_branches env cj n + explain_number_branches env sigma cj n | IllFormedBranch (c, i, actty, expty) -> - explain_ill_formed_branch env c i actty expty + explain_ill_formed_branch env sigma c i actty expty | Generalization (nvar, c) -> explain_generalization env nvar c | ActualType (j, pt) -> - explain_actual_type env j pt + explain_actual_type env sigma j pt | CantApplyBadType (t, rator, randl) -> - explain_cant_apply_bad_type env t rator randl + explain_cant_apply_bad_type env sigma t rator randl | CantApplyNonFunctional (rator, randl) -> - explain_cant_apply_not_functional env rator randl + explain_cant_apply_not_functional env sigma rator randl | IllFormedRecBody (err, lna, i, fixenv, vdefj) -> explain_ill_formed_rec_body env err lna i fixenv vdefj | IllTypedRecBody (i, lna, vdefj, vargs) -> - explain_ill_typed_rec_body env i lna vdefj vargs + explain_ill_typed_rec_body env sigma i lna vdefj vargs | WrongCaseInfo (ind,ci) -> explain_wrong_case_info env ind ci -let explain_pretype_error env err = +let explain_pretype_error env sigma err = + let env = env_nf_betaiotaevar sigma env in let env = make_all_name_different env in match err with - | CantFindCaseType c -> explain_cant_find_case_type env c - | OccurCheck (n,c) -> explain_occur_check env n c - | NotClean (n,c,k) -> explain_not_clean env n c k + | CantFindCaseType c -> explain_cant_find_case_type env sigma c + | OccurCheck (n,c) -> explain_occur_check env sigma n c + | NotClean (n,c,k) -> explain_not_clean env sigma n c k | UnsolvableImplicit (evi,k,exp) -> explain_unsolvable_implicit env evi k exp | VarNotFound id -> explain_var_not_found env id - | UnexpectedType (actual,expect) -> explain_unexpected_type env actual expect - | NotProduct c -> explain_not_product env c - | CannotUnify (m,n) -> explain_cannot_unify env m n - | CannotUnifyLocal (m,n,sn) -> explain_cannot_unify_local env m n sn + | UnexpectedType (actual,expect) -> explain_unexpected_type env sigma actual expect + | NotProduct c -> explain_not_product env sigma c + | CannotUnify (m,n) -> explain_cannot_unify env sigma m n + | CannotUnifyLocal (m,n,sn) -> explain_cannot_unify_local env sigma m n sn | CannotGeneralize ty -> explain_refiner_cannot_generalize env ty | NoOccurrenceFound (c, id) -> explain_no_occurrence_found env c id | CannotUnifyBindingType (m,n) -> explain_cannot_unify_binding_type env m n @@ -504,6 +527,155 @@ let explain_pretype_error env err = explain_cannot_find_well_typed_abstraction env p l | AbstractionOverMeta (m,n) -> explain_abstraction_over_meta env m n | NonLinearUnification (m,c) -> explain_non_linear_unification env m c + | TypingError t -> explain_type_error env sigma t + +(* Module errors *) + +open Modops + +let explain_not_match_error = function + | InductiveFieldExpected _ -> + strbrk "an inductive definition is expected" + | DefinitionFieldExpected -> + strbrk "a definition is expected" + | ModuleFieldExpected -> + strbrk "a module is expected" + | ModuleTypeFieldExpected -> + strbrk "a module type is expected" + | NotConvertibleInductiveField id | NotConvertibleConstructorField id -> + str "types given to " ++ str (string_of_id id) ++ str " differ" + | NotConvertibleBodyField -> + str "the body of definitions differs" + | NotConvertibleTypeField -> + str "types differ" + | NotSameConstructorNamesField -> + str "constructor names differ" + | NotSameInductiveNameInBlockField -> + str "inductive types names differ" + | FiniteInductiveFieldExpected isfinite -> + str "type is expected to be " ++ + str (if isfinite then "coinductive" else "inductive") + | InductiveNumbersFieldExpected n -> + str "number of inductive types differs" + | InductiveParamsNumberField n -> + str "inductive type has not the right number of parameters" + | RecordFieldExpected isrecord -> + str "type is expected " ++ str (if isrecord then "" else "not ") ++ + str "to be a record" + | RecordProjectionsExpected nal -> + (if List.length nal >= 2 then str "expected projection names are " + else str "expected projection name is ") ++ + pr_enum (function Name id -> str (string_of_id id) | _ -> str "_") nal + | NotEqualInductiveAliases -> + str "Aliases to inductive types do not match" + | NoTypeConstraintExpected -> + strbrk "a definition whose type is constrained can only be subtype of a definition whose type is itself constrained" + +let explain_signature_mismatch l spec why = + str "Signature components for label " ++ str (string_of_label l) ++ + str " do not match:" ++ spc () ++ explain_not_match_error why ++ str "." + +let explain_label_already_declared l = + str ("The label "^string_of_label l^" is already declared.") + +let explain_application_to_not_path _ = + str "Application of modules is restricted to paths." + +let explain_not_a_functor mtb = + str "Application of not a functor." + +let explain_incompatible_module_types mexpr1 mexpr2 = + str "Incompatible module types." + +let explain_not_equal_module_paths mp1 mp2 = + str "Non equal modules." + +let explain_no_such_label l = + str "No such label " ++ str (string_of_label l) ++ str "." + +let explain_incompatible_labels l l' = + str "Opening and closing labels are not the same: " ++ + str (string_of_label l) ++ str " <> " ++ str (string_of_label l') ++ str "!" + +let explain_signature_expected mtb = + str "Signature expected." + +let explain_no_module_to_end () = + str "No open module to end." + +let explain_no_module_type_to_end () = + str "No open module type to end." + +let explain_not_a_module s = + quote (str s) ++ str " is not a module." + +let explain_not_a_module_type s = + quote (str s) ++ str " is not a module type." + +let explain_not_a_constant l = + quote (pr_label l) ++ str " is not a constant." + +let explain_incorrect_label_constraint l = + str "Incorrect constraint for label " ++ + quote (pr_label l) ++ str "." + +let explain_generative_module_expected l = + str "The module " ++ str (string_of_label l) ++ + strbrk " is not generative. Only components of generative modules can be changed using the \"with\" construct." + +let explain_non_empty_local_context = function + | None -> str "The local context is not empty." + | Some l -> + str "The local context of the component " ++ + str (string_of_label l) ++ str " is not empty." + +let explain_label_missing l s = + str "The field " ++ str (string_of_label l) ++ str " is missing in " + ++ str s ++ str "." + +let explain_module_error = function + | SignatureMismatch (l,spec,err) -> explain_signature_mismatch l spec err + | LabelAlreadyDeclared l -> explain_label_already_declared l + | ApplicationToNotPath mexpr -> explain_application_to_not_path mexpr + | NotAFunctor mtb -> explain_not_a_functor mtb + | IncompatibleModuleTypes (m1,m2) -> explain_incompatible_module_types m1 m2 + | NotEqualModulePaths (mp1,mp2) -> explain_not_equal_module_paths mp1 mp2 + | NoSuchLabel l -> explain_no_such_label l + | IncompatibleLabels (l1,l2) -> explain_incompatible_labels l1 l2 + | SignatureExpected mtb -> explain_signature_expected mtb + | NoModuleToEnd -> explain_no_module_to_end () + | NoModuleTypeToEnd -> explain_no_module_type_to_end () + | NotAModule s -> explain_not_a_module s + | NotAModuleType s -> explain_not_a_module_type s + | NotAConstant l -> explain_not_a_constant l + | IncorrectWithConstraint l -> explain_incorrect_label_constraint l + | GenerativeModuleExpected l -> explain_generative_module_expected l + | NonEmptyLocalContect lopt -> explain_non_empty_local_context lopt + | LabelMissing (l,s) -> explain_label_missing l s + +(* Module internalization errors *) + +(* +let explain_declaration_not_path _ = + str "Declaration is not a path." + +*) + +let explain_not_module_nor_modtype s = + quote (str s) ++ str " is not a module or module type." + +let explain_incorrect_with_in_module () = + str "The syntax \"with\" is not allowed for modules." + +let explain_incorrect_module_application () = + str "Illegal application to a module type." + +open Modintern + +let explain_module_internalization_error = function + | NotAModuleNorModtype s -> explain_not_module_nor_modtype s + | IncorrectWithInModule -> explain_incorrect_with_in_module () + | IncorrectModuleApplication -> explain_incorrect_module_application () (* Typeclass errors *) @@ -525,6 +697,7 @@ let explain_no_instance env (_,id) l = prlist_with_sep pr_spc (pr_lconstr_env env) l let pr_constraints printenv env evm = + let evm = Evd.undefined_evars (Evarutil.nf_evar_map_undefined evm) in let l = Evd.to_list evm in let (ev, evi) = List.hd l in if List.for_all (fun (ev', evi') -> @@ -534,12 +707,14 @@ let pr_constraints printenv env evm = (reset_with_named_context evi.evar_hyps env) in (if printenv then pe ++ fnl () else mt ()) ++ prlist_with_sep (fun () -> fnl ()) - (fun (ev, evi) -> str(string_of_existential ev)++ str " == " ++ pr_constr evi.evar_concl) l + (fun (ev, evi) -> str(string_of_existential ev) ++ + str " : " ++ pr_lconstr evi.evar_concl) l ++ fnl() ++ + pr_evar_map_constraints evm else - pr_evar_map evm + pr_evar_map None evm let explain_unsatisfiable_constraints env evd constr = - let evm = Evarutil.nf_evars evd in + let evm = Evarutil.nf_evar_map evd in let undef = Evd.undefined_evars evm in match constr with | None -> @@ -684,7 +859,7 @@ let error_not_allowed_case_analysis isrec kind i = let error_not_mutual_in_scheme ind ind' = if ind = ind' then str "The inductive type " ++ pr_inductive (Global.env()) ind ++ - str "occurs twice." + str " occurs twice." else str "The inductive types " ++ pr_inductive (Global.env()) ind ++ spc () ++ str "and" ++ spc () ++ pr_inductive (Global.env()) ind' ++ spc () ++ @@ -805,7 +980,7 @@ let explain_reduction_tactic_error = function | Tacred.InvalidAbstraction (env,c,(env',e)) -> str "The abstracted term" ++ spc () ++ pr_lconstr_env_at_top env c ++ spc () ++ str "is not well typed." ++ fnl () ++ - explain_type_error env' e + explain_type_error env' Evd.empty e let explain_ltac_call_trace (nrep,last,trace,loc) = let calls = @@ -831,7 +1006,7 @@ let explain_ltac_call_trace (nrep,last,trace,loc) = let filter = function (id,None) -> None | (id,Some id') -> Some(id,([],mkVar id')) in let unboundvars = list_map_filter filter unboundvars in - quote (pr_rawconstr_env (Global.env()) c) ++ + quote (pr_glob_constr_env (Global.env()) c) ++ (if unboundvars <> [] or vars <> [] then strbrk " (with " ++ prlist_with_sep pr_comma diff --git a/toplevel/himsg.mli b/toplevel/himsg.mli index e12e445c..a763472b 100644 --- a/toplevel/himsg.mli +++ b/toplevel/himsg.mli @@ -1,14 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* type_error -> std_ppcmds +val explain_type_error : env -> Evd.evar_map -> type_error -> std_ppcmds -val explain_pretype_error : env -> pretype_error -> std_ppcmds +val explain_pretype_error : env -> Evd.evar_map -> pretype_error -> std_ppcmds val explain_inductive_error : inductive_error -> std_ppcmds @@ -44,3 +40,8 @@ val explain_reduction_tactic_error : val explain_ltac_call_trace : int * Proof_type.ltac_call_kind * Proof_type.ltac_trace * Util.loc -> std_ppcmds + +val explain_module_error : Modops.module_typing_error -> std_ppcmds + +val explain_module_internalization_error : + Modintern.module_internalization_error -> std_ppcmds diff --git a/toplevel/ide_intf.ml b/toplevel/ide_intf.ml new file mode 100644 index 00000000..fc8ffa25 --- /dev/null +++ b/toplevel/ide_intf.ml @@ -0,0 +1,434 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Obj.magic (handler.interp (r,b,s) : string) + | Rewind i -> Obj.magic (handler.rewind i : int) + | Goal -> Obj.magic (handler.goals () : goals option) + | Evars -> Obj.magic (handler.evars () : evar list option) + | Hints -> Obj.magic (handler.hints () : (hint list * hint) option) + | Status -> Obj.magic (handler.status () : status) + | GetOptions -> Obj.magic (handler.get_options () : (option_name * option_state) list) + | SetOptions opts -> Obj.magic (handler.set_options opts : unit) + | InLoadPath s -> Obj.magic (handler.inloadpath s : bool) + | MkCases s -> Obj.magic (handler.mkcases s : string list list) + in Good res + with e -> + let (l, str) = handler.handle_exn e in + Fail (l,str) + +(** * XML data marshalling *) + +exception Marshal_error + +(** Utility functions *) + +let massoc x l = + try List.assoc x l + with Not_found -> raise Marshal_error + +let constructor t c args = Element (t, ["val", c], args) + +let do_match constr t mf = match constr with +| Element (s, attrs, args) -> + if s = t then + let c = massoc "val" attrs in + mf c args + else raise Marshal_error +| _ -> raise Marshal_error + +let pcdata = function +| PCData s -> s +| _ -> raise Marshal_error + +let singleton = function +| [x] -> x +| _ -> raise Marshal_error + +let raw_string = function +| [] -> "" +| [PCData s] -> s +| _ -> raise Marshal_error + +let bool_arg tag b = if b then [tag, ""] else [] + +(** Base types *) + +let of_bool b = + if b then constructor "bool" "true" [] + else constructor "bool" "false" [] + +let to_bool xml = do_match xml "bool" + (fun s _ -> match s with + | "true" -> true + | "false" -> false + | _ -> raise Marshal_error) + +let of_list f l = + Element ("list", [], List.map f l) + +let to_list f = function +| Element ("list", [], l) -> + List.map f l +| _ -> raise Marshal_error + +let of_option f = function +| None -> Element ("option", ["val", "none"], []) +| Some x -> Element ("option", ["val", "some"], [f x]) + +let to_option f = function +| Element ("option", ["val", "none"], []) -> None +| Element ("option", ["val", "some"], [x]) -> Some (f x) +| _ -> raise Marshal_error + +let of_string s = Element ("string", [], [PCData s]) + +let to_string = function +| Element ("string", [], l) -> raw_string l +| _ -> raise Marshal_error + +let of_int i = Element ("int", [], [PCData (string_of_int i)]) + +let to_int = function +| Element ("int", [], [PCData s]) -> int_of_string s +| _ -> raise Marshal_error + +let of_pair f g (x, y) = Element ("pair", [], [f x; g y]) + +let to_pair f g = function +| Element ("pair", [], [x; y]) -> (f x, g y) +| _ -> raise Marshal_error + +(** More elaborate types *) + +let of_option_value = function +| IntValue i -> + constructor "option_value" "intvalue" [of_option of_int i] +| BoolValue b -> + constructor "option_value" "boolvalue" [of_bool b] +| StringValue s -> + constructor "option_value" "stringvalue" [of_string s] + +let to_option_value xml = do_match xml "option_value" + (fun s args -> match s with + | "intvalue" -> IntValue (to_option to_int (singleton args)) + | "boolvalue" -> BoolValue (to_bool (singleton args)) + | "stringvalue" -> StringValue (to_string (singleton args)) + | _ -> raise Marshal_error + ) + +let of_option_state s = + Element ("option_state", [], [ + of_bool s.opt_sync; + of_bool s.opt_depr; + of_string s.opt_name; + of_option_value s.opt_value] + ) + +let to_option_state = function +| Element ("option_state", [], [sync; depr; name; value]) -> + { + opt_sync = to_bool sync; + opt_depr = to_bool depr; + opt_name = to_string name; + opt_value = to_option_value value; + } +| _ -> raise Marshal_error + +let of_value f = function +| Good x -> Element ("value", ["val", "good"], [f x]) +| Fail (loc, msg) -> + let loc = match loc with + | None -> [] + | Some (s, e) -> [("loc_s", string_of_int s); ("loc_e", string_of_int e)] + in + Element ("value", ["val", "fail"] @ loc, [PCData msg]) + +let to_value f = function +| Element ("value", attrs, l) -> + let ans = massoc "val" attrs in + if ans = "good" then Good (f (singleton l)) + else if ans = "fail" then + let loc = + try + let loc_s = int_of_string (List.assoc "loc_s" attrs) in + let loc_e = int_of_string (List.assoc "loc_e" attrs) in + Some (loc_s, loc_e) + with _ -> None + in + let msg = raw_string l in + Fail (loc, msg) + else raise Marshal_error +| _ -> raise Marshal_error + +let of_call = function +| Interp (raw, vrb, cmd) -> + let flags = (bool_arg "raw" raw) @ (bool_arg "verbose" vrb) in + Element ("call", ("val", "interp") :: flags, [PCData cmd]) +| Rewind n -> + Element ("call", ("val", "rewind") :: ["steps", string_of_int n], []) +| Goal -> + Element ("call", ["val", "goal"], []) +| Evars -> + Element ("call", ["val", "evars"], []) +| Hints -> + Element ("call", ["val", "hints"], []) +| Status -> + Element ("call", ["val", "status"], []) +| GetOptions -> + Element ("call", ["val", "getoptions"], []) +| SetOptions opts -> + let args = List.map (of_pair (of_list of_string) of_option_value) opts in + Element ("call", ["val", "setoptions"], args) +| InLoadPath file -> + Element ("call", ["val", "inloadpath"], [PCData file]) +| MkCases ind -> + Element ("call", ["val", "mkcases"], [PCData ind]) + +let to_call = function +| Element ("call", attrs, l) -> + let ans = massoc "val" attrs in + begin match ans with + | "interp" -> + let raw = List.mem_assoc "raw" attrs in + let vrb = List.mem_assoc "verbose" attrs in + Interp (raw, vrb, raw_string l) + | "rewind" -> + let steps = int_of_string (massoc "steps" attrs) in + Rewind steps + | "goal" -> Goal + | "evars" -> Evars + | "status" -> Status + | "getoptions" -> GetOptions + | "setoptions" -> + let args = List.map (to_pair (to_list to_string) to_option_value) l in + SetOptions args + | "inloadpath" -> InLoadPath (raw_string l) + | "mkcases" -> MkCases (raw_string l) + | "hints" -> Hints + | _ -> raise Marshal_error + end +| _ -> raise Marshal_error + +let of_status s = + let of_so = of_option of_string in + Element ("status", [], [of_so s.status_path; of_so s.status_proofname]) + +let to_status = function +| Element ("status", [], [path; name]) -> + { + status_path = to_option to_string path; + status_proofname = to_option to_string name; + } +| _ -> raise Marshal_error + +let of_evar s = + Element ("evar", [], [PCData s.evar_info]) + +let to_evar = function +| Element ("evar", [], data) -> { evar_info = raw_string data; } +| _ -> raise Marshal_error + +let of_goal g = + let hyp = of_list of_string g.goal_hyp in + let ccl = of_string g.goal_ccl in + Element ("goal", [], [hyp; ccl]) + +let to_goal = function +| Element ("goal", [], [hyp; ccl]) -> + let hyp = to_list to_string hyp in + let ccl = to_string ccl in + { goal_hyp = hyp; goal_ccl = ccl } +| _ -> raise Marshal_error + +let of_goals g = + let fg = of_list of_goal g.fg_goals in + let bg = of_list of_goal g.bg_goals in + Element ("goals", [], [fg; bg]) + +let to_goals = function +| Element ("goals", [], [fg; bg]) -> + let fg = to_list to_goal fg in + let bg = to_list to_goal bg in + { fg_goals = fg; bg_goals = bg; } +| _ -> raise Marshal_error + +let of_hints = + let of_hint = of_list (of_pair of_string of_string) in + of_option (of_pair (of_list of_hint) of_hint) + +let of_answer (q : 'a call) (r : 'a value) = + let convert = match q with + | Interp _ -> Obj.magic (of_string : string -> xml) + | Rewind _ -> Obj.magic (of_int : int -> xml) + | Goal -> Obj.magic (of_option of_goals : goals option -> xml) + | Evars -> Obj.magic (of_option (of_list of_evar) : evar list option -> xml) + | Hints -> Obj.magic (of_hints : (hint list * hint) option -> xml) + | Status -> Obj.magic (of_status : status -> xml) + | GetOptions -> Obj.magic (of_list (of_pair (of_list of_string) of_option_state) : (option_name * option_state) list -> xml) + | SetOptions _ -> Obj.magic (fun _ -> Element ("unit", [], [])) + | InLoadPath _ -> Obj.magic (of_bool : bool -> xml) + | MkCases _ -> Obj.magic (of_list (of_list of_string) : string list list -> xml) + in + of_value convert r + +let to_answer xml = + let rec convert elt = match elt with + | Element (tpe, attrs, l) -> + begin match tpe with + | "unit" -> Obj.magic () + | "string" -> Obj.magic (to_string elt : string) + | "int" -> Obj.magic (to_int elt : int) + | "status" -> Obj.magic (to_status elt : status) + | "bool" -> Obj.magic (to_bool elt : bool) + | "list" -> Obj.magic (to_list convert elt : 'a list) + | "option" -> Obj.magic (to_option convert elt : 'a option) + | "pair" -> Obj.magic (to_pair convert convert elt : ('a * 'b)) + | "goals" -> Obj.magic (to_goals elt : goals) + | "evar" -> Obj.magic (to_evar elt : evar) + | "option_value" -> Obj.magic (to_option_value elt : option_value) + | "option_state" -> Obj.magic (to_option_state elt : option_state) + | _ -> raise Marshal_error + end + | _ -> raise Marshal_error + in + to_value convert xml + +(** * Debug printing *) + +let pr_option_value = function +| IntValue None -> "none" +| IntValue (Some i) -> string_of_int i +| StringValue s -> s +| BoolValue b -> if b then "true" else "false" + +let rec pr_setoptions opts = + let map (key, v) = + let key = String.concat " " key in + key ^ " := " ^ (pr_option_value v) + in + String.concat "; " (List.map map opts) + +let pr_getoptions opts = + let map (key, s) = + let key = String.concat " " key in + Printf.sprintf "%s: sync := %b; depr := %b; name := %s; value := %s\n" + key s.opt_sync s.opt_depr s.opt_name (pr_option_value s.opt_value) + in + "\n" ^ String.concat "" (List.map map opts) + +let pr_call = function + | Interp (r,b,s) -> + let raw = if r then "RAW" else "" in + let verb = if b then "" else "SILENT" in + "INTERP"^raw^verb^" ["^s^"]" + | Rewind i -> "REWIND "^(string_of_int i) + | Goal -> "GOALS" + | Evars -> "EVARS" + | Hints -> "HINTS" + | Status -> "STATUS" + | GetOptions -> "GETOPTIONS" + | SetOptions l -> "SETOPTIONS" ^ " [" ^ pr_setoptions l ^ "]" + | InLoadPath s -> "INLOADPATH "^s + | MkCases s -> "MKCASES "^s + +let pr_value_gen pr = function + | Good v -> "GOOD " ^ pr v + | Fail (_,str) -> "FAIL ["^str^"]" + +let pr_value v = pr_value_gen (fun _ -> "") v + +let pr_string s = "["^s^"]" +let pr_bool b = if b then "true" else "false" + +let pr_status s = + let path = match s.status_path with + | None -> "no path; " + | Some p -> "path = " ^ p ^ "; " + in + let name = match s.status_proofname with + | None -> "no proof;" + | Some n -> "proof = " ^ n ^ ";" + in + "Status: " ^ path ^ name + +let pr_mkcases l = + let l = List.map (String.concat " ") l in + "[" ^ String.concat " | " l ^ "]" + +let pr_goals_aux g = + if g.fg_goals = [] then + if g.bg_goals = [] then "Proof completed." + else Printf.sprintf "Still %i unfocused goals." (List.length g.bg_goals) + else + let pr_menu s = s in + let pr_goal { goal_hyp = hyps; goal_ccl = goal } = + "[" ^ String.concat "; " (List.map pr_menu hyps) ^ " |- " ^ pr_menu goal ^ "]" + in + String.concat " " (List.map pr_goal g.fg_goals) + +let pr_goals = function +| None -> "No proof in progress." +| Some g -> pr_goals_aux g + +let pr_evar ev = "[" ^ ev.evar_info ^ "]" + +let pr_evars = function +| None -> "No proof in progress." +| Some evars -> String.concat " " (List.map pr_evar evars) + +let pr_full_value call value = + match call with + | Interp _ -> pr_value_gen pr_string (Obj.magic value : string value) + | Rewind i -> pr_value_gen string_of_int (Obj.magic value : int value) + | Goal -> pr_value_gen pr_goals (Obj.magic value : goals option value) + | Evars -> pr_value_gen pr_evars (Obj.magic value : evar list option value) + | Hints -> pr_value value + | Status -> pr_value_gen pr_status (Obj.magic value : status value) + | GetOptions -> pr_value_gen pr_getoptions (Obj.magic value : (option_name * option_state) list value) + | SetOptions _ -> pr_value value + | InLoadPath s -> pr_value_gen pr_bool (Obj.magic value : bool value) + | MkCases s -> pr_value_gen pr_mkcases (Obj.magic value : string list list value) diff --git a/toplevel/ide_intf.mli b/toplevel/ide_intf.mli new file mode 100644 index 00000000..69204da1 --- /dev/null +++ b/toplevel/ide_intf.mli @@ -0,0 +1,87 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* string call + +(** Backtracking by at least a certain number of phrases. + No finished proofs will be re-opened. Instead, + we continue backtracking until before these proofs, + and answer the amount of extra backtracking performed. + Backtracking by more than the number of phrases already + interpreted successfully (and not yet undone) will fail. *) +val rewind : int -> int call + +(** Fetching the list of current goals. Return [None] if no proof is in + progress, [Some gl] otherwise. *) +val goals : goals option call + +(** Retrieving the tactics applicable to the current goal. [None] if there is + no proof in progress. *) +val hints : (hint list * hint) option call + +(** The status, for instance "Ready in SomeSection, proving Foo" *) +val status : status call + +(** Is a directory part of Coq's loadpath ? *) +val inloadpath : string -> bool call + +(** Create a "match" template for a given inductive type. + For each branch of the match, we list the constructor name + followed by enough pattern variables. *) +val mkcases : string -> string list list call + +(** Retrieve the list of unintantiated evars in the current proof. [None] if no + proof is in progress. *) +val evars : evar list option call + +(** Retrieve the list of options of the current toplevel, together with their + state. *) +val get_options : (option_name * option_state) list call + +(** Set the options to the given value. Warning: this is not atomic, so whenever + the call fails, the option state can be messed up... This is the caller duty + to check that everything is correct. *) +val set_options : (option_name * option_value) list -> unit call + +val abstract_eval_call : handler -> 'a call -> 'a value + +(** * XML data marshalling *) + +exception Marshal_error + +val of_value : ('a -> xml) -> 'a value -> xml +val to_value : (xml -> 'a) -> xml -> 'a value + +val of_call : 'a call -> xml +val to_call : xml -> 'a call + +val of_answer : 'a call -> 'a value -> xml +val to_answer : xml -> 'a value + +(** * Debug printing *) + +val pr_call : 'a call -> string +val pr_value : 'a value -> string +val pr_full_value : 'a call -> 'a value -> string diff --git a/toplevel/ide_slave.ml b/toplevel/ide_slave.ml new file mode 100644 index 00000000..42ecb75b --- /dev/null +++ b/toplevel/ide_slave.ml @@ -0,0 +1,579 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + flush_all (); + orig_stdout := Unix.out_channel_of_descr (Unix.dup Unix.stdout); + Unix.dup2 Unix.stderr Unix.stdout; + Pp_control.std_ft := out_ft; + Pp_control.err_ft := out_ft; + Pp_control.deep_ft := deep_out_ft; + set_binary_mode_out !orig_stdout true; + set_binary_mode_in stdin true; + ), + (fun () -> Format.pp_print_flush out_ft (); + let r = Buffer.contents out_buff in + Buffer.clear out_buff; r) + + +(** Categories of commands *) + +let coqide_known_option table = List.mem table [ + ["Printing";"Implicit"]; + ["Printing";"Coercions"]; + ["Printing";"Matching"]; + ["Printing";"Synth"]; + ["Printing";"Notations"]; + ["Printing";"All"]; + ["Printing";"Records"]; + ["Printing";"Existential";"Instances"]; + ["Printing";"Universes"]] + +type command_attribute = + NavigationCommand | QueryCommand | DebugCommand | KnownOptionCommand + | OtherStatePreservingCommand | GoalStartingCommand | SolveCommand + | ProofEndingCommand + +let rec attribute_of_vernac_command = function + (* Control *) + | VernacTime com -> attribute_of_vernac_command com + | VernacTimeout(_,com) -> attribute_of_vernac_command com + | VernacFail com -> attribute_of_vernac_command com + | VernacList _ -> [] (* unsupported *) + | VernacLoad _ -> [] + + (* Syntax *) + | VernacTacticNotation _ -> [] + | VernacSyntaxExtension _ -> [] + | VernacDelimiters _ -> [] + | VernacBindScope _ -> [] + | VernacOpenCloseScope _ -> [] + | VernacArgumentsScope _ -> [] + | VernacInfix _ -> [] + | VernacNotation _ -> [] + + (* Gallina *) + | VernacDefinition (_,_,DefineBody _,_) -> [] + | VernacDefinition (_,_,ProveBody _,_) -> [GoalStartingCommand] + | VernacStartTheoremProof _ -> [GoalStartingCommand] + | VernacEndProof _ -> [ProofEndingCommand] + | VernacExactProof _ -> [ProofEndingCommand] + + | VernacAssumption _ -> [] + | VernacInductive _ -> [] + | VernacFixpoint _ -> [] + | VernacCoFixpoint _ -> [] + | VernacScheme _ -> [] + | VernacCombinedScheme _ -> [] + + (* Modules *) + | VernacDeclareModule _ -> [] + | VernacDefineModule _ -> [] + | VernacDeclareModuleType _ -> [] + | VernacInclude _ -> [] + + (* Gallina extensions *) + | VernacBeginSection _ -> [] + | VernacEndSegment _ -> [] + | VernacRequire _ -> [] + | VernacImport _ -> [] + | VernacCanonical _ -> [] + | VernacCoercion _ -> [] + | VernacIdentityCoercion _ -> [] + + (* Type classes *) + | VernacInstance _ -> [] + | VernacContext _ -> [] + | VernacDeclareInstances _ -> [] + | VernacDeclareClass _ -> [] + + (* Solving *) + | VernacSolve _ -> [SolveCommand] + | VernacSolveExistential _ -> [SolveCommand] + + (* Auxiliary file and library management *) + | VernacRequireFrom _ -> [] + | VernacAddLoadPath _ -> [] + | VernacRemoveLoadPath _ -> [] + | VernacAddMLPath _ -> [] + | VernacDeclareMLModule _ -> [] + | VernacChdir o -> + (* TODO: [Chdir d] is currently not undo-able (not stored in coq state). + But if we register [Chdir] in the state, loading [initial.coq] will + wrongly cd to the compile-time directory at each coqtop launch. *) + if o = None then [QueryCommand] else [] + + (* State management *) + | VernacWriteState _ -> [] + | VernacRestoreState _ -> [] + + (* Resetting *) + | VernacRemoveName _ -> [NavigationCommand] + | VernacResetName _ -> [NavigationCommand] + | VernacResetInitial -> [NavigationCommand] + | VernacBack _ -> [NavigationCommand] + | VernacBackTo _ -> [NavigationCommand] + + (* Commands *) + | VernacDeclareTacticDefinition _ -> [] + | VernacCreateHintDb _ -> [] + | VernacRemoveHints _ -> [] + | VernacHints _ -> [] + | VernacSyntacticDefinition _ -> [] + | VernacDeclareImplicits _ -> [] + | VernacArguments _ -> [] + | VernacDeclareReduction _ -> [] + | VernacReserve _ -> [] + | VernacGeneralizable _ -> [] + | VernacSetOpacity _ -> [] + | VernacSetOption (_,["Ltac";"Debug"], _) -> [DebugCommand] + | VernacSetOption (_,o,BoolValue true) | VernacUnsetOption (_,o) -> + if coqide_known_option o then [KnownOptionCommand] else [] + | VernacSetOption _ -> [] + | VernacRemoveOption _ -> [] + | VernacAddOption _ -> [] + | VernacMemOption _ -> [QueryCommand] + + | VernacPrintOption _ -> [QueryCommand] + | VernacCheckMayEval _ -> [QueryCommand] + | VernacGlobalCheck _ -> [QueryCommand] + | VernacPrint _ -> [QueryCommand] + | VernacSearch _ -> [QueryCommand] + | VernacLocate _ -> [QueryCommand] + + | VernacComments _ -> [OtherStatePreservingCommand] + | VernacNop -> [OtherStatePreservingCommand] + + (* Proof management *) + | VernacGoal _ -> [GoalStartingCommand] + + | VernacAbort _ -> [] + | VernacAbortAll -> [NavigationCommand] + | VernacRestart -> [NavigationCommand] + | VernacSuspend -> [NavigationCommand] + | VernacResume _ -> [NavigationCommand] + | VernacUndo _ -> [NavigationCommand] + | VernacUndoTo _ -> [NavigationCommand] + | VernacBacktrack _ -> [NavigationCommand] + + | VernacFocus _ -> [SolveCommand] + | VernacUnfocus -> [SolveCommand] + | VernacShow _ -> [OtherStatePreservingCommand] + | VernacCheckGuard -> [OtherStatePreservingCommand] + | VernacProof (None, None) -> [OtherStatePreservingCommand] + | VernacProof _ -> [] + + | VernacProofMode _ -> [] + | VernacBullet _ -> [SolveCommand] + | VernacSubproof _ -> [SolveCommand] + | VernacEndSubproof -> [SolveCommand] + + (* Toplevel control *) + | VernacToplevelControl _ -> [] + + (* Extensions *) + | VernacExtend ("Subtac_Obligations", _) -> [GoalStartingCommand] + | VernacExtend _ -> [] + +let is_vernac_navigation_command com = + List.mem NavigationCommand (attribute_of_vernac_command com) + +let is_vernac_query_command com = + List.mem QueryCommand (attribute_of_vernac_command com) + +let is_vernac_known_option_command com = + List.mem KnownOptionCommand (attribute_of_vernac_command com) + +let is_vernac_debug_command com = + List.mem DebugCommand (attribute_of_vernac_command com) + +let is_vernac_goal_printing_command com = + let attribute = attribute_of_vernac_command com in + List.mem GoalStartingCommand attribute or + List.mem SolveCommand attribute + +let is_vernac_state_preserving_command com = + let attribute = attribute_of_vernac_command com in + List.mem OtherStatePreservingCommand attribute or + List.mem QueryCommand attribute + +let is_vernac_tactic_command com = + List.mem SolveCommand (attribute_of_vernac_command com) + +let is_vernac_proof_ending_command com = + List.mem ProofEndingCommand (attribute_of_vernac_command com) + + +(** Command history stack + + We maintain a stack of the past states of the system. Each + successfully interpreted command adds a [reset_info] element + to this stack, storing what were the (label / open proofs / + current proof depth) just _before_ the interpretation of this + command. A label is just an integer (cf. BackTo and Bactrack + vernac commands). +*) + +type reset_info = { label : int; proofs : identifier list; depth : int } + +let com_stk = Stack.create () + +let compute_reset_info () = + { label = Lib.current_command_label (); + proofs = Pfedit.get_all_proof_names (); + depth = max 0 (Pfedit.current_proof_depth ()) } + + +(** Interpretation (cf. [Ide_intf.interp]) *) + +(** Check whether a command is forbidden by CoqIDE *) + +let coqide_cmd_checks (loc,ast) = + let user_error s = + raise (Loc.Exc_located (loc, Util.UserError ("CoqIde", str s))) + in + if is_vernac_debug_command ast then + user_error "Debug mode not available within CoqIDE"; + if is_vernac_navigation_command ast then + user_error "Use CoqIDE navigation instead"; + if is_vernac_known_option_command ast then + user_error "Use CoqIDE display menu instead"; + if is_vernac_query_command ast then + msgerrnl (str "Warning: query commands should not be inserted in scripts") + +let raw_eval_expr = Vernac.eval_expr + +let eval_expr loc_ast = + let rewind_info = compute_reset_info () in + raw_eval_expr loc_ast; + Stack.push rewind_info com_stk + +let interp (raw,verbosely,s) = + if not raw then (prerr_endline "Starting interp..."; prerr_endline s); + let pa = Pcoq.Gram.parsable (Stream.of_string s) in + let loc_ast = Vernac.parse_sentence (pa,None) in + if not raw then coqide_cmd_checks loc_ast; + (* We run tactics silently, since we will query the goal state later. + Otherwise, we honor the IDE verbosity flag. *) + Flags.make_silent + (is_vernac_goal_printing_command (snd loc_ast) || not verbosely); + if raw then raw_eval_expr loc_ast else eval_expr loc_ast; + Flags.make_silent true; + if not raw then prerr_endline ("...Done with interp of : "^s); + read_stdout () + + +(** Backtracking (cf. [Ide_intf.rewind]). + We now rely on the [Backtrack] command just as ProofGeneral. *) + +let rewind count = + if count = 0 then 0 + else + let current_proofs = Pfedit.get_all_proof_names () + in + (* 1) First, let's pop the history stack exactly [count] times. + NB: Normally, the IDE will not rewind by more than the numbers + of already interpreted commands, hence no risk of [Stack.Empty]. + *) + let initial_target = + for i = 1 to count - 1 do ignore (Stack.pop com_stk) done; + Stack.pop com_stk + in + (* 2) Backtrack by enough additional steps to avoid re-opening proofs. + Typically, when a Qed has been crossed, we backtrack to the proof start. + NB: We cannot reach the empty stack, since the oldest [reset_info] + in the history cannot have opened proofs. + *) + let already_opened p = List.mem p current_proofs in + let rec extra_back n target = + if List.for_all already_opened target.proofs then n,target + else extra_back (n+1) (Stack.pop com_stk) + in + let extra_count, target = extra_back 0 initial_target + in + (* 3) Now that [target.proofs] is a subset of the opened proofs before + the rewind, we simply abort the extra proofs (if any). + NB: It is critical here that proofs are nested in a regular way + (i.e. no Resume or Suspend, as enforced above). This way, we can simply + count the extra proofs to abort instead of taking care of their names. + *) + let naborts = List.length current_proofs - List.length target.proofs + in + (* 4) We are now ready to call [Backtrack] *) + prerr_endline ("Rewind to state "^string_of_int target.label^ + ", proof depth "^string_of_int target.depth^ + ", num of aborts "^string_of_int naborts); + Vernacentries.vernac_backtrack target.label target.depth naborts; + Lib.mark_end_of_command (); (* We've short-circuited Vernac.eval_expr *) + extra_count + + +(** Goal display *) + +let hyp_next_tac sigma env (id,_,ast) = + let id_s = Names.string_of_id id in + let type_s = string_of_ppcmds (pr_ltype_env env ast) in + [ + ("clear "^id_s),("clear "^id_s^".\n"); + ("apply "^id_s),("apply "^id_s^".\n"); + ("exact "^id_s),("exact "^id_s^".\n"); + ("generalize "^id_s),("generalize "^id_s^".\n"); + ("absurd <"^id_s^">"),("absurd "^type_s^".\n") + ] @ (if Hipattern.is_equality_type ast then [ + ("discriminate "^id_s),("discriminate "^id_s^".\n"); + ("injection "^id_s),("injection "^id_s^".\n") + ] else []) @ (if Hipattern.is_equality_type (snd (Reductionops.splay_prod env sigma ast)) then [ + ("rewrite "^id_s),("rewrite "^id_s^".\n"); + ("rewrite <- "^id_s),("rewrite <- "^id_s^".\n") + ] else []) @ [ + ("elim "^id_s), ("elim "^id_s^".\n"); + ("inversion "^id_s), ("inversion "^id_s^".\n"); + ("inversion clear "^id_s), ("inversion_clear "^id_s^".\n") + ] + +let concl_next_tac sigma concl = + let expand s = (s,s^".\n") in + List.map expand ([ + "intro"; + "intros"; + "intuition" + ] @ (if Hipattern.is_equality_type (Goal.V82.concl sigma concl) then [ + "reflexivity"; + "discriminate"; + "symmetry" + ] else []) @ [ + "assumption"; + "omega"; + "ring"; + "auto"; + "eauto"; + "tauto"; + "trivial"; + "decide equality"; + "simpl"; + "subst"; + "red"; + "split"; + "left"; + "right" + ]) + +let process_goal sigma g = + let env = Goal.V82.env sigma g in + let ccl = + let norm_constr = Reductionops.nf_evar sigma (Goal.V82.concl sigma g) in + string_of_ppcmds (pr_ltype_env_at_top env norm_constr) in + let process_hyp h_env d acc = + let d = Term.map_named_declaration (Reductionops.nf_evar sigma) d in + (string_of_ppcmds (pr_var_decl h_env d)) :: acc in +(* (string_of_ppcmds (pr_var_decl h_env d), hyp_next_tac sigma h_env d)::acc in *) + let hyps = + List.rev (Environ.fold_named_context process_hyp env ~init: []) in + { Interface.goal_hyp = hyps; Interface.goal_ccl = ccl } +(* hyps,(ccl,concl_next_tac sigma g)) *) + +let goals () = + try + let pfts = Proof_global.give_me_the_proof () in + let { Evd.it = all_goals ; sigma = sigma } = Proof.V82.subgoals pfts in + let fg = List.map (process_goal sigma) all_goals in + let { Evd.it = bgoals ; sigma = sigma } = Proof.V82.background_subgoals pfts in + let bg = List.map (process_goal sigma) bgoals in + Some { Interface.fg_goals = fg; Interface.bg_goals = bg; } + with Proof_global.NoCurrentProof -> None + +let evars () = + try + let pfts = Proof_global.give_me_the_proof () in + let { Evd.it = all_goals ; sigma = sigma } = Proof.V82.subgoals pfts in + let exl = Evarutil.non_instantiated sigma in + let map_evar ev = { Interface.evar_info = string_of_ppcmds (pr_evar ev); } in + let el = List.map map_evar exl in + Some el + with Proof_global.NoCurrentProof -> None + +let hints () = + try + let pfts = Proof_global.give_me_the_proof () in + let { Evd.it = all_goals ; sigma = sigma } = Proof.V82.subgoals pfts in + match all_goals with + | [] -> None + | g :: _ -> + let env = Goal.V82.env sigma g in + let hint_goal = concl_next_tac sigma g in + let get_hint_hyp env d accu = hyp_next_tac sigma env d :: accu in + let hint_hyps = List.rev (Environ.fold_named_context get_hint_hyp env ~init: []) in + Some (hint_hyps, hint_goal) + with Proof_global.NoCurrentProof -> None + +(** Other API calls *) + +let inloadpath dir = + Library.is_in_load_paths (System.physical_path_of_string dir) + +let status () = + (** We remove the initial part of the current [dir_path] + (usually Top in an interactive session, cf "coqtop -top"), + and display the other parts (opened sections and modules) *) + let path = + let l = Names.repr_dirpath (Lib.cwd ()) in + let l = snd (Util.list_sep_last l) in + if l = [] then None + else Some (Names.string_of_dirpath (Names.make_dirpath l)) + in + let proof = + try + Some (Names.string_of_id (Pfedit.get_current_proof_name ())) + with _ -> None + in + { Interface.status_path = path; Interface.status_proofname = proof } + +let get_options () = + let table = Goptions.get_tables () in + let fold key state accu = (key, state) :: accu in + Goptions.OptionMap.fold fold table [] + +let set_options options = + let iter (name, value) = match value with + | BoolValue b -> Goptions.set_bool_option_value name b + | IntValue i -> Goptions.set_int_option_value name i + | StringValue s -> Goptions.set_string_option_value name s + in + List.iter iter options + +(** Grouping all call handlers together + error handling *) + +let eval_call c = + let rec handle_exn e = + catch_break := false; + let pr_exn e = string_of_ppcmds (Errors.print e) in + match e with + | Vernacexpr.Drop -> None, "Drop is not allowed by coqide!" + | Vernacexpr.Quit -> None, "Quit is not allowed by coqide!" + | Vernac.DuringCommandInterp (_,inner) -> handle_exn inner + | Error_in_file (_,_,inner) -> None, pr_exn inner + | Loc.Exc_located (loc, inner) when loc = dummy_loc -> None, pr_exn inner + | Loc.Exc_located (loc, inner) -> Some (Util.unloc loc), pr_exn inner + | e -> None, pr_exn e + in + let interruptible f x = + catch_break := true; + Util.check_for_interrupt (); + let r = f x in + catch_break := false; + r + in + let handler = { + Interface.interp = interruptible interp; + Interface.rewind = interruptible rewind; + Interface.goals = interruptible goals; + Interface.evars = interruptible evars; + Interface.hints = interruptible hints; + Interface.status = interruptible status; + Interface.inloadpath = interruptible inloadpath; + Interface.get_options = interruptible get_options; + Interface.set_options = interruptible set_options; + Interface.mkcases = interruptible Vernacentries.make_cases; + Interface.handle_exn = handle_exn; } + in + (* If the messages of last command are still there, we remove them *) + ignore (read_stdout ()); + Ide_intf.abstract_eval_call handler c + + +(** The main loop *) + +(** Exceptions during eval_call should be converted into [Interface.Fail] + messages by [handle_exn] above. Otherwise, we die badly, after having + tried to send a last message to the ide: trying to recover from errors + with the current protocol would most probably bring desynchronisation + between coqtop and ide. With marshalling, reading an answer to + a different request could hang the ide... *) + +let pr_debug s = + if !Flags.debug then Printf.eprintf "[pid %d] %s\n%!" (Unix.getpid ()) s + +let fail err = + Ide_intf.of_value (fun _ -> assert false) (Interface.Fail (None, err)) + +let loop () = + let p = Xml_parser.make () in + let () = Xml_parser.check_eof p false in + init_signal_handler (); + catch_break := false; + (* ensure we have a command separator object (DOT) so that the first + command can be reseted. *) + Lib.mark_end_of_command(); + try + while true do + let xml_answer = + try + let xml_query = Xml_parser.parse p (Xml_parser.SChannel stdin) in + let q = Ide_intf.to_call xml_query in + let () = pr_debug ("<-- " ^ Ide_intf.pr_call q) in + let r = eval_call q in + let () = pr_debug ("--> " ^ Ide_intf.pr_full_value q r) in + Ide_intf.of_answer q r + with + | Xml_parser.Error (err, loc) -> + let msg = "Syntax error in query: " ^ Xml_parser.error_msg err in + fail msg + | Ide_intf.Marshal_error -> + fail "Incorrect query." + in + Xml_utils.print_xml !orig_stdout xml_answer; + flush !orig_stdout + done + with e -> + let msg = Printexc.to_string e in + let r = "Fatal exception in coqtop:\n" ^ msg in + pr_debug ("==> " ^ r); + (try + Xml_utils.print_xml !orig_stdout (fail r); + flush !orig_stdout + with _ -> ()); + exit 1 diff --git a/toplevel/ide_slave.mli b/toplevel/ide_slave.mli new file mode 100644 index 00000000..13dff280 --- /dev/null +++ b/toplevel/ide_slave.mli @@ -0,0 +1,17 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* unit + +val loop : unit -> unit diff --git a/toplevel/ind_tables.ml b/toplevel/ind_tables.ml index 53c3bcea..de3b62f8 100644 --- a/toplevel/ind_tables.ml +++ b/toplevel/ind_tables.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* (Lib.discharge_inductive ind,Lib.discharge_con const)) l) -let (inScheme,_) = +let inScheme : string * (inductive * constant) array -> obj = declare_object {(default_object "SCHEME") with cache_function = cache_scheme; load_function = (fun _ -> cache_scheme); @@ -111,21 +109,28 @@ let declare_individual_scheme_object s ?(aux="") f = let declare_scheme kind indcl = Lib.add_anonymous_leaf (inScheme (kind,indcl)) +let is_visible_name id = + try ignore (Nametab.locate (Libnames.qualid_of_ident id)); true + with Not_found -> false + +let compute_name internal id = + match internal with + | KernelVerbose | UserVerbose -> id + | KernelSilent -> + Namegen.next_ident_away_from (add_prefix "internal_" id) is_visible_name + let define internal id c = - (* TODO: specify even more by distinguish between KernelVerbose and - * UserVerbose *) - let fd = match internal with - | KernelSilent -> declare_internal_constant - | _ -> declare_constant in + let fd = declare_constant ~internal in + let id = compute_name internal id in let kn = fd id (DefinitionEntry { const_entry_body = c; + const_entry_secctx = None; const_entry_type = None; - const_entry_opaque = false; - const_entry_boxed = Flags.boxed_definitions() }, + const_entry_opaque = false }, Decl_kinds.IsDefinition Scheme) in (match internal with - | KernelSilent -> () + | KernelSilent -> () | _-> definition_message id); kn diff --git a/toplevel/ind_tables.mli b/toplevel/ind_tables.mli index e6f5e77a..96096d47 100644 --- a/toplevel/ind_tables.mli +++ b/toplevel/ind_tables.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* constr array type individual_scheme_object_function = inductive -> constr -(* Main functions to register a scheme builder *) +(** Main functions to register a scheme builder *) val declare_mutual_scheme_object : string -> ?aux:string -> mutual_scheme_object_function -> mutual scheme_kind @@ -37,16 +37,16 @@ val declare_individual_scheme_object : string -> ?aux:string -> val declare_scheme : 'a scheme_kind -> (inductive * constant) array -> unit *) -(* Force generation of a (mutually) scheme with possibly user-level names *) +(** Force generation of a (mutually) scheme with possibly user-level names *) val define_individual_scheme : individual scheme_kind -> - Declare.internal_flag (* internal *) -> + Declare.internal_flag (** internal *) -> identifier option -> inductive -> constant -val define_mutual_scheme : mutual scheme_kind -> Declare.internal_flag (* internal *) -> +val define_mutual_scheme : mutual scheme_kind -> Declare.internal_flag (** internal *) -> (int * identifier) list -> mutual_inductive -> constant array -(* Main function to retrieve a scheme in the cache or to generate it *) +(** Main function to retrieve a scheme in the cache or to generate it *) val find_scheme : 'a scheme_kind -> inductive -> constant val check_scheme : 'a scheme_kind -> inductive -> bool diff --git a/toplevel/indschemes.ml b/toplevel/indschemes.ml index 3596085f..51eddbae 100644 --- a/toplevel/indschemes.ml +++ b/toplevel/indschemes.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* !elim_flag) ; @@ -58,6 +57,7 @@ let case_flag = ref false let _ = declare_bool_option { optsync = true; + optdepr = false; optname = "automatic declaration of case analysis schemes"; optkey = ["Case";"Analysis";"Schemes"]; optread = (fun () -> !case_flag) ; @@ -67,6 +67,7 @@ let eq_flag = ref false let _ = declare_bool_option { optsync = true; + optdepr = false; optname = "automatic declaration of boolean equality"; optkey = ["Boolean";"Equality";"Schemes"]; optread = (fun () -> !eq_flag) ; @@ -74,6 +75,7 @@ let _ = let _ = (* compatibility *) declare_bool_option { optsync = true; + optdepr = true; optname = "automatic declaration of boolean equality"; optkey = ["Equality";"Scheme"]; optread = (fun () -> !eq_flag) ; @@ -81,10 +83,11 @@ let _ = (* compatibility *) let is_eq_flag () = !eq_flag && Flags.version_strictly_greater Flags.V8_2 -let eq_dec_flag = ref false +let eq_dec_flag = ref false let _ = declare_bool_option { optsync = true; + optdepr = false; optname = "automatic declaration of decidable equality"; optkey = ["Decidable";"Equality";"Schemes"]; optread = (fun () -> !eq_dec_flag) ; @@ -94,6 +97,7 @@ let rewriting_flag = ref false let _ = declare_bool_option { optsync = true; + optdepr = false; optname ="automatic declaration of rewriting schemes for equality types"; optkey = ["Rewriting";"Schemes"]; optread = (fun () -> !rewriting_flag) ; @@ -102,16 +106,13 @@ let _ = (* Util *) let define id internal c t = - (* TODO: specify even more by distinguish KernelVerbose and UserVerbose *) - let f = match internal with - | KernelSilent -> declare_internal_constant - | _ -> declare_constant in + let f = declare_constant ~internal in let kn = f id (DefinitionEntry { const_entry_body = c; + const_entry_secctx = None; const_entry_type = t; - const_entry_opaque = false; - const_entry_boxed = Flags.boxed_definitions() }, + const_entry_opaque = false }, Decl_kinds.IsDefinition Scheme) in definition_message id; kn @@ -127,7 +128,7 @@ let alarm what internal msg = | KernelVerbose | KernelSilent -> (if debug then - Flags.if_verbose Pp.msg_warning + Flags.if_warn Pp.msg_warning (hov 0 msg ++ fnl () ++ what ++ str " not defined.")) | _ -> errorlabstrm "" msg @@ -158,7 +159,7 @@ let try_declare_scheme what f internal names kn = (strbrk "Required constant " ++ str s ++ str " undefined.") | AlreadyDeclared msg -> alarm what internal (msg ++ str ".") - | _ -> + | _ -> alarm what internal (str "Unknown exception during scheme creation.") @@ -173,7 +174,7 @@ let declare_beq_scheme_with l kn = try_declare_scheme (beq_scheme_msg kn) declare_beq_scheme_gen UserVerbose l kn let try_declare_beq_scheme kn = - (* TODO: handle Fix, see e.g. TheoryList.In_spec, eventually handle + (* TODO: handle Fix, eventually handle proof-irrelevance; improve decidability by depending on decidability for the parameters rather than on the bl and lb properties *) try_declare_scheme (beq_scheme_msg kn) declare_beq_scheme_gen KernelVerbose [] kn diff --git a/toplevel/indschemes.mli b/toplevel/indschemes.mli index 707b9e00..87aedc7b 100644 --- a/toplevel/indschemes.mli +++ b/toplevel/indschemes.mli @@ -1,56 +1,52 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* unit val declare_eq_decidability : mutual_inductive -> unit -(* Build and register a congruence scheme for an equality-like inductive type *) +(** Build and register a congruence scheme for an equality-like inductive type *) val declare_congr_scheme : inductive -> unit -(* Build and register rewriting schemes for an equality-like inductive type *) +(** Build and register rewriting schemes for an equality-like inductive type *) val declare_rewriting_schemes : inductive -> unit -(* Mutual Minimality/Induction scheme *) +(** Mutual Minimality/Induction scheme *) val do_mutual_induction_scheme : - (identifier located * bool * inductive * rawsort) list -> unit + (identifier located * bool * inductive * glob_sort) list -> unit -(* Main calls to interpret the Scheme command *) +(** Main calls to interpret the Scheme command *) val do_scheme : (identifier located option * scheme) list -> unit -(* Combine a list of schemes into a conjunction of them *) +(** Combine a list of schemes into a conjunction of them *) val build_combined_scheme : env -> constant list -> constr * types val do_combined_scheme : identifier located -> identifier located list -> unit -(* Hook called at each inductive type definition *) +(** Hook called at each inductive type definition *) val declare_default_schemes : mutual_inductive -> unit diff --git a/toplevel/interface.mli b/toplevel/interface.mli new file mode 100644 index 00000000..e1410f5b --- /dev/null +++ b/toplevel/interface.mli @@ -0,0 +1,87 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* string; + rewind : int -> int; + goals : unit -> goals option; + evars : unit -> evar list option; + hints : unit -> (hint list * hint) option; + status : unit -> status; + get_options : unit -> (option_name * option_state) list; + set_options : (option_name * option_value) list -> unit; + inloadpath : string -> bool; + mkcases : string -> string list list; + handle_exn : exn -> location * string; +} diff --git a/toplevel/lemmas.ml b/toplevel/lemmas.ml index 8ef82105..7704449f 100644 --- a/toplevel/lemmas.ml +++ b/toplevel/lemmas.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* (pi2 (Global.lookup_named id),variable_opacity id) | ConstRef cst -> - let {const_body=body;const_opaque=opaq} = Global.lookup_constant cst in - (Option.map Declarations.force body,opaq) + let cb = Global.lookup_constant cst in + (Option.map Declarations.force (body_of_constant cb), is_opaque cb) | _ -> assert false let adjust_guardness_conditions const = function @@ -126,13 +124,13 @@ let find_mutually_recursive_statements thms = assert (rest=[]); (* One occ. of common coind ccls and no common inductive hyps *) if common_same_indhyp <> [] then - if_verbose warning "Assuming mutual coinductive statements."; + if_verbose msgnl (str "Assuming mutual coinductive statements."); flush_all (); indccl, true, [] | [], _::_ -> if same_indccl <> [] && list_distinct (List.map pi1 (List.hd same_indccl)) then - if_verbose warn (strbrk "Coinductive statements do not follow the order of definition, assume the proof to be by induction."); flush_all (); + if_verbose msgnl (strbrk "Coinductive statements do not follow the order of definition, assuming the proof to be by induction."); flush_all (); let possible_guards = List.map (List.map pi3) inds_hyps in (* assume the largest indices as possible *) list_last common_same_indhyp, false, possible_guards @@ -176,14 +174,6 @@ let save id const do_guard (locality,kind) hook = definition_message id; hook l r -let save_hook = ref ignore -let set_save_hook f = save_hook := f - -let save_named opacity = - let id,(const,do_guard,persistence,hook) = Pfedit.cook_proof !save_hook in - let const = { const with const_entry_opaque = opacity } in - save id const do_guard persistence hook - let default_thm_id = id_of_string "Unnamed_thm" let compute_proof_name locality = function @@ -209,7 +199,7 @@ let save_remaining_recthms (local,kind) body opaq i (id,(t_i,(_,imps))) = (Local,VarRef id,imps) | Global -> let k = IsAssumption Conjectural in - let kn = declare_constant id (ParameterEntry (t_i,false), k) in + let kn = declare_constant id (ParameterEntry (None,t_i,None), k) in (Global,ConstRef kn,imps)) | Some body -> let k = logical_kind_of_goal_kind kind in @@ -225,27 +215,34 @@ let save_remaining_recthms (local,kind) body opaq i (id,(t_i,(_,imps))) = | Global -> let const = { const_entry_body = body_i; + const_entry_secctx = None; const_entry_type = Some t_i; - const_entry_opaque = opaq; - const_entry_boxed = false (* copy of what cook_proof does *)} in + const_entry_opaque = opaq } in let kn = declare_constant id (DefinitionEntry const, k) in (Global,ConstRef kn,imps) -(* 4.2| General support for goals *) +let save_hook = ref ignore +let set_save_hook f = save_hook := f + +let get_proof opacity = + let id,(const,do_guard,persistence,hook) = Pfedit.cook_proof !save_hook in + id,{const with const_entry_opaque = opacity},do_guard,persistence,hook + +let save_named opacity = + let id,const,do_guard,persistence,hook = get_proof opacity in + save id const do_guard persistence hook let check_anonymity id save_ident = - if atompart_of_id id <> "Unnamed_thm" then + if atompart_of_id id <> string_of_id (default_thm_id) then error "This command can only be used for unnamed theorem." let save_anonymous opacity save_ident = - let id,(const,do_guard,persistence,hook) = Pfedit.cook_proof !save_hook in - let const = { const with const_entry_opaque = opacity } in + let id,const,do_guard,persistence,hook = get_proof opacity in check_anonymity id save_ident; save save_ident const do_guard persistence hook let save_anonymous_with_strength kind opacity save_ident = - let id,(const,do_guard,_,hook) = Pfedit.cook_proof !save_hook in - let const = { const with const_entry_opaque = opacity } in + let id,const,do_guard,_,hook = get_proof opacity in check_anonymity id save_ident; (* we consider that non opaque behaves as local for discharge *) save save_ident const do_guard (Global, Proof kind) hook @@ -256,8 +253,7 @@ let start_hook = ref ignore let set_start_hook = (:=) start_hook let start_proof id kind c ?init_tac ?(compute_guard=[]) hook = - let sign = Global.named_context () in - let sign = clear_proofs sign in + let sign = initialize_named_context_for_proof () in !start_hook c; Pfedit.start_proof id kind sign c ?init_tac ~compute_guard hook @@ -314,11 +310,11 @@ let start_proof_with_initialization kind recguard thms snl hook = start_proof id kind t ?init_tac hook ~compute_guard:guard let start_proof_com kind thms hook = - let evdref = ref (create_evar_defs Evd.empty) in + let evdref = ref Evd.empty in let env0 = Global.env () in let thms = List.map (fun (sopt,(bl,t,guard)) -> - let (env, ctx), imps = interp_context_evars evdref env0 bl in - let t', imps' = interp_type_evars_impls ~evdref env t in + let impls, ((env, ctx), imps) = interp_context_evars evdref env0 bl in + let t', imps' = interp_type_evars_impls ~impls ~evdref env t in Sign.iter_rel_context (check_evars env Evd.empty !evdref) ctx; let ids = List.map pi1 ctx in (compute_proof_name (fst kind) sopt, @@ -333,8 +329,9 @@ let start_proof_com kind thms hook = let admit () = let (id,k,typ,hook) = Pfedit.current_proof_statement () in + let e = Pfedit.get_used_variables(), typ, None in let kn = - declare_constant id (ParameterEntry (typ,false),IsAssumption Conjectural) in + declare_constant id (ParameterEntry e,IsAssumption Conjectural) in Pfedit.delete_current_proof (); assumption_message id; hook Global (ConstRef kn) diff --git a/toplevel/lemmas.mli b/toplevel/lemmas.mli index 0e8eaac2..8b496f82 100644 --- a/toplevel/lemmas.mli +++ b/toplevel/lemmas.mli @@ -1,14 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* unit) -> unit val start_proof : identifier -> goal_kind -> types -> @@ -35,31 +31,32 @@ val start_proof_with_initialization : (identifier * (types * (name list * Impargs.manual_explicitation list))) list -> int list option -> declaration_hook -> unit -(* A hook the next three functions pass to cook_proof *) -val set_save_hook : (Refiner.pftreestate -> unit) -> unit +(** A hook the next three functions pass to cook_proof *) +val set_save_hook : (Proof.proof -> unit) -> unit -(*s [save_named b] saves the current completed proof under the name it +(** {6 ... } *) +(** [save_named b] saves the current completed proof under the name it was started; boolean [b] tells if the theorem is declared opaque; it fails if the proof is not completed *) val save_named : bool -> unit -(* [save_anonymous b name] behaves as [save_named] but declares the theorem +(** [save_anonymous b name] behaves as [save_named] but declares the theorem under the name [name] and respects the strength of the declaration *) val save_anonymous : bool -> identifier -> unit -(* [save_anonymous_with_strength s b name] behaves as [save_anonymous] but +(** [save_anonymous_with_strength s b name] behaves as [save_anonymous] but declares the theorem under the name [name] and gives it the strength [strength] *) val save_anonymous_with_strength : theorem_kind -> bool -> identifier -> unit -(* [admit ()] aborts the current goal and save it as an assmumption *) +(** [admit ()] aborts the current goal and save it as an assmumption *) val admit : unit -> unit -(* [get_current_context ()] returns the evar context and env of the +(** [get_current_context ()] returns the evar context and env of the current open proof if any, otherwise returns the empty evar context and the current global env *) diff --git a/toplevel/libtypes.ml b/toplevel/libtypes.ml index 27e19bd8..2f98962c 100644 --- a/toplevel/libtypes.ml +++ b/toplevel/libtypes.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* obj = declare_object { (default_object "LIBTYPES") with load_function = (fun _ -> load); diff --git a/toplevel/libtypes.mli b/toplevel/libtypes.mli index 03329592..a6a95ccf 100644 --- a/toplevel/libtypes.mli +++ b/toplevel/libtypes.mli @@ -1,31 +1,25 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* types -(* The different types of search available. - * See term_dnet.mli for more explanations *) +(** The different types of search available. + See term_dnet.mli for more explanations *) val search_pattern : types -> result list val search_concl : types -> result list val search_head_concl : types -> result list diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml index 0adae08a..6a4d7251 100644 --- a/toplevel/metasyntax.ml +++ b/toplevel/metasyntax.ml @@ -1,15 +1,14 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* obj = declare_object {(default_object "TOKEN") with open_function = (fun i o -> if i=1 then cache_token o); cache_function = cache_token; @@ -70,7 +70,12 @@ let subst_tactic_parule subst (key,n,p,(d,tac)) = let subst_tactic_notation (subst,(pa,pp)) = (subst_tactic_parule subst pa,pp) -let (inTacticGrammar, outTacticGrammar) = +type tactic_grammar_obj = + (string * int * grammar_prod_item list * + (dir_path * Tacexpr.glob_tactic_expr)) + * (string * Genarg.argument_type list * (int * Pptactic.grammar_terminals)) + +let inTacticGrammar : tactic_grammar_obj -> obj = declare_object {(default_object "TacticGrammar") with open_function = (fun i o -> if i=1 then cache_tactic_notation o); cache_function = cache_tactic_notation; @@ -106,33 +111,33 @@ let add_tactic_notation (n,prods,e) = let print_grammar = function | "constr" | "operconstr" | "binder_constr" -> msgnl (str "Entry constr is"); - entry_print Pcoq.Constr.constr; + Gram.entry_print Pcoq.Constr.constr; msgnl (str "and lconstr is"); - entry_print Pcoq.Constr.lconstr; + Gram.entry_print Pcoq.Constr.lconstr; msgnl (str "where binder_constr is"); - entry_print Pcoq.Constr.binder_constr; + Gram.entry_print Pcoq.Constr.binder_constr; msgnl (str "and operconstr is"); - entry_print Pcoq.Constr.operconstr; + Gram.entry_print Pcoq.Constr.operconstr; | "pattern" -> - entry_print Pcoq.Constr.pattern + Gram.entry_print Pcoq.Constr.pattern | "tactic" -> msgnl (str "Entry tactic_expr is"); - entry_print Pcoq.Tactic.tactic_expr; + Gram.entry_print Pcoq.Tactic.tactic_expr; msgnl (str "Entry binder_tactic is"); - entry_print Pcoq.Tactic.binder_tactic; + Gram.entry_print Pcoq.Tactic.binder_tactic; msgnl (str "Entry simple_tactic is"); - entry_print Pcoq.Tactic.simple_tactic; + Gram.entry_print Pcoq.Tactic.simple_tactic; | "vernac" -> msgnl (str "Entry vernac is"); - entry_print Pcoq.Vernac_.vernac; + Gram.entry_print Pcoq.Vernac_.vernac; msgnl (str "Entry command is"); - entry_print Pcoq.Vernac_.command; + Gram.entry_print Pcoq.Vernac_.command; msgnl (str "Entry syntax is"); - entry_print Pcoq.Vernac_.syntax; + Gram.entry_print Pcoq.Vernac_.syntax; msgnl (str "Entry gallina is"); - entry_print Pcoq.Vernac_.gallina; + Gram.entry_print Pcoq.Vernac_.gallina; msgnl (str "Entry gallina_ext is"); - entry_print Pcoq.Vernac_.gallina_ext; + Gram.entry_print Pcoq.Vernac_.gallina_ext; | _ -> error "Unknown or unprintable grammar entry." (**********************************************************************) @@ -233,7 +238,7 @@ let parse_format (loc,str) = else error "Empty format." with e -> - Stdpp.raise_with_loc loc e + Loc.raise loc e (***********************) (* Analyzing notations *) @@ -279,9 +284,9 @@ let rec find_pattern nt xl = function find_pattern nt (x::xl) (l,l') | [], NonTerminal x' :: l' -> (out_nt nt,x',List.rev xl),l' - | [], Terminal s :: _ | Terminal s :: _, _ -> + | _, Terminal s :: _ | Terminal s :: _, _ -> error ("The token \""^s^"\" occurs on one side of \"..\" but not on the other side.") - | [], Break s :: _ | Break s :: _, _ -> + | _, Break s :: _ | Break s :: _, _ -> error ("A break occurs on one side of \"..\" but not on the other side.") | _, [] -> error ("The special symbol \"..\" must occur in a configuration of the form\n\"x symbs .. symbs y\".") @@ -311,13 +316,10 @@ let rec interp_list_parser hd = function (* Find non-terminal tokens of notation *) -let is_normal_token str = - try let _ = Lexer.check_ident str in true with Lexer.Error _ -> false - (* To protect alphabetic tokens and quotes from being seen as variables *) let quote_notation_token x = let n = String.length x in - let norm = is_normal_token x in + let norm = is_ident x in if (n > 0 & norm) or (n > 2 & x.[0] = '\'') then "'"^x^"'" else x @@ -325,11 +327,9 @@ let rec raw_analyze_notation_tokens = function | [] -> [] | String ".." :: sl -> NonTerminal ldots_var :: raw_analyze_notation_tokens sl | String "_" :: _ -> error "_ must be quoted." - | String x :: sl when is_normal_token x -> - Lexer.check_ident x; + | String x :: sl when is_ident x -> NonTerminal (Names.id_of_string x) :: raw_analyze_notation_tokens sl | String s :: sl -> - Lexer.check_keyword s; Terminal (drop_simple_quotes s) :: raw_analyze_notation_tokens sl | WhiteSpace n :: sl -> Break n :: raw_analyze_notation_tokens sl @@ -363,11 +363,6 @@ let error_not_same_scope x y = error ("Variables "^string_of_id x^" and "^string_of_id y^ " must be in the same scope.") -let error_both_bound_and_binding x y = - errorlabstrm "" (strbrk "The recursive variables " ++ pr_id x ++ - strbrk " and " ++ pr_id y ++ strbrk " cannot be used as placeholder - for both terms and binders.") - (**********************************************************************) (* Build pretty-printing rules *) @@ -375,9 +370,9 @@ type printing_precedence = int * parenRelation type parsing_precedence = int option let prec_assoc = function - | Gramext.RightA -> (L,E) - | Gramext.LeftA -> (E,L) - | Gramext.NonA -> (L,L) + | RightA -> (L,E) + | LeftA -> (E,L) + | NonA -> (L,L) let precedence_of_entry_type from = function | ETConstr (NumLevel n,BorderProd (_,None)) -> n, Prec n @@ -403,12 +398,6 @@ let is_right_bracket s = let l = String.length s in l <> 0 & (s.[l-1] = '}' or s.[l-1] = ']' or s.[l-1] = ')') -let is_left_bracket_on_left s = - let l = String.length s in l <> 0 & s.[l-1] = '>' - -let is_right_bracket_on_right s = - let l = String.length s in l <> 0 & s.[0] = '<' - let is_comma s = let l = String.length s in l <> 0 & (s.[0] = ',' or s.[0] = ';') @@ -598,20 +587,20 @@ let is_not_small_constr = function | _ -> false let rec define_keywords_aux = function - | GramConstrNonTerminal(e,Some _) as n1 :: GramConstrTerminal("IDENT",k) :: l + | GramConstrNonTerminal(e,Some _) as n1 :: GramConstrTerminal(IDENT k) :: l when is_not_small_constr e -> - message ("Defining '"^k^"' as keyword"); - Lexer.add_token("",k); - n1 :: GramConstrTerminal("",k) :: define_keywords_aux l + message ("Identifier '"^k^"' now a keyword"); + Lexer.add_keyword k; + n1 :: GramConstrTerminal(KEYWORD k) :: define_keywords_aux l | n :: l -> n :: define_keywords_aux l | [] -> [] (* Ensure that IDENT articulation terminal symbols are keywords *) let define_keywords = function - | GramConstrTerminal("IDENT",k)::l -> - message ("Defining '"^k^"' as keyword"); - Lexer.add_token("",k); - GramConstrTerminal("",k) :: define_keywords_aux l + | GramConstrTerminal(IDENT k)::l -> + message ("Identifier '"^k^"' now a keyword"); + Lexer.add_keyword k; + GramConstrTerminal(KEYWORD k) :: define_keywords_aux l | l -> define_keywords_aux l let distribute a ll = List.map (fun l -> a @ l) ll @@ -673,9 +662,9 @@ let border = function let recompute_assoc typs = match border typs, border (List.rev typs) with - | Some Gramext.LeftA, Some Gramext.RightA -> assert false - | Some Gramext.LeftA, _ -> Some Gramext.LeftA - | _, Some Gramext.RightA -> Some Gramext.RightA + | Some LeftA, Some RightA -> assert false + | Some LeftA, _ -> Some LeftA + | _, Some RightA -> Some RightA | _ -> None (**************************************************************************) @@ -726,7 +715,13 @@ let subst_syntax_extension (subst,(local,sy)) = let classify_syntax_definition (local,_ as o) = if local then Dispose else Substitute o -let (inSyntaxExtension, outSyntaxExtension) = +type syntax_extension_obj = + bool * + (notation_var_internalization_type list * Notation.level * + notation * notation_grammar * unparsing list) + list + +let inSyntaxExtension : syntax_extension_obj -> obj = declare_object {(default_object "SYNTAX-EXTENSION") with open_function = (fun i o -> if i=1 then cache_syntax_extension o); cache_function = cache_syntax_extension; @@ -891,15 +886,17 @@ specially and require that the notation \"{ _ }\" is already reserved." (* Remove patterns of the form "{ _ }", unless it is the "{ _ }" notation *) let remove_curly_brackets l = - let rec next = function - | Break _ :: l -> next l - | l -> l in + let rec skip_break acc = function + | Break _ as br :: l -> skip_break (br::acc) l + | l -> List.rev acc, l in let rec aux deb = function | [] -> [] | Terminal "{" as t1 :: l -> - (match next l with + let br,next = skip_break [] l in + (match next with | NonTerminal _ as x :: l' as l0 -> - (match next l' with + let br',next' = skip_break [] l' in + (match next' with | Terminal "}" as t2 :: l'' as l1 -> if l <> l0 or l' <> l1 then warning "Skipping spaces inside curly brackets"; @@ -907,15 +904,14 @@ let remove_curly_brackets l = check_curly_brackets_notation_exists (); x :: aux false l'' end - | l1 -> t1 :: x :: aux false l1) + | l1 -> t1 :: br @ x :: br' @ aux false l1) | l0 -> t1 :: aux false l0) | x :: l -> x :: aux false l in aux true l let compute_syntax_data (df,modifiers) = let (assoc,n,etyps,onlyparse,fmt) = interp_modifiers modifiers in - (* Notation defaults to NONA *) - let assoc = match assoc with None -> Some Gramext.NonA | a -> a in + let assoc = match assoc with None -> (* default *) Some NonA | a -> a in let toks = split_notation_string df in let (recvars,mainvars,symbols) = analyze_notation_tokens toks in let ntn_for_interp = make_notation_key symbols in @@ -977,7 +973,11 @@ let subst_notation (subst,(lc,scope,pat,b,ndf)) = let classify_notation (local,_,_,_,_ as o) = if local then Dispose else Substitute o -let (inNotation, outNotation) = +type notation_obj = + bool * scope_name option * interpretation * bool * + (notation * notation_location) + +let inNotation : notation_obj -> obj = declare_object {(default_object "NOTATION") with open_function = open_notation; cache_function = cache_notation; @@ -1153,7 +1153,7 @@ let subst_scope_command (subst,(scope,o as x)) = match o with scope, ScopeClasses cl' | _ -> x -let (inScopeCommand,outScopeCommand) = +let inScopeCommand : scope_name * scope_command -> obj = declare_object {(default_object "DELIMITERS") with cache_function = cache_scope_command; open_function = open_scope_command; diff --git a/toplevel/metasyntax.mli b/toplevel/metasyntax.mli index 2c4e29bb..4ee1310a 100644 --- a/toplevel/metasyntax.mli +++ b/toplevel/metasyntax.mli @@ -1,14 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* unit -(* Adding a tactic notation in the environment *) +(** Adding a tactic notation in the environment *) val add_tactic_notation : int * grammar_tactic_prod_item_expr list * raw_tactic_expr -> unit -(* Adding a (constr) notation in the environment*) +(** Adding a (constr) notation in the environment*) val add_infix : locality_flag -> (lstring * syntax_modifier list) -> constr_expr -> scope_name option -> unit @@ -35,32 +31,32 @@ val add_infix : locality_flag -> (lstring * syntax_modifier list) -> val add_notation : locality_flag -> constr_expr -> (lstring * syntax_modifier list) -> scope_name option -> unit -(* Declaring delimiter keys and default scopes *) +(** Declaring delimiter keys and default scopes *) val add_delimiters : scope_name -> string -> unit val add_class_scope : scope_name -> Classops.cl_typ -> unit -(* Add only the interpretation of a notation that already has pa/pp rules *) +(** Add only the interpretation of a notation that already has pa/pp rules *) val add_notation_interpretation : (lstring * constr_expr * scope_name option) -> unit -(* Add a notation interpretation for supporting the "where" clause *) +(** Add a notation interpretation for supporting the "where" clause *) val set_notation_for_interpretation : Constrintern.internalization_env -> (lstring * constr_expr * scope_name option) -> unit -(* Add only the parsing/printing rule of a notation *) +(** Add only the parsing/printing rule of a notation *) val add_syntax_extension : locality_flag -> (lstring * syntax_modifier list) -> unit -(* Add a syntactic definition (as in "Notation f := ...") *) +(** Add a syntactic definition (as in "Notation f := ...") *) val add_syntactic_definition : identifier -> identifier list * constr_expr -> bool -> bool -> unit -(* Print the Camlp4 state of a grammar *) +(** Print the Camlp4 state of a grammar *) val print_grammar : string -> unit diff --git a/toplevel/mltop.ml4 b/toplevel/mltop.ml4 index 59bc01d0..ff3ce8a0 100644 --- a/toplevel/mltop.ml4 +++ b/toplevel/mltop.ml4 @@ -1,18 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* () (* For Rec Add ML Path *) -let add_rec_ml_dir dir = - List.iter (fun (lp,_) -> add_ml_dir lp) (all_subdirs dir) +let add_rec_ml_dir unix_path = + List.iter (fun (lp,_) -> add_ml_dir lp) (all_subdirs ~unix_path) (* Adding files to Coq and ML loadpath *) @@ -150,24 +143,24 @@ let add_path ~unix_path:dir ~coq_root:coq_dirpath = let convert_string d = try Names.id_of_string d with _ -> - if_verbose warning - ("Directory "^d^" cannot be used as a Coq identifier (skipped)"); + if_warn msg_warning + (str ("Directory "^d^" cannot be used as a Coq identifier (skipped)")); flush_all (); failwith "caught" -let add_rec_path ~unix_path:dir ~coq_root:coq_dirpath = - if exists_dir dir then - let dirs = all_subdirs dir in - let prefix = Names.repr_dirpath coq_dirpath in +let add_rec_path ~unix_path ~coq_root = + if exists_dir unix_path then + let dirs = all_subdirs ~unix_path in + let prefix = Names.repr_dirpath coq_root in let convert_dirs (lp,cp) = (lp,Names.make_dirpath (List.map convert_string (List.rev cp)@prefix)) in let dirs = map_succeed convert_dirs dirs in List.iter (fun lpe -> add_ml_dir (fst lpe)) dirs; - add_ml_dir dir; + add_ml_dir unix_path; List.iter (Library.add_load_path false) dirs; - Library.add_load_path true (dir,coq_dirpath) + Library.add_load_path true (unix_path, coq_root) else - msg_warning (str ("Cannot open " ^ dir)) + msg_warning (str ("Cannot open " ^ unix_path)) (* convertit un nom quelconque en nom de fichier ou de module *) let mod_of_name name = @@ -224,8 +217,6 @@ let file_of_name name = coqtop could always load plugins, we prefer to have uniformity between bytecode and native versions. *) -let stdlib_use_plugins = Coq_config.has_natdynlink - (* [known_loaded_module] contains the names of the loaded ML modules * (linked or loaded with load_object). It is used not to load a * module twice. It is NOT the list of ML modules Coq knows. *) @@ -244,7 +235,7 @@ let add_known_module mname = let module_is_known mname = Stringset.mem (String.capitalize mname) !known_loaded_modules -let load_object mname fname= +let load_ml_object mname fname= dir_ml_load fname; add_known_module mname @@ -266,7 +257,7 @@ let unfreeze_ml_modules x = if not (module_is_known mname) then if has_dynlink then let fname = file_of_name mname in - load_object mname fname + load_ml_object mname fname else errorlabstrm "Mltop.unfreeze_ml_modules" (str"Loading of ML object file forbidden in a native Coq."); @@ -291,7 +282,7 @@ let cache_ml_module_object (_,{mnames=mnames}) = try if_verbose msg (str"[Loading ML file " ++ str fname ++ str" ..."); - load_object mname fname; + load_ml_object mname fname; if_verbose msgnl (str" done]"); add_loaded_module mname with e -> @@ -305,7 +296,7 @@ let cache_ml_module_object (_,{mnames=mnames}) = let classify_ml_module_object ({mlocal=mlocal} as o) = if mlocal then Dispose else Substitute o -let (inMLModule,outMLModule) = +let inMLModule : ml_module_object -> obj = declare_object {(default_object "ML-MODULE") with load_function = (fun _ -> cache_ml_module_object); cache_function = cache_ml_module_object; diff --git a/toplevel/mltop.mli b/toplevel/mltop.mli index ae562bd2..1e9c3b03 100644 --- a/toplevel/mltop.mli +++ b/toplevel/mltop.mli @@ -1,14 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* unit; @@ -16,44 +14,44 @@ type toplevel = { add_dir : string -> unit; ml_loop : unit -> unit } -(* Sets and initializes a toplevel (if any) *) +(** Sets and initializes a toplevel (if any) *) val set_top : toplevel -> unit -(* Are we in a native version of Coq? *) +(** Are we in a native version of Coq? *) val is_native : bool -(* Removes the toplevel (if any) *) +(** Removes the toplevel (if any) *) val remove : unit -> unit -(* Tests if an Ocaml toplevel runs under Coq *) +(** Tests if an Ocaml toplevel runs under Coq *) val is_ocaml_top : unit -> bool -(* Tests if we can load ML files *) +(** Tests if we can load ML files *) val has_dynlink : bool -(* Starts the Ocaml toplevel loop *) +(** Starts the Ocaml toplevel loop *) val ocaml_toploop : unit -> unit -(* Dynamic loading of .cmo *) +(** Dynamic loading of .cmo *) val dir_ml_load : string -> unit -(* Dynamic interpretation of .ml *) +(** Dynamic interpretation of .ml *) val dir_ml_use : string -> unit -(* Adds a path to the ML paths *) +(** Adds a path to the ML paths *) val add_ml_dir : string -> unit val add_rec_ml_dir : string -> unit -(* Adds a path to the Coq and ML paths *) +(** Adds a path to the Coq and ML paths *) val add_path : unix_path:string -> coq_root:Names.dir_path -> unit val add_rec_path : unix_path:string -> coq_root:Names.dir_path -> unit -(* List of modules linked to the toplevel *) +(** List of modules linked to the toplevel *) val add_known_module : string -> unit val module_is_known : string -> bool -val load_object : string -> string -> unit +val load_ml_object : string -> string -> unit -(* Summary of Declared ML Modules *) +(** Summary of Declared ML Modules *) val get_loaded_modules : unit -> string list val add_loaded_module : string -> unit val init_ml_modules : unit -> unit @@ -63,8 +61,6 @@ type ml_module_object = { mlocal: Vernacexpr.locality_flag; mnames: string list; } -val inMLModule : ml_module_object -> Libobject.obj -val outMLModule : Libobject.obj -> ml_module_object val declare_ml_modules : Vernacexpr.locality_flag -> string list -> unit diff --git a/toplevel/record.ml b/toplevel/record.ml index ee9b8d66..86849cbb 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -1,20 +1,17 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* let impl, t' = interp_evars evars env impls Pretyping.IsType t in @@ -44,12 +41,12 @@ let interp_fields_evars evars env nots l = let impls = match i with | Anonymous -> impls - | Name id -> (id, compute_internalization_data env Constrintern.Method t' impl) :: impls + | Name id -> Idmap.add id (compute_internalization_data env Constrintern.Method t' impl) impls in let d = (i,b',t') in List.iter (Metasyntax.set_notation_for_interpretation impls) no; (push_rel d env, impl :: uimpls, d::params, impls)) - (env, [], [], []) nots l + (env, [], [], impls_env) nots l let binder_of_decl = function | Vernacexpr.AssumExpr(n,t) -> (n,None,t) @@ -60,11 +57,23 @@ let binders_of_decls = List.map binder_of_decl let typecheck_params_and_fields id t ps nots fs = let env0 = Global.env () in let evars = ref Evd.empty in - let (env1,newps), imps = interp_context_evars evars env0 ps in - let fullarity = it_mkProd_or_LetIn (Option.cata (fun x -> x) (new_Type ()) t) newps in + let _ = + let error bk (loc, name) = + match bk with + | Default _ -> + if name = Anonymous then + user_err_loc (loc, "record", str "Record parameters must be named") + | _ -> () + in + List.iter + (function LocalRawDef (b, _) -> error default_binder_kind b + | LocalRawAssum (ls, bk, ce) -> List.iter (error bk) ls) ps + in + let impls_env, ((env1,newps), imps) = interp_context_evars evars env0 ps in + let fullarity = it_mkProd_or_LetIn (Option.cata (fun x -> x) (Termops.new_Type ()) t) newps in let env_ar = push_rel_context newps (push_rel (Name id,None,fullarity) env0) in let env2,impls,newfs,data = - interp_fields_evars evars env_ar nots (binders_of_decls fs) + interp_fields_evars evars env_ar impls_env nots (binders_of_decls fs) in let evars = Evarconv.consider_remaining_unif_problems env_ar !evars in let evars = Typeclasses.resolve_typeclasses env_ar evars in @@ -153,7 +162,7 @@ let subst_projection fid l c = let instantiate_possibly_recursive_type indsp paramdecls fields = let subst = list_map_i (fun i _ -> mkRel i) 1 paramdecls in - substl_rel_context (subst@[mkInd indsp]) fields + Termops.substl_rel_context (subst@[mkInd indsp]) fields (* We build projections *) let declare_projections indsp ?(kind=StructureComponent) ?name coers fieldimpls fields = @@ -161,11 +170,11 @@ let declare_projections indsp ?(kind=StructureComponent) ?name coers fieldimpls let (mib,mip) = Global.lookup_inductive indsp in let paramdecls = mib.mind_params_ctxt in let r = mkInd indsp in - let rp = applist (r, extended_rel_list 0 paramdecls) in - let paramargs = extended_rel_list 1 paramdecls in (*def in [[params;x:rp]]*) + let rp = applist (r, Termops.extended_rel_list 0 paramdecls) in + let paramargs = Termops.extended_rel_list 1 paramdecls in (*def in [[params;x:rp]]*) let x = match name with Some n -> Name n | None -> Namegen.named_hd (Global.env()) r Anonymous in let fields = instantiate_possibly_recursive_type indsp paramdecls fields in - let lifted_fields = lift_rel_context 1 fields in + let lifted_fields = Termops.lift_rel_context 1 fields in let (_,kinds,sp_projs,_) = list_fold_left3 (fun (nfi,kinds,sp_projs,subst) coe (fi,optci,ti) impls -> @@ -194,11 +203,11 @@ let declare_projections indsp ?(kind=StructureComponent) ?name coers fieldimpls try let cie = { const_entry_body = proj; + const_entry_secctx = None; const_entry_type = Some projtyp; - const_entry_opaque = false; - const_entry_boxed = Flags.boxed_definitions() } in + const_entry_opaque = false } in let k = (DefinitionEntry cie,IsDefinition kind) in - let kn = declare_internal_constant fid k in + let kn = declare_constant ~internal:KernelSilent fid k in Flags.if_verbose message (string_of_id fid ^" is defined"); kn with Type_errors.TypeError (ctx,te) -> @@ -208,7 +217,7 @@ let declare_projections indsp ?(kind=StructureComponent) ?name coers fieldimpls Impargs.maybe_declare_manual_implicits false refi impls; if coe then begin let cl = Class.class_of_global (IndRef indsp) in - Class.try_add_new_coercion_with_source refi Global cl + Class.try_add_new_coercion_with_source refi Global ~source:cl end; let proj_args = (*Rel 1 refers to "x"*) paramargs@[mkRel 1] in let constr_fip = applist (constr_fi,proj_args) in @@ -239,7 +248,7 @@ open Typeclasses let declare_structure finite infer id idbuild paramimpls params arity fieldimpls fields ?(kind=StructureComponent) ?name is_coe coers sign = let nparams = List.length params and nfields = List.length fields in - let args = extended_rel_list nfields params in + let args = Termops.extended_rel_list nfields params in let ind = applist (mkRel (1+nparams+nfields), args) in let type_constructor = it_mkProd_or_LetIn ind fields in let mie_ind = @@ -253,7 +262,7 @@ let declare_structure finite infer id idbuild paramimpls params arity fieldimpls (* there is probably a way to push this to "declare_mutual" *) begin match finite with | BiFinite -> - if dependent (mkRel (nparams+1)) (it_mkProd_or_LetIn mkProp fields) then + if Termops.dependent (mkRel (nparams+1)) (it_mkProd_or_LetIn mkProp fields) then error "Records declared with the keyword Record or Structure cannot be recursive. Maybe you meant to define an Inductive or CoInductive record." | _ -> () end; @@ -282,18 +291,15 @@ let implicits_of_context ctx = in ExplByPos (i, explname), (true, true, true)) 1 (List.rev (Anonymous :: (List.map pi1 ctx))) -let qualid_of_con c = - Qualid (dummy_loc, shortest_qualid_of_global Idset.empty (ConstRef c)) - -let declare_instance_cst glob con = +let declare_instance_cst glob con pri = let instance = Typeops.type_of_constant (Global.env ()) con in let _, r = decompose_prod_assum instance in match class_of_constr r with - | Some tc -> add_instance (new_instance tc None glob (ConstRef con)) + | Some (_, (tc, _)) -> add_instance (new_instance tc pri glob (ConstRef con)) | None -> errorlabstrm "" (Pp.strbrk "Constant does not build instances of a declared type class.") let declare_class finite def infer id idbuild paramimpls params arity fieldimpls fields - ?(kind=StructureComponent) ?name is_coe coers sign = + ?(kind=StructureComponent) ?name is_coe coers priorities sign = let fieldimpls = (* Make the class and all params implicits in the projections *) let ctx_impls = implicits_of_context params in @@ -307,21 +313,21 @@ let declare_class finite def infer id idbuild paramimpls params arity fieldimpls let class_type = Option.map (fun ar -> it_mkProd_or_LetIn ar params) arity in let class_entry = { const_entry_body = class_body; + const_entry_secctx = None; const_entry_type = class_type; - const_entry_opaque = false; - const_entry_boxed = false } + const_entry_opaque = false } in let cst = Declare.declare_constant (snd id) (DefinitionEntry class_entry, IsDefinition Definition) in - let inst_type = appvectc (mkConst cst) (rel_vect 0 (List.length params)) in + let inst_type = appvectc (mkConst cst) (Termops.rel_vect 0 (List.length params)) in let proj_type = it_mkProd_or_LetIn (mkProd(Name (snd id), inst_type, lift 1 field)) params in let proj_body = it_mkLambda_or_LetIn (mkLambda (Name (snd id), inst_type, mkRel 1)) params in let proj_entry = { const_entry_body = proj_body; + const_entry_secctx = None; const_entry_type = Some proj_type; - const_entry_opaque = false; - const_entry_boxed = false } + const_entry_opaque = false } in let proj_cst = Declare.declare_constant proj_name (DefinitionEntry proj_entry, IsDefinition Definition) @@ -329,22 +335,27 @@ let declare_class finite def infer id idbuild paramimpls params arity fieldimpls let cref = ConstRef cst in Impargs.declare_manual_implicits false cref [paramimpls]; Impargs.declare_manual_implicits false (ConstRef proj_cst) [List.hd fieldimpls]; - Classes.set_typeclass_transparency (EvalConstRef cst) false; + Classes.set_typeclass_transparency (EvalConstRef cst) false false; if infer then Evd.fold (fun ev evi _ -> Recordops.declare_method (ConstRef cst) ev sign) sign (); - cref, [proj_name, Some proj_cst] + let sub = match List.hd coers with Some b -> Some ((if b then Backward else Forward), List.hd priorities) | None -> None in + cref, [Name proj_name, sub, Some proj_cst] | _ -> - let idarg = Namegen.next_ident_away (snd id) (ids_of_context (Global.env())) in + let idarg = Namegen.next_ident_away (snd id) (Termops.ids_of_context (Global.env())) in let ind = declare_structure BiFinite infer (snd id) idbuild paramimpls - params (Option.cata (fun x -> x) (new_Type ()) arity) fieldimpls fields + params (Option.default (Termops.new_Type ()) arity) fieldimpls fields ~kind:Method ~name:idarg false (List.map (fun _ -> false) fields) sign in - IndRef ind, (List.map2 (fun (id, _, _) y -> (Nameops.out_name id, y)) - (List.rev fields) (Recordops.lookup_projections ind)) + let coers = List.map2 (fun coe pri -> + Option.map (fun b -> if b then Backward, pri else Forward, pri) coe) + coers priorities + in + IndRef ind, (list_map3 (fun (id, _, _) b y -> (id, b, y)) + (List.rev fields) coers (Recordops.lookup_projections ind)) in let ctx_context = List.map (fun (na, b, t) -> match Typeclasses.class_of_constr t with - | Some cl -> Some (cl.cl_impl, true) (*List.exists (fun (_, n) -> n = na) supnames)*) + | Some (_, (cl, _)) -> Some (cl.cl_impl, true) (*List.exists (fun (_, n) -> n = na) supnames)*) | None -> None) params, params in @@ -354,9 +365,9 @@ let declare_class finite def infer id idbuild paramimpls params arity fieldimpls cl_props = fields; cl_projs = projs } in - List.iter2 (fun p sub -> - if sub then match snd p with Some p -> declare_instance_cst true p | None -> ()) - k.cl_projs coers; +(* list_iter3 (fun p sub pri -> *) +(* if sub then match p with (_, _, Some p) -> declare_instance_cst true p pri | _ -> ()) *) +(* k.cl_projs coers priorities; *) add_class k; impl let interp_and_check_sort sort = @@ -369,10 +380,12 @@ let interp_and_check_sort sort = open Vernacexpr open Autoinstance -(* [fs] corresponds to fields and [ps] to parameters; [coers] is a boolean - list telling if the corresponding fields must me declared as coercion *) +(* [fs] corresponds to fields and [ps] to parameters; [coers] is a + list telling if the corresponding fields must me declared as coercions + or subinstances *) let definition_structure (kind,finite,infer,(is_coe,(loc,idstruc)),ps,cfs,idbuild,s) = let cfs,notations = List.split cfs in + let cfs,priorities = List.split cfs in let coers,fs = List.split cfs in let extract_name acc = function Vernacexpr.AssumExpr((_,Name id),_) -> id::acc @@ -380,6 +393,8 @@ let definition_structure (kind,finite,infer,(is_coe,(loc,idstruc)),ps,cfs,idbuil | _ -> acc in let allnames = idstruc::(List.fold_left extract_name [] fs) in if not (list_distinct allnames) then error "Two objects have the same name"; + if not (kind = Class false) && List.exists ((<>) None) priorities then + error "Priorities only allowed for type class substructures"; (* Now, younger decl in params and fields is on top *) let sc = interp_and_check_sort s in let implpars, params, implfs, fields = @@ -389,13 +404,14 @@ let definition_structure (kind,finite,infer,(is_coe,(loc,idstruc)),ps,cfs,idbuil match kind with | Class def -> let gr = declare_class finite def infer (loc,idstruc) idbuild - implpars params sc implfs fields is_coe coers sign in + implpars params sc implfs fields is_coe coers priorities sign in if infer then search_record declare_class_instance gr sign; gr | _ -> - let arity = Option.default (new_Type ()) sc in + let arity = Option.default (Termops.new_Type ()) sc in let implfs = List.map (fun impls -> implpars @ Impargs.lift_implicits (succ (List.length params)) impls) implfs in - let ind = declare_structure finite infer idstruc idbuild implpars params arity implfs fields is_coe coers sign in + let ind = declare_structure finite infer idstruc idbuild implpars params arity implfs + fields is_coe (List.map (fun coe -> coe <> None) coers) sign in if infer then search_record declare_record_instance (ConstructRef (ind,1)) sign; IndRef ind diff --git a/toplevel/record.mli b/toplevel/record.mli index 44b34550..45670f1f 100644 --- a/toplevel/record.mli +++ b/toplevel/record.mli @@ -1,14 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* ?kind:Decl_kinds.definition_object_kind -> ?name:identifier -> - bool list -> manual_explicitation list list -> rel_context -> + coercion_flag list -> manual_explicitation list list -> rel_context -> (name * bool) list * constant option list val declare_structure : Decl_kinds.recursivity_kind -> - bool (*infer?*) -> identifier -> identifier -> - manual_explicitation list -> rel_context -> (* params *) constr -> (* arity *) - Impargs.manual_explicitation list list -> rel_context -> (* fields *) + bool (**infer?*) -> identifier -> identifier -> + manual_explicitation list -> rel_context -> (** params *) constr -> (** arity *) + Impargs.manual_explicitation list list -> rel_context -> (** fields *) ?kind:Decl_kinds.definition_object_kind -> ?name:identifier -> - bool -> (* coercion? *) - bool list -> (* field coercions *) + bool -> (** coercion? *) + bool list -> (** field coercions *) Evd.evar_map -> inductive val definition_structure : - inductive_kind * Decl_kinds.recursivity_kind * bool(*infer?*)* lident with_coercion * local_binder list * - (local_decl_expr with_coercion with_notation) list * + inductive_kind * Decl_kinds.recursivity_kind * bool(**infer?*)* lident with_coercion * local_binder list * + (local_decl_expr with_instance with_priority with_notation) list * identifier * constr_expr option -> global_reference diff --git a/toplevel/search.ml b/toplevel/search.ml index fd3024a4..33e8e51d 100644 --- a/toplevel/search.ml +++ b/toplevel/search.ml @@ -1,19 +1,17 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* env -> constr -> unit) = fn (VarRef id) env typ with Not_found -> (* we are in a section *) ()) | "CONSTANT" -> - let cst = Global.constant_of_delta(constant_of_kn kn) in + let cst = Global.constant_of_delta_kn kn in let typ = Typeops.type_of_constant env cst in if refopt = None || head_const typ = constr_of_global (Option.get refopt) then fn (ConstRef cst) env typ | "INDUCTIVE" -> - let mind = Global.mind_of_delta(mind_of_kn kn) in + let mind = Global.mind_of_delta_kn kn in let mib = Global.lookup_mind mind in (match refopt with | Some (IndRef ((kn',tyi) as ind)) when eq_mind mind kn' -> @@ -95,10 +103,6 @@ let rec head c = | LetIn (_,_,_,c) -> head c | _ -> c -let constr_to_full_path c = match kind_of_term c with - | Const sp -> sp - | _ -> raise No_full_path - let xor a b = (a or b) & (not (a & b)) let plain_display ref a c = @@ -170,6 +174,10 @@ let raw_search_by_head extra_filter display_function pattern = let name_of_reference ref = string_of_id (basename_of_global ref) +let full_name_of_reference ref = + let (dir,id) = repr_path (path_of_global ref) in + string_of_dirpath dir ^ "." ^ string_of_id id + (* * functions to use the new Libtypes facility *) @@ -196,20 +204,21 @@ let filter_by_module_from_list = function | [], _ -> (fun _ _ _ -> true) | l, outside -> filter_by_module l (not outside) -let filter_subproof gr _ _ = - not (string_string_contains (name_of_reference gr) "_subproof") && - not (string_string_contains (name_of_reference gr) "_admitted") +let filter_blacklist gr _ _ = + let name = full_name_of_reference gr in + let l = SearchBlacklist.elements () in + List.for_all (fun str -> not (string_string_contains ~where:name ~what:str)) l let (&&&&&) f g x y z = f x y z && g x y z let search_by_head pat inout = - text_search_by_head (filter_by_module_from_list inout &&&&& filter_subproof) pat + text_search_by_head (filter_by_module_from_list inout &&&&& filter_blacklist) pat let search_rewrite pat inout = - text_search_rewrite (filter_by_module_from_list inout &&&&& filter_subproof) pat + text_search_rewrite (filter_by_module_from_list inout &&&&& filter_blacklist) pat let search_pattern pat inout = - text_pattern_search (filter_by_module_from_list inout &&&&& filter_subproof) pat + text_pattern_search (filter_by_module_from_list inout &&&&& filter_blacklist) pat let gen_filtered_search filter_function display_function = gen_crible None @@ -223,13 +232,13 @@ type glob_search_about_item = let search_about_item (itemref,typ) = function | GlobSearchSubPattern pat -> is_matching_appsubterm ~closed:false pat typ - | GlobSearchString s -> string_string_contains (name_of_reference itemref) s + | GlobSearchString s -> string_string_contains ~where:(name_of_reference itemref) ~what:s let raw_search_about filter_modules display_function l = let filter ref' env typ = filter_modules ref' env typ && List.for_all (fun (b,i) -> b = search_about_item (ref',typ) i) l && - filter_subproof ref' () () + filter_blacklist ref' () () in gen_filtered_search filter display_function diff --git a/toplevel/search.mli b/toplevel/search.mli index 6a85a12f..d2d5c538 100644 --- a/toplevel/search.mli +++ b/toplevel/search.mli @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* dir_path list * bool -> unit val search_about : (bool * glob_search_about_item) list -> dir_path list * bool -> unit -(* The filtering function that is by standard search facilities. +(** The filtering function that is by standard search facilities. It can be passed as argument to the raw search functions. It is used in pcoq. *) val filter_by_module_from_list : dir_path list * bool -> global_reference -> env -> 'a -> bool -(* raw search functions can be used for various extensions. +(** raw search functions can be used for various extensions. They are also used for pcoq. *) val gen_filtered_search : (global_reference -> env -> constr -> bool) -> (global_reference -> env -> constr -> unit) -> unit diff --git a/toplevel/toplevel.ml b/toplevel/toplevel.ml index 9954ff56..699fd12f 100644 --- a/toplevel/toplevel.ml +++ b/toplevel/toplevel.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* () -(* emacs special character for prompt end (fast) detection. Prefer - (Char.chr 6) since it does not interfere with utf8. For - compatibility we let (Char.chr 249) as default for a while. *) +(* emacs special prompt tag for easy detection. No special character, + to avoid interfering with utf8. Compatibility code removed. *) -let emacs_prompt_startstring() = Printer.emacs_str "" "" +let emacs_prompt_startstring() = Printer.emacs_str "" -let emacs_prompt_endstring() = Printer.emacs_str (String.make 1 (Char.chr 249)) "" +let emacs_prompt_endstring() = Printer.emacs_str "" (* Read a char in an input channel, displaying a prompt at every beginning of line. *) @@ -165,26 +163,26 @@ let print_location_in_file s inlibrary fname loc = hov 0 (errstrm ++ str"Module " ++ str ("\""^fname^"\"") ++ spc() ++ str"characters " ++ Cerrors.print_loc loc) ++ fnl () else - let (bp,ep) = unloc loc in - let ic = open_in fname in - let rec line_of_pos lin bol cnt = - if cnt < bp then - if input_char ic == '\n' - then line_of_pos (lin + 1) (cnt +1) (cnt+1) - else line_of_pos lin bol (cnt+1) - else (lin, bol) - in - try - let (line, bol) = line_of_pos 1 0 0 in - close_in ic; - hov 0 (* No line break so as to follow emacs error message format *) - (errstrm ++ str"File " ++ str ("\""^fname^"\"") ++ - str", line " ++ int line ++ str", characters " ++ - Cerrors.print_loc (make_loc (bp-bol,ep-bol))) ++ str":" ++ - fnl () - with e -> - (close_in ic; - hov 1 (errstrm ++ spc() ++ str"(invalid location):") ++ fnl ()) + let (bp,ep) = unloc loc in + let ic = open_in fname in + let rec line_of_pos lin bol cnt = + if cnt < bp then + if input_char ic == '\n' + then line_of_pos (lin + 1) (cnt +1) (cnt+1) + else line_of_pos lin bol (cnt+1) + else (lin, bol) + in + try + let (line, bol) = line_of_pos 1 0 0 in + close_in ic; + hov 0 (* No line break so as to follow emacs error message format *) + (errstrm ++ str"File " ++ str ("\""^fname^"\"") ++ + str", line " ++ int line ++ str", characters " ++ + Cerrors.print_loc (make_loc (bp-bol,ep-bol))) ++ str":" ++ + fnl () + with e -> + (close_in ic; + hov 1 (errstrm ++ spc() ++ str"(invalid location):") ++ fnl ()) let print_command_location ib dloc = match dloc with @@ -274,7 +272,7 @@ let set_prompt prompt = let rec is_pervasive_exn = function | Out_of_memory | Stack_overflow | Sys.Break -> true | Error_in_file (_,_,e) -> is_pervasive_exn e - | Stdpp.Exc_located (_,e) -> is_pervasive_exn e + | Loc.Exc_located (_,e) -> is_pervasive_exn e | DuringCommandInterp (_,e) -> is_pervasive_exn e | _ -> false @@ -290,7 +288,7 @@ let print_toplevel_error exc = in let (locstrm,exc) = match exc with - | Stdpp.Exc_located (loc, ie) -> + | Loc.Exc_located (loc, ie) -> if valid_buffer_loc top_buffer dloc loc then (print_highlight_location top_buffer loc, ie) else @@ -310,13 +308,13 @@ let print_toplevel_error exc = raise Vernacexpr.Quit | _ -> (if is_pervasive_exn exc then (mt ()) else locstrm) ++ - Cerrors.explain_exn exc + Errors.print exc (* Read the input stream until a dot is encountered *) let parse_to_dot = - let rec dot st = match Stream.next st with - | ("", ".") -> () - | ("EOI", "") -> raise End_of_input + let rec dot st = match get_tok (Stream.next st) with + | Tok.KEYWORD "." -> () + | Tok.EOI -> raise End_of_input | _ -> dot st in Gram.Entry.of_parser "Coqtoplevel.dot" dot @@ -324,8 +322,8 @@ let parse_to_dot = (* We assume that when a lexer error occurs, at least one char was eaten *) let rec discard_to_dot () = try - Gram.Entry.parse parse_to_dot top_buffer.tokens - with Stdpp.Exc_located(_,(Token.Error _|Lexer.Error _)) -> + Gram.entry_parse parse_to_dot top_buffer.tokens + with Loc.Exc_located(_,(Token.Error _|Lexer.Error.E _)) -> discard_to_dot() diff --git a/toplevel/toplevel.mli b/toplevel/toplevel.mli index 022a6541..757aab1a 100644 --- a/toplevel/toplevel.mli +++ b/toplevel/toplevel.mli @@ -1,46 +1,42 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* string; - mutable str : string; (* buffer of already read characters *) - mutable len : int; (* number of chars in the buffer *) - mutable bols : int list; (* offsets in str of begining of lines *) - mutable tokens : Pcoq.Gram.parsable; (* stream of tokens *) - mutable start : int } (* stream count of the first char of the buffer *) + mutable str : string; (** buffer of already read characters *) + mutable len : int; (** number of chars in the buffer *) + mutable bols : int list; (** offsets in str of begining of lines *) + mutable tokens : Pcoq.Gram.parsable; (** stream of tokens *) + mutable start : int } (** stream count of the first char of the buffer *) -(* The input buffer of stdin. *) +(** The input buffer of stdin. *) val top_buffer : input_buffer val set_prompt : (unit -> string) -> unit -(* Toplevel error explanation, dealing with locations, Drop, Ctrl-D +(** Toplevel error explanation, dealing with locations, Drop, Ctrl-D May raise only the following exceptions: [Drop] and [End_of_input], meaning we get out of the Coq loop. *) val print_toplevel_error : exn -> std_ppcmds -(* Parse and execute a vernac command. *) +(** Parse and execute a vernac command. *) val do_vernac : unit -> unit -(* Main entry point of Coq: read and execute vernac commands. *) +(** Main entry point of Coq: read and execute vernac commands. *) val loop : unit -> unit diff --git a/toplevel/toplevel.mllib b/toplevel/toplevel.mllib index 4c229d16..8b03e938 100644 --- a/toplevel/toplevel.mllib +++ b/toplevel/toplevel.mllib @@ -18,6 +18,8 @@ Mltop Vernacentries Whelp Vernac +Ide_intf +Ide_slave Toplevel Usage Coqinit diff --git a/toplevel/usage.ml b/toplevel/usage.ml index 0282f30a..8c9b1078 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -1,18 +1,16 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* \n\n" let print_usage_coqc () = - print_usage "Usage: coqc file...\n -options are: - -verbose compile verbosely - -image f specify an alternative executable for Coq - -t keep temporary files\n\n" + print_usage "Usage: coqc file...\n\ +\noptions are:\ +\n -verbose compile verbosely\ +\n -image f specify an alternative executable for Coq\ +\n -t keep temporary files\n\n" (* Print the configuration information *) let print_config () = if Coq_config.local then Printf.printf "LOCAL=1\n" else Printf.printf "LOCAL=0\n"; - Printf.printf "COQLIB=%s/\n" Coq_config.coqlib; - Printf.printf "COQSRC=%s/\n" Coq_config.coqsrc; - Printf.printf "CAMLBIN=%s/\n" Coq_config.camlbin; - Printf.printf "CAMLLIB=%s/\n" Coq_config.camllib; + Printf.printf "COQLIB=%s/\n" (Envars.coqlib ()); + Printf.printf "DOCDIR=%s/\n" (Envars.docdir ()); + Printf.printf "OCAMLDEP=%s\n" Coq_config.ocamldep; + Printf.printf "OCAMLC=%s\n" Coq_config.ocamlc; + Printf.printf "OCAMLOPT=%s\n" Coq_config.ocamlopt; + Printf.printf "OCAMLDOC=%s\n" Coq_config.ocamldoc; + Printf.printf "CAMLBIN=%s/\n" (Envars.camlbin ()); + Printf.printf "CAMLLIB=%s/\n" (Envars.camllib ()); Printf.printf "CAMLP4=%s\n" Coq_config.camlp4; - Printf.printf "CAMLP4BIN=%s\n" Coq_config.camlp4bin; - Printf.printf "CAMLP4LIB=%s\n" Coq_config.camlp4lib - - + Printf.printf "CAMLP4BIN=%s/\n" (Envars.camlp4bin ()); + Printf.printf "CAMLP4LIB=%s\n" (Envars.camlp4lib ()); + Printf.printf "HASNATDYNLINK=%s\n" (if Coq_config.has_natdynlink then "true" else "false") diff --git a/toplevel/usage.mli b/toplevel/usage.mli index 721edccb..0b98f061 100644 --- a/toplevel/usage.mli +++ b/toplevel/usage.mli @@ -1,23 +1,21 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 'a -val version : unit -> 'a - -(*s Prints the usage on the error output, preceeded by a user-provided message. *) +(** {6 Prints the usage on the error output, preceeded by a user-provided message. } *) val print_usage : string -> unit -(*s Prints the usage on the error output. *) +(** {6 Prints the usage on the error output. } *) val print_usage_coqtop : unit -> unit val print_usage_coqc : unit -> unit -(*s Prints the configuration information *) +(** {6 Prints the configuration information } *) val print_config : unit -> unit diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index a7aef93f..84e20f5e 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* dummy_loc -> ((b, f, loc), e) - | Stdpp.Exc_located (loc, e) when loc <> dummy_loc -> + | Loc.Exc_located (loc, e) when loc <> dummy_loc -> ((false,file, loc), e) - | Stdpp.Exc_located (_, e) | e -> ((false,file,cmdloc), e) + | Loc.Exc_located (_, e) | e -> ((false,file,cmdloc), e) in raise (Error_in_file (file, inner, disable_drop inex)) let real_error = function - | Stdpp.Exc_located (_, e) -> e + | Loc.Exc_located (_, e) -> e | Error_in_file (_, _, e) -> e | e -> e @@ -62,6 +61,7 @@ let default_timeout = ref None let _ = Goptions.declare_int_option { Goptions.optsync = true; + Goptions.optdepr = false; Goptions.optname = "the default timeout"; Goptions.optkey = ["Default";"Timeout"]; Goptions.optread = (fun () -> !default_timeout); @@ -133,8 +133,8 @@ let verbose_phrase verbch loc = exception End_of_input -let parse_phrase (po, verbch) = - match Pcoq.Gram.Entry.parse Pcoq.main_entry po with +let parse_sentence (po, verbch) = + match Pcoq.Gram.entry_parse Pcoq.main_entry po with | Some (loc,_ as com) -> verbose_phrase verbch loc; com | None -> raise End_of_input @@ -211,10 +211,11 @@ let rec vernac_com interpfun (loc,com) = | HasNotFailed -> errorlabstrm "Fail" (str "The command has not failed !") | e -> - (* if [e] is an anomaly, the next function will re-raise it *) - let msg = Cerrors.explain_exn_no_anomaly e in - if_verbose msgnl (str "The command has indeed failed with message:" ++ - fnl () ++ str "=> " ++ hov 0 msg) + (* Anomalies are re-raised by the next line *) + let msg = Errors.print_no_anomaly e in + if_verbose msgnl + (str "The command has indeed failed with message:" ++ + fnl () ++ str "=> " ++ hov 0 msg) end | VernacTime v -> @@ -249,22 +250,21 @@ let rec vernac_com interpfun (loc,com) = Format.set_formatter_out_channel stdout; raise (DuringCommandInterp (loc, e)) -and vernac interpfun input = - vernac_com interpfun (parse_phrase input) - and read_vernac_file verbosely s = Flags.make_warn verbosely; let interpfun = - if verbosely then - Vernacentries.interp - else - Flags.silently Vernacentries.interp + if verbosely then Vernacentries.interp + else Flags.silently Vernacentries.interp in - let (in_chan, fname, input) = open_file_twice_if verbosely s in + let (in_chan, fname, input) = + open_file_twice_if verbosely s in try (* we go out of the following infinite loop when a End_of_input is * raised, which means that we raised the end of the file being loaded *) - while true do vernac interpfun input; pp_flush () done + while true do + vernac_com interpfun (parse_sentence input); + pp_flush () + done with e -> (* whatever the exception *) Format.set_formatter_out_channel stdout; close_input in_chan input; (* we must close the file first *) @@ -273,17 +273,20 @@ and read_vernac_file verbosely s = if do_beautify () then pr_new_syntax (make_loc (max_int,max_int)) None | _ -> raise_with_file fname e -(* raw_do_vernac : char Stream.t -> unit - * parses and executes one command of the vernacular char stream. - * Marks the end of the command in the lib_stk with a new label to - * make vernac undoing easier. Also freeze state to speed up - * backtracking. *) -let raw_do_vernac po = - vernac Vernacentries.interp (po,None); +(* eval_expr : Util.loc * Vernacexpr.vernac_expr -> unit + * execute one vernacular command. Marks the end of the command in the lib_stk + * with a new label to make vernac undoing easier. Also freeze state to speed up + * backtracking. *) +let eval_expr last = + vernac_com Vernacentries.interp last; Lib.add_frozen_state(); Lib.mark_end_of_command() +(* raw_do_vernac : Pcoq.Gram.parsable -> unit + * vernac_step . parse_sentence *) +let raw_do_vernac po = eval_expr (parse_sentence (po,None)) + (* XML output hooks *) let xml_start_library = ref (fun _ -> ()) let xml_end_library = ref (fun _ -> ()) @@ -305,15 +308,14 @@ let load_vernac verb file = (* Compile a vernac file (f is assumed without .v suffix) *) let compile verbosely f = let ldir,long_f_dot_v = Flags.verbosely Library.start_library f in - if Dumpglob.multi_dump () then - Dumpglob.open_glob_file (f ^ ".glob"); - Dumpglob.dump_string ("F" ^ Names.string_of_dirpath ldir ^ "\n"); - if !Flags.xml_export then !xml_start_library (); - let _ = load_vernac verbosely long_f_dot_v in - if Pfedit.get_all_proof_names () <> [] then - (message "Error: There are pending proofs"; exit 1); - if !Flags.xml_export then !xml_end_library (); - if Dumpglob.multi_dump () then Dumpglob.close_glob_file (); - Library.save_library_to ldir (long_f_dot_v ^ "o") + Dumpglob.start_dump_glob long_f_dot_v; + Dumpglob.dump_string ("F" ^ Names.string_of_dirpath ldir ^ "\n"); + if !Flags.xml_export then !xml_start_library (); + let _ = load_vernac verbosely long_f_dot_v in + if Pfedit.get_all_proof_names () <> [] then + (message "Error: There are pending proofs"; exit 1); + if !Flags.xml_export then !xml_end_library (); + Dumpglob.end_dump_glob (); + Library.save_library_to ldir (long_f_dot_v ^ "o") diff --git a/toplevel/vernac.mli b/toplevel/vernac.mli index 54ce9244..d89e90d0 100644 --- a/toplevel/vernac.mli +++ b/toplevel/vernac.mli @@ -1,46 +1,39 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* - Util.loc * Vernacexpr.vernac_expr +val parse_sentence : Pcoq.Gram.parsable * in_channel option -> + Util.loc * Vernacexpr.vernac_expr -(* Reads and executes vernac commands from a stream. +(** Reads and executes vernac commands from a stream. The boolean [just_parsing] disables interpretation of commands. *) exception DuringCommandInterp of Util.loc * exn exception End_of_input val just_parsing : bool ref +val eval_expr : Util.loc * Vernacexpr.vernac_expr -> unit val raw_do_vernac : Pcoq.Gram.parsable -> unit -(* Set XML hooks *) +(** Set XML hooks *) val set_xml_start_library : (unit -> unit) -> unit val set_xml_end_library : (unit -> unit) -> unit -(* Load a vernac file, verbosely or not. Errors are annotated with file +(** Load a vernac file, verbosely or not. Errors are annotated with file and location *) val load_vernac : bool -> string -> unit -(* Compile a vernac file, verbosely or not (f is assumed without .v suffix) *) +(** Compile a vernac file, verbosely or not (f is assumed without .v suffix) *) val compile : bool -> string -> unit - -(* Interpret a vernac AST *) - -val vernac_com : - (Vernacexpr.vernac_expr -> unit) -> - Util.loc * Vernacexpr.vernac_expr -> unit diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 3be3c6db..5787feb0 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Environ.unsafe_judgment -> unit; print_eval : Reductionops.reduction_function -> Environ.env -> Evd.evar_map -> constr_expr -> Environ.unsafe_judgment -> unit; - show_goal : int option -> unit + show_goal : goal_reference -> unit } let pcoq = ref None @@ -66,52 +62,34 @@ let cl_of_qualid = function (* "Show" commands *) let show_proof () = - let pts = get_pftreestate () in - let cursor = cursor_of_pftreestate pts in - let evc = evc_of_pftreestate pts in - let (pfterm,meta_types) = extract_open_pftreestate pts in - msgnl (str"LOC: " ++ - prlist_with_sep pr_spc pr_int (List.rev cursor) ++ fnl () ++ - str"Subgoals" ++ fnl () ++ - prlist (fun (mv,ty) -> Nameops.pr_meta mv ++ str" -> " ++ - pr_ltype ty ++ fnl ()) - meta_types - ++ str"Proof: " ++ pr_lconstr (Evarutil.nf_evar evc pfterm)) + (* spiwack: this would probably be cooler with a bit of polishing. *) + let p = Proof_global.give_me_the_proof () in + let pprf = Proof.partial_proof p in + msgnl (Util.prlist_with_sep Pp.fnl Printer.pr_constr pprf) let show_node () = - let pts = get_pftreestate () in - let pf = proof_of_pftreestate pts - and cursor = cursor_of_pftreestate pts in - msgnl (prlist_with_sep pr_spc pr_int (List.rev cursor) ++ fnl () ++ - pr_goal (goal_of_proof pf) ++ fnl () ++ - (match pf.Proof_type.ref with - | None -> (str"BY ") - | Some(r,spfl) -> - (str"BY " ++ pr_rule r ++ fnl () ++ - str" " ++ - hov 0 (prlist_with_sep pr_fnl pr_goal - (List.map goal_of_proof spfl))))) + (* spiwack: I'm have little clue what this function used to do. I deactivated it, + could, possibly, be cleaned away. (Feb. 2010) *) + () let show_script () = - let pts = get_pftreestate () in - let pf = proof_of_pftreestate pts - and evc = evc_of_pftreestate pts in - msgnl_with !Pp_control.deep_ft (print_treescript evc pf) + (* spiwack: show_script is currently not working *) + () let show_thesis () = msgnl (anomaly "TODO" ) let show_top_evars () = + (* spiwack: new as of Feb. 2010: shows goal evars in addition to non-goal evars. *) let pfts = get_pftreestate () in - let gls = top_goal_of_pftreestate pfts in - let sigma = project gls in + let gls = Proof.V82.subgoals pfts in + let sigma = gls.Evd.sigma in msg (pr_evars_int 1 (Evarutil.non_instantiated sigma)) + let show_prooftree () = - let pts = get_pftreestate () in - let pf = proof_of_pftreestate pts - and evc = evc_of_pftreestate pts in - msg (print_proof evc (Global.named_context()) pf) + (* Spiwack: proof tree is currently not working *) + () let print_subgoals () = if_verbose (fun () -> msg (pr_open_subgoals ())) () @@ -119,7 +97,8 @@ let print_subgoals () = if_verbose (fun () -> msg (pr_open_subgoals ())) () let show_intro all = let pf = get_pftreestate() in - let gl = nth_goal_of_pftreestate 1 pf in + let {Evd.it=gls ; sigma=sigma} = Proof.V82.subgoals pf in + let gl = {Evd.it=List.hd gls ; sigma = sigma} in let l,_= decompose_prod_assum (strip_outer_cast (pf_concl gl)) in if all then @@ -131,13 +110,12 @@ let show_intro all = msgnl (pr_id (List.hd (Tactics.find_intro_names [n] gl))) with Failure "list_last" -> message "" -let id_of_name = function - | Names.Anonymous -> id_of_string "x" - | Names.Name x -> x - +(** Prepare a "match" template for a given inductive type. + For each branch of the match, we list the constructor name + followed by enough pattern variables. + [Not_found] is raised if the given string isn't the qualid of + a known inductive type. *) -(* Building of match expression *) -(* From ide/coq.ml *) let make_cases s = let qualified_name = Libnames.qualid_of_string s in let glob_ref = Nametab.locate qualified_name in @@ -147,36 +125,31 @@ let make_cases s = , {Declarations.mind_consnames = carr ; Declarations.mind_nf_lc = tarr } = Global.lookup_inductive i in Util.array_fold_right2 - (fun n t l -> - let (al,_) = Term.decompose_prod t in - let al,_ = Util.list_chop (List.length al - np) al in + (fun consname typ l -> + let al = List.rev (fst (Term.decompose_prod typ)) in + let al = Util.list_skipn np al in let rec rename avoid = function | [] -> [] | (n,_)::l -> - let n' = Namegen.next_ident_away_in_goal (id_of_name n) avoid in + let n' = Namegen.next_name_away_in_cases_pattern n avoid in string_of_id n' :: rename (n'::avoid) l in - let al' = rename [] (List.rev al) in - (string_of_id n :: al') :: l) + let al' = rename [] al in + (string_of_id consname :: al') :: l) carr tarr [] | _ -> raise Not_found +(** Textual display of a generic "match" template *) let show_match id = - try - let s = string_of_id (snd id) in - let patterns = List.rev (make_cases s) in - let cases = - List.fold_left - (fun acc x -> - match x with - | [] -> assert false - | [x] -> "| "^ x ^ " => \n" ^ acc - | x::l -> - "| " ^ List.fold_left (fun acc s -> acc ^ " " ^ s) x l - ^ " => \n" ^ acc) - "end" patterns in - msg (str ("match # with\n" ^ cases)) - with Not_found -> error "Unknown inductive type." + let patterns = + try make_cases (string_of_id (snd id)) + with Not_found -> error "Unknown inductive type." + in + let pr_branch l = + str "| " ++ hov 1 (prlist_with_sep spc str l) ++ str " =>" + in + msg (v 1 (str "match # with" ++ fnl () ++ + prlist_with_sep fnl pr_branch patterns ++ fnl ())) (* "Print" commands *) @@ -220,18 +193,55 @@ let print_modtype r = let (loc,qid) = qualid_of_reference r in try let kn = Nametab.locate_modtype qid in - msgnl (Printmod.print_modtype kn) - with - Not_found -> msgnl (str"Unknown Module Type " ++ pr_qualid qid) + msgnl (Printmod.print_modtype kn) + with Not_found -> + (* Is there a module of this name ? If yes we display its type *) + try + let mp = Nametab.locate_module qid in + msgnl (Printmod.print_module false mp) + with Not_found -> + msgnl (str"Unknown Module Type or Module " ++ pr_qualid qid) -let dump_universes s = +let dump_universes_gen g s = let output = open_out s in + let output_constraint, close = + if Filename.check_suffix s ".dot" || Filename.check_suffix s ".gv" then begin + (* the lazy unit is to handle errors while printing the first line *) + let init = lazy (Printf.fprintf output "digraph universes {\n") in + begin fun kind left right -> + let () = Lazy.force init in + match kind with + | Univ.Lt -> + Printf.fprintf output " \"%s\" -> \"%s\" [style=bold];\n" right left + | Univ.Le -> + Printf.fprintf output " \"%s\" -> \"%s\" [style=solid];\n" right left + | Univ.Eq -> + Printf.fprintf output " \"%s\" -> \"%s\" [style=dashed];\n" left right + end, begin fun () -> + if Lazy.lazy_is_val init then Printf.fprintf output "}\n"; + close_out output + end + end else begin + begin fun kind left right -> + let kind = match kind with + | Univ.Lt -> "<" + | Univ.Le -> "<=" + | Univ.Eq -> "=" + in Printf.fprintf output "%s %s %s ;\n" left kind right + end, (fun () -> close_out output) + end + in try - Univ.dump_universes output (Global.universes ()); - close_out output; + Univ.dump_universes output_constraint g; + close (); msgnl (str ("Universes written to file \""^s^"\".")) with - e -> close_out output; raise e + e -> close (); raise e + +let dump_universes sorted s = + let g = Global.universes () in + let g = if sorted then Univ.sort_universes g else g in + dump_universes_gen g s (*********************) (* "Locate" commands *) @@ -318,7 +328,7 @@ let start_proof_and_print k l hook = print_subgoals (); if !pcoq <> None then (Option.get !pcoq).start_proof () -let vernac_definition (local,boxed,k) (loc,id as lid) def hook = +let vernac_definition (local,k) (loc,id as lid) def hook = if local = Local then Dumpglob.dump_definition lid true "var" else Dumpglob.dump_definition lid false "def"; (match def with @@ -332,7 +342,7 @@ let vernac_definition (local,boxed,k) (loc,id as lid) def hook = | Some r -> let (evc,env)= get_current_context () in Some (interp_redexp env evc r) in - let ce,imps = interp_definition boxed bl red_option c typ_opt in + let ce,imps = interp_definition bl red_option c typ_opt in declare_definition id (local,k) ce imps hook) let vernac_start_proof kind l lettop hook = @@ -360,14 +370,10 @@ let vernac_end_proof = function the theories [??] *) let vernac_exact_proof c = - let pfs = top_of_tree (get_pftreestate()) in - let pf = proof_of_pftreestate pfs in - if (is_leaf_proof pf) then begin - by (Tactics.exact_proof c); - save_named true end - else - errorlabstrm "Vernacentries.ExactProof" - (strbrk "Command 'Proof ...' can only be used at the beginning of the proof.") + (* spiwack: for simplicity I do not enforce that "Proof proof_term" is + called only at the begining of a proof. *) + by (Tactics.exact_proof c); + save_named true let vernac_assumption kind l nl= let global = fst kind = Global in @@ -386,7 +392,7 @@ let vernac_record k finite infer struc binders sort nameopt cfs = Dumpglob.dump_definition lid false "constr"; id in if Dumpglob.dump () then ( Dumpglob.dump_definition (snd struc) false "rec"; - List.iter (fun ((_, x), _) -> + List.iter (fun (((_, x), _), _) -> match x with | Vernacexpr.AssumExpr ((loc, Name id), _) -> Dumpglob.dump_definition (loc,id) false "proj" | _ -> ()) cfs); @@ -409,7 +415,8 @@ let vernac_inductive finite infer indl = | [ ( id , bl , c , Class true, Constructors [l]), _ ] -> let f = let (coe, ((loc, id), ce)) = l in - ((coe, AssumExpr ((loc, Name id), ce)), []) + let coe' = if coe then Some true else None in + (((coe', AssumExpr ((loc, Name id), ce)), None), []) in vernac_record (Class true) finite infer id bl c None [f] | [ ( id , bl , c , Class true, _), _ ] -> Util.error "Definitional classes must have a single method" @@ -424,15 +431,15 @@ let vernac_inductive finite infer indl = let indl = List.map unpack indl in do_mutual_inductive indl (recursivity_flag_of_kind finite) -let vernac_fixpoint l b = +let vernac_fixpoint l = if Dumpglob.dump () then List.iter (fun ((lid, _, _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; - do_fixpoint l b + do_fixpoint l -let vernac_cofixpoint l b = +let vernac_cofixpoint l = if Dumpglob.dump () then List.iter (fun ((lid, _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; - do_cofixpoint l b + do_cofixpoint l let vernac_scheme = Indschemes.do_scheme @@ -585,10 +592,10 @@ let vernac_end_section (loc,_) = let vernac_end_segment (_,id as lid) = check_no_pending_proofs (); match Lib.find_opening_node id with - | Lib.OpenedModule (export,_,_) -> vernac_end_module export lid - | Lib.OpenedModtype _ -> vernac_end_modtype lid + | Lib.OpenedModule (false,export,_,_) -> vernac_end_module export lid + | Lib.OpenedModule (true,_,_,_) -> vernac_end_modtype lid | Lib.OpenedSection _ -> vernac_end_section lid - | _ -> anomaly "No more opened things" + | _ -> assert false (* Libraries *) @@ -608,13 +615,13 @@ let vernac_coercion stre ref qids qidt = let target = cl_of_qualid qidt in let source = cl_of_qualid qids in let ref' = smart_global ref in - Class.try_add_new_coercion_with_target ref' stre source target; + Class.try_add_new_coercion_with_target ref' stre ~source ~target; if_verbose msgnl (pr_global ref' ++ str " is now a coercion") let vernac_identity_coercion stre id qids qidt = let target = cl_of_qualid qidt in let source = cl_of_qualid qids in - Class.try_add_new_identity_coercion id stre source target + Class.try_add_new_identity_coercion id stre ~source ~target (* Type classes *) @@ -625,32 +632,32 @@ let vernac_instance abst glob sup inst props pri = let vernac_context l = Classes.context l -let vernac_declare_instance glob id = - Classes.declare_instance glob id +let vernac_declare_instances glob ids = + List.iter (fun (id) -> Classes.existing_instance glob id) ids let vernac_declare_class id = Classes.declare_class id (***********) (* Solving *) + +let command_focus = Proof.new_focus_kind () +let focus_command_cond = Proof.no_cond command_focus + + let vernac_solve n tcom b = if not (refining ()) then error "Unknown command of the non proof-editing mode."; - Decl_mode.check_not_proof_mode "Unknown proof instruction"; - begin - if b then - solve_nth n (Tacinterp.hide_interp tcom (get_end_tac ())) - else solve_nth n (Tacinterp.hide_interp tcom None) - end; - (* in case a strict subtree was completed, - go back to the top of the prooftree *) - if subtree_solved () then begin - Flags.if_verbose msgnl (str "Subgoal proved"); - make_focus 0; - reset_top_of_script () - end; - print_subgoals(); - if !pcoq <> None then (Option.get !pcoq).solve n + let p = Proof_global.give_me_the_proof () in + Proof.transaction p begin fun () -> + solve_nth n (Tacinterp.hide_interp tcom None) ~with_end_tac:b; + (* in case a strict subtree was completed, + go back to the top of the prooftree *) + Proof_global.maximal_unfocus command_focus p; + print_subgoals(); + if !pcoq <> None then (Option.get !pcoq).solve n + end + (* A command which should be a tactic. It has been added by Christine to patch an error in the design of the proof @@ -666,32 +673,15 @@ let vernac_set_end_tac tac = if tac <> (Tacexpr.TacId []) then set_end_tac (Tacinterp.interp tac) else () (* TO DO verifier s'il faut pas mettre exist s | TacId s ici*) -(***********************) -(* Proof Language Mode *) - -let vernac_decl_proof () = - check_not_proof_mode "Already in Proof Mode"; - if tree_solved () then - error "Nothing left to prove here." - else - begin - Decl_proof_instr.go_to_proof_mode (); - print_subgoals () - end - -let vernac_return () = - match get_current_mode () with - Mode_tactic -> - Decl_proof_instr.return_from_tactic_mode (); - print_subgoals () - | Mode_proof -> - error "\"return\" is only used after \"escape\"." - | Mode_none -> - error "There is no proof to end." - -let vernac_proof_instr instr = - Decl_proof_instr.proof_instr instr; - print_subgoals () +let vernac_set_used_variables l = + let l = List.map snd l in + if not (list_distinct l) then error "Used variables list contains duplicates"; + let vars = Environ.named_context (Global.env ()) in + List.iter (fun id -> + if not (List.exists (fun (id',_,_) -> id = id') vars) then + error ("Unknown variable: " ^ string_of_id id)) + l; + set_used_variables l (*****************************) (* Auxiliary file management *) @@ -706,7 +696,7 @@ let vernac_add_loadpath isrec pdir ldiropt = let alias = match ldiropt with | None -> Nameops.default_root_prefix | Some ldir -> ldir in - (if isrec then Mltop.add_rec_path else Mltop.add_path) pdir alias + (if isrec then Mltop.add_rec_path else Mltop.add_path) ~unix_path:pdir ~coq_root:alias let vernac_remove_loadpath path = Library.remove_load_path (System.expand_path_macros path) @@ -764,6 +754,9 @@ let vernac_declare_tactic_definition (local,x,def) = let vernac_create_hintdb local id b = Auto.create_hint_db local id full_transparent_state b +let vernac_remove_hints local dbs ids = + Auto.remove_hints local dbs (List.map Smartlocate.global_with_alias ids) + let vernac_hints local lb h = Auto.add_hints local lb (Auto.interp_hints h) @@ -778,11 +771,89 @@ let vernac_declare_implicits local r = function Impargs.declare_manual_implicits local (smart_global r) ~enriching:false (List.map (List.map (fun (ex,b,f) -> ex, (b,true,f))) imps) +let vernac_declare_arguments local r l nargs flags = + let names = List.map (List.map (fun (id, _,_,_,_) -> id)) l in + let names, rest = List.hd names, List.tl names in + if List.exists ((<>) names) rest then + error "All arguments lists must declare the same names."; + if not (Util.list_distinct (List.filter ((<>) Anonymous) names)) then + error "Arguments names must be distinct."; + let sr = smart_global r in + let inf_names = + Impargs.compute_implicits_names (Global.env()) (Global.type_of_global sr) in + let string_of_name = function Anonymous -> "_" | Name id -> string_of_id id in + let rec check li ld = match li, ld with + | [], [] -> () + | [], x::_ -> error ("Extra argument " ^ string_of_name x ^ ".") + | l, [] -> error ("The following arguments are not declared: " ^ + (String.concat ", " (List.map string_of_name l)) ^ ".") + | _::li, _::ld -> check li ld in + if l <> [[]] then + List.iter (fun l -> check inf_names l) (names :: rest); + (* we interpret _ as the inferred names *) + let l = if l = [[]] then l else + let name_anons = function + | (Anonymous, a,b,c,d), Name id -> Name id, a,b,c,d + | x, _ -> x in + List.map (fun ns -> List.map name_anons (List.combine ns inf_names)) l in + let names_decl = List.map (List.map (fun (id, _,_,_,_) -> id)) l in + let some_renaming_specified = + try Arguments_renaming.arguments_names sr <> names_decl + with Not_found -> false in + let some_renaming_specified, implicits = + if l = [[]] then false, [[]] else + Util.list_fold_map (fun sr il -> + let sr', impl = Util.list_fold_map (fun b -> function + | (Anonymous, _,_, true, max), Name id -> assert false + | (Name x, _,_, true, _), Anonymous -> + error ("Argument "^string_of_id x^" cannot be declared implicit.") + | (Name iid, _,_, true, max), Name id -> + b || iid <> id, Some (ExplByName id, max, false) + | (Name iid, _,_, _, _), Name id -> b || iid <> id, None + | _ -> b, None) + sr (List.combine il inf_names) in + sr || sr', Util.list_map_filter (fun x -> x) impl) + some_renaming_specified l in + if some_renaming_specified then + if not (List.mem `Rename flags) then + error "To rename arguments the \"rename\" flag must be specified." + else Arguments_renaming.rename_arguments local sr names_decl; + (* All other infos are in the first item of l *) + let l = List.hd l in + let some_implicits_specified = implicits <> [[]] in + let scopes = List.map (function + | (_,_, None,_,_) -> None + | (_,_, Some (o, k), _,_) -> + try Some(ignore(Notation.find_scope k); k) + with _ -> Some (Notation.find_delimiters_scope o k)) l in + let some_scopes_specified = List.exists ((<>) None) scopes in + let rargs = + Util.list_map_filter (function (n, true) -> Some n | _ -> None) + (Util.list_map_i (fun i (_, b, _,_,_) -> i, b) 0 l) in + if some_scopes_specified || List.mem `ClearScopes flags then + vernac_arguments_scope local r scopes; + if not some_implicits_specified && List.mem `DefaultImplicits flags then + vernac_declare_implicits local r [] + else if some_implicits_specified || List.mem `ClearImplicits flags then + vernac_declare_implicits local r implicits; + if nargs >= 0 && nargs < List.fold_left max 0 rargs then + error "The \"/\" option must be placed after the last \"!\"."; + let rec narrow = function + | #Tacred.simpl_flag as x :: tl -> x :: narrow tl + | [] -> [] | _ :: tl -> narrow tl in + let flags = narrow flags in + if rargs <> [] || nargs >= 0 || flags <> [] then + match sr with + | ConstRef _ as c -> + Tacred.set_simpl_behaviour local c (rargs, nargs, flags) + | _ -> errorlabstrm "" (strbrk "Modifiers of the behavior of the simpl tactic are relevant for constants only.") + let vernac_reserve bl = let sb_decl = (fun (idl,c) -> let t = Constrintern.interp_type Evd.empty (Global.env()) c in - let t = Detyping.detype false [] [] t in - List.iter (fun id -> Reserve.declare_reserved_type id t) idl) + let t = Detyping.detype false [] [] t in + let t = aconstr_of_glob_constr [] [] t in + Reserve.declare_reserved_type idl t) in List.iter sb_decl bl let vernac_generalizable = Implicit_quantifiers.declare_generalizable @@ -795,6 +866,7 @@ let make_silent_if_not_pcoq b = let _ = declare_bool_option { optsync = false; + optdepr = false; optname = "silent"; optkey = ["Silent"]; optread = is_silent; @@ -803,6 +875,7 @@ let _ = let _ = declare_bool_option { optsync = true; + optdepr = false; optname = "implicit arguments"; optkey = ["Implicit";"Arguments"]; optread = Impargs.is_implicit_args; @@ -811,6 +884,7 @@ let _ = let _ = declare_bool_option { optsync = true; + optdepr = false; optname = "strict implicit arguments"; optkey = ["Strict";"Implicit"]; optread = Impargs.is_strict_implicit_args; @@ -819,6 +893,7 @@ let _ = let _ = declare_bool_option { optsync = true; + optdepr = false; optname = "strong strict implicit arguments"; optkey = ["Strongly";"Strict";"Implicit"]; optread = Impargs.is_strongly_strict_implicit_args; @@ -827,22 +902,16 @@ let _ = let _ = declare_bool_option { optsync = true; + optdepr = false; optname = "contextual implicit arguments"; optkey = ["Contextual";"Implicit"]; optread = Impargs.is_contextual_implicit_args; optwrite = Impargs.make_contextual_implicit_args } -(* let _ = *) -(* declare_bool_option *) -(* { optsync = true; *) -(* optname = "forceable implicit arguments"; *) -(* optkey = ["Forceable";"Implicit")); *) -(* optread = Impargs.is_forceable_implicit_args; *) -(* optwrite = Impargs.make_forceable_implicit_args } *) - let _ = declare_bool_option { optsync = true; + optdepr = false; optname = "implicit status of reversible patterns"; optkey = ["Reversible";"Pattern";"Implicit"]; optread = Impargs.is_reversible_pattern_implicit_args; @@ -851,6 +920,7 @@ let _ = let _ = declare_bool_option { optsync = true; + optdepr = false; optname = "maximal insertion of implicit"; optkey = ["Maximal";"Implicit";"Insertion"]; optread = Impargs.is_maximal_implicit_args; @@ -859,6 +929,7 @@ let _ = let _ = declare_bool_option { optsync = true; + optdepr = false; optname = "automatic introduction of variables"; optkey = ["Automatic";"Introduction"]; optread = Flags.is_auto_intros; @@ -867,6 +938,7 @@ let _ = let _ = declare_bool_option { optsync = true; + optdepr = false; optname = "coercion printing"; optkey = ["Printing";"Coercions"]; optread = (fun () -> !Constrextern.print_coercions); @@ -875,6 +947,7 @@ let _ = let _ = declare_bool_option { optsync = true; + optdepr = false; optname = "printing of existential variable instances"; optkey = ["Printing";"Existential";"Instances"]; optread = (fun () -> !Constrextern.print_evar_arguments); @@ -882,6 +955,7 @@ let _ = let _ = declare_bool_option { optsync = true; + optdepr = false; optname = "implicit arguments printing"; optkey = ["Printing";"Implicit"]; optread = (fun () -> !Constrextern.print_implicits); @@ -890,6 +964,7 @@ let _ = let _ = declare_bool_option { optsync = true; + optdepr = false; optname = "implicit arguments defensive printing"; optkey = ["Printing";"Implicit";"Defensive"]; optread = (fun () -> !Constrextern.print_implicits_defensive); @@ -898,6 +973,7 @@ let _ = let _ = declare_bool_option { optsync = true; + optdepr = false; optname = "projection printing using dot notation"; optkey = ["Printing";"Projections"]; optread = (fun () -> !Constrextern.print_projections); @@ -906,6 +982,7 @@ let _ = let _ = declare_bool_option { optsync = true; + optdepr = false; optname = "notations printing"; optkey = ["Printing";"Notations"]; optread = (fun () -> not !Constrextern.print_no_symbol); @@ -914,6 +991,7 @@ let _ = let _ = declare_bool_option { optsync = true; + optdepr = false; optname = "raw printing"; optkey = ["Printing";"All"]; optread = (fun () -> !Flags.raw_print); @@ -922,38 +1000,57 @@ let _ = let _ = declare_bool_option { optsync = true; + optdepr = false; + optname = "record printing"; + optkey = ["Printing";"Records"]; + optread = (fun () -> !Flags.record_print); + optwrite = (fun b -> Flags.record_print := b) } + +let _ = + declare_bool_option + { optsync = true; + optdepr = false; optname = "use of virtual machine inside the kernel"; optkey = ["Virtual";"Machine"]; optread = (fun () -> Vconv.use_vm ()); optwrite = (fun b -> Vconv.set_use_vm b) } let _ = - declare_bool_option + declare_int_option { optsync = true; - optname = "use of boxed definitions"; - optkey = ["Boxed";"Definitions"]; - optread = Flags.boxed_definitions; - optwrite = (fun b -> Flags.set_boxed_definitions b) } + optdepr = false; + optname = "the level of inling duging functor application"; + optkey = ["Inline";"Level"]; + optread = (fun () -> Some (Flags.get_inline_level ())); + optwrite = (fun o -> + let lev = Option.default Flags.default_inline_level o in + Flags.set_inline_level lev) } let _ = declare_bool_option { optsync = true; + optdepr = false; optname = "use of boxed values"; optkey = ["Boxed";"Values"]; optread = (fun _ -> not (Vm.transp_values ())); optwrite = (fun b -> Vm.set_transp_values (not b)) } +(* No more undo limit in the new proof engine. + The command still exists for compatibility (e.g. with ProofGeneral) *) + let _ = declare_int_option { optsync = false; - optname = "the undo limit"; + optdepr = true; + optname = "the undo limit (OBSOLETE)"; optkey = ["Undo"]; - optread = Pfedit.get_undo; - optwrite = Pfedit.set_undo } + optread = (fun _ -> None); + optwrite = (fun _ -> ()) } let _ = declare_int_option { optsync = false; + optdepr = false; optname = "the hypotheses limit"; optkey = ["Hyps";"Limit"]; optread = Flags.print_hyps_limit; @@ -962,6 +1059,7 @@ let _ = let _ = declare_int_option { optsync = true; + optdepr = false; optname = "the printing depth"; optkey = ["Printing";"Depth"]; optread = Pp_control.get_depth_boxes; @@ -970,6 +1068,7 @@ let _ = let _ = declare_int_option { optsync = true; + optdepr = false; optname = "the printing width"; optkey = ["Printing";"Width"]; optread = Pp_control.get_margin; @@ -978,6 +1077,7 @@ let _ = let _ = declare_bool_option { optsync = true; + optdepr = false; optname = "printing of universes"; optkey = ["Printing";"Universes"]; optread = (fun () -> !Constrextern.print_universes); @@ -989,6 +1089,7 @@ let vernac_debug b = let _ = declare_bool_option { optsync = false; + optdepr = false; optname = "Ltac debug"; optkey = ["Ltac";"Debug"]; optread = (fun () -> get_debug () <> Tactic_debug.DebugOff); @@ -1006,7 +1107,7 @@ let vernac_set_opacity local str = let vernac_set_option locality key = function | StringValue s -> set_string_option_value_gen locality key s - | IntValue n -> set_int_option_value_gen locality key (Some n) + | IntValue n -> set_int_option_value_gen locality key n | BoolValue b -> set_bool_option_value_gen locality key b let vernac_unset_option locality key = @@ -1046,18 +1147,25 @@ let get_current_context_of_args = function | None -> get_current_context () let vernac_check_may_eval redexp glopt rc = - let (evmap,env) = get_current_context_of_args glopt in - let c = interp_constr evmap env rc in - let j = Typeops.typing env c in + let module P = Pretype_errors in + let (sigma, env) = get_current_context_of_args glopt in + let sigma', c = interp_open_constr sigma env rc in + let j = + try + Evarutil.check_evars env sigma sigma' c; + Arguments_renaming.rename_typing env c + with P.PretypeError (_,_,P.UnsolvableImplicit _) + | Compat.Loc.Exc_located (_,P.PretypeError (_,_,P.UnsolvableImplicit _)) -> + Evarutil.j_nf_evar sigma' (Retyping.get_judgment_of env sigma' c) in match redexp with | None -> if !pcoq <> None then (Option.get !pcoq).print_check env j else msg (print_judgment env j) | Some r -> - let redfun = fst (reduction_of_red_expr (interp_redexp env evmap r)) in + let redfun = fst (reduction_of_red_expr (interp_redexp env sigma' r)) in if !pcoq <> None - then (Option.get !pcoq).print_eval redfun env evmap rc j - else msg (print_eval redfun env evmap rc j) + then (Option.get !pcoq).print_eval redfun env sigma' rc j + else msg (print_eval redfun env sigma' rc j) let vernac_declare_reduction locality s r = declare_red_expr locality s (interp_redexp (Global.env()) Evd.empty r) @@ -1095,19 +1203,22 @@ let vernac_print = function | PrintCoercionPaths (cls,clt) -> ppnl (Prettyp.print_path_between (cl_of_qualid cls) (cl_of_qualid clt)) | PrintCanonicalConversions -> ppnl (Prettyp.print_canonical_projections ()) - | PrintUniverses None -> pp (Univ.pr_universes (Global.universes ())) - | PrintUniverses (Some s) -> dump_universes s + | PrintUniverses (b, None) -> + let univ = Global.universes () in + let univ = if b then Univ.sort_universes univ else univ in + pp (Univ.pr_universes univ) + | PrintUniverses (b, Some s) -> dump_universes b s | PrintHint r -> Auto.print_hint_ref (smart_global r) | PrintHintGoal -> Auto.print_applicable_hint () | PrintHintDbName s -> Auto.print_hint_db_by_name s | PrintRewriteHintDbName s -> Autorewrite.print_rewrite_hintdb s | PrintHintDb -> Auto.print_searchtable () | PrintScopes -> - pp (Notation.pr_scopes (Constrextern.without_symbols pr_lrawconstr)) + pp (Notation.pr_scopes (Constrextern.without_symbols pr_lglob_constr)) | PrintScope s -> - pp (Notation.pr_scope (Constrextern.without_symbols pr_lrawconstr) s) + pp (Notation.pr_scope (Constrextern.without_symbols pr_lglob_constr) s) | PrintVisibility s -> - pp (Notation.pr_visibility (Constrextern.without_symbols pr_lrawconstr) s) + pp (Notation.pr_visibility (Constrextern.without_symbols pr_lglob_constr) s) | PrintAbout qid -> msg (print_about qid) | PrintImplicit qid -> msg (print_impargs qid) | PrintAssumptions (o,r) -> @@ -1145,7 +1256,7 @@ let interp_search_about_item = function (fun _ -> true) s sc in GlobSearchSubPattern (Pattern.PRef ref) with UserError _ -> - error ("Unable to interp \""^s^"\" either as a reference or + error ("Unable to interp \""^s^"\" either as a reference or \ as an identifier component") let vernac_search s r = @@ -1169,7 +1280,7 @@ let vernac_locate = function | LocateTerm (Genarg.ByNotation (_,ntn,sc)) -> ppnl (Notation.locate_notation - (Constrextern.without_symbols pr_lrawconstr) ntn sc) + (Constrextern.without_symbols pr_lglob_constr) ntn sc) | LocateLibrary qid -> print_located_library qid | LocateModule qid -> print_located_module qid | LocateTactic qid -> print_located_tactic qid @@ -1178,16 +1289,6 @@ let vernac_locate = function (********************) (* Proof management *) -let vernac_goal = function - | None -> () - | Some c -> - if not (refining()) then begin - let unnamed_kind = Lemma (* Arbitrary *) in - start_proof_com (Global, Proof unnamed_kind) [None,c] (fun _ _ ->()); - print_subgoals () - end else - error "repeated Goal not permitted in refining mode." - let vernac_abort = function | None -> delete_current_proof (); @@ -1229,48 +1330,58 @@ let vernac_backtrack snum pnum naborts = vernac_backto snum; Pp.flush_all(); (* there may be no proof in progress, even if no abort *) - (try print_subgoals () with UserError _ -> ()) + (try print_subgoals () with Proof_global.NoCurrentProof | UserError _ -> ()) let vernac_focus gln = - check_not_proof_mode "No focussing or Unfocussing in Proof Mode."; + let p = Proof_global.give_me_the_proof () in match gln with - | None -> traverse_nth_goal 1; print_subgoals () - | Some n -> traverse_nth_goal n; print_subgoals () + | None -> Proof.focus focus_command_cond () 1 p; print_subgoals () + | Some n -> Proof.focus focus_command_cond () n p; print_subgoals () + - (* Reset the focus to the top of the tree *) + (* Unfocuses one step in the focus stack. *) let vernac_unfocus () = - check_not_proof_mode "No focussing or Unfocussing in Proof Mode."; - make_focus 0; reset_top_of_script (); print_subgoals () - -let vernac_go = function - | GoTo n -> Pfedit.traverse n;show_node() - | GoTop -> Pfedit.reset_top_of_tree ();show_node() - | GoNext -> Pfedit.traverse_next_unproven ();show_node() - | GoPrev -> Pfedit.traverse_prev_unproven ();show_node() - -let apply_subproof f occ = - let pts = get_pftreestate() in - let evc = evc_of_pftreestate pts in - let rec aux pts = function - | [] -> pts - | (n::l) -> aux (Tacmach.traverse n pts) occ in - let pts = aux pts (occ@[-1]) in - let pf = proof_of_pftreestate pts in - f evc (Global.named_context()) pf - -let explain_proof occ = - msg (apply_subproof (fun evd _ -> print_treescript evd) occ) - -let explain_tree occ = - msg (apply_subproof print_proof occ) + let p = Proof_global.give_me_the_proof () in + Proof.unfocus command_focus p; print_subgoals () + +(* BeginSubproof / EndSubproof. + BeginSubproof (vernac_subproof) focuses on the first goal, or the goal + given as argument. + EndSubproof (vernac_end_subproof) unfocuses from a BeginSubproof, provided + that the proof of the goal has been completed. +*) +let subproof_kind = Proof.new_focus_kind () +let subproof_cond = Proof.done_cond subproof_kind + +let vernac_subproof gln = + let p = Proof_global.give_me_the_proof () in + begin match gln with + | None -> Proof.focus subproof_cond () 1 p + | Some n -> Proof.focus subproof_cond () n p + end ; + print_subgoals () + +let vernac_end_subproof () = + let p = Proof_global.give_me_the_proof () in + Proof.unfocus subproof_kind p ; print_subgoals () + + +let vernac_bullet (bullet:Proof_global.Bullet.t) = + let p = Proof_global.give_me_the_proof () in + Proof.transaction p + (fun () -> Proof_global.Bullet.put p bullet); + (* Makes the focus visible in emacs by re-printing the goal. *) + if !Flags.print_emacs then print_subgoals () + let vernac_show = function - | ShowGoal nopt -> - if !pcoq <> None then (Option.get !pcoq).show_goal nopt - else msg (match nopt with - | None -> pr_open_subgoals () - | Some n -> pr_nth_open_subgoal n) + | ShowGoal goalref -> + if !pcoq <> None then (Option.get !pcoq).show_goal goalref + else msg (match goalref with + | OpenSubgoals -> pr_open_subgoals () + | NthGoal n -> pr_nth_open_subgoal n + | GoalId id -> pr_goal_by_id id) | ShowGoalImplicitly None -> Constrextern.with_implicits msg (pr_open_subgoals ()) | ShowGoalImplicitly (Some n) -> @@ -1285,17 +1396,15 @@ let vernac_show = function | ShowIntros all -> show_intro all | ShowMatch id -> show_match id | ShowThesis -> show_thesis () - | ExplainProof occ -> explain_proof occ - | ExplainTree occ -> explain_tree occ let vernac_check_guard () = let pts = get_pftreestate () in - let pf = proof_of_pftreestate pts in - let (pfterm,_) = extract_open_pftreestate pts in + let pfterm = List.hd (Proof.partial_proof pts) in let message = try - Inductiveops.control_only_guard (Evd.evar_env (goal_of_proof pf)) + let { Evd.it=gl ; sigma=sigma } = Proof.V82.top_goal pts in + Inductiveops.control_only_guard (Goal.V82.env sigma gl) pfterm; (str "The condition holds up to here") with UserError(_,s) -> @@ -1325,8 +1434,8 @@ let interp c = match c with | VernacExactProof c -> vernac_exact_proof c | VernacAssumption (stre,nl,l) -> vernac_assumption stre l nl | VernacInductive (finite,infer,l) -> vernac_inductive finite infer l - | VernacFixpoint (l,b) -> vernac_fixpoint l b - | VernacCoFixpoint (l,b) -> vernac_cofixpoint l b + | VernacFixpoint l -> vernac_fixpoint l + | VernacCoFixpoint l -> vernac_cofixpoint l | VernacScheme l -> vernac_scheme l | VernacCombinedScheme (id, l) -> vernac_combined_scheme id l @@ -1354,21 +1463,13 @@ let interp c = match c with | VernacInstance (abst, glob, sup, inst, props, pri) -> vernac_instance abst glob sup inst props pri | VernacContext sup -> vernac_context sup - | VernacDeclareInstance (glob, id) -> vernac_declare_instance glob id + | VernacDeclareInstances (glob, ids) -> vernac_declare_instances glob ids | VernacDeclareClass id -> vernac_declare_class id (* Solving *) | VernacSolve (n,tac,b) -> vernac_solve n tac b | VernacSolveExistential (n,c) -> vernac_solve_existential n c - (* MMode *) - - | VernacDeclProof -> vernac_decl_proof () - | VernacReturn -> vernac_return () - | VernacProofInstr stp -> vernac_proof_instr stp - - (* /MMode *) - (* Auxiliary file and library management *) | VernacRequireFrom (exp,spec,f) -> vernac_require_from exp spec f | VernacAddLoadPath (isrec,s,alias) -> vernac_add_loadpath isrec s alias @@ -1391,9 +1492,11 @@ let interp c = match c with (* Commands *) | VernacDeclareTacticDefinition def -> vernac_declare_tactic_definition def | VernacCreateHintDb (local,dbname,b) -> vernac_create_hintdb local dbname b + | VernacRemoveHints (local,dbnames,ids) -> vernac_remove_hints local dbnames ids | VernacHints (local,dbnames,hints) -> vernac_hints local dbnames hints | VernacSyntacticDefinition (id,c,l,b) ->vernac_syntactic_definition id c l b | VernacDeclareImplicits (local,qid,l) ->vernac_declare_implicits local qid l + | VernacArguments (local, qid, l, narg, flags) -> vernac_declare_arguments local qid l narg flags | VernacReserve bl -> vernac_reserve bl | VernacGeneralizable (local,gen) -> vernac_generalizable local gen | VernacSetOpacity (local,qidl) -> vernac_set_opacity local qidl @@ -1424,10 +1527,17 @@ let interp c = match c with | VernacBacktrack (snum,pnum,naborts) -> vernac_backtrack snum pnum naborts | VernacFocus n -> vernac_focus n | VernacUnfocus -> vernac_unfocus () - | VernacGo g -> vernac_go g + | VernacBullet b -> vernac_bullet b + | VernacSubproof n -> vernac_subproof n + | VernacEndSubproof -> vernac_end_subproof () | VernacShow s -> vernac_show s | VernacCheckGuard -> vernac_check_guard () - | VernacProof tac -> vernac_set_end_tac tac + | VernacProof (None, None) -> () + | VernacProof (Some tac, None) -> vernac_set_end_tac tac + | VernacProof (None, Some l) -> vernac_set_used_variables l + | VernacProof (Some tac, Some l) -> + vernac_set_end_tac tac; vernac_set_used_variables l + | VernacProofMode mn -> Proof_global.set_proof_mode mn (* Toplevel control *) | VernacToplevelControl e -> raise e diff --git a/toplevel/vernacentries.mli b/toplevel/vernacentries.mli index 1cca3540..8fb6f466 100644 --- a/toplevel/vernacentries.mli +++ b/toplevel/vernacentries.mli @@ -1,34 +1,31 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* unit val show_prooftree : unit -> unit val show_node : unit -> unit -(* This function can be used by any command that want to observe terms +(** This function can be used by any command that want to observe terms in the context of the current goal, as for instance in pcoq *) val get_current_context_of_args : int option -> Evd.evar_map * Environ.env (*i -(* this function is used to analyse the extra arguments in search commands. + +(** this function is used to analyse the extra arguments in search commands. It is used in pcoq. *) (*i anciennement: inside_outside i*) val interp_search_restriction : search_restriction -> dir_path list * bool i*) @@ -42,12 +39,12 @@ type pcoq_hook = { print_check : Environ.env -> Environ.unsafe_judgment -> unit; print_eval : Reductionops.reduction_function -> Environ.env -> Evd.evar_map -> constr_expr -> Environ.unsafe_judgment -> unit; - show_goal : int option -> unit + show_goal : goal_reference -> unit } val set_pcoq_hook : pcoq_hook -> unit -(* This function makes sure that the function given in argument is preceded +(** This function makes sure that the function given in argument is preceded by a command aborting all proofs if necessary. It is used in pcoq. *) val abort_refine : ('a -> unit) -> 'a -> unit;; @@ -55,3 +52,17 @@ val abort_refine : ('a -> unit) -> 'a -> unit;; val interp : Vernacexpr.vernac_expr -> unit val vernac_reset_name : identifier Util.located -> unit + +val vernac_backtrack : int -> int -> int -> unit + +(* Print subgoals when the verbose flag is on. Meant to be used inside + vernac commands from plugins. *) +val print_subgoals : unit -> unit + +(** Prepare a "match" template for a given inductive type. + For each branch of the match, we list the constructor name + followed by enough pattern variables. + [Not_found] is raised if the given string isn't the qualid of + a known inductive type. *) + +val make_cases : string -> string list list diff --git a/toplevel/vernacexpr.ml b/toplevel/vernacexpr.ml index 31c46a54..850bc111 100644 --- a/toplevel/vernacexpr.ml +++ b/toplevel/vernacexpr.ml @@ -1,13 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* "Prop" - | RProp Pos -> "Set" - | RType _ -> "Type" +let whelp_of_glob_sort = function + | GProp Null -> "Prop" + | GProp Pos -> "Set" + | GType _ -> "Type" let uri_int n = Buffer.add_string b (string_of_int n) @@ -130,9 +129,9 @@ let uri_params f = function let get_discharged_hyp_names sp = List.map basename (get_discharged_hyps sp) let section_parameters = function - | RRef (_,(ConstructRef ((induri,_),_) | IndRef (induri,_))) -> + | GRef (_,(ConstructRef ((induri,_),_) | IndRef (induri,_))) -> get_discharged_hyp_names (path_of_global (IndRef(induri,0))) - | RRef (_,(ConstRef cst as ref)) -> + | GRef (_,(ConstRef cst as ref)) -> get_discharged_hyp_names (path_of_global ref) | _ -> [] @@ -144,33 +143,33 @@ let merge vl al = let rec uri_of_constr c = match c with - | RVar (_,id) -> url_id id - | RRef (_,ref) -> uri_of_global ref - | RHole _ | REvar _ -> url_string "?" - | RSort (_,s) -> url_string (whelp_of_rawsort s) + | GVar (_,id) -> url_id id + | GRef (_,ref) -> uri_of_global ref + | GHole _ | GEvar _ -> url_string "?" + | GSort (_,s) -> url_string (whelp_of_glob_sort s) | _ -> url_paren (fun () -> match c with - | RApp (_,f,args) -> + | GApp (_,f,args) -> let inst,rest = merge (section_parameters f) args in uri_of_constr f; url_char ' '; uri_params uri_of_constr inst; url_list_with_sep " " uri_of_constr rest - | RLambda (_,na,k,ty,c) -> + | GLambda (_,na,k,ty,c) -> url_string "\\lambda "; url_of_name na; url_string ":"; uri_of_constr ty; url_string "."; uri_of_constr c - | RProd (_,Anonymous,k,ty,c) -> + | GProd (_,Anonymous,k,ty,c) -> uri_of_constr ty; url_string "\\to "; uri_of_constr c - | RProd (_,Name id,k,ty,c) -> + | GProd (_,Name id,k,ty,c) -> url_string "\\forall "; url_id id; url_string ":"; uri_of_constr ty; url_string "."; uri_of_constr c - | RLetIn (_,na,b,c) -> + | GLetIn (_,na,b,c) -> url_string "let "; url_of_name na; url_string "\\def "; uri_of_constr b; url_string " in "; uri_of_constr c - | RCast (_,c, CastConv (_,t)) -> + | GCast (_,c, CastConv (_,t)) -> uri_of_constr c; url_string ":"; uri_of_constr t - | RRec _ | RIf _ | RLetTuple _ | RCases _ -> + | GRec _ | GIf _ | GLetTuple _ | GCases _ -> error "Whelp does not support pattern-matching and (co-)fixpoint." - | RVar _ | RRef _ | RHole _ | REvar _ | RSort _ | RCast (_,_, CastCoerce) -> + | GVar _ | GRef _ | GHole _ | GEvar _ | GSort _ | GCast (_,_, CastCoerce) -> anomaly "Written w/o parenthesis" - | RPatVar _ | RDynamic _ -> + | GPatVar _ -> anomaly "Found constructors not supported in constr") () let make_string f x = Buffer.reset b; f x; Buffer.contents b @@ -196,8 +195,9 @@ let whelp_elim ind = send_whelp "elim" (make_string uri_of_global (IndRef ind)) let on_goal f = - let gls = nth_goal_of_pftreestate 1 (get_pftreestate ()) in - f (it_mkNamedProd_or_LetIn (pf_concl gls) (pf_hyps gls)) + let { Evd.it=goals ; sigma=sigma } = Proof.V82.subgoals (get_pftreestate ()) in + let gls = { Evd.it=List.hd goals ; sigma = sigma } in + f (Termops.it_mkNamedProd_or_LetIn (pf_concl gls) (pf_hyps gls)) type whelp_request = | Locate of string diff --git a/toplevel/whelp.mli b/toplevel/whelp.mli index 75e9ad49..b0fb5491 100644 --- a/toplevel/whelp.mli +++ b/toplevel/whelp.mli @@ -1,14 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Date: Mon, 4 Jun 2012 12:07:52 +0200 Subject: Imported Upstream version 8.4~gamma0+really8.4beta2 --- .gitignore | 3 + CHANGES | 56 +- COPYRIGHT | 2 +- CREDITS | 10 +- INSTALL | 6 +- Makefile | 2 +- Makefile.build | 14 +- Makefile.common | 17 +- Makefile.doc | 44 +- README | 6 +- TODO | 53 - checker/mod_checking.ml | 74 +- checker/subtyping.ml | 58 +- configure | 29 +- dev/base_include | 6 +- dev/printers.mllib | 2 +- dev/top_printers.ml | 4 + doc/common/macros.tex | 1 + doc/common/styles/html/coqremote/cover.html | 9 +- doc/common/styles/html/coqremote/footer.html | 45 + doc/common/styles/html/coqremote/header.html | 49 + doc/common/styles/html/simple/cover.html | 10 +- doc/common/styles/html/simple/footer.html | 2 + doc/common/styles/html/simple/header.html | 13 + doc/common/title.tex | 2 +- doc/faq/FAQ.tex | 6 +- doc/refman/Cases.tex | 2 +- doc/refman/RefMan-cic.tex | 77 +- doc/refman/RefMan-coi.tex | 4 +- doc/refman/RefMan-com.tex | 176 +- doc/refman/RefMan-ext.tex | 41 +- doc/refman/RefMan-gal.tex | 4 +- doc/refman/RefMan-ltac.tex | 3 +- doc/refman/RefMan-oth.tex | 138 +- doc/refman/RefMan-pro.tex | 79 +- doc/refman/RefMan-sch.tex | 418 ++ doc/refman/RefMan-syn.tex | 2 +- doc/refman/RefMan-tac.tex | 6168 ++++++++++++------------ doc/refman/RefMan-tacex.tex | 584 --- doc/refman/RefMan-uti.tex | 52 +- doc/refman/Reference-Manual.tex | 7 +- doc/refman/coqdoc.tex | 12 +- doc/stdlib/hidden-files | 0 doc/stdlib/index-list.html.template | 36 +- doc/stdlib/index-trailer.html | 2 - doc/stdlib/make-library-index | 34 +- ide/command_windows.ml | 24 +- ide/command_windows.mli | 2 + ide/coq.ml | 120 +- ide/coq.mli | 14 +- ide/coq_commands.ml | 1 - ide/coq_lex.mll | 28 +- ide/coqide-gtk2rc | 10 - ide/coqide.ml | 231 +- ide/coqide.mli | 3 - ide/coqide_main.ml4 | 24 +- ide/coqide_ui.ml | 28 +- ide/ideproof.ml | 16 +- ide/ideutils.ml | 99 +- ide/ideutils.mli | 13 + ide/minilib.ml | 47 +- ide/preferences.ml | 210 +- ide/preferences.mli | 21 +- ide/tags.ml | 33 +- ide/tags.mli | 50 + ide/utils/configwin.ml | 4 +- ide/utils/configwin_ihm.ml | 6 +- interp/constrextern.ml | 50 +- interp/constrextern.mli | 1 + interp/constrintern.ml | 70 +- interp/constrintern.mli | 3 + interp/genarg.ml | 42 +- interp/genarg.mli | 6 +- interp/notation.ml | 5 + interp/notation.mli | 2 + interp/topconstr.ml | 15 +- interp/topconstr.mli | 4 + kernel/declarations.mli | 4 + kernel/mod_typing.ml | 82 +- kernel/safe_typing.ml | 56 +- kernel/safe_typing.mli | 2 +- kernel/subtyping.ml | 74 +- kernel/term.ml | 1 + kernel/term.mli | 6 +- kernel/univ.ml | 111 +- kernel/univ.mli | 4 + lib/envars.ml | 6 +- lib/explore.ml | 18 +- lib/explore.mli | 2 +- lib/pp.ml4 | 19 +- lib/pp.mli | 3 + lib/util.ml | 25 +- lib/util.mli | 6 + lib/xml_parser.mli | 2 +- library/assumptions.ml | 18 +- library/declare.ml | 2 +- library/global.ml | 2 +- library/global.mli | 2 +- library/goptions.ml | 1 + library/impargs.ml | 13 +- library/lib.ml | 111 +- library/lib.mli | 43 +- man/coqc.1 | 12 + man/coqtop.1 | 8 +- myocamlbuild.ml | 9 + parsing/argextend.ml4 | 74 +- parsing/egrammar.ml | 41 +- parsing/egrammar.mli | 2 + parsing/extrawit.ml | 12 +- parsing/g_constr.ml4 | 24 +- parsing/g_proofs.ml4 | 21 +- parsing/g_tactic.ml4 | 27 +- parsing/g_vernac.ml4 | 4 +- parsing/ppconstr.ml | 72 +- parsing/ppconstr.mli | 6 +- parsing/pptactic.ml | 30 +- parsing/ppvernac.ml | 76 +- parsing/printer.ml | 37 +- parsing/printer.mli | 3 +- parsing/q_coqast.ml4 | 15 +- parsing/tacextend.ml4 | 61 +- plugins/decl_mode/g_decl_mode.ml4 | 5 +- plugins/dp/Dp.v | 118 - plugins/dp/TODO | 24 - plugins/dp/dp.ml | 1133 ----- plugins/dp/dp.mli | 20 - plugins/dp/dp_plugin.mllib | 5 - plugins/dp/dp_why.ml | 185 - plugins/dp/dp_why.mli | 17 - plugins/dp/dp_zenon.mli | 7 - plugins/dp/dp_zenon.mll | 189 - plugins/dp/fol.mli | 58 - plugins/dp/g_dp.ml4 | 77 - plugins/dp/test2.v | 80 - plugins/dp/tests.v | 300 -- plugins/dp/vo.itarget | 1 - plugins/dp/zenon.v | 92 - plugins/extraction/extract_env.ml | 11 +- plugins/extraction/modutil.ml | 11 +- plugins/firstorder/g_ground.ml4 | 2 - plugins/funind/functional_principles_proofs.ml | 3 +- plugins/funind/g_indfun.ml4 | 2 +- plugins/funind/invfun.ml | 55 +- plugins/funind/recdef.ml | 42 +- plugins/micromega/coq_micromega.ml | 19 +- plugins/nsatz/nsatz.ml4 | 2 +- plugins/pluginsbyte.itarget | 1 - plugins/pluginsdyn.itarget | 1 - plugins/pluginsopt.itarget | 1 - plugins/pluginsvo.itarget | 3 +- plugins/rtauto/proof_search.ml | 4 +- plugins/rtauto/proof_search.mli | 2 +- plugins/subtac/eterm.ml | 17 +- plugins/subtac/g_subtac.ml4 | 4 +- plugins/subtac/subtac.ml | 4 +- plugins/subtac/subtac_cases.ml | 2 +- plugins/subtac/subtac_classes.ml | 9 +- plugins/subtac/subtac_coercion.ml | 107 +- plugins/subtac/subtac_command.ml | 2 +- plugins/subtac/subtac_obligations.ml | 25 +- plugins/subtac/subtac_pretyping.ml | 4 +- plugins/subtac/subtac_pretyping_F.ml | 33 +- plugins/subtac/subtac_utils.ml | 11 +- plugins/subtac/subtac_utils.mli | 1 + plugins/xml/dumptree.ml4 | 4 +- pretyping/cases.ml | 5 +- pretyping/coercion.ml | 2 +- pretyping/detyping.ml | 8 +- pretyping/evarconv.ml | 119 +- pretyping/evarutil.ml | 1503 +++--- pretyping/evarutil.mli | 6 +- pretyping/evd.ml | 10 +- pretyping/evd.mli | 2 + pretyping/inductiveops.ml | 19 +- pretyping/namegen.ml | 47 +- pretyping/namegen.mli | 5 +- pretyping/pretyping.ml | 9 +- pretyping/pretyping.mli | 3 +- pretyping/tacred.ml | 12 +- pretyping/typeclasses.ml | 34 +- pretyping/typeclasses.mli | 12 +- pretyping/unification.ml | 2 +- pretyping/vnorm.ml | 9 +- proofs/clenv.ml | 4 +- proofs/evar_refiner.ml | 2 +- proofs/goal.ml | 6 +- proofs/goal.mli | 4 +- proofs/logic.ml | 8 +- proofs/pfedit.ml | 14 +- proofs/pfedit.mli | 22 +- proofs/proof.ml | 134 +- proofs/proof.mli | 14 +- proofs/proof_global.ml | 72 +- proofs/proof_global.mli | 6 - proofs/proofview.ml | 11 + proofs/proofview.mli | 5 + proofs/refiner.ml | 4 - proofs/refiner.mli | 1 - proofs/tacexpr.ml | 11 +- proofs/tacmach.ml | 8 - proofs/tacmach.mli | 3 - proofs/tactic_debug.ml | 103 +- proofs/tactic_debug.mli | 7 + scripts/coqc.ml | 23 +- tactics/auto.ml | 417 +- tactics/auto.mli | 54 +- tactics/class_tactics.ml4 | 37 +- tactics/dhyp.ml | 359 -- tactics/dhyp.mli | 28 - tactics/eauto.ml4 | 146 +- tactics/eauto.mli | 4 +- tactics/extraargs.ml4 | 35 +- tactics/extraargs.mli | 2 + tactics/extratactics.ml4 | 18 +- tactics/refine.ml | 2 +- tactics/rewrite.ml4 | 22 +- tactics/tacinterp.ml | 605 ++- tactics/tacinterp.mli | 14 +- tactics/tacticals.ml | 1 - tactics/tacticals.mli | 1 - tactics/tactics.ml | 10 +- tactics/tactics.mllib | 1 - test-suite/bugs/closed/shouldsucceed/2603.v | 21 +- test-suite/bugs/closed/shouldsucceed/2732.v | 19 + test-suite/bugs/closed/shouldsucceed/2733.v | 26 + test-suite/complexity/autodecomp.v | 11 - test-suite/output/Arguments.out | 8 + test-suite/output/Arguments.v | 12 + test-suite/output/Notations2.out | 6 + test-suite/output/Notations2.v | 15 + test-suite/output/PrintInfos.out | 9 +- test-suite/success/Cases.v | 71 +- test-suite/success/CasesDep.v | 22 +- test-suite/success/Hints.v | 5 - test-suite/success/Mod_params.v | 84 +- test-suite/success/Notations.v | 14 +- test-suite/success/RecTutorial.v | 69 +- test-suite/success/Reset.v | 7 - test-suite/success/apply.v | 17 +- test-suite/success/coercions.v | 42 + test-suite/success/dependentind.v | 31 + test-suite/success/evars.v | 70 + test-suite/success/hyps_inclusion.v | 8 +- test-suite/success/telescope_canonical.v | 70 +- theories/Arith/Div2.v | 26 +- theories/Init/Logic.v | 4 +- theories/Init/Prelude.v | 1 - theories/Init/Specif.v | 2 +- theories/Lists/intro.tex | 2 +- theories/Logic/ChoiceFacts.v | 16 +- theories/MSets/MSetAVL.v | 1377 +----- theories/MSets/MSetGenTree.v | 1145 +++++ theories/MSets/MSetRBT.v | 1931 ++++++++ theories/MSets/vo.itarget | 2 + theories/Program/Equality.v | 26 +- theories/Unicode/Utf8_core.v | 4 +- theories/Vectors/Fin.v | 10 +- theories/Vectors/VectorDef.v | 23 +- theories/Vectors/VectorSpec.v | 6 + theories/Wellfounded/Lexicographic_Product.v | 14 +- theories/ZArith/Int.v | 128 +- theories/ZArith/ZOdiv.v | 88 + theories/ZArith/ZOdiv_def.v | 15 + theories/ZArith/Zeven.v | 6 +- theories/ZArith/vo.itarget | 2 + tools/coq_makefile.ml | 26 +- tools/coqdoc/cpretty.mll | 20 +- tools/coqdoc/index.ml | 6 +- tools/coqdoc/output.ml | 8 +- tools/win32hack.mllib | 1 + tools/win32hack_filename.ml | 4 + toplevel/backtrack.ml | 225 + toplevel/backtrack.mli | 93 + toplevel/class.ml | 2 +- toplevel/classes.ml | 9 +- toplevel/command.ml | 36 +- toplevel/coqtop.ml | 11 +- toplevel/himsg.ml | 16 +- toplevel/ide_intf.ml | 120 +- toplevel/ide_intf.mli | 26 + toplevel/ide_slave.ml | 436 +- toplevel/interface.mli | 47 +- toplevel/metasyntax.ml | 12 + toplevel/metasyntax.mli | 2 + toplevel/mltop.ml4 | 23 +- toplevel/mltop.mli | 10 + toplevel/record.ml | 6 +- toplevel/search.mli | 2 + toplevel/toplevel.ml | 3 - toplevel/toplevel.mllib | 1 + toplevel/vernac.ml | 65 +- toplevel/vernac.mli | 9 +- toplevel/vernacentries.ml | 198 +- toplevel/vernacentries.mli | 31 +- toplevel/vernacexpr.ml | 28 +- 295 files changed, 12968 insertions(+), 11382 deletions(-) delete mode 100644 TODO create mode 100644 doc/common/styles/html/coqremote/footer.html create mode 100644 doc/common/styles/html/coqremote/header.html create mode 100644 doc/common/styles/html/simple/footer.html create mode 100644 doc/common/styles/html/simple/header.html create mode 100644 doc/refman/RefMan-sch.tex create mode 100644 doc/stdlib/hidden-files delete mode 100644 doc/stdlib/index-trailer.html create mode 100644 ide/tags.mli delete mode 100644 plugins/dp/Dp.v delete mode 100644 plugins/dp/TODO delete mode 100644 plugins/dp/dp.ml delete mode 100644 plugins/dp/dp.mli delete mode 100644 plugins/dp/dp_plugin.mllib delete mode 100644 plugins/dp/dp_why.ml delete mode 100644 plugins/dp/dp_why.mli delete mode 100644 plugins/dp/dp_zenon.mli delete mode 100644 plugins/dp/dp_zenon.mll delete mode 100644 plugins/dp/fol.mli delete mode 100644 plugins/dp/g_dp.ml4 delete mode 100644 plugins/dp/test2.v delete mode 100644 plugins/dp/tests.v delete mode 100644 plugins/dp/vo.itarget delete mode 100644 plugins/dp/zenon.v delete mode 100644 tactics/dhyp.ml delete mode 100644 tactics/dhyp.mli create mode 100644 test-suite/bugs/closed/shouldsucceed/2732.v create mode 100644 test-suite/bugs/closed/shouldsucceed/2733.v delete mode 100644 test-suite/complexity/autodecomp.v delete mode 100644 test-suite/success/Reset.v create mode 100644 theories/MSets/MSetGenTree.v create mode 100644 theories/MSets/MSetRBT.v create mode 100644 theories/ZArith/ZOdiv.v create mode 100644 theories/ZArith/ZOdiv_def.v create mode 100644 tools/win32hack.mllib create mode 100644 tools/win32hack_filename.ml create mode 100644 toplevel/backtrack.ml create mode 100644 toplevel/backtrack.mli (limited to 'toplevel') diff --git a/.gitignore b/.gitignore index 7fcd2580..32a40af6 100644 --- a/.gitignore +++ b/.gitignore @@ -79,6 +79,9 @@ doc/stdlib/Library.out doc/stdlib/Library.pdf doc/stdlib/Library.ps doc/stdlib/Library.coqdoc.tex +doc/stdlib/FullLibrary.pdf +doc/stdlib/FullLibrary.ps +doc/stdlib/FullLibrary.coqdoc.tex doc/stdlib/html/ doc/stdlib/index-body.html doc/stdlib/index-list.html diff --git a/CHANGES b/CHANGES index 74aefe49..c245fb25 100644 --- a/CHANGES +++ b/CHANGES @@ -1,5 +1,54 @@ -Changes from V8.3 to V8.4 -========================= +Changes from V8.4beta to V8.4 +============================= + +Vernacular commands + +- Undo and UndoTo are now handling the proof states. They may + perform some extra steps of backtrack to avoid states where + the proof state is unavailable (typically a closed proof). +- The commands Suspend and Resume have been removed. +- A basic Show Script has been reintroduced (no indentation). +- New command "Set Parsing Explicit" for deactivating parsing (and printing) + of implicit arguments (useful for teaching). +- New command "Grab Existential Variables" to transform the unresolved evars at + the end of a proof into goals. + +Tactics + +- Still no general "info" tactical, but new specific tactics + info_auto, info_eauto, info_trivial which provides information + on the proofs found by auto/eauto/trivial. Display of these + details could also be activated by Set Info Auto/Eauto/Trivial. +- Details on everything tried by auto/eauto/trivial during + a proof search could be obtained by "debug auto", "debug eauto", + "debug trivial" or by a global "Set Debug Auto/Eauto/Trivial". +- New command "r string" that interprets "idtac string" as a breakpoint + and jumps to its next use in Ltac debugger. +- Tactics from the Dp plugin (simplify, ergo, yices, cvc3, z3, cvcl, + harvey, zenon, gwhy) have been removed, since Why2 has not been + maintained for the last few years. The Why3 plugin should be a suitable + replacement in most cases. + +Libraries + +- MSetRBT : a new implementation of MSets via Red-Black trees (initial + contribution by Andrew Appel). +- MSetAVL : for maximal sharing with the new MSetRBT, the argument order + of Node has changed (this should be transparent to regular MSets users). + +Module System + +- The names of modules (and module types) are now in a fully separated + namespace from ordinary definitions : "Definition E:=0. Module E. End E." + is now accepted. + +CoqIDE + +- Coqide now supports the Restart command, and Undo (with a warning). + Better support for Abort. + +Changes from V8.3 to V8.4beta +============================= Logic @@ -69,6 +118,8 @@ Tactics - When applying destruct or inversion on a fixpoint hiding an inductive type, recursive calls to the fixpoint now remain folded by default (rare source of incompatibility generally solvable by adding a call to simpl). +- The behavior of the simpl tactic can be tuned using the new "Arguments" + vernacular. Vernacular commands @@ -90,6 +141,7 @@ Vernacular commands to avoid conversion at Qed time to go into a very long computation. - New command "Show Goal ident" to display the statement of a goal, even a closed one (available from Proof General). +- New command "Arguments" subsuming "Implicit Arguments" and "Arguments Scope". Module System diff --git a/COPYRIGHT b/COPYRIGHT index 8d81d8c4..3aa6aae9 100644 --- a/COPYRIGHT +++ b/COPYRIGHT @@ -1,6 +1,6 @@ The Coq proof assistant -Copyright 1999-2010 The Coq development team, INRIA, CNRS, University +Copyright 1999-2012 The Coq development team, INRIA, CNRS, University Paris Sud, University Paris 7, Ecole Polytechnique. This product includes also software developed by diff --git a/CREDITS b/CREDITS index 53bd9e93..543cb3f3 100644 --- a/CREDITS +++ b/CREDITS @@ -106,6 +106,7 @@ The following people have contributed to the development of different versions of the Coq Proof assistant during the indicated time: Bruno Barras (INRIA, 1995-now) + Pierre Boutillier (INRIA-PPS, 2010-now) Jacek Chrzaszcz (LRI, 1998-2003) Thierry Coquand (INRIA, 1985-1989) Pierre Corbineau (LRI, 2003-2005, Nijmegen, 2005-2008, Grenoble 1, 2008-now) @@ -118,10 +119,12 @@ of the Coq Proof assistant during the indicated time: Amy Felty (INRIA, 1993) Jean-Christophe Filliâtre (ENS Lyon, 1994-1997, LRI, 1997-now) Eduardo Giménez (ENS Lyon, 1993-1996, INRIA, 1997-1998) + Stéphane Glondu (INRIA-PPS, 2007-now) Benjamin Grégoire (INRIA, 2003-now) Hugo Herbelin (INRIA, 1996-now) Gérard Huet (INRIA, 1985-1997) - Pierre Letouzey (LRI, 2000-2004 & PPS, 2005-now) + Pierre Letouzey (LRI, 2000-2004, PPS, 2005-2008, INRIA-PPS, 2009-now) + Patrick Loiseleur (Paris Sud, 1997-1999) Evgeny Makarov (INRIA, 2007) Pascal Manoury (INRIA, 1993) Micaela Mayero (INRIA, 1997-2002) @@ -132,9 +135,11 @@ of the Coq Proof assistant during the indicated time: Julien Narboux (INRIA, 2005-2006, Strasbourg, 2007-now) Jean-Marc Notin (CNRS, 2006-now) Catherine Parent-Vigouroux (ENS Lyon, 1992-1995) - Patrick Loiseleur (Paris Sud, 1997-1999) Christine Paulin-Mohring (INRIA, 1985-1989, ENS Lyon, 1989-1997, LRI, 1997-now) + Pierre-Marie Pédrot (INRIA-PPS, 2011-now) + Matthias Puech (INRIA-Bologna, 2008-now) + Yann Régis-Gianas (INRIA-PPS, 2009-now) Clément Renard (INRIA, 2001-2004) Claudio Sacerdoti Coen (INRIA, 2004-2005) Amokrane Saïbi (INRIA, 1993-1998) @@ -142,6 +147,7 @@ of the Coq Proof assistant during the indicated time: Élie Soubiran (INRIA, 2007-now) Matthieu Sozeau (INRIA, 2005-now) Arnaud Spiwack (INRIA, 2006-now) + Enrico Tassi (INRIA, 2011-now) Benjamin Werner (INRIA, 1989-1994) *************************************************************************** diff --git a/INSTALL b/INSTALL index e88dc319..5ee00613 100644 --- a/INSTALL +++ b/INSTALL @@ -39,9 +39,9 @@ WHAT DO YOU NEED ? urpmi coq - Should you need or prefer to compile Coq V8.2 yourself, you need: + Should you need or prefer to compile Coq V8.4 yourself, you need: - - Objective Caml version 3.10.0 or later + - Objective Caml version 3.11.2 or later (available at http://caml.inria.fr/) - Camlp5 (version <= 4.08, or 5.* transitional) @@ -87,7 +87,7 @@ QUICK INSTALLATION PROCEDURE. INSTALLATION PROCEDURE IN DETAILS (NORMAL USERS). ================================================= -1- Check that you have the Objective Caml compiler version 3.10.0 (or later) +1- Check that you have the Objective Caml compiler version 3.11.2 (or later) installed on your computer and that "ocamlmktop" and "ocamlc" (or its native code version "ocamlc.opt") lie in a directory which is present in your $PATH environment variable. diff --git a/Makefile b/Makefile index 876ac583..0ff72856 100644 --- a/Makefile +++ b/Makefile @@ -191,6 +191,7 @@ docclean: rm -f doc/common/version.tex rm -f doc/refman/styles.hva doc/refman/cover.html doc/refman/Reference-Manual.html rm -f doc/coq.tex + rm -f doc/refman/styles.hva doc/refman/cover.html archclean: clean-ide optclean voclean rm -rf _build myocamlbuild_config.ml @@ -221,7 +222,6 @@ cleanconfig: rm -f config/Makefile config/coq_config.ml dev/ocamldebug-v7 ide/undo.mli distclean: clean cleanconfig - $(MAKE) -C test-suite distclean voclean: rm -f states/*.coq diff --git a/Makefile.build b/Makefile.build index 59ee457c..41dfabbf 100644 --- a/Makefile.build +++ b/Makefile.build @@ -318,7 +318,7 @@ $(COQIDEOPT): $(LINKIDEOPT) | $(COQTOPOPT) $(STRIP) $@ $(COQIDEBYTE): $(LINKIDE) | $(COQTOPBYTE) - $(SHOW)'OCAMLOPT -o $@' + $(SHOW)'OCAMLC -o $@' $(HIDE)$(OCAMLC) $(COQIDEFLAGS) $(BYTEFLAGS) -o $@ unix.cma threads.cma lablgtk.cma gtkThread.cmo\ str.cma $(COQRUNBYTEFLAGS) $(LINKIDE) @@ -446,7 +446,7 @@ noreal: logic arith bool zarith qarith lists sets fsets relations \ # 3) plugins ########################################################################### -.PHONY: plugins omega micromega ring setoid_ring nsatz dp xml extraction +.PHONY: plugins omega micromega ring setoid_ring nsatz xml extraction .PHONY: field fourier funind cc subtac rtauto pluginsopt plugins: $(PLUGINSVO) @@ -455,7 +455,6 @@ micromega: $(MICROMEGAVO) $(MICROMEGACMA) $(CSDPCERT) ring: $(RINGVO) $(RINGCMA) setoid_ring: $(NEWRINGVO) $(NEWRINGCMA) nsatz: $(NSATZVO) $(NSATZCMA) -dp: $(DPCMA) xml: $(XMLVO) $(XMLCMA) extraction: $(EXTRACTIONCMA) field: $(FIELDVO) $(FIELDCMA) @@ -623,7 +622,7 @@ INSTALLCMI = $(sort \ install-library: $(MKDIR) $(FULLCOQLIB) - $(INSTALLSH) $(FULLCOQLIB) $(LIBFILES) $(PLUGINS) $(PLUGINSOPT) + $(INSTALLSH) $(FULLCOQLIB) $(LIBFILES) $(PLUGINS) $(MKDIR) $(FULLCOQLIB)/states $(INSTALLLIB) states/*.coq $(FULLCOQLIB)/states $(MKDIR) $(FULLCOQLIB)/user-contrib @@ -632,7 +631,7 @@ install-library: $(INSTALLSH) $(FULLCOQLIB) $(INSTALLCMI) ifeq ($(BEST),opt) $(INSTALLLIB) $(LIBCOQRUN) $(FULLCOQLIB) - $(INSTALLSH) $(FULLCOQLIB) $(CONFIG:.cmo=.cmx) $(CONFIG:.cmo=.o) $(LINKCMO:.cma=.cmxa) $(LINKCMO:.cma=.a) + $(INSTALLSH) $(FULLCOQLIB) $(CONFIG:.cmo=.cmx) $(CONFIG:.cmo=.o) $(LINKCMO:.cma=.cmxa) $(LINKCMO:.cma=.a) $(PLUGINSOPT) endif # csdpcert is not meant to be directly called by the user; we install # it with libraries @@ -643,11 +642,14 @@ endif install-library-light: $(MKDIR) $(FULLCOQLIB) - $(INSTALLSH) $(FULLCOQLIB) $(LIBFILESLIGHT) $(INITPLUGINS) $(INITPLUGINSOPT) + $(INSTALLSH) $(FULLCOQLIB) $(LIBFILESLIGHT) $(INITPLUGINS) $(MKDIR) $(FULLCOQLIB)/states $(INSTALLLIB) states/*.coq $(FULLCOQLIB)/states rm -f $(FULLCOQLIB)/revision -$(INSTALLLIB) revision $(FULLCOQLIB) +ifeq ($(BEST),opt) + $(INSTALLSH) $(FULLCOQLIB) $(INITPLUGINSOPT) +endif install-coq-info: install-coq-manpages install-emacs install-latex diff --git a/Makefile.common b/Makefile.common index b560bae5..3740b52e 100644 --- a/Makefile.common +++ b/Makefile.common @@ -79,7 +79,7 @@ SRCDIRS:=\ pretyping interp toplevel/utils toplevel parsing \ ide/utils ide \ $(addprefix plugins/, \ - omega romega micromega quote ring dp \ + omega romega micromega quote ring \ setoid_ring xml extraction fourier \ cc funind firstorder field subtac \ rtauto nsatz syntax decl_mode) @@ -125,14 +125,15 @@ REFMANCOQTEXFILES:=$(addprefix doc/refman/, \ RefMan-cic.v.tex RefMan-lib.v.tex \ RefMan-tacex.v.tex RefMan-syn.v.tex \ RefMan-oth.v.tex RefMan-ltac.v.tex \ - RefMan-decl.v.tex \ + RefMan-decl.v.tex RefMan-sch.v.tex \ + RefMan-pro.v.tex \ Cases.v.tex Coercion.v.tex Extraction.v.tex \ Program.v.tex Omega.v.tex Micromega.v.tex Polynom.v.tex Nsatz.v.tex \ Setoid.v.tex Helm.tex Classes.v.tex ) REFMANTEXFILES:=$(addprefix doc/refman/, \ headers.sty Reference-Manual.tex \ - RefMan-pre.tex RefMan-int.tex RefMan-pro.tex RefMan-com.tex \ + RefMan-pre.tex RefMan-int.tex RefMan-com.tex \ RefMan-uti.tex RefMan-ide.tex RefMan-add.tex RefMan-modr.tex ) \ $(REFMANCOQTEXFILES) \ @@ -176,7 +177,6 @@ QUOTECMA:=plugins/quote/quote_plugin.cma RINGCMA:=plugins/ring/ring_plugin.cma NEWRINGCMA:=plugins/setoid_ring/newring_plugin.cma NSATZCMA:=plugins/nsatz/nsatz_plugin.cma -DPCMA:=plugins/dp/dp_plugin.cma FIELDCMA:=plugins/field/field_plugin.cma XMLCMA:=plugins/xml/xml_plugin.cma FOURIERCMA:=plugins/fourier/fourier_plugin.cma @@ -196,14 +196,14 @@ OTHERSYNTAXCMA:=$(addprefix plugins/syntax/, \ DECLMODECMA:=plugins/decl_mode/decl_mode_plugin.cma PLUGINSCMA:=$(OMEGACMA) $(ROMEGACMA) $(MICROMEGACMA) $(DECLMODECMA) \ - $(QUOTECMA) $(RINGCMA) $(NEWRINGCMA) $(DPCMA) $(FIELDCMA) \ + $(QUOTECMA) $(RINGCMA) $(NEWRINGCMA) $(FIELDCMA) \ $(FOURIERCMA) $(EXTRACTIONCMA) $(XMLCMA) \ $(CCCMA) $(FOCMA) $(SUBTACCMA) $(RTAUTOCMA) \ $(FUNINDCMA) $(NSATZCMA) $(NATSYNTAXCMA) $(OTHERSYNTAXCMA) ifneq ($(HASNATDYNLINK),false) STATICPLUGINS:= - INITPLUGINS:=$(EXTRACTIONCMA) $(FOCMA) $(CCCMA) $(DPCMA) \ + INITPLUGINS:=$(EXTRACTIONCMA) $(FOCMA) $(CCCMA) \ $(XMLCMA) $(FUNINDCMA) $(SUBTACCMA) $(NATSYNTAXCMA) INITPLUGINSOPT:=$(INITPLUGINS:.cma=.cmxs) PLUGINS:=$(PLUGINSCMA) @@ -314,7 +314,6 @@ NEWRINGVO:=$(call cat_vo_itarget, plugins/setoid_ring) NSATZVO:=$(call cat_vo_itarget, plugins/nsatz) FOURIERVO:=$(call cat_vo_itarget, plugins/fourier) FUNINDVO:=$(call cat_vo_itarget, plugins/funind) -DPVO:=$(call cat_vo_itarget, plugins/dp) RTAUTOVO:=$(call cat_vo_itarget, plugins/rtauto) EXTRACTIONVO:=$(call cat_vo_itarget, plugins/extraction) XMLVO:= @@ -322,7 +321,7 @@ CCVO:= PLUGINSVO:= $(OMEGAVO) $(ROMEGAVO) $(MICROMEGAVO) $(RINGVO) $(FIELDVO) \ $(XMLVO) $(FOURIERVO) $(CCVO) $(FUNINDVO) \ - $(RTAUTOVO) $(NEWRINGVO) $(DPVO) $(QUOTEVO) \ + $(RTAUTOVO) $(NEWRINGVO) $(QUOTEVO) \ $(NSATZVO) $(EXTRACTIONVO) ALLVO:= $(THEORIESVO) $(PLUGINSVO) @@ -347,8 +346,6 @@ MANPAGES:=man/coq-tex.1 man/coqdep.1 man/gallina.1 \ man/coqwc.1 man/coqdoc.1 man/coqide.1 \ man/coq_makefile.1 man/coqmktop.1 man/coqchk.1 -DATE=$(shell LANG=C date +"%B %Y") - ########################################################################### # Source documentation ########################################################################### diff --git a/Makefile.doc b/Makefile.doc index 59eb2fe8..685887f5 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -12,7 +12,7 @@ ###################################################################### .PHONY: doc doc-html doc-pdf doc-ps refman refman-quick tutorial -.PHONY: stdlib full-stdlib faq rectutorial +.PHONY: stdlib full-stdlib faq rectutorial refman-html-dir INDEXURLS:=doc/refman/html/index_urls.txt @@ -126,14 +126,16 @@ doc/refman/styles.hva: doc/common/styles/html/$(HTMLSTYLE)/styles.hva INDEXES:= doc/refman/html/command-index.html doc/refman/html/tactic-index.html ALLINDEXES:= doc/refman/html/index.html $(INDEXES) -$(ALLINDEXES): doc/refman/Reference-Manual.html $(REFMANPNGFILES) \ +$(ALLINDEXES): refman-html-dir + +refman-html-dir: doc/refman/Reference-Manual.html $(REFMANPNGFILES) \ doc/refman/cover.html doc/refman/styles.hva doc/refman/index.html - rm -rf doc/refman/html $(MKDIR) doc/refman/html $(INSTALLLIB) $(REFMANPNGFILES) doc/refman/html (cd doc/refman/html; hacha -nolinks -tocbis -o toc.html ../styles.hva ../Reference-Manual.html) $(INSTALLLIB) doc/refman/cover.html doc/refman/html/index.html - $(INSTALLLIB) doc/common/styles/html/$(HTMLSTYLE)/*.css doc/refman/html + -$(INSTALLLIB) doc/common/styles/html/$(HTMLSTYLE)/*.css doc/refman/html refman-quick: (cd doc/refman;\ @@ -200,40 +202,32 @@ doc/faq/html/index.html: doc/faq/FAQ.v.html ### Standard library (browsable html format) ifdef QUICK -doc/stdlib/index-body.html: - - rm -rf doc/stdlib/html - $(MKDIR) doc/stdlib/html - $(COQDOC) -q -boot -d doc/stdlib/html --multi-index --html -g --utf8 \ - -R theories Coq $(THEORIESVO:.vo=.v) - mv doc/stdlib/html/index.html doc/stdlib/index-body.html +doc/stdlib/html/genindex.html: else -doc/stdlib/index-body.html: $(COQDOC) $(THEORIESVO) +doc/stdlib/html/genindex.html: | $(COQDOC) $(THEORIESVO) +endif - rm -rf doc/stdlib/html $(MKDIR) doc/stdlib/html - $(COQDOC) -q -boot -d doc/stdlib/html --multi-index --html -g --utf8 \ + $(COQDOC) -q -d doc/stdlib/html --with-header doc/common/styles/html/$(HTMLSTYLE)/header.html --with-footer doc/common/styles/html/$(HTMLSTYLE)/footer.html --multi-index --html -g \ -R theories Coq $(THEORIESVO:.vo=.v) - mv doc/stdlib/html/index.html doc/stdlib/index-body.html -endif + mv doc/stdlib/html/index.html doc/stdlib/html/genindex.html doc/stdlib/index-list.html: doc/stdlib/index-list.html.template doc/stdlib/make-library-index - ./doc/stdlib/make-library-index doc/stdlib/index-list.html + ./doc/stdlib/make-library-index doc/stdlib/index-list.html doc/stdlib/hidden-files -doc/stdlib/html/index.html: doc/stdlib/index-list.html doc/stdlib/index-body.html doc/stdlib/index-trailer.html - cat doc/stdlib/index-list.html > $@ - sed -n -e '//,/<\/table>/p' doc/stdlib/index-body.html >> $@ - cat doc/stdlib/index-trailer.html >> $@ +doc/stdlib/html/index.html: doc/stdlib/html/genindex.html doc/stdlib/index-list.html + cat doc/common/styles/html/$(HTMLSTYLE)/header.html doc/stdlib/index-list.html > $@ + cat doc/common/styles/html/$(HTMLSTYLE)/footer.html >> $@ ### Standard library (light version, full version is definitely too big) ifdef QUICK doc/stdlib/Library.coqdoc.tex: - $(COQDOC) -q -boot --gallina --body-only --latex --stdout --utf8 \ - -R theories Coq $(THEORIESLIGHTVO:.vo=.v) > $@ else -doc/stdlib/Library.coqdoc.tex: $(COQDOC) $(THEORIESLIGHTVO) - $(COQDOC) -q -boot --gallina --body-only --latex --stdout --utf8 \ - -R theories Coq $(THEORIESLIGHTVO:.vo=.v) > $@ +doc/stdlib/Library.coqdoc.tex: | $(COQDOC) $(THEORIESLIGHTVO) endif + $(COQDOC) -q -boot --gallina --body-only --latex --stdout \ + -R theories Coq $(THEORIESLIGHTVO:.vo=.v) >> $@ doc/stdlib/Library.dvi: $(DOCCOMMON) doc/stdlib/Library.coqdoc.tex doc/stdlib/Library.tex (cd doc/stdlib;\ @@ -255,12 +249,12 @@ ifdef QUICK doc/stdlib/FullLibrary.coqdoc.tex: $(COQDOC) -q -boot --gallina --body-only --latex --stdout --utf8 \ -R theories Coq $(THEORIESVO:.vo=.v) > $@ - sed -i "" -e 's///g' $@ + sed -i.tmp -e 's///g' $@ && rm $@.tmp else doc/stdlib/FullLibrary.coqdoc.tex: $(COQDOC) $(THEORIESVO) $(COQDOC) -q -boot --gallina --body-only --latex --stdout --utf8 \ -R theories Coq $(THEORIESVO:.vo=.v) > $@ - sed -i "" -e 's///g' $@ + sed -i.tmp -e 's///g' $@ && rm $@.tmp endif doc/stdlib/FullLibrary.dvi: $(DOCCOMMON) doc/stdlib/FullLibrary.coqdoc.tex doc/stdlib/FullLibrary.tex diff --git a/README b/README index 4f4afa5b..9bf63c43 100644 --- a/README +++ b/README @@ -38,7 +38,7 @@ THE COQ CLUB. discuss questions about the Coq system and related topics. The submission address is: - coq-club@coq.inria.fr + coq-club@inria.fr The topics to be discussed in the club should include: @@ -55,7 +55,7 @@ THE COQ CLUB. To be added to, or removed from, the mailing list, please write to: - coq-club-request@coq.inria.fr + coq-club-request@inria.fr Please use also this address for any questions/suggestions about the Coq Club. It might sometimes take a few days before your messages get @@ -67,7 +67,7 @@ BUGS REPORT. Send your bug reports by filling a form at - http://logical.saclay.inria.fr/coq-bugs + http://coq.inria.fr/bugs To be effective, bug reports should mention the Caml version used to compile and run Coq, the Coq version (coqtop -v), the configuration diff --git a/TODO b/TODO deleted file mode 100644 index d6891e5f..00000000 --- a/TODO +++ /dev/null @@ -1,53 +0,0 @@ -Langage: - -Distribution: - -Environnement: - -- Porter SearchIsos - -Noyau: - -Tactic: - -- Que contradiction raisonne a isomorphisme pres de False - -Vernac: - -- Print / Print Proof en fait identiques ; Print ne devrait pas afficher - les constantes opaques (devrait afficher qqchose comme ) - -Theories: - -- Rendre transparent tous les theoremes prouvant {A}+{B} -- Faire demarrer PolyList.nth a` l'indice 0 - Renommer l'actuel nth en nth1 ?? - -Doc: - -- Mettre à jour les messages d'erreurs de Discriminate/Simplify_eq/Injection -- Documenter le filtrage sur les types inductifs avec let-ins (dont la - compatibilite V6) - -- Ajouter let dans les règles du CIC - -> FAIT, mais reste a documenter le let dans les inductifs - et les champs manifestes dans les Record -- revoir le chapitre sur les tactiques utilisateur -- faut-il mieux spécifier la sémantique de Simpl (??) - -- Préciser la clarification syntaxique de IntroPattern -- preciser que Goal vient en dernier dans une clause pattern list et - qu'il doit apparaitre si il y a un "in" - -- Omega Time debranche mais Omega System et Omega Action remarchent ? -- Ajout "Replace in" (mais TODO) -- Syntaxe Conditional tac Rewrite marche, à documenter -- Documenter Dependent Rewrite et CutRewrite ? -- Ajouter les motifs sous-termes de ltac - -- ajouter doc de GenFixpoint (mais avant: changer syntaxe) (J. Forest ou Pierre C.) -- mettre à jour la doc de induction (arguments multiples) (Pierre C.) -- mettre à jour la doc de functional induction/scheme (J. Forest ou Pierre C.) ---> mettre à jour le CHANGES (vers la ligne 72) - - diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml index 9942816d..e3431fec 100644 --- a/checker/mod_checking.ml +++ b/checker/mod_checking.ml @@ -53,10 +53,14 @@ let path_of_mexpr = function | SEBident mp -> mp | _ -> raise Not_path -let rec list_split_assoc k rev_before = function +let is_modular = function + | SFBmodule _ | SFBmodtype _ -> true + | SFBconst _ | SFBmind _ -> false + +let rec list_split_assoc ((k,m) as km) rev_before = function | [] -> raise Not_found - | (k',b)::after when k=k' -> rev_before,b,after - | h::tail -> list_split_assoc k (h::rev_before) tail + | (k',b)::after when k=k' && is_modular b = m -> rev_before,b,after + | h::tail -> list_split_assoc km (h::rev_before) tail let check_definition_sub env cb1 cb2 = let check_type env t1 t2 = @@ -131,38 +135,35 @@ let lookup_modtype mp env = let rec check_with env mtb with_decl mp= match with_decl with - | With_definition_body _ -> - check_with_aux_def env mtb with_decl mp; + | With_definition_body (idl,c) -> + check_with_def env mtb (idl,c) mp; mtb - | With_module_body _ -> - check_with_aux_mod env mtb with_decl mp; + | With_module_body (idl,mp1) -> + check_with_mod env mtb (idl,mp1) mp; mtb -and check_with_aux_def env mtb with_decl mp = +and check_with_def env mtb (idl,c) mp = let sig_b = match mtb with | SEBstruct(sig_b) -> sig_b | _ -> error_signature_expected mtb in - let id,idl = match with_decl with - | With_definition_body (id::idl,_) | With_module_body (id::idl,_) -> - id,idl - | With_definition_body ([],_) | With_module_body ([],_) -> assert false + let id,idl = match idl with + | [] -> assert false + | id::idl -> id,idl in let l = label_of_id id in try - let rev_before,spec,after = list_split_assoc l [] sig_b in + let rev_before,spec,after = list_split_assoc (l,(idl<>[])) [] sig_b in let before = List.rev rev_before in let env' = Modops.add_signature mp before empty_delta_resolver env in - match with_decl with - | With_definition_body ([],_) -> assert false - | With_definition_body ([id],c) -> + if idl = [] then let cb = match spec with SFBconst cb -> cb | _ -> error_not_a_constant l in check_definition_sub env' c cb - | With_definition_body (_::_,_) -> + else let old = match spec with SFBmodule msb -> msb | _ -> error_not_a_module l @@ -170,49 +171,36 @@ and check_with_aux_def env mtb with_decl mp = begin match old.mod_expr with | None -> - let new_with_decl = match with_decl with - With_definition_body (_,c) -> - With_definition_body (idl,c) - | With_module_body (_,c) -> - With_module_body (idl,c) in - check_with_aux_def env' old.mod_type new_with_decl (MPdot(mp,l)) + check_with_def env' old.mod_type (idl,c) (MPdot(mp,l)) | Some msb -> error_a_generative_module_expected l end - | _ -> anomaly "Modtyping:incorrect use of with" with Not_found -> error_no_such_label l | Reduction.NotConvertible -> error_with_incorrect l -and check_with_aux_mod env mtb with_decl mp = +and check_with_mod env mtb (idl,mp1) mp = let sig_b = match mtb with | SEBstruct(sig_b) -> sig_b | _ -> error_signature_expected mtb in - let id,idl = match with_decl with - | With_definition_body (id::idl,_) | With_module_body (id::idl,_) -> - id,idl - | With_definition_body ([],_) | With_module_body ([],_) -> assert false + let id,idl = match idl with + | [] -> assert false + | id::idl -> id,idl in let l = label_of_id id in try - let rev_before,spec,after = list_split_assoc l [] sig_b in + let rev_before,spec,after = list_split_assoc (l,false) [] sig_b in let before = List.rev rev_before in - let rec mp_rec = function - | [] -> mp - | i::r -> MPdot(mp_rec r,label_of_id i) - in let env' = Modops.add_signature mp before empty_delta_resolver env in - match with_decl with - | With_module_body ([],_) -> assert false - | With_module_body ([id], mp1) -> + if idl = [] then let _ = match spec with SFBmodule msb -> msb | _ -> error_not_a_module l in let (_:module_body) = (lookup_module mp1 env) in () - | With_module_body (_::_,mp) -> + else let old = match spec with SFBmodule msb -> msb | _ -> error_not_a_module l @@ -220,17 +208,11 @@ and check_with_aux_mod env mtb with_decl mp = begin match old.mod_expr with None -> - let new_with_decl = match with_decl with - With_definition_body (_,c) -> - With_definition_body (idl,c) - | With_module_body (_,c) -> - With_module_body (idl,c) in - check_with_aux_mod env' - old.mod_type new_with_decl (MPdot(mp,l)) + check_with_mod env' + old.mod_type (idl,mp1) (MPdot(mp,l)) | Some msb -> error_a_generative_module_expected l end - | _ -> anomaly "Modtyping:incorrect use of with" with Not_found -> error_no_such_label l | Reduction.NotConvertible -> error_with_incorrect l diff --git a/checker/subtyping.ml b/checker/subtyping.ml index 0c97254b..9870ba13 100644 --- a/checker/subtyping.ml +++ b/checker/subtyping.ml @@ -28,15 +28,18 @@ type namedobject = | Constant of constant_body | IndType of inductive * mutual_inductive_body | IndConstr of constructor * mutual_inductive_body + +type namedmodule = | Module of module_body | Modtype of module_type_body (* adds above information about one mutual inductive: all types and constructors *) -let add_nameobjects_of_mib ln mib map = - let add_nameobjects_of_one j oib map = - let ip = (ln,j) in +let add_mib_nameobjects mp l mib map = + let ind = make_mind mp empty_dirpath l in + let add_mip_nameobjects j oib map = + let ip = (ind,j) in let map = array_fold_right_i (fun i id map -> @@ -46,22 +49,32 @@ let add_nameobjects_of_mib ln mib map = in Labmap.add (label_of_id oib.mind_typename) (IndType (ip, mib)) map in - array_fold_right_i add_nameobjects_of_one mib.mind_packets map + array_fold_right_i add_mip_nameobjects mib.mind_packets map + + +(* creates (namedobject/namedmodule) map for the whole signature *) +type labmap = { objs : namedobject Labmap.t; mods : namedmodule Labmap.t } -(* creates namedobject map for the whole signature *) +let empty_labmap = { objs = Labmap.empty; mods = Labmap.empty } -let make_label_map mp list = +let get_obj mp map l = + try Labmap.find l map.objs + with Not_found -> error_no_such_label_sub l mp + +let get_mod mp map l = + try Labmap.find l map.mods + with Not_found -> error_no_such_label_sub l mp + +let make_labmap mp list = let add_one (l,e) map = - let add_map obj = Labmap.add l obj map in match e with - | SFBconst cb -> add_map (Constant cb) - | SFBmind mib -> - add_nameobjects_of_mib (make_mind mp empty_dirpath l) mib map - | SFBmodule mb -> add_map (Module mb) - | SFBmodtype mtb -> add_map (Modtype mtb) + | SFBconst cb -> { map with objs = Labmap.add l (Constant cb) map.objs } + | SFBmind mib -> { map with objs = add_mib_nameobjects mp l mib map.objs } + | SFBmodule mb -> { map with mods = Labmap.add l (Module mb) map.mods } + | SFBmodtype mtb -> { map with mods = Labmap.add l (Modtype mtb) map.mods } in - List.fold_right add_one list Labmap.empty + List.fold_right add_one list empty_labmap let check_conv_error error f env a1 a2 = @@ -282,7 +295,6 @@ let check_constant env mp1 l info1 cb2 spec2 subst1 subst2 = let ty1 = type_of_constructor cstr (mind1,mind1.mind_packets.(i)) in let ty2 = Typeops.type_of_constant_type env cb2.const_type in check_conv conv env ty1 ty2 - | _ -> error () let rec check_modules env msb1 msb2 subst1 subst2 = let mty1 = module_type_of_module None msb1 in @@ -291,29 +303,25 @@ let rec check_modules env msb1 msb2 subst1 subst2 = and check_signatures env mp1 sig1 sig2 subst1 subst2 = - let map1 = make_label_map mp1 sig1 in + let map1 = make_labmap mp1 sig1 in let check_one_body (l,spec2) = - let info1 = - try - Labmap.find l map1 - with - Not_found -> error_no_such_label_sub l mp1 - in match spec2 with | SFBconst cb2 -> - check_constant env mp1 l info1 cb2 spec2 subst1 subst2 + check_constant env mp1 l (get_obj mp1 map1 l) + cb2 spec2 subst1 subst2 | SFBmind mib2 -> - check_inductive env mp1 l info1 mib2 spec2 subst1 subst2 + check_inductive env mp1 l (get_obj mp1 map1 l) + mib2 spec2 subst1 subst2 | SFBmodule msb2 -> begin - match info1 with + match get_mod mp1 map1 l with | Module msb -> check_modules env msb msb2 subst1 subst2 | _ -> error_not_match l spec2 end | SFBmodtype mtb2 -> let mtb1 = - match info1 with + match get_mod mp1 map1 l with | Modtype mtb -> mtb | _ -> error_not_match l spec2 in diff --git a/configure b/configure index 867ee935..44170b99 100755 --- a/configure +++ b/configure @@ -6,10 +6,10 @@ # ################################## -VERSION=8.4beta +VERSION=8.4beta2 VOMAGIC=08400 STATEMAGIC=58400 -DATE="December 2011" +DATE=`LC_ALL=C LANG=C date +"%B %Y"` # Create the bin/ directory if non-existent test -d bin || mkdir bin @@ -292,7 +292,7 @@ case $DATEPGM in "") echo "I can't find the program \"date\" in your path." echo "Please give me the current date" read COMPILEDATE;; - *) COMPILEDATE=`date +"%h %d %Y %H:%M:%S"`;; + *) COMPILEDATE=`LC_ALL=C LANG=C date +"%h %d %Y %H:%M:%S"`;; esac # Architecture @@ -388,7 +388,7 @@ fi if [ "$browser_spec" = "no" ]; then case $ARCH in - win32) BROWSER='C:\PROGRA~1\INTERN~1\IEXPLORE %s' ;; + win32) BROWSER='start %s' ;; Darwin) BROWSER='open %s' ;; *) BROWSER='firefox -remote "OpenURL(%s,new-tab)" || firefox %s &' ;; esac @@ -445,16 +445,16 @@ esac CAMLVERSION=`"$bytecamlc" -version` case $CAMLVERSION in - 1.*|2.*|3.0*) + 1.*|2.*|3.0*|3.10*|3.11.[01]) echo "Your version of Objective-Caml is $CAMLVERSION." if [ "$force_caml_version" = "yes" ]; then echo "*Warning* You are compiling Coq with an outdated version of Objective-Caml." else - echo " You need Objective-Caml 3.10.0 or later." + echo " You need Objective-Caml 3.11.2 or later." echo " Configuration script failed!" exit 1 fi;; - 3.1*) + 3.11.2|3.12*) CAMLP4COMPAT="-loc loc" echo "You have Objective-Caml $CAMLVERSION. Good!";; *) @@ -742,7 +742,7 @@ case $ARCH$CYGWIN in bindir_def=${W32PREF}bin libdir_def=${W32PREF}lib configdir_def=${W32PREF}config - datadir_def=${W32PREF}data + datadir_def=${W32PREF}share mandir_def=${W32PREF}man docdir_def=${W32PREF}doc emacslib_def=${W32PREF}emacs @@ -795,10 +795,15 @@ case $libdir_spec in *) LIBDIR_OPTION="None";; esac -case $configdir_spec/$local in - yes/*) CONFIGDIR=$configdir;; - */true) CONFIGDIR=$COQTOP/ide - configdir_spec=yes;; +case $configdir_spec/$prefix_spec/$local in + yes/*/*) CONFIGDIR=$configdir;; + */yes/*) configdir_spec=yes + case $ARCH in + win32) CONFIGDIR=$prefix/config;; + *) CONFIGDIR=$prefix/etc/xdg/coq;; + esac;; + */*/true) CONFIGDIR=$COQTOP/ide + configdir_spec=yes;; *) printf "Where should I install the Coqide configuration files [$configdir_def]? " read CONFIGDIR case $CONFIGDIR in diff --git a/dev/base_include b/dev/base_include index d1125965..ad2a3aec 100644 --- a/dev/base_include +++ b/dev/base_include @@ -123,7 +123,6 @@ open Decl_mode open Auto open Autorewrite open Contradiction -open Dhyp open Eauto open Elim open Equality @@ -199,6 +198,11 @@ let current_goal () = get_nth_goal 1;; let pf_e gl s = Constrintern.interp_constr (project gl) (pf_env gl) (parse_constr s);; +(* Set usual printing since the global env is available from the tracer *) +let _ = Constrextern.in_debugger := false +let _ = Constrextern.set_debug_global_reference_printer + (fun loc r -> Libnames.Qualid (loc,Nametab.shortest_qualid_of_global Idset.empty r));; + open Toplevel let go = loop diff --git a/dev/printers.mllib b/dev/printers.mllib index 6a42678e..40a5a822 100644 --- a/dev/printers.mllib +++ b/dev/printers.mllib @@ -105,12 +105,12 @@ Notation Dumpglob Reserve Impargs -Constrextern Syntax_def Implicit_quantifiers Smartlocate Constrintern Modintern +Constrextern Tacexpr Proof_type Goal diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 3fc90761..3116cbf2 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -487,5 +487,9 @@ let short_string_of_ref loc = function [id_of_label (pi3 (repr_mind kn));id_of_string ("_"^string_of_int i)] (id_of_string ("_"^string_of_int j)) +(* Anticipate that printers can be used from ocamldebug and that + pretty-printer should not make calls to the global env since ocamldebug + runs in a different process and does not have the proper env at hand *) +let _ = Constrextern.in_debugger := true let _ = Constrextern.set_debug_global_reference_printer (if !rawdebug then raw_string_of_ref else short_string_of_ref) diff --git a/doc/common/macros.tex b/doc/common/macros.tex index f0fb0883..ce998a9b 100755 --- a/doc/common/macros.tex +++ b/doc/common/macros.tex @@ -206,6 +206,7 @@ %END LATEX %HEVEA \renewcommand{\proof}{\nterm{proof}} \newcommand{\record}{\nterm{record}} +\newcommand{\recordkw}{\nterm{record\_keyword}} \newcommand{\rewrule}{\nterm{rewriting\_rule}} \newcommand{\sentence}{\nterm{sentence}} \newcommand{\simplepattern}{\nterm{simple\_pattern}} diff --git a/doc/common/styles/html/coqremote/cover.html b/doc/common/styles/html/coqremote/cover.html index f4809a48..62ee00ac 100644 --- a/doc/common/styles/html/coqremote/cover.html +++ b/doc/common/styles/html/coqremote/cover.html @@ -27,7 +27,6 @@
  • Home
    • -
  • About Coq
  • Get Coq
  • Documentation
    • @@ -64,9 +63,11 @@
    • V7.x © INRIA 1999-2004
      • -
    • V8.0 © INRIA 2004-2006
      • -
    • V8.1 © INRIA 2006-2008
      • -
    • V8.2 © INRIA 2008-2009
      • +
    • V8.0 © INRIA 2004-2008
      • +
    • V8.1 © INRIA 2006-2011
      • +
    • V8.2 © INRIA 2008-2011
      • +
    • V8.3 © INRIA 2010-2011
      • +
    • V8.4 © INRIA 2012

    This material may be distributed only subject to the terms and conditions set forth in the Open Publication License, v1.0 or later (the latest version is presently available at http://www.opencontent.org/openpub). Options A and B are not elected.

    diff --git a/doc/common/styles/html/coqremote/footer.html b/doc/common/styles/html/coqremote/footer.html new file mode 100644 index 00000000..138c3025 --- /dev/null +++ b/doc/common/styles/html/coqremote/footer.html @@ -0,0 +1,45 @@ +
    + +
    + + +
    + + + + + + + + + + diff --git a/doc/common/styles/html/coqremote/header.html b/doc/common/styles/html/coqremote/header.html new file mode 100644 index 00000000..afcdbe73 --- /dev/null +++ b/doc/common/styles/html/coqremote/header.html @@ -0,0 +1,49 @@ + + + + + +Standard Library | The Coq Proof Assistant + + + + + + + + + + + + + + + +
    + + + + +
    + diff --git a/doc/common/styles/html/simple/cover.html b/doc/common/styles/html/simple/cover.html index 75b938f9..39dfd4ab 100644 --- a/doc/common/styles/html/simple/cover.html +++ b/doc/common/styles/html/simple/cover.html @@ -25,7 +25,7 @@

    Reference Manual

    - Version 8.21

    + Version 8.41





    The Coq Development Team

    @@ -35,9 +35,11 @@
    • V7.x © INRIA 1999-2004
      • -
    • V8.0 © INRIA 2004-2006
      • -
    • V8.1 © INRIA 2006-2008
      • -
    • V8.2 © INRIA 2008-2009
      • +
    • V8.0 © INRIA 2004-2008
      • +
    • V8.1 © INRIA 2006-2011
      • +
    • V8.2 © INRIA 2008-2011
      • +
    • V8.3 © INRIA 2010-2011
      • +
    • V8.4 © INRIA 2012

    This material may be distributed only subject to the terms and conditions set forth in the Open Publication License, v1.0 or later (the latest version is presently available at http://www.opencontent.org/openpub). Options A and B are not elected.

    diff --git a/doc/common/styles/html/simple/footer.html b/doc/common/styles/html/simple/footer.html new file mode 100644 index 00000000..308b1d01 --- /dev/null +++ b/doc/common/styles/html/simple/footer.html @@ -0,0 +1,2 @@ + + diff --git a/doc/common/styles/html/simple/header.html b/doc/common/styles/html/simple/header.html new file mode 100644 index 00000000..14d2f988 --- /dev/null +++ b/doc/common/styles/html/simple/header.html @@ -0,0 +1,13 @@ + + + + + + +The Coq Standard Library + + + + diff --git a/doc/common/title.tex b/doc/common/title.tex index 1dc52432..809b1046 100755 --- a/doc/common/title.tex +++ b/doc/common/title.tex @@ -45,7 +45,7 @@ V\coqversion, \today %END LATEX \copyright INRIA 1999-2004 ({\Coq} versions 7.x) -\copyright INRIA 2004-2009 ({\Coq} versions 8.x) +\copyright INRIA 2004-2012 ({\Coq} versions 8.x) #3 \end{flushleft} diff --git a/doc/faq/FAQ.tex b/doc/faq/FAQ.tex index c0f8c087..0bd84992 100644 --- a/doc/faq/FAQ.tex +++ b/doc/faq/FAQ.tex @@ -379,15 +379,15 @@ This FAQ is unfinished (in the sense that there are some obvious sections that are missing). Please send contributions to Coq-Club. \Question{Is there any mailing list about {\Coq}?} -The main {\Coq} mailing list is \url{coq-club@pauillac.inria.fr}, which +The main {\Coq} mailing list is \url{coq-club@inria.fr}, which broadcasts questions and suggestions about the implementation, the logical formalism or proof developments. See -\ahref{http://coq.inria.fr/mailman/listinfo/coq-club}{\url{http://pauillac.inria.fr/mailman/listinfo/coq-club}} for +\ahref{http://coq.inria.fr/mailman/listinfo/coq-club}{\url{http://sympa-roc.inria.fr/wws/info/coq-club}} for subscription. For bugs reports see question \ref{coqbug}. \Question{Where can I find an archive of the list?} The archives of the {\Coq} mailing list are available at -\ahref{http://pauillac.inria.fr/pipermail/coq-club}{\url{http://coq.inria.fr/pipermail/coq-club}}. +\ahref{http://pauillac.inria.fr/pipermail/coq-club}{\url{http://sympa-roc.inria.fr/wws/arc/coq-club}}. \Question{How can I be kept informed of new releases of {\Coq}?} diff --git a/doc/refman/Cases.tex b/doc/refman/Cases.tex index 6f58269f..3ff4e25d 100644 --- a/doc/refman/Cases.tex +++ b/doc/refman/Cases.tex @@ -14,7 +14,7 @@ This section describes the full form of pattern-matching in {\Coq} terms. match} is presented in Figures~\ref{term-syntax} and~\ref{term-syntax-aux}. Identifiers in patterns are either constructor names or variables. Any identifier that is not the -constructor of an inductive or coinductive type is considered to be a +constructor of an inductive or co-inductive type is considered to be a variable. A variable name cannot occur more than once in a given pattern. It is recommended to start variable names by a lowercase letter. diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 9660a04b..6a132eba 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -41,7 +41,7 @@ The beginner can skip them. The reader seeking a background on the Calculus of Inductive Constructions may read several papers. Giménez and Castéran~\cite{GimCas05} provide -an introduction to inductive and coinductive definitions in Coq. In +an introduction to inductive and co-inductive definitions in Coq. In their book~\cite{CoqArt}, Bertot and Castéran give a precise description of the \CIC{} based on numerous practical examples. Barras~\cite{Bar99}, Werner~\cite{Wer94} and @@ -80,35 +80,48 @@ type $(P~n)$ and consequently represent proofs of the formula \subsection[Sorts]{Sorts\label{Sorts} \index{Sorts}} -Types are seen as terms of the language and then should belong to -another type. The type of a type is always a constant of the language -called a {\em sort}. - -The two basic sorts in the language of \CIC\ are \Set\ and \Prop. - -The sort \Prop\ intends to be the type of logical propositions. If -$M$ is a logical proposition then it denotes a class, namely the class -of terms representing proofs of $M$. An object $m$ belonging to $M$ -witnesses the fact that $M$ is true. An object of type \Prop\ is -called a {\em proposition}. - -The sort \Set\ intends to be the type of specifications. This includes -programs and the usual sets such as booleans, naturals, lists -etc. - -These sorts themselves can be manipulated as ordinary terms. -Consequently sorts also should be given a type. Because assuming -simply that \Set\ has type \Set\ leads to an inconsistent theory, we -have infinitely many sorts in the language of \CIC. These are, in -addition to \Set\ and \Prop\, a hierarchy of universes \Type$(i)$ -for any integer $i$. We call \Sort\ the set of sorts -which is defined by: +When manipulated as terms, types have themselves a type which is called a sort. + +There is an infinite well-founded typing hierarchy of sorts whose base +sorts are {\Prop} and {\Set}. + +The sort {\Prop} intends to be the type of logical propositions. If +$M$ is a logical proposition then it denotes the class of terms +representing proofs of $M$. An object $m$ belonging to $M$ witnesses +the fact that $M$ is provable. An object of type {\Prop} is called a +proposition. + +The sort {\Set} intends to be the type of small sets. This includes data +types such as booleans and naturals, but also products, subsets, and +function types over these data types. + +{\Prop} and {\Set} themselves can be manipulated as ordinary +terms. Consequently they also have a type. Because assuming simply +that {\Set} has type {\Set} leads to an inconsistent theory, the +language of {\CIC} has infinitely many sorts. There are, in addition +to {\Set} and {\Prop} a hierarchy of universes {\Type$(i)$} for any +integer $i$. + +Like {\Set}, all of the sorts {\Type$(i)$} contain small sets such as +booleans, natural numbers, as well as products, subsets and function +types over small sets. But, unlike {\Set}, they also contain large +sets, namely the sorts {\Set} and {\Type$(j)$} for $j! \emph{$id_i$} \verb!! - -Where: - -\begin{itemize} -\item \emph{$id_i$} is the name of the current proof (if there is - one, otherwise \texttt{Coq} is displayed, see -Chapter~\ref{Proof-handling}). -\item $\num_1$ is the environment state number after the last - command. -\item $\num_2$ is the proof state number after the last - command. -\item $id_1$ $id_2$ {\dots} $id_n$ are the currently opened proof names - (order not significant). +\item $\num_1$: State label to reach, as for {\tt BackTo}. \end{itemize} - -It is then possible to compute the \texttt{Backtrack} command to -unbury the state corresponding to a particular prompt. For example, -suppose the current prompt is: - -\verb!! - -and we want to backtrack to a state labeled by: - -\verb!! - -We have to perform \verb!Backtrack 32 12 2! , i.e. perform 2 -\texttt{Abort}s (to cancel goal4 and goal3), then rewind proof until -state 12 and finally go back to environment state 32. Notice that this -supposes that proofs are nested in a regular way (no \texttt{Resume} or -\texttt{Suspend} commands). - -\begin{Variants} -\item {\tt BackTo n}. \comindex{BackTo}\\ - Is a more basic form of \texttt{Backtrack} where only the first - argument (global environment number) is given, no \texttt{abort} and - no \texttt{Undo} is performed. \end{Variants} -\subsection[\tt Restore State \str.]{\tt Restore State \str.\comindex{Restore State}} - Restores the state contained in the file \str. +\begin{ErrMsgs} +\item \errindex{Invalid backtrack} \\ + The destination state label is unknown. +\end{ErrMsgs} -\begin{Variants} -\item {\tt Restore State \ident}\\ - Equivalent to {\tt Restore State "}{\ident}{\tt .coq"}. -\item {\tt Reset Initial.}\comindex{Reset Initial}\\ - Goes back to the initial state (like after the command {\tt coqtop}, - when the interactive session began). This command is only available - interactively. -\end{Variants} +\section{State files} \subsection[\tt Write State \str.]{\tt Write State \str.\comindex{Write State}} Writes the current state into a file \str{} for @@ -870,6 +836,14 @@ use in a further session. This file can be given as the {\tt The state is saved in the current directory (see Section~\ref{Pwd}). \end{Variants} +\subsection[\tt Restore State \str.]{\tt Restore State \str.\comindex{Restore State}} + Restores the state contained in the file \str. + +\begin{Variants} +\item {\tt Restore State \ident}\\ + Equivalent to {\tt Restore State "}{\ident}{\tt .coq"}. +\end{Variants} + \section{Quitting and debugging} \subsection[\tt Quit.]{\tt Quit.\comindex{Quit}} diff --git a/doc/refman/RefMan-pro.tex b/doc/refman/RefMan-pro.tex index e5dc669d..ca3a9cc9 100644 --- a/doc/refman/RefMan-pro.tex +++ b/doc/refman/RefMan-pro.tex @@ -34,9 +34,6 @@ isomorphism} \cite{How80,Bar91,Gir89,Hue89}, \Coq~ stores proofs as terms of {\sc Cic}. Those terms are called {\em proof terms}\index{Proof term}. -It is possible to edit several proofs in parallel: see Section -\ref{Resume}. - \ErrMsg When one attempts to use a proof editing command out of the proof editing mode, \Coq~ raises the error message : \errindex{No focused proof}. @@ -173,35 +170,6 @@ proof was edited. \end{Variants} -%%%% -\subsection[\tt Suspend.]{\tt Suspend.\comindex{Suspend}} - -This command applies in proof editing mode. It switches back to the -\Coq\ toplevel, but without canceling the current proofs. - -%%%% -\subsection[\tt Resume.]{\tt Resume.\comindex{Resume}\label{Resume}} - -This commands switches back to the editing of the last edited proof. - -\begin{ErrMsgs} -\item \errindex{No proof-editing in progress} -\end{ErrMsgs} - -\begin{Variants} - -\item {\tt Resume {\ident}.} - - Restarts the editing of the proof named {\ident}. This can be used - to navigate between currently edited proofs. - -\end{Variants} - -\begin{ErrMsgs} -\item \errindex{No such proof} -\end{ErrMsgs} - - %%%% \subsection[\tt Existential {\num} := {\term}.]{\tt Existential {\num} := {\term}.\comindex{Existential} \label{Existential}} @@ -216,7 +184,14 @@ existential variables remain. To instantiate existential variables during proof edition, you should use the tactic {\tt instantiate}. \SeeAlso {\tt instantiate (\num:= \term).} in Section~\ref{instantiate}. +\SeeAlso {\tt Grab Existential Variables.} below. + +\subsection[\tt Grab Existential Variables.]{\tt Grab Existential Variables.\comindex{Grab Existential Variables} +\label{GrabEvars}} +This command can be run when a proof has no more goal to be solved but has remaining +uninstantiated existential variables. It takes every uninstantiated existential variable +and turns it into a goal. %%%%%%%% \section{Navigation in the proof tree} @@ -259,7 +234,45 @@ This focuses the attention on the $\num^{th}$ subgoal to prove. \end{Variant} \subsection[\tt Unfocus.]{\tt Unfocus.\comindex{Unfocus}} -Turns off the focus mode. +This command restores to focus the goal that were suspended by the +last {\tt Focus} command. + +\subsection[\tt Unfocused.]{\tt Unfocused.\comindex{Unfocused}} +Succeeds in the proof is fully unfocused, fails is there are some +goals out of focus. + +\subsection[\tt \{ \textrm{and} \}]{\tt \{ \textrm{and} \}\comindex{\{}\comindex{\}}} +The command {\tt \{} (without a terminating period) focuses on the +first goal, much like {\tt Focus.} does, however, the subproof can +only be unfocused when it has been fully solved (\emph{i.e.} when +there is no focused goal left). Unfocusing is then handled by {\tt \}} +(again, without a terminating period). See also example in next section. + +\subsection[Bullets]{Bullets\comindex{+ (command)}\comindex{- (command)}\comindex{* (command)}\index{Bullets}} +Alternatively to {\tt \{} and {\tt \}}, proofs can be structured with +bullets. The use of a bullet for the first time focuses on the first +goal, the same bullet cannot be used again until the subproof in +completed, then it focuses on the next goal. Different bullets can be +used to nest levels. The scope of bullet does not go beyond enclosing +{\tt \{} and {\tt \}}, so bullets can be reused as further nesting +level provided they are delimited by these. Available bullets are +{\tt -}, {\tt +} and {\tt *} (without a terminating period). + +The following example script illustrates all these features: +\begin{coq_example*} +Goal (((True/\True)/\True)/\True)/\True. +Proof. + split. + - split. + + split. + * { split. + - trivial. + - trivial. + } + * trivial. + + trivial. + - trivial. +\end{coq_example*} \section{Requesting information} diff --git a/doc/refman/RefMan-sch.tex b/doc/refman/RefMan-sch.tex new file mode 100644 index 00000000..707ee824 --- /dev/null +++ b/doc/refman/RefMan-sch.tex @@ -0,0 +1,418 @@ +\chapter{Proof schemes} + +\section{Generation of induction principles with {\tt Scheme}} +\label{Scheme} +\index{Schemes} +\comindex{Scheme} + +The {\tt Scheme} command is a high-level tool for generating +automatically (possibly mutual) induction principles for given types +and sorts. Its syntax follows the schema: +\begin{quote} +{\tt Scheme {\ident$_1$} := Induction for \ident'$_1$ Sort {\sort$_1$} \\ + with\\ + \mbox{}\hspace{0.1cm} \dots\\ + with {\ident$_m$} := Induction for {\ident'$_m$} Sort + {\sort$_m$}} +\end{quote} +where \ident'$_1$ \dots\ \ident'$_m$ are different inductive type +identifiers belonging to the same package of mutual inductive +definitions. This command generates {\ident$_1$}\dots{} {\ident$_m$} +to be mutually recursive definitions. Each term {\ident$_i$} proves a +general principle of mutual induction for objects in type {\term$_i$}. + +\begin{Variants} +\item {\tt Scheme {\ident$_1$} := Minimality for \ident'$_1$ Sort {\sort$_1$} \\ + with\\ + \mbox{}\hspace{0.1cm} \dots\ \\ + with {\ident$_m$} := Minimality for {\ident'$_m$} Sort + {\sort$_m$}} + + Same as before but defines a non-dependent elimination principle more + natural in case of inductively defined relations. + +\item {\tt Scheme Equality for \ident$_1$\comindex{Scheme Equality}} + + Tries to generate a boolean equality and a proof of the + decidability of the usual equality. If \ident$_i$ involves + some other inductive types, their equality has to be defined first. + +\item {\tt Scheme Induction for \ident$_1$ Sort {\sort$_1$} \\ + with\\ + \mbox{}\hspace{0.1cm} \dots\\ + with Induction for {\ident$_m$} Sort + {\sort$_m$}} + + If you do not provide the name of the schemes, they will be automatically + computed from the sorts involved (works also with Minimality). + +\end{Variants} +\label{Scheme-examples} + +\firstexample +\example{Induction scheme for \texttt{tree} and \texttt{forest}} + +The definition of principle of mutual induction for {\tt tree} and +{\tt forest} over the sort {\tt Set} is defined by the command: + +\begin{coq_eval} +Reset Initial. +Variables A B : Set. +\end{coq_eval} + +\begin{coq_example*} +Inductive tree : Set := + node : A -> forest -> tree +with forest : Set := + | leaf : B -> forest + | cons : tree -> forest -> forest. + +Scheme tree_forest_rec := Induction for tree Sort Set + with forest_tree_rec := Induction for forest Sort Set. +\end{coq_example*} + +You may now look at the type of {\tt tree\_forest\_rec}: + +\begin{coq_example} +Check tree_forest_rec. +\end{coq_example} + +This principle involves two different predicates for {\tt trees} and +{\tt forests}; it also has three premises each one corresponding to a +constructor of one of the inductive definitions. + +The principle {\tt forest\_tree\_rec} shares exactly the same +premises, only the conclusion now refers to the property of forests. + +\begin{coq_example} +Check forest_tree_rec. +\end{coq_example} + +\example{Predicates {\tt odd} and {\tt even} on naturals} + +Let {\tt odd} and {\tt even} be inductively defined as: + +% Reset Initial. +\begin{coq_eval} +Open Scope nat_scope. +\end{coq_eval} + +\begin{coq_example*} +Inductive odd : nat -> Prop := + oddS : forall n:nat, even n -> odd (S n) +with even : nat -> Prop := + | evenO : even 0 + | evenS : forall n:nat, odd n -> even (S n). +\end{coq_example*} + +The following command generates a powerful elimination +principle: + +\begin{coq_example} +Scheme odd_even := Minimality for odd Sort Prop + with even_odd := Minimality for even Sort Prop. +\end{coq_example} + +The type of {\tt odd\_even} for instance will be: + +\begin{coq_example} +Check odd_even. +\end{coq_example} + +The type of {\tt even\_odd} shares the same premises but the +conclusion is {\tt (n:nat)(even n)->(Q n)}. + +\subsection{Automatic declaration of schemes} +\comindex{Set Equality Schemes} +\comindex{Set Elimination Schemes} + +It is possible to deactivate the automatic declaration of the induction + principles when defining a new inductive type with the + {\tt Unset Elimination Schemes} command. It may be +reactivated at any time with {\tt Set Elimination Schemes}. +\\ + +You can also activate the automatic declaration of those boolean equalities +(see the second variant of {\tt Scheme}) with the {\tt Set Equality Schemes} + command. However you have to be careful with this option since +\Coq~ may now reject well-defined inductive types because it cannot compute +a boolean equality for them. + +\subsection{\tt Combined Scheme} +\label{CombinedScheme} +\comindex{Combined Scheme} + +The {\tt Combined Scheme} command is a tool for combining +induction principles generated by the {\tt Scheme} command. +Its syntax follows the schema : +\begin{quote} +{\tt Combined Scheme {\ident$_0$} from {\ident$_1$}, .., {\ident$_n$}} +\end{quote} +where +\ident$_1$ \ldots \ident$_n$ are different inductive principles that must belong to +the same package of mutual inductive principle definitions. This command +generates {\ident$_0$} to be the conjunction of the principles: it is +built from the common premises of the principles and concluded by the +conjunction of their conclusions. + +\Example +We can define the induction principles for trees and forests using: +\begin{coq_example} +Scheme tree_forest_ind := Induction for tree Sort Prop + with forest_tree_ind := Induction for forest Sort Prop. +\end{coq_example} + +Then we can build the combined induction principle which gives the +conjunction of the conclusions of each individual principle: +\begin{coq_example} +Combined Scheme tree_forest_mutind from tree_forest_ind, forest_tree_ind. +\end{coq_example} + +The type of {\tt tree\_forest\_mutrec} will be: +\begin{coq_example} +Check tree_forest_mutind. +\end{coq_example} + +\section{Generation of induction principles with {\tt Functional Scheme}} +\label{FunScheme} +\comindex{Functional Scheme} + +The {\tt Functional Scheme} command is a high-level experimental +tool for generating automatically induction principles +corresponding to (possibly mutually recursive) functions. Its +syntax follows the schema: +\begin{quote} +{\tt Functional Scheme {\ident$_1$} := Induction for \ident'$_1$ Sort {\sort$_1$} \\ + with\\ + \mbox{}\hspace{0.1cm} \dots\ \\ + with {\ident$_m$} := Induction for {\ident'$_m$} Sort + {\sort$_m$}} +\end{quote} +where \ident'$_1$ \dots\ \ident'$_m$ are different mutually defined function +names (they must be in the same order as when they were defined). +This command generates the induction principles +\ident$_1$\dots\ident$_m$, following the recursive structure and case +analyses of the functions \ident'$_1$ \dots\ \ident'$_m$. + +\Rem +There is a difference between obtaining an induction scheme by using +\texttt{Functional Scheme} on a function defined by \texttt{Function} +or not. Indeed \texttt{Function} generally produces smaller +principles, closer to the definition written by the user. + +\firstexample +\example{Induction scheme for \texttt{div2}} +\label{FunScheme-examples} + +We define the function \texttt{div2} as follows: + +\begin{coq_eval} +Reset Initial. +\end{coq_eval} + +\begin{coq_example*} +Require Import Arith. +Fixpoint div2 (n:nat) : nat := + match n with + | O => 0 + | S O => 0 + | S (S n') => S (div2 n') + end. +\end{coq_example*} + +The definition of a principle of induction corresponding to the +recursive structure of \texttt{div2} is defined by the command: + +\begin{coq_example} +Functional Scheme div2_ind := Induction for div2 Sort Prop. +\end{coq_example} + +You may now look at the type of {\tt div2\_ind}: + +\begin{coq_example} +Check div2_ind. +\end{coq_example} + +We can now prove the following lemma using this principle: + +\begin{coq_example*} +Lemma div2_le' : forall n:nat, div2 n <= n. +intro n. + pattern n , (div2 n). +\end{coq_example*} + +\begin{coq_example} +apply div2_ind; intros. +\end{coq_example} + +\begin{coq_example*} +auto with arith. +auto with arith. +simpl; auto with arith. +Qed. +\end{coq_example*} + +We can use directly the \texttt{functional induction} +(\ref{FunInduction}) tactic instead of the pattern/apply trick: +\tacindex{functional induction} + +\begin{coq_example*} +Reset div2_le'. +Lemma div2_le : forall n:nat, div2 n <= n. +intro n. +\end{coq_example*} + +\begin{coq_example} +functional induction (div2 n). +\end{coq_example} + +\begin{coq_example*} +auto with arith. +auto with arith. +auto with arith. +Qed. +\end{coq_example*} + +\Rem There is a difference between obtaining an induction scheme for a +function by using \texttt{Function} (see Section~\ref{Function}) and by +using \texttt{Functional Scheme} after a normal definition using +\texttt{Fixpoint} or \texttt{Definition}. See \ref{Function} for +details. + + +\example{Induction scheme for \texttt{tree\_size}} + +\begin{coq_eval} +Reset Initial. +\end{coq_eval} + +We define trees by the following mutual inductive type: + +\begin{coq_example*} +Variable A : Set. +Inductive tree : Set := + node : A -> forest -> tree +with forest : Set := + | empty : forest + | cons : tree -> forest -> forest. +\end{coq_example*} + +We define the function \texttt{tree\_size} that computes the size +of a tree or a forest. Note that we use \texttt{Function} which +generally produces better principles. + +\begin{coq_example*} +Function tree_size (t:tree) : nat := + match t with + | node A f => S (forest_size f) + end + with forest_size (f:forest) : nat := + match f with + | empty => 0 + | cons t f' => (tree_size t + forest_size f') + end. +\end{coq_example*} + +\Rem \texttt{Function} generates itself non mutual induction +principles {\tt tree\_size\_ind} and {\tt forest\_size\_ind}: + +\begin{coq_example} +Check tree_size_ind. +\end{coq_example} + +The definition of mutual induction principles following the recursive +structure of \texttt{tree\_size} and \texttt{forest\_size} is defined +by the command: + +\begin{coq_example*} +Functional Scheme tree_size_ind2 := Induction for tree_size Sort Prop +with forest_size_ind2 := Induction for forest_size Sort Prop. +\end{coq_example*} + +You may now look at the type of {\tt tree\_size\_ind2}: + +\begin{coq_example} +Check tree_size_ind2. +\end{coq_example} + +\section{Generation of inversion principles with \tt Derive Inversion} +\label{Derive-Inversion} +\comindex{Derive Inversion} + +The syntax of {\tt Derive Inversion} follows the schema: +\begin{quote} +{\tt Derive Inversion {\ident} with forall + $(\vec{x} : \vec{T})$, $I~\vec{t}$ Sort \sort} +\end{quote} + +This command generates an inversion principle for the +\texttt{inversion \dots\ using} tactic. +\tacindex{inversion \dots\ using} +Let $I$ be an inductive predicate and $\vec{x}$ the variables +occurring in $\vec{t}$. This command generates and stocks the +inversion lemma for the sort \sort~ corresponding to the instance +$\forall (\vec{x}:\vec{T}), I~\vec{t}$ with the name {\ident} in the {\bf +global} environment. When applied, it is equivalent to having inverted +the instance with the tactic {\tt inversion}. + +\begin{Variants} +\item \texttt{Derive Inversion\_clear {\ident} with forall + $(\vec{x}:\vec{T})$, $I~\vec{t}$ Sort \sort}\\ + \comindex{Derive Inversion\_clear} + When applied, it is equivalent to having + inverted the instance with the tactic \texttt{inversion} + replaced by the tactic \texttt{inversion\_clear}. +\item \texttt{Derive Dependent Inversion {\ident} with forall + $(\vec{x}:\vec{T})$, $I~\vec{t}$ Sort \sort}\\ + \comindex{Derive Dependent Inversion} + When applied, it is equivalent to having + inverted the instance with the tactic \texttt{dependent inversion}. +\item \texttt{Derive Dependent Inversion\_clear {\ident} with forall + $(\vec{x}:\vec{T})$, $I~\vec{t}$ Sort \sort}\\ + \comindex{Derive Dependent Inversion\_clear} + When applied, it is equivalent to having + inverted the instance with the tactic \texttt{dependent inversion\_clear}. +\end{Variants} + +\Example + +Let us consider the relation \texttt{Le} over natural numbers and the +following variable: + +\begin{coq_eval} +Reset Initial. +\end{coq_eval} + +\begin{coq_example*} +Inductive Le : nat -> nat -> Set := + | LeO : forall n:nat, Le 0 n + | LeS : forall n m:nat, Le n m -> Le (S n) (S m). +Variable P : nat -> nat -> Prop. +\end{coq_example*} + +To generate the inversion lemma for the instance +\texttt{(Le (S n) m)} and the sort \texttt{Prop}, we do: + +\begin{coq_example*} +Derive Inversion_clear leminv with (forall n m:nat, Le (S n) m) Sort Prop. +\end{coq_example*} + +\begin{coq_example} +Check leminv. +\end{coq_example} + +Then we can use the proven inversion lemma: + +\begin{coq_eval} +Lemma ex : forall n m:nat, Le (S n) m -> P n m. +intros. +\end{coq_eval} + +\begin{coq_example} +Show. +\end{coq_example} + +\begin{coq_example} +inversion H using leminv. +\end{coq_example} + diff --git a/doc/refman/RefMan-syn.tex b/doc/refman/RefMan-syn.tex index ea3d55f2..fd608f06 100644 --- a/doc/refman/RefMan-syn.tex +++ b/doc/refman/RefMan-syn.tex @@ -369,7 +369,7 @@ reserved. Hence their precedence and associativity cannot be changed. \comindex{CoFixpoint {\ldots} where {\ldots}} \comindex{Inductive {\ldots} where {\ldots}}} -Thanks to reserved notations, the inductive, coinductive, recursive +Thanks to reserved notations, the inductive, co-inductive, recursive and corecursive definitions can benefit of customized notations. To do this, insert a {\tt where} notation clause after the definition of the (co)inductive type or (co)recursive term (or after the definition of diff --git a/doc/refman/RefMan-tac.tex b/doc/refman/RefMan-tac.tex index 198f8f30..b630772b 100644 --- a/doc/refman/RefMan-tac.tex +++ b/doc/refman/RefMan-tac.tex @@ -6,15 +6,15 @@ A deduction rule is a link between some (unique) formula, that we call the {\em conclusion} and (several) formulas that we call the {\em -premises}. Indeed, a deduction rule can be read in two ways. The first -one has the shape: {\it ``if I know this and this then I can deduce +premises}. A deduction rule can be read in two ways. The first +one says: {\it ``if I know this and this then I can deduce this''}. For instance, if I have a proof of $A$ and a proof of $B$ then I have a proof of $A \land B$. This is forward reasoning from premises to conclusion. The other way says: {\it ``to prove this I have to prove this and this''}. For instance, to prove $A \land B$, I have to prove $A$ and I have to prove $B$. This is backward reasoning -which proceeds from conclusion to premises. We say that the conclusion -is {\em the goal}\index{goal} to prove and premises are {\em the +from conclusion to premises. We say that the conclusion +is the {\em goal}\index{goal} to prove and premises are the {\em subgoals}\index{subgoal}. The tactics implement {\em backward reasoning}. When applied to a goal, a tactic replaces this goal with the subgoals it generates. We say that a tactic reduces a goal to its @@ -25,29 +25,23 @@ Each (sub)goal is denoted with a number. The current goal is numbered address a particular goal in the list by writing {\sl n:\tac} which means {\it ``apply tactic {\tac} to goal number {\sl n}''}. We can show the list of subgoals by typing {\tt Show} (see -Section~\ref{Show}). +Section~\ref{Show}). Since not every rule applies to a given statement, every tactic cannot be used to reduce any goal. In other words, before applying a tactic to a given goal, the system checks that some {\em preconditions} are satisfied. If it is not the case, the tactic raises an error message. -Tactics are build from atomic tactics and tactic expressions (which +Tactics are built from atomic tactics and tactic expressions (which extends the folklore notion of tactical) to combine those atomic tactics. This chapter is devoted to atomic tactics. The tactic language will be described in Chapter~\ref{TacticLanguage}. -There are, at least, three levels of atomic tactics. The simplest one -implements basic rules of the logical framework. The second level is -the one of {\em derived rules} which are built by combination of other -tactics. The third one implements heuristics or decision procedures to -build a complete proof of a goal. - \section{Invocation of tactics \label{tactic-syntax} \index{tactic@{\tac}}} -A tactic is applied as an ordinary command. If the tactic does not +A tactic is applied as an ordinary command. If the tactic is not meant to address the first subgoal, the command may be preceded by the wished subgoal number as shown below: @@ -56,11 +50,107 @@ subgoal number as shown below: & $|$ & {\tac} {\tt .} \end{tabular} -\section{Explicit proof as a term} +\subsection{Bindings list +\index{Binding list} +\label{Binding-list}} + +Tactics that take a term as argument may also support a bindings list, so +as to instantiate some parameters of the term by name or position. +The general form of a term equipped with a bindings list is {\tt +{\term} with {\bindinglist}} where {\bindinglist} may be of two +different forms: + +\begin{itemize} +\item In a bindings list of the form {\tt (\vref$_1$ := \term$_1$) + \dots\ (\vref$_n$ := \term$_n$)}, {\vref} is either an {\ident} or a + {\num}. The references are determined according to the type of + {\term}. If \vref$_i$ is an identifier, this identifier has to be + bound in the type of {\term} and the binding provides the tactic + with an instance for the parameter of this name. If \vref$_i$ is + some number $n$, this number denotes the $n$-th non dependent + premise of the {\term}, as determined by the type of {\term}. + + \ErrMsg \errindex{No such binder} + +\item A bindings list can also be a simple list of terms {\tt + \term$_1$ \dots\ \term$_n$}. In that case the references to + which these terms correspond are determined by the tactic. In case + of {\tt induction}, {\tt destruct}, {\tt elim} and {\tt case} (see + Section~\ref{elim}) the terms have to provide instances for all the + dependent products in the type of \term\ while in the case of {\tt + apply}, or of {\tt constructor} and its variants, only instances for + the dependent products that are not bound in the conclusion of the + type are required. + + \ErrMsg \errindex{Not the right number of missing arguments} +\end{itemize} + +\subsection{Occurrences sets and occurrences clauses} +\label{Occurrences clauses} +\index{Occurrences clauses} + +An occurrences clause is a modifier to some tactics that obeys the +following syntax: + +\begin{tabular}{lcl} +{\occclause} & ::= & {\tt in} {\occgoalset} \\ +{\occgoalset} & ::= & + \zeroone{{\ident$_1$} \zeroone{\atoccurrences} {\tt ,} \\ +& & {\dots} {\tt ,}\\ +& & {\ident$_m$} \zeroone{\atoccurrences}}\\ +& & \zeroone{{\tt |-} \zeroone{{\tt *} \zeroone{\atoccurrences}}}\\ +& | & + {\tt *} {\tt |-} \zeroone{{\tt *} \zeroone{\atoccurrences}}\\ +& | & + {\tt *}\\ +{\atoccurrences} & ::= & {\tt at} {\occlist}\\ +{\occlist} & ::= & \zeroone{{\tt -}} {\num$_1$} \dots\ {\num$_n$} +\end{tabular} + +The role of an occurrence clause is to select a set of occurrences of +a {\term} in a goal. In the first case, the {{\ident$_i$} +\zeroone{{\tt at} {\num$_1^i$} \dots\ {\num$_{n_i}^i$}}} parts +indicate that occurrences have to be selected in the hypotheses named +{\ident$_i$}. If no numbers are given for hypothesis {\ident$_i$}, +then all the occurrences of {\term} in the hypothesis are selected. If +numbers are given, they refer to occurrences of {\term} when the term +is printed using option {\tt Set Printing All} (see +Section~\ref{SetPrintingAll}), counting from left to right. In +particular, occurrences of {\term} in implicit arguments (see +Section~\ref{Implicit Arguments}) or coercions (see +Section~\ref{Coercions}) are counted. + +If a minus sign is given between {\tt at} and the list of occurrences, +it negates the condition so that the clause denotes all the occurrences except +the ones explicitly mentioned after the minus sign. + +As an exception to the left-to-right order, the occurrences in the +{\tt return} subexpression of a {\tt match} are considered {\em +before} the occurrences in the matched term. + +In the second case, the {\tt *} on the left of {\tt |-} means that +all occurrences of {\term} are selected in every hypothesis. + +In the first and second case, if {\tt *} is mentioned on the right of +{\tt |-}, the occurrences of the conclusion of the goal have to be +selected. If some numbers are given, then only the occurrences denoted +by these numbers are selected. In no numbers are given, all +occurrences of {\term} in the goal are selected. + +Finally, the last notation is an abbreviation for {\tt * |- *}. Note +also that {\tt |-} is optional in the first case when no {\tt *} is +given. + +Here are some tactics that understand occurrences clauses: +{\tt set}, {\tt remember}, {\tt induction}, {\tt destruct}. + +\SeeAlso~Sections~\ref{tactic:set}, \ref{Tac-induction}, \ref{SetPrintingAll}. + +\section{Applying theorems} -\subsection{\tt exact \term +\subsection{\tt exact \term} \tacindex{exact} -\label{exact}} +\label{exact} This tactic applies to any goal. It gives directly the exact proof term of the goal. Let {\T} be our goal, let {\tt p} be a term of type @@ -72,48 +162,17 @@ convertible (see Section~\ref{conv-rules}). \end{ErrMsgs} \begin{Variants} - \item \texttt{eexact \term}\tacindex{eexact} - - This tactic behaves like \texttt{exact} but is able to handle terms with meta-variables. - -\end{Variants} + \item \texttt{eexact \term}\tacindex{eexact} + This tactic behaves like \texttt{exact} but is able to handle terms + and goals with meta-variables. -\subsection{\tt refine \term -\tacindex{refine} -\label{refine} -\index{?@{\texttt{?}}}} - -This tactic allows to give an exact proof but still with some -holes. The holes are noted ``\texttt{\_}''. - -\begin{ErrMsgs} -\item \errindex{invalid argument}: - the tactic \texttt{refine} doesn't know what to do - with the term you gave. -\item \texttt{Refine passed ill-formed term}: the term you gave is not - a valid proof (not easy to debug in general). - This message may also occur in higher-level tactics, which call - \texttt{refine} internally. -\item \errindex{Cannot infer a term for this placeholder} - there is a hole in the term you gave - which type cannot be inferred. Put a cast around it. -\end{ErrMsgs} - -An example of use is given in Section~\ref{refine-example}. - -\section{Basics -\index{Typing rules}} - -Tactics presented in this section implement the basic typing rules of -{\CIC} given in Chapter~\ref{Cic}. +\end{Variants} -\subsection{{\tt assumption} -\tacindex{assumption}} +\subsection{\tt assumption} +\tacindex{assumption} -This tactic applies to any goal. It implements the -``Var''\index{Typing rules!Var} rule given in -Section~\ref{Typed-terms}. It looks in the local context for an +This tactic looks in the local context for an hypothesis which type is equal to the goal. If it is the case, the subgoal is proved. Otherwise, it fails. @@ -130,134 +189,470 @@ subgoal is proved. Otherwise, it fails. \end{Variants} +\subsection{\tt refine \term} +\tacindex{refine} +\label{refine} +\label{refine-example} +\index{?@{\texttt{?}}} -\subsection{\tt clear {\ident} -\tacindex{clear} -\label{clear}} - -This tactic erases the hypothesis named {\ident} in the local context -of the current goal. Then {\ident} is no more displayed and no more -usable in the proof development. +This tactic applies to any goal. It behaves like {\tt exact} with a big +difference: the user can leave some holes (denoted by \texttt{\_} or +{\tt (\_:\type)}) in the term. {\tt refine} will generate as +many subgoals as there are holes in the term. The type of holes must be +either synthesized by the system or declared by an +explicit cast like \verb|(_:nat->Prop)|. This low-level +tactic can be useful to advanced users. -\begin{Variants} +\Example -\item {\tt clear {\ident$_1$} {\ldots} {\ident$_n$}} - - This is equivalent to {\tt clear {\ident$_1$}. {\ldots} clear - {\ident$_n$}.} - -\item {\tt clearbody {\ident}}\tacindex{clearbody} +\begin{coq_example*} +Inductive Option : Set := + | Fail : Option + | Ok : bool -> Option. +\end{coq_example} +\begin{coq_example} +Definition get : forall x:Option, x <> Fail -> bool. +refine + (fun x:Option => + match x return x <> Fail -> bool with + | Fail => _ + | Ok b => fun _ => b + end). +intros; absurd (Fail = Fail); trivial. +\end{coq_example} +\begin{coq_example*} +Defined. +\end{coq_example*} - This tactic expects {\ident} to be a local definition then clears - its body. Otherwise said, this tactic turns a definition into an - assumption. +\begin{ErrMsgs} +\item \errindex{invalid argument}: + the tactic \texttt{refine} does not know what to do + with the term you gave. +\item \texttt{Refine passed ill-formed term}: the term you gave is not + a valid proof (not easy to debug in general). + This message may also occur in higher-level tactics that call + \texttt{refine} internally. +\item \errindex{Cannot infer a term for this placeholder}: + there is a hole in the term you gave + which type cannot be inferred. Put a cast around it. +\end{ErrMsgs} -\item \texttt{clear - {\ident$_1$} {\ldots} {\ident$_n$}} +\subsection{\tt apply \term} +\tacindex{apply} +\label{apply} - This tactic clears all hypotheses except the ones depending in - the hypotheses named {\ident$_1$} {\ldots} {\ident$_n$} and in the - goal. +This tactic applies to any goal. The argument {\term} is a term +well-formed in the local context. The tactic {\tt apply} tries to +match the current goal against the conclusion of the type of {\term}. +If it succeeds, then the tactic returns as many subgoals as the number +of non-dependent premises of the type of {\term}. If the conclusion of +the type of {\term} does not match the goal {\em and} the conclusion +is an inductive type isomorphic to a tuple type, then each component +of the tuple is recursively matched to the goal in the left-to-right +order. -\item \texttt{clear} +The tactic {\tt apply} relies on first-order unification with +dependent types unless the conclusion of the type of {\term} is of the +form {\tt ($P$ $t_1$ \dots\ $t_n$)} with $P$ to be instantiated. In +the latter case, the behavior depends on the form of the goal. If the +goal is of the form {\tt (fun $x$ => $Q$)~$u_1$~\ldots~$u_n$} and the +$t_i$ and $u_i$ unifies, then $P$ is taken to be {\tt (fun $x$ => $Q$)}. +Otherwise, {\tt apply} tries to define $P$ by abstracting over +$t_1$~\ldots ~$t_n$ in the goal. See {\tt pattern} in +Section~\ref{pattern} to transform the goal so that it gets the form +{\tt (fun $x$ => $Q$)~$u_1$~\ldots~$u_n$}. - This tactic clears all hypotheses except the ones depending in - goal. +\begin{ErrMsgs} +\item \errindex{Impossible to unify \dots\ with \dots} -\item {\tt clear dependent \ident \tacindex{clear dependent}} + The {\tt apply} + tactic failed to match the conclusion of {\term} and the current goal. + You can help the {\tt apply} tactic by transforming your + goal with the {\tt change} or {\tt pattern} tactics (see + sections~\ref{pattern},~\ref{change}). - This clears the hypothesis \ident\ and all hypotheses - which depend on it. +\item \errindex{Unable to find an instance for the variables +{\ident} \dots\ {\ident}} -\end{Variants} + This occurs when some instantiations of the premises of {\term} are not + deducible from the unification. This is the case, for instance, when + you want to apply a transitivity property. In this case, you have to + use one of the variants below: -\begin{ErrMsgs} -\item \errindex{{\ident} not found} -\item \errindexbis{{\ident} is used in the conclusion}{is used in the - conclusion} -\item \errindexbis{{\ident} is used in the hypothesis {\ident'}}{is - used in the hypothesis} \end{ErrMsgs} -\subsection{\tt move {\ident$_1$} after {\ident$_2$} -\tacindex{move} -\label{move}} +\begin{Variants} -This moves the hypothesis named {\ident$_1$} in the local context -after the hypothesis named {\ident$_2$}. +\item{\tt apply {\term} with {\term$_1$} \dots\ {\term$_n$}} + \tacindex{apply \dots\ with} -If {\ident$_1$} comes before {\ident$_2$} in the order of dependences, -then all hypotheses between {\ident$_1$} and {\ident$_2$} which -(possibly indirectly) depend on {\ident$_1$} are moved also. + Provides {\tt apply} with explicit instantiations for all dependent + premises of the type of {\term} which do not occur in the conclusion + and consequently cannot be found by unification. Notice that + {\term$_1$} \dots\ {\term$_n$} must be given according to the order + of these dependent premises of the type of {\term}. -If {\ident$_1$} comes after {\ident$_2$} in the order of dependences, -then all hypotheses between {\ident$_1$} and {\ident$_2$} which -(possibly indirectly) occur in {\ident$_1$} are moved also. + \ErrMsg \errindex{Not the right number of missing arguments} -\begin{Variants} +\item{\tt apply {\term} with ({\vref$_1$} := {\term$_1$}) \dots\ ({\vref$_n$} + := {\term$_n$})} -\item {\tt move {\ident$_1$} before {\ident$_2$}} + This also provides {\tt apply} with values for instantiating + premises. Here, variables are referred by names and non-dependent + products by increasing numbers (see syntax in Section~\ref{Binding-list}). -This moves {\ident$_1$} towards and just before the hypothesis named {\ident$_2$}. +\item {\tt apply} {\term$_1$} {\tt ,} \ldots {\tt ,} {\term$_n$} -\item {\tt move {\ident} at top} + This is a shortcut for {\tt apply} {\term$_1$} {\tt ; [ ..~|} + \ldots~{\tt ; [ ..~| {\tt apply} {\term$_n$} ]} \ldots~{\tt ]}, i.e. for the + successive applications of {\term$_{i+1}$} on the last subgoal + generated by {\tt apply} {\term$_i$}, starting from the application + of {\term$_1$}. -This moves {\ident} at the top of the local context (at the beginning of the context). +\item {\tt eapply \term}\tacindex{eapply}\label{eapply} -\item {\tt move {\ident} at bottom} + The tactic {\tt eapply} behaves like {\tt apply} but it does not fail + when no instantiations are deducible for some variables in the + premises. Rather, it turns these variables into so-called + existential variables which are variables still to instantiate. An + existential variable is identified by a name of the form {\tt ?$n$} + where $n$ is a number. The instantiation is intended to be found + later in the proof. -This moves {\ident} at the bottom of the local context (at the end of the context). +\item {\tt simple apply {\term}} \tacindex{simple apply} -\end{Variants} + This behaves like {\tt apply} but it reasons modulo conversion only + on subterms that contain no variables to instantiate. For instance, + the following example does not succeed because it would require the + conversion of {\tt id ?1234} and {\tt O}. -\begin{ErrMsgs} +\begin{coq_eval} +Reset Initial. +\end{coq_eval} +\begin{coq_example*} +Definition id (x : nat) := x. +Hypothesis H : forall y, id y = y. +Goal O = O. +\end{coq_example*} +\begin{coq_example} +simple apply H. +\end{coq_example} -\item \errindex{{\ident$_i$} not found} + Because it reasons modulo a limited amount of conversion, {\tt + simple apply} fails quicker than {\tt apply} and it is then + well-suited for uses in used-defined tactics that backtrack often. + Moreover, it does not traverse tuples as {\tt apply} does. -\item \errindex{Cannot move {\ident$_1$} after {\ident$_2$}: - it occurs in {\ident$_2$}} +\item \zeroone{{\tt simple}} {\tt apply} {\term$_1$} \zeroone{{\tt with} + {\bindinglist$_1$}} {\tt ,} \ldots {\tt ,} {\term$_n$} \zeroone{{\tt with} + {\bindinglist$_n$}}\\ + \zeroone{{\tt simple}} {\tt eapply} {\term$_1$} \zeroone{{\tt with} + {\bindinglist$_1$}} {\tt ,} \ldots {\tt ,} {\term$_n$} \zeroone{{\tt with} + {\bindinglist$_n$}} -\item \errindex{Cannot move {\ident$_1$} after {\ident$_2$}: - it depends on {\ident$_2$}} + This summarizes the different syntaxes for {\tt apply} and {\tt eapply}. -\end{ErrMsgs} +\item {\tt lapply {\term}} \tacindex{lapply} -\subsection{\tt rename {\ident$_1$} into {\ident$_2$} -\tacindex{rename}} + This tactic applies to any goal, say {\tt G}. The argument {\term} + has to be well-formed in the current context, its type being + reducible to a non-dependent product {\tt A -> B} with {\tt B} + possibly containing products. Then it generates two subgoals {\tt + B->G} and {\tt A}. Applying {\tt lapply H} (where {\tt H} has type + {\tt A->B} and {\tt B} does not start with a product) does the same + as giving the sequence {\tt cut B. 2:apply H.} where {\tt cut} is + described below. -This renames hypothesis {\ident$_1$} into {\ident$_2$} in the current -context\footnote{but it does not rename the hypothesis in the - proof-term...} + \Warning When {\term} contains more than one non + dependent product the tactic {\tt lapply} only takes into account the + first product. -\begin{Variants} +\end{Variants} -\item {\tt rename {\ident$_1$} into {\ident$_2$}, \ldots, - {\ident$_{2k-1}$} into {\ident$_{2k}$}} +\Example +Assume we have a transitive relation {\tt R} on {\tt nat}: +\label{eapply-example} - Is equivalent to the sequence of the corresponding atomic {\tt rename}. +\begin{coq_eval} +Reset Initial. +\end{coq_eval} +\begin{coq_example*} +Variable R : nat -> nat -> Prop. +Hypothesis Rtrans : forall x y z:nat, R x y -> R y z -> R x z. +Variables n m p : nat. +Hypothesis Rnm : R n m. +Hypothesis Rmp : R m p. +\end{coq_example*} -\end{Variants} +Consider the goal {\tt (R n p)} provable using the transitivity of +{\tt R}: + +\begin{coq_example*} +Goal R n p. +\end{coq_example*} + +The direct application of {\tt Rtrans} with {\tt apply} fails because +no value for {\tt y} in {\tt Rtrans} is found by {\tt apply}: + +%\begin{coq_eval} +%Set Printing Depth 50. +%(********** The following is not correct and should produce **********) +%(**** Error: generated subgoal (R n ?17) has metavariables in it *****) +%\end{coq_eval} +\begin{coq_example} +apply Rtrans. +\end{coq_example} + +A solution is to apply {\tt (Rtrans n m p)} or {\tt (Rtrans n m)}. + +\begin{coq_example} +apply (Rtrans n m p). +\end{coq_example} + +\begin{coq_eval} +Undo. +\end{coq_eval} + +Note that {\tt n} can be inferred from the goal, so the following would +work too. + +\begin{coq_example*} +apply (Rtrans _ m). +\end{coq_example*} +\begin{coq_eval} +Undo. +\end{coq_eval} + +More elegantly, {\tt apply Rtrans with (y:=m)} allows to only mention +the unknown {\tt m}: + +\begin{coq_example*} +apply Rtrans with (y := m). +\end{coq_example*} +\begin{coq_eval} +Undo. +\end{coq_eval} + +Another solution is to mention the proof of {\tt (R x y)} in {\tt +Rtrans} \ldots + +\begin{coq_example} +apply Rtrans with (1 := Rnm). +\end{coq_example} +\begin{coq_eval} +Undo. +\end{coq_eval} + +\ldots or the proof of {\tt (R y z)}. + +\begin{coq_example} +apply Rtrans with (2 := Rmp). +\end{coq_example} +\begin{coq_eval} +Undo. +\end{coq_eval} + +On the opposite, one can use {\tt eapply} which postpone the problem +of finding {\tt m}. Then one can apply the hypotheses {\tt Rnm} and {\tt +Rmp}. This instantiates the existential variable and completes the proof. + +\begin{coq_example} +eapply Rtrans. +apply Rnm. +apply Rmp. +\end{coq_example} + +\begin{coq_eval} +Reset R. +\end{coq_eval} + +\subsection{\tt apply {\term} in {\ident}} +\tacindex{apply \dots\ in} + +This tactic applies to any goal. The argument {\term} is a term +well-formed in the local context and the argument {\ident} is an +hypothesis of the context. The tactic {\tt apply {\term} in {\ident}} +tries to match the conclusion of the type of {\ident} against a +non-dependent premise of the type of {\term}, trying them from right to +left. If it succeeds, the statement of hypothesis {\ident} is +replaced by the conclusion of the type of {\term}. The tactic also +returns as many subgoals as the number of other non-dependent premises +in the type of {\term} and of the non-dependent premises of the type +of {\ident}. If the conclusion of the type of {\term} does not match +the goal {\em and} the conclusion is an inductive type isomorphic to a +tuple type, then the tuple is (recursively) decomposed and the first +component of the tuple of which a non-dependent premise matches the +conclusion of the type of {\ident}. Tuples are decomposed in a +width-first left-to-right order (for instance if the type of {\tt H1} +is a \verb=A <-> B= statement, and the type of {\tt H2} is \verb=A= +then {\tt apply H1 in H2} transforms the type of {\tt H2} into {\tt + B}). The tactic {\tt apply} relies on first-order pattern-matching +with dependent types. \begin{ErrMsgs} +\item \errindex{Statement without assumptions} -\item \errindex{{\ident$_1$} not found} +This happens if the type of {\term} has no non dependent premise. -\item \errindexbis{{\ident$_2$} is already used}{is already used} +\item \errindex{Unable to apply} + +This happens if the conclusion of {\ident} does not match any of the +non dependent premises of the type of {\term}. +\end{ErrMsgs} + +\begin{Variants} +\item {\tt apply \nelist{\term}{,} in {\ident}} + +This applies each of {\term} in sequence in {\ident}. + +\item {\tt apply \nelist{{\term} with {\bindinglist}}{,} in {\ident}} + +This does the same but uses the bindings in each {\bindinglist} to +instantiate the parameters of the corresponding type of {\term} +(see syntax of bindings in Section~\ref{Binding-list}). + +\item {\tt eapply \nelist{{\term} with {\bindinglist}}{,} in {\ident}} +\tacindex{eapply \dots\ in} + +This works as {\tt apply \nelist{{\term} with {\bindinglist}}{,} in +{\ident}} but turns unresolved bindings into existential variables, if +any, instead of failing. + +\item {\tt apply \nelist{{\term}{,} with {\bindinglist}}{,} in {\ident} as {\disjconjintropattern}} + +This works as {\tt apply \nelist{{\term}{,} with {\bindinglist}}{,} in +{\ident}} then destructs the hypothesis {\ident} along +{\disjconjintropattern} as {\tt destruct {\ident} as +{\disjconjintropattern}} would. + +\item {\tt eapply \nelist{{\term}{,} with {\bindinglist}}{,} in {\ident} as {\disjconjintropattern}} + +This works as {\tt apply \nelist{{\term}{,} with {\bindinglist}}{,} in {\ident} as {\disjconjintropattern}} but using {\tt eapply}. + +\item {\tt simple apply {\term} in {\ident}} +\tacindex{simple apply \dots\ in} +\tacindex{simple eapply \dots\ in} + +This behaves like {\tt apply {\term} in {\ident}} but it reasons +modulo conversion only on subterms that contain no variables to +instantiate. For instance, if {\tt id := fun x:nat => x} and {\tt H : + forall y, id y = y -> True} and {\tt H0 :\ O = O} then {\tt simple + apply H in H0} does not succeed because it would require the +conversion of {\tt id ?1234} and {\tt O} where {\tt ?1234} is a variable to +instantiate. Tactic {\tt simple apply {\term} in {\ident}} does not +either traverse tuples as {\tt apply {\term} in {\ident}} does. + +\item {\tt \zeroone{simple} apply \nelist{{\term} \zeroone{with {\bindinglist}}}{,} in {\ident} \zeroone{as {\disjconjintropattern}}}\\ +{\tt \zeroone{simple} eapply \nelist{{\term} \zeroone{with {\bindinglist}}}{,} in {\ident} \zeroone{as {\disjconjintropattern}}} + +This summarizes the different syntactic variants of {\tt apply {\term} + in {\ident}} and {\tt eapply {\term} in {\ident}}. +\end{Variants} + +\subsection{\tt constructor \num} +\label{constructor} +\tacindex{constructor} + +This tactic applies to a goal such that its conclusion is +an inductive type (say {\tt I}). The argument {\num} must be less +or equal to the numbers of constructor(s) of {\tt I}. Let {\tt ci} be +the {\tt i}-th constructor of {\tt I}, then {\tt constructor i} is +equivalent to {\tt intros; apply ci}. +\begin{ErrMsgs} +\item \errindex{Not an inductive product} +\item \errindex{Not enough constructors} \end{ErrMsgs} -\subsection{\tt intro +\begin{Variants} +\item \texttt{constructor} + + This tries \texttt{constructor 1} then \texttt{constructor 2}, + \dots\ , then \texttt{constructor} \textit{n} where \textit{n} is + the number of constructors of the head of the goal. + +\item {\tt constructor \num~with} {\bindinglist} + + Let {\tt ci} be the {\tt i}-th constructor of {\tt I}, then {\tt + constructor i with \bindinglist} is equivalent to {\tt intros; + apply ci with \bindinglist}. + + \Warning the terms in the \bindinglist\ are checked + in the context where {\tt constructor} is executed and not in the + context where {\tt apply} is executed (the introductions are not + taken into account). + +% To document? +% \item {\tt constructor {\tactic}} + +\item {\tt split}\tacindex{split} + + This applies only if {\tt I} has a single constructor. It is then + equivalent to {\tt constructor 1}. It is typically used in the case + of a conjunction $A\land B$. + + \ErrMsg \errindex{Not an inductive goal with 1 constructor} + +\item {\tt exists {\bindinglist}}\tacindex{exists} + + This applies only if {\tt I} has a single constructor. It is then + equivalent to {\tt intros; constructor 1 with \bindinglist}. It is + typically used in the case of an existential quantification $\exists + x, P(x)$. + + \ErrMsg \errindex{Not an inductive goal with 1 constructor} + +\item {\tt exists \nelist{\bindinglist}{,}} + + This iteratively applies {\tt exists {\bindinglist}}. + +\item {\tt left}\tacindex{left}\\ + {\tt right}\tacindex{right} + + These tactics apply only if {\tt I} has two constructors, for instance + in the case of a + disjunction $A\lor B$. Then, they are respectively equivalent to {\tt + constructor 1} and {\tt constructor 2}. + + \ErrMsg \errindex{Not an inductive goal with 2 constructors} + +\item {\tt left with \bindinglist}\\ + {\tt right with \bindinglist}\\ + {\tt split with \bindinglist} + + As soon as the inductive type has the right number of constructors, + these expressions are equivalent to calling {\tt + constructor $i$ with \bindinglist} for the appropriate $i$. + +\item \texttt{econstructor}\tacindex{econstructor}\\ + \texttt{eexists}\tacindex{eexists}\\ + \texttt{esplit}\tacindex{esplit}\\ + \texttt{eleft}\tacindex{eleft}\\ + \texttt{eright}\tacindex{eright} + + These tactics and their variants behave like \texttt{constructor}, + \texttt{exists}, \texttt{split}, \texttt{left}, \texttt{right} and + their variants but they introduce existential variables instead of + failing when the instantiation of a variable cannot be found (cf + \texttt{eapply} and Section~\ref{eapply-example}). + +\end{Variants} + +\section{Managing the local context} + +\subsection{\tt intro} \tacindex{intro} -\label{intro}} +\label{intro} -This tactic applies to a goal which is either a product or starts with +This tactic applies to a goal that is either a product or starts with a let binder. If the goal is a product, the tactic implements the ``Lam''\index{Typing rules!Lam} rule given in Section~\ref{Typed-terms}\footnote{Actually, only the second subgoal will be generated since the other one can be automatically checked.}. If the -goal starts with a let binder then the tactic implements a mix of the +goal starts with a let binder, then the tactic implements a mix of the ``Let''\index{Typing rules!Let} and ``Conv''\index{Typing rules!Conv}. -If the current goal is a dependent product {\tt forall $x$:$T$, $U$} (resp {\tt +If the current goal is a dependent product $\forall x:T,~U$ (resp {\tt let $x$:=$t$ in $U$}) then {\tt intro} puts {\tt $x$:$T$} (resp {\tt $x$:=$t$}) in the local context. % Obsolete (quantified names already avoid hypotheses names): @@ -265,15 +660,15 @@ let $x$:=$t$ in $U$}) then {\tt intro} puts {\tt $x$:$T$} (resp {\tt $x$:=$t$}) % {\tt x}{\it n}{\tt :T} where {\it n} is such that {\tt x}{\it n} is a %fresh name. The new subgoal is $U$. -% If the {\tt x} has been renamed {\tt x}{\it n} then it is replaced -% by {\tt x}{\it n} in {\tt U}. +% If the {\tt x} has been renamed {\tt x}{\it n} then it is replaced +% by {\tt x}{\it n} in {\tt U}. -If the goal is a non dependent product {\tt $T$ -> $U$}, then it puts +If the goal is a non-dependent product $T \to U$, then it puts in the local context either {\tt H}{\it n}{\tt :$T$} (if $T$ is of type {\tt Set} or {\tt Prop}) or {\tt X}{\it n}{\tt :$T$} (if the type of $T$ is {\tt Type}). The optional index {\it n} is such that {\tt H}{\it n} or {\tt X}{\it n} is a fresh identifier. -In both cases the new subgoal is $U$. +In both cases, the new subgoal is $U$. If the goal is neither a product nor starting with a let definition, the tactic {\tt intro} applies the tactic {\tt red} until the tactic @@ -288,12 +683,12 @@ the tactic {\tt intro} applies the tactic {\tt red} until the tactic \item {\tt intros}\tacindex{intros} - Repeats {\tt intro} until it meets the head-constant. It never reduces + This repeats {\tt intro} until it meets the head-constant. It never reduces head-constants and it never fails. \item {\tt intro {\ident}} - Applies {\tt intro} but forces {\ident} to be the name of the + This applies {\tt intro} but forces {\ident} to be the name of the introduced hypothesis. \ErrMsg \errindex{name {\ident} is already used} @@ -302,28 +697,28 @@ the tactic {\tt intro} applies the tactic {\tt red} until the tactic constant then the latter can still be referred to by a qualified name (see \ref{LongNames}). -\item {\tt intros \ident$_1$ \dots\ \ident$_n$} - - Is equivalent to the composed tactic {\tt intro \ident$_1$; \dots\ ; +\item {\tt intros \ident$_1$ \dots\ \ident$_n$} + + This is equivalent to the composed tactic {\tt intro \ident$_1$; \dots\ ; intro \ident$_n$}. More generally, the \texttt{intros} tactic takes a pattern as argument in order to introduce names for components of an inductive - definition or to clear introduced hypotheses; This is explained + definition or to clear introduced hypotheses. This is explained in~\ref{intros-pattern}. \item {\tt intros until {\ident}} \tacindex{intros until} - - Repeats {\tt intro} until it meets a premise of the goal having form + + This repeats {\tt intro} until it meets a premise of the goal having form {\tt (} {\ident}~{\tt :}~{\term} {\tt )} and discharges the variable named {\ident} of the current goal. \ErrMsg \errindex{No such hypothesis in current goal} - + \item {\tt intros until {\num}} \tacindex{intros until} - - Repeats {\tt intro} until the {\num}-th non-dependent product. For - instance, on the subgoal % + + This repeats {\tt intro} until the {\num}-th non-dependent product. For + instance, on the subgoal % \verb+forall x y:nat, x=y -> y=x+ the tactic \texttt{intros until 1} is equivalent to \texttt{intros x y H}, as \verb+x=y -> y=x+ is the first non-dependent product. And on the subgoal % @@ -335,7 +730,7 @@ the tactic {\tt intro} applies the tactic {\tt red} until the tactic \ErrMsg \errindex{No such hypothesis in current goal} - Happens when {\num} is 0 or is greater than the number of non-dependent + This happens when {\num} is 0 or is greater than the number of non-dependent products of the goal. \item {\tt intro after \ident} \tacindex{intro after}\\ @@ -343,7 +738,7 @@ the tactic {\tt intro} applies the tactic {\tt red} until the tactic {\tt intro at top} \tacindex{intro at top}\\ {\tt intro at bottom} \tacindex{intro at bottom} - Applies {\tt intro} and moves the freshly introduced hypothesis + These tactics apply {\tt intro} and move the freshly introduced hypothesis respectively after the hypothesis \ident{}, before the hypothesis \ident{}, at the top of the local context, or at the bottom of the local context. All hypotheses on which the new hypothesis depends @@ -351,337 +746,412 @@ the tactic {\tt intro} applies the tactic {\tt red} until the tactic hypotheses. Note that {\tt intro at bottom} is a synonym for {\tt intro} with no argument. -\begin{ErrMsgs} -\item \errindex{No product even after head-reduction} -\item \errindex{No such hypothesis} : {\ident} -\end{ErrMsgs} + \ErrMsg \errindex{No such hypothesis} : {\ident} \item {\tt intro \ident$_1$ after \ident$_2$}\\ {\tt intro \ident$_1$ before \ident$_2$}\\ {\tt intro \ident$_1$ at top}\\ {\tt intro \ident$_1$ at bottom} - - Behaves as previously but naming the introduced hypothesis + + These tactics behave as previously but naming the introduced hypothesis \ident$_1$. It is equivalent to {\tt intro \ident$_1$} followed by the appropriate call to {\tt move}~(see Section~\ref{move}). -\begin{ErrMsgs} -\item \errindex{No product even after head-reduction} -\item \errindex{No such hypothesis} : {\ident} -\end{ErrMsgs} - \end{Variants} -\subsection{\tt apply \term -\tacindex{apply} -\label{apply}} - -This tactic applies to any goal. The argument {\term} is a term -well-formed in the local context. The tactic {\tt apply} tries to -match the current goal against the conclusion of the type of {\term}. -If it succeeds, then the tactic returns as many subgoals as the number -of non dependent premises of the type of {\term}. If the conclusion of -the type of {\term} does not match the goal {\em and} the conclusion -is an inductive type isomorphic to a tuple type, then each component -of the tuple is recursively matched to the goal in the left-to-right -order. - -The tactic {\tt apply} relies on first-order unification with -dependent types unless the conclusion of the type of {\term} is of the -form {\tt ($P$~ $t_1$~\ldots ~$t_n$)} with $P$ to be instantiated. In -the latter case, the behavior depends on the form of the goal. If the -goal is of the form {\tt (fun $x$ => $Q$)~$u_1$~\ldots~$u_n$} and the -$t_i$ and $u_i$ unifies, then $P$ is taken to be (fun $x$ => $Q$). -Otherwise, {\tt apply} tries to define $P$ by abstracting over -$t_1$~\ldots ~$t_n$ in the goal. See {\tt pattern} in -Section~\ref{pattern} to transform the goal so that it gets the form -{\tt (fun $x$ => $Q$)~$u_1$~\ldots~$u_n$}. - -\begin{ErrMsgs} -\item \errindex{Impossible to unify \dots\ with \dots} - - The {\tt apply} - tactic failed to match the conclusion of {\term} and the current goal. - You can help the {\tt apply} tactic by transforming your - goal with the {\tt change} or {\tt pattern} tactics (see - sections~\ref{pattern},~\ref{change}). - -\item \errindex{Unable to find an instance for the variables -{\ident} \ldots {\ident}} +\subsection{\tt intros {\intropattern} {\ldots} {\intropattern}} +\label{intros-pattern} +\tacindex{intros \intropattern} +\index{Introduction patterns} +\index{Naming introduction patterns} +\index{Disjunctive/conjunctive introduction patterns} - This occurs when some instantiations of the premises of {\term} are not - deducible from the unification. This is the case, for instance, when - you want to apply a transitivity property. In this case, you have to - use one of the variants below: +This extension of the tactic {\tt intros} combines introduction of +variables or hypotheses and case analysis. An {\em introduction pattern} is +either: +\begin{itemize} +\item a {\em naming introduction pattern}, i.e. either one of: + \begin{itemize} + \item the pattern \texttt{?} + \item the pattern \texttt{?\ident} + \item an identifier + \end{itemize} +\item a {\em disjunctive/conjunctive introduction pattern}, i.e. either one of: + \begin{itemize} + \item a disjunction of lists of patterns: + {\tt [$p_{11}$ \dots\ $p_{1m_1}$ | \dots\ | $p_{11}$ \dots\ $p_{nm_n}$]} + \item a conjunction of patterns: {\tt ($p_1$ , \dots\ , $p_n$)} + \item a list of patterns {\tt ($p_1$ \&\ \dots\ \&\ $p_n$)} + for sequence of right-associative binary constructs + \end{itemize} +\item the wildcard: {\tt \_} +\item the rewriting orientations: {\tt ->} or {\tt <-} +\end{itemize} -\end{ErrMsgs} +Assuming a goal of type $Q \to P$ (non-dependent product), or +of type $\forall x:T,~P$ (dependent product), the behavior of +{\tt intros $p$} is defined inductively over the structure of the +introduction pattern~$p$: +\begin{itemize} +\item introduction on \texttt{?} performs the introduction, and lets {\Coq} + choose a fresh name for the variable; +\item introduction on \texttt{?\ident} performs the introduction, and + lets {\Coq} choose a fresh name for the variable based on {\ident}; +\item introduction on \texttt{\ident} behaves as described in + Section~\ref{intro}; +\item introduction over a disjunction of list of patterns {\tt + [$p_{11}$ \dots\ $p_{1m_1}$ | \dots\ | $p_{11}$ \dots\ $p_{nm_n}$]} + expects the product to be over an inductive type + whose number of constructors is $n$ (or more generally over a type + of conclusion an inductive type built from $n$ constructors, + e.g. {\tt C -> A\textbackslash/B if $n=2$}): it destructs the introduced + hypothesis as {\tt destruct} (see Section~\ref{destruct}) would and + applies on each generated subgoal the corresponding tactic; + \texttt{intros}~$p_{i1}$ {\ldots} $p_{im_i}$; if the disjunctive + pattern is part of a sequence of patterns and is not the last + pattern of the sequence, then {\Coq} completes the pattern so that all + the argument of the constructors of the inductive type are + introduced (for instance, the list of patterns {\tt [$\;$|$\;$] H} + applied on goal {\tt forall x:nat, x=0 -> 0=x} behaves the same as + the list of patterns {\tt [$\,$|$\,$?$\,$] H}); +\item introduction over a conjunction of patterns {\tt ($p_1$, \ldots, + $p_n$)} expects the goal to be a product over an inductive type $I$ with a + single constructor that itself has at least $n$ arguments: it + performs a case analysis over the hypothesis, as {\tt destruct} + would, and applies the patterns $p_1$~\ldots~$p_n$ to the arguments + of the constructor of $I$ (observe that {\tt ($p_1$, {\ldots}, + $p_n$)} is an alternative notation for {\tt [$p_1$ {\ldots} + $p_n$]}); +\item introduction via {\tt ($p_1$ \& \dots\ \& $p_n$)} + is a shortcut for introduction via + {\tt ($p_1$,(\ldots,(\dots,$p_n$)\ldots))}; it expects the + hypothesis to be a sequence of right-associative binary inductive + constructors such as {\tt conj} or {\tt ex\_intro}; for instance, an + hypothesis with type {\tt A\verb|/\|exists x, B\verb|/\|C\verb|/\|D} can be + introduced via pattern {\tt (a \& x \& b \& c \& d)}; +\item introduction on the wildcard depends on whether the product is + dependent or not: in the non-dependent case, it erases the + corresponding hypothesis (i.e. it behaves as an {\tt intro} followed + by a {\tt clear}, cf Section~\ref{clear}) while in the dependent + case, it succeeds and erases the variable only if the wildcard is + part of a more complex list of introduction patterns that also + erases the hypotheses depending on this variable; +\item introduction over {\tt ->} (respectively {\tt <-}) expects the + hypothesis to be an equality and the right-hand-side (respectively + the left-hand-side) is replaced by the left-hand-side (respectively + the right-hand-side) in both the conclusion and the context of the goal; + if moreover the term to substitute is a variable, the hypothesis is + removed. +\end{itemize} -\begin{Variants} +\Example -\item{\tt apply {\term} with {\term$_1$} \dots\ {\term$_n$}} - \tacindex{apply \dots\ with} - - Provides {\tt apply} with explicit instantiations for all dependent - premises of the type of {\term} which do not occur in the conclusion - and consequently cannot be found by unification. Notice that - {\term$_1$} \dots\ {\term$_n$} must be given according to the order - of these dependent premises of the type of {\term}. +\begin{coq_example} +Goal forall A B C:Prop, A \/ B /\ C -> (A -> C) -> C. +intros A B C [a| [_ c]] f. +apply (f a). +exact c. +Qed. +\end{coq_example} - \ErrMsg \errindex{Not the right number of missing arguments} +\Rem {\tt intros $p_1~\ldots~p_n$} is not equivalent to \texttt{intros + $p_1$;\ldots; intros $p_n$} for the following reasons: +\begin{itemize} +\item A wildcard pattern never succeeds when applied isolated on a + dependent product, while it succeeds as part of a list of + introduction patterns if the hypotheses that depends on it are + erased too. +\item A disjunctive or conjunctive pattern followed by an introduction + pattern forces the introduction in the context of all arguments of + the constructors before applying the next pattern while a terminal + disjunctive or conjunctive pattern does not. Here is an example -\item{\tt apply {\term} with ({\vref$_1$} := {\term$_1$}) \dots\ ({\vref$_n$} - := {\term$_n$})} - - This also provides {\tt apply} with values for instantiating - premises. Here, variables are referred by names and non-dependent - products by increasing numbers (see syntax in Section~\ref{Binding-list}). +\begin{coq_example} +Goal forall n:nat, n = 0 -> n = 0. +intros [ | ] H. +Show 2. +Undo. +intros [ | ]; intros H. +Show 2. +\end{coq_example} -\item {\tt apply} {\term$_1$} {\tt ,} \ldots {\tt ,} {\term$_n$} +\end{itemize} - This is a shortcut for {\tt apply} {\term$_1$} {\tt ; [ ..~|} - \ldots~{\tt ; [ ..~| {\tt apply} {\term$_n$} ]} \ldots~{\tt ]}, i.e. for the - successive applications of {\term$_{i+1}$} on the last subgoal - generated by {\tt apply} {\term$_i$}, starting from the application - of {\term$_1$}. +\subsection{\tt clear \ident} +\tacindex{clear} +\label{clear} -\item {\tt eapply \term}\tacindex{eapply}\label{eapply} - - The tactic {\tt eapply} behaves as {\tt apply} but does not fail - when no instantiation are deducible for some variables in the - premises. Rather, it turns these variables into so-called - existential variables which are variables still to instantiate. An - existential variable is identified by a name of the form {\tt ?$n$} - where $n$ is a number. The instantiation is intended to be found - later in the proof. +This tactic erases the hypothesis named {\ident} in the local context +of the current goal. As a consequence, {\ident} is no more displayed and no more +usable in the proof development. - An example of use of {\tt eapply} is given in - Section~\ref{eapply-example}. +\begin{ErrMsgs} +\item \errindex{No such hypothesis} +\item \errindexbis{{\ident} is used in the conclusion}{is used in the + conclusion} +\item \errindexbis{{\ident} is used in the hypothesis {\ident'}}{is + used in the hypothesis} +\end{ErrMsgs} -\item {\tt simple apply {\term}} \tacindex{simple apply} +\begin{Variants} - This behaves like {\tt apply} but it reasons modulo conversion only - on subterms that contain no variables to instantiate. For instance, - if {\tt id := fun x:nat => x} and {\tt H : forall y, id y = y} then - {\tt simple apply H} on goal {\tt O = O} does not succeed because it - would require the conversion of {\tt f ?y} and {\tt O} where {\tt - ?y} is a variable to instantiate. Tactic {\tt simple apply} does not - either traverse tuples as {\tt apply} does. +\item {\tt clear {\ident$_1$} \dots\ {\ident$_n$}} - Because it reasons modulo a limited amount of conversion, {\tt - simple apply} fails quicker than {\tt apply} and it is then - well-suited for uses in used-defined tactics that backtrack often. + This is equivalent to {\tt clear {\ident$_1$}. {\ldots} clear + {\ident$_n$}.} -\item \zeroone{{\tt simple}} {\tt apply} {\term$_1$} \zeroone{{\tt with} - {\bindinglist$_1$}} {\tt ,} \ldots {\tt ,} {\term$_n$} \zeroone{{\tt with} - {\bindinglist$_n$}}\\ - \zeroone{{\tt simple}} {\tt eapply} {\term$_1$} \zeroone{{\tt with} - {\bindinglist$_1$}} {\tt ,} \ldots {\tt ,} {\term$_n$} \zeroone{{\tt with} - {\bindinglist$_n$}} +\item {\tt clearbody {\ident}}\tacindex{clearbody} - This summarizes the different syntaxes for {\tt apply} and {\tt eapply}. + This tactic expects {\ident} to be a local definition then clears + its body. Otherwise said, this tactic turns a definition into an + assumption. -\item {\tt lapply {\term}} \tacindex{lapply} + \ErrMsg \errindexbis{{\ident} is not a local definition}{is not a local definition} - This tactic applies to any goal, say {\tt G}. The argument {\term} - has to be well-formed in the current context, its type being - reducible to a non-dependent product {\tt A -> B} with {\tt B} - possibly containing products. Then it generates two subgoals {\tt - B->G} and {\tt A}. Applying {\tt lapply H} (where {\tt H} has type - {\tt A->B} and {\tt B} does not start with a product) does the same - as giving the sequence {\tt cut B. 2:apply H.} where {\tt cut} is - described below. +\item \texttt{clear - {\ident$_1$} \dots\ {\ident$_n$}} - \Warning When {\term} contains more than one non - dependent product the tactic {\tt lapply} only takes into account the - first product. + This tactic clears all the hypotheses except the ones depending in + the hypotheses named {\ident$_1$} {\ldots} {\ident$_n$} and in the + goal. + +\item \texttt{clear} + + This tactic clears all the hypotheses except the ones the goal depends on. + +\item {\tt clear dependent \ident \tacindex{clear dependent}} + + This clears the hypothesis \ident\ and all the hypotheses + that depend on it. \end{Variants} -\subsection{{\tt apply {\term} in {\ident}} -\tacindex{apply \ldots\ in}} +\subsection{\tt revert \ident$_1$ \dots\ \ident$_n$} +\tacindex{revert} +\label{revert} -This tactic applies to any goal. The argument {\term} is a term -well-formed in the local context and the argument {\ident} is an -hypothesis of the context. The tactic {\tt apply {\term} in {\ident}} -tries to match the conclusion of the type of {\ident} against a non -dependent premise of the type of {\term}, trying them from right to -left. If it succeeds, the statement of hypothesis {\ident} is -replaced by the conclusion of the type of {\term}. The tactic also -returns as many subgoals as the number of other non dependent premises -in the type of {\term} and of the non dependent premises of the type -of {\ident}. If the conclusion of the type of {\term} does not match -the goal {\em and} the conclusion is an inductive type isomorphic to a -tuple type, then the tuple is (recursively) decomposed and the first -component of the tuple of which a non dependent premise matches the -conclusion of the type of {\ident}. Tuples are decomposed in a -width-first left-to-right order (for instance if the type of {\tt H1} -is a \verb=A <-> B= statement, and the type of {\tt H2} is \verb=A= -then {\tt apply H1 in H2} transforms the type of {\tt H2} into {\tt - B}). The tactic {\tt apply} relies on first-order pattern-matching -with dependent types. +This applies to any goal with variables \ident$_1$ \dots\ \ident$_n$. +It moves the hypotheses (possibly defined) to the goal, if this respects +dependencies. This tactic is the inverse of {\tt intro}. \begin{ErrMsgs} -\item \errindex{Statement without assumptions} +\item \errindex{No such hypothesis} +\item \errindexbis{{\ident} is used in the hypothesis {\ident'}}{is + used in the hypothesis} +\end{ErrMsgs} -This happens if the type of {\term} has no non dependent premise. +\begin{Variants} +\item {\tt revert dependent \ident \tacindex{revert dependent}} -\item \errindex{Unable to apply} + This moves to the goal the hypothesis \ident\ and all hypotheses + which depend on it. -This happens if the conclusion of {\ident} does not match any of the -non dependent premises of the type of {\term}. -\end{ErrMsgs} +\end{Variants} + +\subsection{\tt move {\ident$_1$} after {\ident$_2$}} +\tacindex{move} +\label{move} + +This moves the hypothesis named {\ident$_1$} in the local context +after the hypothesis named {\ident$_2$}. The proof term is not changed. + +If {\ident$_1$} comes before {\ident$_2$} in the order of dependences, +then all hypotheses between {\ident$_1$} and {\ident$_2$} that +(possibly indirectly) depend on {\ident$_1$} are moved also. + +If {\ident$_1$} comes after {\ident$_2$} in the order of dependences, +then all hypotheses between {\ident$_1$} and {\ident$_2$} that +(possibly indirectly) occur in {\ident$_1$} are moved also. \begin{Variants} -\item {\tt apply \nelist{\term}{,} in {\ident}} -This applies each of {\term} in sequence in {\ident}. +\item {\tt move {\ident$_1$} before {\ident$_2$}} -\item {\tt apply \nelist{{\term} with {\bindinglist}}{,} in {\ident}} +This moves {\ident$_1$} towards and just before the hypothesis named {\ident$_2$}. -This does the same but uses the bindings in each {\bindinglist} to -instantiate the parameters of the corresponding type of {\term} -(see syntax of bindings in Section~\ref{Binding-list}). +\item {\tt move {\ident} at top} -\item {\tt eapply \nelist{{\term} with {\bindinglist}}{,} in {\ident}} -\tacindex{eapply {\ldots} in} +This moves {\ident} at the top of the local context (at the beginning of the context). -This works as {\tt apply \nelist{{\term} with {\bindinglist}}{,} in -{\ident}} but turns unresolved bindings into existential variables, if -any, instead of failing. +\item {\tt move {\ident} at bottom} -\item {\tt apply \nelist{{\term}{,} with {\bindinglist}}{,} in {\ident} as {\disjconjintropattern}} +This moves {\ident} at the bottom of the local context (at the end of the context). -This works as {\tt apply \nelist{{\term}{,} with {\bindinglist}}{,} in -{\ident}} then destructs the hypothesis {\ident} along -{\disjconjintropattern} as {\tt destruct {\ident} as -{\disjconjintropattern}} would. +\end{Variants} -\item {\tt eapply \nelist{{\term}{,} with {\bindinglist}}{,} in {\ident} as {\disjconjintropattern}} +\begin{ErrMsgs} -This works as {\tt apply \nelist{{\term}{,} with {\bindinglist}}{,} in {\ident} as {\disjconjintropattern}} but using {\tt eapply}. +\item \errindex{No such hypothesis} -\item {\tt simple apply {\term} in {\ident}} -\tacindex{simple apply {\ldots} in} -\tacindex{simple eapply {\ldots} in} +\item \errindex{Cannot move {\ident$_1$} after {\ident$_2$}: + it occurs in {\ident$_2$}} -This behaves like {\tt apply {\term} in {\ident}} but it reasons -modulo conversion only on subterms that contain no variables to -instantiate. For instance, if {\tt id := fun x:nat => x} and {\tt H : - forall y, id y = y -> True} and {\tt H0 : O = O} then {\tt simple - apply H in H0} does not succeed because it would require the -conversion of {\tt f ?y} and {\tt O} where {\tt ?y} is a variable to -instantiate. Tactic {\tt simple apply {\term} in {\ident}} does not -either traverse tuples as {\tt apply {\term} in {\ident}} does. +\item \errindex{Cannot move {\ident$_1$} after {\ident$_2$}: + it depends on {\ident$_2$}} -\item {\tt \zeroone{simple} apply \nelist{{\term} \zeroone{with {\bindinglist}}}{,} in {\ident} \zeroone{as {\disjconjintropattern}}}\\ -{\tt \zeroone{simple} eapply \nelist{{\term} \zeroone{with {\bindinglist}}}{,} in {\ident} \zeroone{as {\disjconjintropattern}}} +\end{ErrMsgs} + +\subsection{\tt rename {\ident$_1$} into {\ident$_2$}} +\tacindex{rename} + +This renames hypothesis {\ident$_1$} into {\ident$_2$} in the current +context. The name of the hypothesis in the proof-term, however, is left +unchanged. + +\begin{Variants} + +\item {\tt rename {\ident$_1$} into {\ident$_2$}, \ldots, + {\ident$_{2k-1}$} into {\ident$_{2k}$}} + +This is equivalent to the sequence of the corresponding atomic {\tt rename}. -This summarizes the different syntactic variants of {\tt apply {\term} - in {\ident}} and {\tt eapply {\term} in {\ident}}. \end{Variants} -\subsection{{\tt set ( {\ident} {\tt :=} {\term} \tt )} +\begin{ErrMsgs} +\item \errindex{No such hypothesis} +\item \errindexbis{{\ident$_2$} is already used}{is already used} +\end{ErrMsgs} + +\subsection{\tt set ( {\ident} := {\term} )} \label{tactic:set} \tacindex{set} -\tacindex{pose} -\tacindex{remember}} -This replaces {\term} by {\ident} in the conclusion or in the -hypotheses of the current goal and adds the new definition {\ident -{\tt :=} \term} to the local context. The default is to make this -replacement only in the conclusion. +This replaces {\term} by {\ident} in the conclusion of the current goal +and adds the new definition {\tt {\ident} := \term} to the local context. If {\term} has holes (i.e. subexpressions of the form ``\_''), the tactic first checks that all subterms matching the pattern are compatible before doing the replacement using the leftmost subterm matching the pattern. +\begin{ErrMsgs} +\item \errindex{The variable {\ident} is already defined} +\end{ErrMsgs} + \begin{Variants} -\item {\tt set (} {\ident} {\tt :=} {\term} {\tt ) in {\occgoalset}} +\item {\tt set ( {\ident} := {\term} ) in {\occgoalset}} This notation allows to specify which occurrences of {\term} have to be substituted in the context. The {\tt in {\occgoalset}} clause is an -occurrence clause whose syntax and behavior is described in +occurrence clause whose syntax and behavior are described in Section~\ref{Occurrences clauses}. -\item {\tt set (} {\ident} \nelist{\binder}{} {\tt :=} {\term} {\tt )} +\item {\tt set ( {\ident} \nelist{\binder}{} := {\term} )} - This is equivalent to {\tt set (} {\ident} {\tt :=} {\tt fun} - \nelist{\binder}{} {\tt =>} {\term} {\tt )}. + This is equivalent to {\tt set ( {\ident} := fun + \nelist{\binder}{} => {\term} )}. -\item {\tt set } {\term} +\item {\tt set \term} This behaves as {\tt set (} {\ident} := {\term} {\tt )} but {\ident} is generated by {\Coq}. This variant also supports an occurrence clause. -\item {\tt set (} {\ident$_0$} \nelist{\binder}{} {\tt :=} {\term} - {\tt ) in {\occgoalset}}\\ +\item {\tt set ( {\ident$_0$} \nelist{\binder}{} := {\term} ) in {\occgoalset}}\\ {\tt set {\term} in {\occgoalset}} These are the general forms which combine the previous possibilities. -\item {\tt remember {\term} {\tt as} {\ident}} +\item {\tt remember {\term} as {\ident}}\tacindex{remember} - This behaves as {\tt set (} {\ident} := {\term} {\tt ) in *} and using a + This behaves as {\tt set ( {\ident} := {\term} ) in *} and using a logical (Leibniz's) equality instead of a local definition. -\item {\tt remember {\term} {\tt as} {\ident} in {\occgoalset}} +\item {\tt remember {\term} as {\ident} in {\occgoalset}} This is a more general form of {\tt remember} that remembers the occurrences of {\term} specified by an occurrences set. -\item {\tt pose ( {\ident} := {\term} )} - +\item {\tt pose ( {\ident} := {\term} )}\tacindex{pose} + This adds the local definition {\ident} := {\term} to the current context without performing any replacement in the goal or in the hypotheses. It is equivalent to {\tt set ( {\ident} {\tt :=} {\term} {\tt ) in |-}}. -\item {\tt pose (} {\ident} \nelist{\binder}{} {\tt :=} {\term} {\tt )} +\item {\tt pose ( {\ident} \nelist{\binder}{} := {\term} )} This is equivalent to {\tt pose (} {\ident} {\tt :=} {\tt fun} \nelist{\binder}{} {\tt =>} {\term} {\tt )}. \item{\tt pose {\term}} - This behaves as {\tt pose (} {\ident} := {\term} {\tt )} but + This behaves as {\tt pose ( {\ident} := {\term} )} but {\ident} is generated by {\Coq}. \end{Variants} -\subsection{{\tt assert ( {\ident} : {\form} \tt )} -\tacindex{assert}} - -This tactic applies to any goal. {\tt assert (H : U)} adds a new -hypothesis of name \texttt{H} asserting \texttt{U} to the current goal -and opens a new subgoal \texttt{U}\footnote{This corresponds to the - cut rule of sequent calculus.}. The subgoal {\texttt U} comes first -in the list of subgoals remaining to prove. - -\begin{ErrMsgs} -\item \errindex{Not a proposition or a type} - - Arises when the argument {\form} is neither of type {\tt Prop}, {\tt - Set} nor {\tt Type}. +\subsection{\tt decompose [ {\qualid$_1$} \dots\ {\qualid$_n$} ] \term} +\label{decompose} +\tacindex{decompose} -\end{ErrMsgs} +This tactic allows to recursively decompose a +complex proposition in order to obtain atomic ones. -\begin{Variants} +\Example + +\begin{coq_eval} +Reset Initial. +\end{coq_eval} +\begin{coq_example} +Goal forall A B C:Prop, A /\ B /\ C \/ B /\ C \/ C /\ A -> C. +intros A B C H; decompose [and or] H; assumption. +\end{coq_example} +\begin{coq_example*} +Qed. +\end{coq_example*} + +{\tt decompose} does not work on right-hand sides of implications or products. + +\begin{Variants} + +\item {\tt decompose sum \term}\tacindex{decompose sum} + + This decomposes sum types (like \texttt{or}). + +\item {\tt decompose record \term}\tacindex{decompose record} + + This decomposes record types (inductive types with one constructor, + like \texttt{and} and \texttt{exists} and those defined with the + \texttt{Record} macro, see Section~\ref{Record}). + +\end{Variants} + +\section{Controlling the proof flow} + +\subsection{\tt assert ( {\ident} :\ {\form} )} +\tacindex{assert} + +This tactic applies to any goal. {\tt assert (H : U)} adds a new +hypothesis of name \texttt{H} asserting \texttt{U} to the current goal +and opens a new subgoal \texttt{U}\footnote{This corresponds to the + cut rule of sequent calculus.}. The subgoal {\texttt U} comes first +in the list of subgoals remaining to prove. + +\begin{ErrMsgs} +\item \errindex{Not a proposition or a type} + + Arises when the argument {\form} is neither of type {\tt Prop}, {\tt + Set} nor {\tt Type}. + +\end{ErrMsgs} + +\begin{Variants} \item{\tt assert {\form}} - - This behaves as {\tt assert (} {\ident} : {\form} {\tt )} but + + This behaves as {\tt assert ( {\ident} :\ {\form} )} but {\ident} is generated by {\Coq}. -\item{\tt assert (} {\ident} := {\term} {\tt )} - - This behaves as {\tt assert ({\ident} : {\type});[exact +\item{\tt assert ( {\ident} := {\term} )} + + This behaves as {\tt assert ({\ident} :\ {\type});[exact {\term}|idtac]} where {\type} is the type of {\term}. -\item {\tt cut {\form}}\tacindex{cut} - - This tactic applies to any goal. It implements the non dependent + \ErrMsg \errindex{Variable {\ident} is already declared} + +\item {\tt cut {\form}}\tacindex{cut} + + This tactic applies to any goal. It implements the non-dependent case of the ``App''\index{Typing rules!App} rule given in Section~\ref{Typed-terms}. (This is Modus Ponens inference rule.) {\tt cut U} transforms the current goal \texttt{T} into the two @@ -689,16 +1159,18 @@ in the list of subgoals remaining to prove. -> T} comes first in the list of remaining subgoal to prove. \item \texttt{assert {\form} by {\tac}}\tacindex{assert by} - + This tactic behaves like \texttt{assert} but applies {\tac} to solve the subgoals generated by \texttt{assert}. + \ErrMsg \errindex{Proof is not complete} + \item \texttt{assert {\form} as {\intropattern}\tacindex{assert as}} If {\intropattern} is a naming introduction pattern (see Section~\ref{intros-pattern}), the hypothesis is named after this introduction pattern (in particular, if {\intropattern} is {\ident}, - the tactic behaves like \texttt{assert ({\ident} : {\form})}). + the tactic behaves like \texttt{assert ({\ident} :\ {\form})}). If {\intropattern} is a disjunctive/conjunctive introduction pattern, the tactic behaves like \texttt{assert {\form}} then destructing the @@ -714,12 +1186,11 @@ in the list of subgoals remaining to prove. exact {\term}} where \texttt{T} is the type of {\term}. In particular, \texttt{pose proof {\term} as {\ident}} behaves as - \texttt{assert ({\ident}:T) by exact {\term}} (where \texttt{T} is - the type of {\term}) and \texttt{pose proof {\term} as + \texttt{assert ({\ident} := {\term})} and \texttt{pose proof {\term} as {\disjconjintropattern}\tacindex{pose proof}} behaves like \texttt{destruct {\term} as {\disjconjintropattern}}. -\item {\tt specialize ({\ident} \term$_1$ {\ldots} \term$_n$)\tacindex{specialize}} \\ +\item {\tt specialize ({\ident} \term$_1$ \dots\ \term$_n$)\tacindex{specialize}} \\ {\tt specialize {\ident} with \bindinglist} The tactic {\tt specialize} works on local hypothesis \ident. @@ -730,30 +1201,37 @@ in the list of subgoals remaining to prove. Section~\ref{Binding-list} for more about bindings lists). In the second form, all instantiation elements must be given, whereas in the first form the application to \term$_1$ {\ldots} - \term$_n$ can be partial. The first form is equivalent to - {\tt assert (\ident':=\ident \term$_1$ {\ldots} \term$_n$); - clear \ident; rename \ident' into \ident}. + \term$_n$ can be partial. The first form is equivalent to + {\tt assert (\ident' := {\ident} {\term$_1$} \dots\ \term$_n$); + clear \ident; rename \ident' into \ident}. The name {\ident} can also refer to a global lemma or hypothesis. In this case, for compatibility reasons, the behavior of {\tt specialize} is close to that of {\tt - generalize}: the instantiated statement becomes an additional - premise of the goal. + generalize}: the instantiated statement becomes an additional + premise of the goal. + + \begin{ErrMsgs} + \item \errindexbis{{\ident} is used in hypothesis \ident'}{is used in hypothesis} + \item \errindexbis{{\ident} is used in conclusion}{is used in conclusion} + \end{ErrMsgs} -%% Moreover, the old syntax allows the use of a number after {\tt specialize} -%% for controlling the number of premises to instantiate. Giving this +%% Moreover, the old syntax allows the use of a number after {\tt specialize} +%% for controlling the number of premises to instantiate. Giving this %% number should not be mandatory anymore (automatic detection of how -%% many premises can be eaten without leaving meta-variables). Hence +%% many premises can be eaten without leaving meta-variables). Hence %% no documentation for this integer optional argument of specialize \end{Variants} -\subsection{\tt generalize \term +\subsection{\tt generalize \term} \tacindex{generalize} -\label{generalize}} +\label{generalize} + +This tactic applies to any goal. It generalizes the conclusion with +respect to one of its subterms. -This tactic applies to any goal. It generalizes the conclusion w.r.t. -one subterm of it. For example: +\Example \begin{coq_eval} Goal forall x y:nat, (0 <= x + y + y). @@ -775,185 +1253,49 @@ where $G'$ is obtained from $G$ by replacing all occurrences of $t$ by \begin{Variants} \item {\tt generalize {\term$_1$ , \dots\ , \term$_n$}} - - Is equivalent to {\tt generalize \term$_n$; \dots\ ; generalize + + This is equivalent to {\tt generalize \term$_n$; \dots\ ; generalize \term$_1$}. Note that the sequence of \term$_i$'s are processed from $n$ to $1$. \item {\tt generalize {\term} at {\num$_1$ \dots\ \num$_i$}} - - Is equivalent to {\tt generalize \term} but generalizing only over + + This is equivalent to {\tt generalize \term} but it generalizes only over the specified occurrences of {\term} (counting from left to right on the expression printed using option {\tt Set Printing All}). \item {\tt generalize {\term} as {\ident}} - - Is equivalent to {\tt generalize \term} but use {\ident} to name the + + This is equivalent to {\tt generalize \term} but it uses {\ident} to name the generalized hypothesis. -\item {\tt generalize {\term$_1$} at {\num$_{11}$ \dots\ \num$_{1i_1}$} +\item {\tt generalize {\term$_1$} at {\num$_{11}$ \dots\ \num$_{1i_1}$} as {\ident$_1$} , {\ldots} , {\term$_n$} at {\num$_{n1}$ \dots\ \num$_{ni_n}$} as {\ident$_2$}} - + This is the most general form of {\tt generalize} that combines the previous behaviors. - -\item {\tt generalize dependent \term} \tacindex{generalize dependent} - - This generalizes {\term} but also {\em all} hypotheses which depend - on {\term}. It clears the generalized hypotheses. - -\end{Variants} - - -\subsection{\tt revert \ident$_1$ \dots\ \ident$_n$ -\tacindex{revert} -\label{revert}} - -This applies to any goal with variables \ident$_1$ \dots\ \ident$_n$. -It moves the hypotheses (possibly defined) to the goal, if this respects -dependencies. This tactic is the inverse of {\tt intro}. - -\begin{ErrMsgs} -\item \errindexbis{{\ident} is used in the hypothesis {\ident'}}{is - used in the hypothesis} -\end{ErrMsgs} - -\begin{Variants} -\item {\tt revert dependent \ident \tacindex{revert dependent}} - - This moves to the goal the hypothesis \ident\ and all hypotheses - which depend on it. - -\end{Variants} - -\subsection{\tt change \term -\tacindex{change} -\label{change}} - -This tactic applies to any goal. It implements the rule -``Conv''\index{Typing rules!Conv} given in Section~\ref{Conv}. {\tt - change U} replaces the current goal \T\ with \U\ providing that -\U\ is well-formed and that \T\ and \U\ are convertible. - -\begin{ErrMsgs} -\item \errindex{Not convertible} -\end{ErrMsgs} - -\tacindex{change \dots\ in} -\begin{Variants} -\item {\tt change \term$_1$ with \term$_2$} - - This replaces the occurrences of \term$_1$ by \term$_2$ in the - current goal. The terms \term$_1$ and \term$_2$ must be - convertible. - -\item {\tt change \term$_1$ at \num$_1$ \dots\ \num$_i$ with \term$_2$} - - This replaces the occurrences numbered \num$_1$ \dots\ \num$_i$ of - \term$_1$ by \term$_2$ in the current goal. - The terms \term$_1$ and \term$_2$ must be convertible. - - \ErrMsg {\tt Too few occurrences} - -\item {\tt change {\term} in {\ident}} - -\item {\tt change \term$_1$ with \term$_2$ in {\ident}} - -\item {\tt change \term$_1$ at \num$_1$ \dots\ \num$_i$ with \term$_2$ in - {\ident}} - - This applies the {\tt change} tactic not to the goal but to the - hypothesis {\ident}. - -\end{Variants} - -\SeeAlso \ref{Conversion-tactics} - -\subsection{\tt fix {\ident} {\num} -\tacindex{fix} -\label{tactic:fix}} - -This tactic is a primitive tactic to start a proof by induction. In -general, it is easier to rely on higher-level induction tactics such -as the ones described in Section~\ref{Tac-induction}. - -In the syntax of the tactic, the identifier {\ident} is the name given -to the induction hypothesis. The natural number {\num} tells on which -premise of the current goal the induction acts, starting -from 1 and counting both dependent and non dependent -products. Especially, the current lemma must be composed of at least -{\num} products. - -Like in a {\tt fix} expression, the induction -hypotheses have to be used on structurally smaller arguments. -The verification that inductive proof arguments are correct is done -only at the time of registering the lemma in the environment. To know -if the use of induction hypotheses is correct at some -time of the interactive development of a proof, use the command {\tt - Guarded} (see Section~\ref{Guarded}). - -\begin{Variants} - \item {\tt fix} {\ident}$_1$ {\num} {\tt with (} {\ident}$_2$ - \nelist{{\binder}$_{2}$}{} \zeroone{{\tt \{ struct {\ident$'_2$} - \}}} {\tt :} {\type}$_2$ {\tt )} {\ldots} {\tt (} {\ident}$_1$ - \nelist{{\binder}$_n$}{} \zeroone{{\tt \{ struct {\ident$'_n$} \}}} - {\tt :} {\type}$_n$ {\tt )} - -This starts a proof by mutual induction. The statements to be -simultaneously proved are respectively {\tt forall} - \nelist{{\binder}$_2$}{}{\tt ,} {\type}$_2$, {\ldots}, {\tt forall} - \nelist{{\binder}$_n$}{}{\tt ,} {\type}$_n$. The identifiers -{\ident}$_1$ {\ldots} {\ident}$_n$ are the names of the induction -hypotheses. The identifiers {\ident}$'_2$ {\ldots} {\ident}$'_n$ are the -respective names of the premises on which the induction is performed -in the statements to be simultaneously proved (if not given, the -system tries to guess itself what they are). - -\end{Variants} - -\subsection{\tt cofix {\ident} -\tacindex{cofix} -\label{tactic:cofix}} - -This tactic starts a proof by coinduction. The identifier {\ident} is -the name given to the coinduction hypothesis. Like in a {\tt cofix} -expression, the use of induction hypotheses have to guarded by a -constructor. The verification that the use of coinductive hypotheses -is correct is done only at the time of registering the lemma in the -environment. To know if the use of coinduction hypotheses is correct -at some time of the interactive development of a proof, use the -command {\tt Guarded} (see Section~\ref{Guarded}). - -\begin{Variants} - \item {\tt cofix} {\ident}$_1$ {\tt with (} {\ident}$_2$ - \nelist{{\binder}$_2$}{} {\tt :} {\type}$_2$ {\tt )} {\ldots} {\tt - (} {\ident}$_1$ \nelist{{\binder}$_1$}{} {\tt :} {\type}$_n$ - {\tt )} +\item {\tt generalize dependent \term} \tacindex{generalize dependent} -This starts a proof by mutual coinduction. The statements to be -simultaneously proved are respectively {\tt forall} -\nelist{{\binder}$_2$}{}{\tt ,} {\type}$_2$, {\ldots}, {\tt forall} - \nelist{{\binder}$_n$}{}{\tt ,} {\type}$_n$. The identifiers - {\ident}$_1$ {\ldots} {\ident}$_n$ are the names of the - coinduction hypotheses. + This generalizes {\term} but also {\em all} hypotheses that depend + on {\term}. It clears the generalized hypotheses. \end{Variants} -\subsection{\tt evar (\ident:\term) +\subsection{\tt evar ( {\ident} :\ {\term} )} \tacindex{evar} -\label{evar}} +\label{evar} The {\tt evar} tactic creates a new local definition named \ident\ with type \term\ in the context. The body of this binding is a fresh existential variable. -\subsection{\tt instantiate (\num:= \term) +\subsection{\tt instantiate ( {\num} := {\term} )} \tacindex{instantiate} -\label{instantiate}} +\label{instantiate} The {\tt instantiate} tactic allows to refine (see Section~\ref{refine}) an existential variable @@ -963,14 +1305,14 @@ the number of the existential variable since this number is different in every session. \begin{Variants} - \item {\tt instantiate (\num:=\term) in \ident} - - \item {\tt instantiate (\num:=\term) in (Value of \ident)} - - \item {\tt instantiate (\num:=\term) in (Type of \ident)} + \item {\tt instantiate ( {\num} := {\term} ) in \ident} + + \item {\tt instantiate ( {\num} := {\term} ) in ( Value of {\ident} )} -These allow to refer respectively to existential variables occurring in -a hypothesis or in the body or the type of a local definition. + \item {\tt instantiate ( {\num} := {\term} ) in ( Type of {\ident} )} + +These allow to refer respectively to existential variables occurring in +a hypothesis or in the body or the type of a local definition. \item {\tt instantiate} @@ -983,9 +1325,9 @@ a hypothesis or in the body or the type of a local definition. \end{Variants} -\subsection{\tt admit +\subsection{\tt admit} \tacindex{admit} -\label{admit}} +\label{admit} The {\tt admit} tactic ``solves'' the current subgoal by an axiom. This typically allows to temporarily skip a subgoal so as to @@ -995,1422 +1337,1165 @@ Assumptions} (see Section~\ref{PrintAssumptions}). Admitted subgoals have names of the form {\ident}\texttt{\_admitted} possibly followed by a number. -\subsection{\tt constr\_eq \term$_1$ \term$_2$ -\tacindex{constr\_eq} -\label{constreq}} +\subsection{\tt absurd \term} +\tacindex{absurd} +\label{absurd} -This tactic applies to any goal. It checks whether its arguments are -equal modulo alpha conversion and casts. +This tactic applies to any goal. The argument {\term} is any +proposition {\tt P} of type {\tt Prop}. This tactic applies {\tt + False} elimination, that is it deduces the current goal from {\tt + False}, and generates as subgoals {\tt $\sim$P} and {\tt P}. It is +very useful in proofs by cases, where some cases are impossible. In +most cases, \texttt{P} or $\sim$\texttt{P} is one of the hypotheses of +the local context. -\ErrMsg \errindex{Not equal} +\subsection{\tt contradiction} +\label{contradiction} +\tacindex{contradiction} -\subsection{\tt is\_evar \term -\tacindex{is\_evar} -\label{isevar}} +This tactic applies to any goal. The {\tt contradiction} tactic +attempts to find in the current context (after all {\tt intros}) one +hypothesis that is equivalent to {\tt False}. It permits to prune +irrelevant cases. This tactic is a macro for the tactics sequence +{\tt intros; elimtype False; assumption}. -This tactic applies to any goal. It checks whether its argument is an -existential variable. Existential variables are uninstantiated -variables generated by e.g. {\tt eapply} (see Section~\ref{apply}). +\begin{ErrMsgs} +\item \errindex{No such assumption} +\end{ErrMsgs} -\ErrMsg \errindex{Not an evar} +\begin{Variants} +\item {\tt contradiction \ident} -\subsection{\tt has\_evar \term -\tacindex{has\_evar} -\label{hasevar}} +The proof of {\tt False} is searched in the hypothesis named \ident. +\end{Variants} -This tactic applies to any goal. It checks whether its argument has an -existential variable as a subterm. Unlike {\tt context} patterns -combined with {\tt is\_evar}, this tactic scans all subterms, -including those under binders. +\subsection{\tt contradict \ident} +\label{contradict} +\tacindex{contradict} -\ErrMsg \errindex{No evars} +This tactic allows to manipulate negated hypothesis and goals. The +name \ident\ should correspond to a hypothesis. With +{\tt contradict H}, the current goal and context is transformed in +the following way: +\begin{itemize} +\item {\tt H:$\neg$A $\vd$ B} \ becomes \ {\tt $\vd$ A} +\item {\tt H:$\neg$A $\vd$ $\neg$B} \ becomes \ {\tt H: B $\vd$ A } +\item {\tt H: A $\vd$ B} \ becomes \ {\tt $\vd$ $\neg$A} +\item {\tt H: A $\vd$ $\neg$B} \ becomes \ {\tt H: B $\vd$ $\neg$A} +\end{itemize} -\subsection{\tt is\_var \term -\tacindex{is\_var} -\label{isvar}} +\subsection{\tt exfalso} +\label{exfalso} +\tacindex{exfalso} -This tactic applies to any goal. It checks whether its argument is a -variable or hypothesis in the current goal context or in the opened sections. +This tactic implements the ``ex falso quodlibet'' logical principle: +an elimination of {\tt False} is performed on the current goal, and the +user is then required to prove that {\tt False} is indeed provable in +the current context. This tactic is a macro for {\tt elimtype False}. -\ErrMsg \errindex{Not a variable or hypothesis} +\section{Case analysis and induction} -\subsection{Bindings list -\index{Binding list} -\label{Binding-list}} +The tactics presented in this section implement induction or case +analysis on inductive or co-inductive objects (see +Section~\ref{Cic-inductive-definitions}). -Tactics that take a term as argument may also support a bindings list, so -as to instantiate some parameters of the term by name or position. -The general form of a term equipped with a bindings list is {\tt -{\term} with {\bindinglist}} where {\bindinglist} may be of two -different forms: +\subsection{\tt destruct \term} +\tacindex{destruct} +\label{destruct} -\begin{itemize} -\item In a bindings list of the form {\tt (\vref$_1$ := \term$_1$) - \dots\ (\vref$_n$ := \term$_n$)}, {\vref} is either an {\ident} or a - {\num}. The references are determined according to the type of - {\term}. If \vref$_i$ is an identifier, this identifier has to be - bound in the type of {\term} and the binding provides the tactic - with an instance for the parameter of this name. If \vref$_i$ is - some number $n$, this number denotes the $n$-th non dependent - premise of the {\term}, as determined by the type of {\term}. +This tactic applies to any goal. The argument {\term} must be of +inductive or co-inductive type and the tactic generates subgoals, one +for each possible form of {\term}, i.e. one for each constructor of +the inductive or co-inductive type. Unlike {\tt induction}, no +induction hypothesis is generated by {\tt destruct}. - \ErrMsg \errindex{No such binder} +If the argument is dependent in either the conclusion or some +hypotheses of the goal, the argument is replaced by the appropriate +constructor form in each of the resulting subgoals, thus performing +case analysis. If non-dependent, the tactic simply exposes the +inductive or co-inductive structure of the argument. -\item A bindings list can also be a simple list of terms {\tt - \term$_1$ \dots\term$_n$}. In that case the references to - which these terms correspond are determined by the tactic. In case - of {\tt induction}, {\tt destruct}, {\tt elim} and {\tt case} (see - Section~\ref{elim}) the terms have to provide instances for all the - dependent products in the type of \term\ while in the case of {\tt - apply}, or of {\tt constructor} and its variants, only instances for - the dependent products which are not bound in the conclusion of the - type are required. +There are special cases: - \ErrMsg \errindex{Not the right number of missing arguments} -\end{itemize} +\begin{itemize} -\subsection{Occurrences sets and occurrences clauses} -\label{Occurrences clauses} -\index{Occurrences clauses} +\item If {\term} is an identifier {\ident} denoting a quantified +variable of the conclusion of the goal, then {\tt destruct {\ident}} +behaves as {\tt intros until {\ident}; destruct {\ident}}. -An occurrences clause is a modifier to some tactics that obeys the -following syntax: +\item If {\term} is a {\num}, then {\tt destruct {\num}} behaves as +{\tt intros until {\num}} followed by {\tt destruct} applied to the +last introduced hypothesis. Remark: For destruction of a numeral, use +syntax {\tt destruct ({\num})} (not very interesting anyway). -$\!\!\!$\begin{tabular}{lcl} -{\occclause} & ::= & {\tt in} {\occgoalset} \\ -{\occgoalset} & ::= & - \zeroone{{\ident$_1$} \zeroone{\atoccurrences} {\tt ,} \\ -& & {\dots} {\tt ,}\\ -& & {\ident$_m$} \zeroone{\atoccurrences}}\\ -& & \zeroone{{\tt |-} \zeroone{{\tt *} \zeroone{\atoccurrences}}}\\ -& | & - {\tt *} {\tt |-} \zeroone{{\tt *} \zeroone{\atoccurrences}}\\ -& | & - {\tt *}\\ -{\atoccurrences} & ::= & {\tt at} {\occlist}\\ -{\occlist} & ::= & \zeroone{{\tt -}} {\num$_1$} \dots\ {\num$_n$} -\end{tabular} +\item The argument {\term} can also be a pattern of which holes are + denoted by ``\_''. In this case, the tactic checks that all subterms + matching the pattern in the conclusion and the hypotheses are + compatible and performs case analysis using this subterm. -The role of an occurrence clause is to select a set of occurrences of -a {\term} in a goal. In the first case, the {{\ident$_i$} -\zeroone{{\tt at} {\num$_1^i$} \dots\ {\num$_{n_i}^i$}}} parts -indicate that occurrences have to be selected in the hypotheses named -{\ident$_i$}. If no numbers are given for hypothesis {\ident$_i$}, -then all occurrences of {\term} in the hypothesis are selected. If -numbers are given, they refer to occurrences of {\term} when the term -is printed using option {\tt Set Printing All} (see -Section~\ref{SetPrintingAll}), counting from left to right. In -particular, occurrences of {\term} in implicit arguments (see -Section~\ref{Implicit Arguments}) or coercions (see -Section~\ref{Coercions}) are counted. +\end{itemize} -If a minus sign is given between {\tt at} and the list of occurrences, -it negates the condition so that the clause denotes all the occurrences except -the ones explicitly mentioned after the minus sign. +\begin{Variants} +\item{\tt destruct {\term} as {\disjconjintropattern}} -As an exception to the left-to-right order, the occurrences in the -{\tt return} subexpression of a {\tt match} are considered {\em -before} the occurrences in the matched term. + This behaves as {\tt destruct {\term}} but uses the names in + {\intropattern} to name the variables introduced in the context. + The {\intropattern} must have the form {\tt [} $p_{11}$ \ldots + $p_{1n_1}$ {\tt |} {\ldots} {\tt |} $p_{m1}$ \ldots $p_{mn_m}$ {\tt + ]} with $m$ being the number of constructors of the type of + {\term}. Each variable introduced by {\tt destruct} in the context + of the $i^{th}$ goal gets its name from the list $p_{i1}$ \ldots + $p_{in_i}$ in order. If there are not enough names, {\tt destruct} + invents names for the remaining variables to introduce. More + generally, the $p_{ij}$ can be any disjunctive/conjunctive + introduction pattern (see Section~\ref{intros-pattern}). This + provides a concise notation for nested destruction. -In the second case, the {\tt *} on the left of {\tt |-} means that -all occurrences of {\term} are selected in every hypothesis. +% It is recommended to use this variant of {\tt destruct} for +% robust proof scripts. -In the first and second case, if {\tt *} is mentioned on the right of -{\tt |-}, the occurrences of the conclusion of the goal have to be -selected. If some numbers are given, then only the occurrences denoted -by these numbers are selected. In no numbers are given, all -occurrences of {\term} in the goal are selected. +\item{\tt destruct {\term} as {\disjconjintropattern} \_eqn} -Finally, the last notation is an abbreviation for {\tt * |- *}. Note -also that {\tt |-} is optional in the first case when no {\tt *} is -given. + This behaves as {\tt destruct {\term}} but adds an equation between + {\term} and the value that {\term} takes in each of the possible + cases. The name of the equation is chosen by Coq. If + {\disjconjintropattern} is simply {\tt []}, it is automatically considered + as a disjunctive pattern of the appropriate size. -Here are some tactics that understand occurrences clauses: -{\tt set}, {\tt remember}, {\tt induction}, {\tt destruct}. +\item{\tt destruct {\term} as {\disjconjintropattern} \_eqn:~{\namingintropattern}} -\SeeAlso~Sections~\ref{tactic:set}, \ref{Tac-induction}, \ref{SetPrintingAll}. + This behaves as {\tt destruct {\term} as + {\disjconjintropattern} \_eqn} but use {\namingintropattern} to + name the equation (see Section~\ref{intros-pattern}). Note that spaces + can generally be removed around {\tt \_eqn}. +\item{\tt destruct {\term} with \bindinglist} -\section{Negation and contradiction} + This behaves like \texttt{destruct {\term}} providing explicit + instances for the dependent premises of the type of {\term} (see + syntax of bindings in Section~\ref{Binding-list}). -\subsection{\tt absurd \term -\tacindex{absurd} -\label{absurd}} +\item{\tt edestruct {\term}\tacindex{edestruct}} -This tactic applies to any goal. The argument {\term} is any -proposition {\tt P} of type {\tt Prop}. This tactic applies {\tt - False} elimination, that is it deduces the current goal from {\tt - False}, and generates as subgoals {\tt $\sim$P} and {\tt P}. It is -very useful in proofs by cases, where some cases are impossible. In -most cases, \texttt{P} or $\sim$\texttt{P} is one of the hypotheses of -the local context. + This tactic behaves like \texttt{destruct {\term}} except that it + does not fail if the instance of a dependent premises of the type of + {\term} is not inferable. Instead, the unresolved instances are left + as existential variables to be inferred later, in the same way as + {\tt eapply} does (see Section~\ref{eapply-example}). -\subsection{\tt contradiction -\label{contradiction} -\tacindex{contradiction}} +\item{\tt destruct {\term$_1$} using {\term$_2$}}\\ + {\tt destruct {\term$_1$} using {\term$_2$} with {\bindinglist}} -This tactic applies to any goal. The {\tt contradiction} tactic -attempts to find in the current context (after all {\tt intros}) one -hypothesis which is equivalent to {\tt False}. It permits to prune -irrelevant cases. This tactic is a macro for the tactics sequence -{\tt intros; elimtype False; assumption}. + These are synonyms of {\tt induction {\term$_1$} using {\term$_2$}} and + {\tt induction {\term$_1$} using {\term$_2$} with {\bindinglist}}. -\begin{ErrMsgs} -\item \errindex{No such assumption} -\end{ErrMsgs} +\item \texttt{destruct {\term} in {\occgoalset}} -\begin{Variants} -\item {\tt contradiction \ident} + This syntax is used for selecting which occurrences of {\term} the + case analysis has to be done on. The {\tt in {\occgoalset}} clause is an + occurrence clause whose syntax and behavior is described in + Section~\ref{Occurrences clauses}. -The proof of {\tt False} is searched in the hypothesis named \ident. -\end{Variants} +% When an occurrence clause is given, an equation between {\term} and +% the value it gets in each case of the analysis is added to the +% context of the subgoals corresponding to the cases (even +% if no clause {\tt as {\namingintropattern}} is given). -\subsection {\tt contradict \ident} -\label{contradict} -\tacindex{contradict} +\item{\tt destruct {\term$_1$} with {\bindinglist$_1$} as {\disjconjintropattern} \_eqn:~{\namingintropattern} using {\term$_2$} with {\bindinglist$_2$} in {\occgoalset}}\\ + {\tt edestruct {\term$_1$} with {\bindinglist$_1$} as {\disjconjintropattern} \_eqn:~{\namingintropattern} using {\term$_2$} with {\bindinglist$_2$} in {\occgoalset}} -This tactic allows to manipulate negated hypothesis and goals. The -name \ident\ should correspond to a hypothesis. With -{\tt contradict H}, the current goal and context is transformed in -the following way: -\begin{itemize} -\item {\tt H:$\neg$A $\vd$ B} \ becomes \ {\tt $\vd$ A} -\item {\tt H:$\neg$A $\vd$ $\neg$B} \ becomes \ {\tt H: B $\vd$ A } -\item {\tt H: A $\vd$ B} \ becomes \ {\tt $\vd$ $\neg$A} -\item {\tt H: A $\vd$ $\neg$B} \ becomes \ {\tt H: B $\vd$ $\neg$A} -\end{itemize} + These are the general forms of {\tt destruct} and {\tt edestruct}. + They combine the effects of the {\tt with}, {\tt as}, {\tt using}, + and {\tt in} clauses. -\subsection{\tt exfalso} -\label{exfalso} -\tacindex{exfalso} +\item{\tt case \term}\label{case}\tacindex{case} -This tactic implements the ``ex falso quodlibet'' logical principle: -an elimination of {\tt False} is performed on the current goal, and the -user is then required to prove that {\tt False} is indeed provable in -the current context. This tactic is a macro for {\tt elimtype False}. + The tactic {\tt case} is a more basic tactic to perform case + analysis without recursion. It behaves as {\tt elim \term} but using + a case-analysis elimination principle and not a recursive one. -\section{Conversion tactics -\index{Conversion tactics} -\label{Conversion-tactics}} +\item {\tt case {\term} with {\bindinglist}} -This set of tactics implements different specialized usages of the -tactic \texttt{change}. + Analogous to {\tt elim {\term} with {\bindinglist}} above. -All conversion tactics (including \texttt{change}) can be -parameterized by the parts of the goal where the conversion can -occur. This is done using \emph{goal clauses} which consists in a list -of hypotheses and, optionally, of a reference to the conclusion of the -goal. For defined hypothesis it is possible to specify if the -conversion should occur on the type part, the body part or both -(default). +\item{\tt ecase {\term}\tacindex{ecase}}\\ + {\tt ecase {\term} with {\bindinglist}} -\index{Clauses} -\index{Goal clauses} -Goal clauses are written after a conversion tactic (tactics -\texttt{set}~\ref{tactic:set}, \texttt{rewrite}~\ref{rewrite}, -\texttt{replace}~\ref{tactic:replace} and -\texttt{autorewrite}~\ref{tactic:autorewrite} also use goal clauses) and -are introduced by the keyword \texttt{in}. If no goal clause is provided, -the default is to perform the conversion only in the conclusion. + In case the type of {\term} has dependent premises, or dependent + premises whose values are not inferable from the {\tt with + {\bindinglist}} clause, {\tt ecase} turns them into existential + variables to be resolved later on. -The syntax and description of the various goal clauses is the following: -\begin{description} -\item[]\texttt{in {\ident}$_1$ $\ldots$ {\ident}$_n$ |- } only in hypotheses {\ident}$_1$ - \ldots {\ident}$_n$ -\item[]\texttt{in {\ident}$_1$ $\ldots$ {\ident}$_n$ |- *} in hypotheses {\ident}$_1$ \ldots - {\ident}$_n$ and in the conclusion -\item[]\texttt{in * |-} in every hypothesis -\item[]\texttt{in *} (equivalent to \texttt{in * |- *}) everywhere -\item[]\texttt{in (type of {\ident}$_1$) (value of {\ident}$_2$) $\ldots$ |-} in - type part of {\ident}$_1$, in the value part of {\ident}$_2$, etc. -\end{description} +\item {\tt simple destruct \ident}\tacindex{simple destruct} -For backward compatibility, the notation \texttt{in}~{\ident}$_1$\ldots {\ident}$_n$ -performs the conversion in hypotheses {\ident}$_1$\ldots {\ident}$_n$. + This tactic behaves as {\tt intros until + {\ident}; case {\tt {\ident}}} when {\ident} is a quantified + variable of the goal. -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%voir reduction__conv_x : histoires d'univers. -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\item {\tt simple destruct {\num}} -\subsection[{\tt cbv \flag$_1$ \dots\ \flag$_n$}, {\tt lazy \flag$_1$ -\dots\ \flag$_n$} and {\tt compute}] -{{\tt cbv \flag$_1$ \dots\ \flag$_n$}, {\tt lazy \flag$_1$ -\dots\ \flag$_n$} and {\tt compute} -\tacindex{cbv} -\tacindex{lazy} -\tacindex{compute} -\tacindex{vm\_compute}\label{vmcompute}} + This tactic behaves as {\tt intros until + {\num}; case {\tt {\ident}}} where {\ident} is the name given by + {\tt intros until {\num}} to the {\num}-th non-dependent premise of + the goal. -These parameterized reduction tactics apply to any goal and perform -the normalization of the goal according to the specified flags. In -correspondence with the kinds of reduction considered in \Coq\, namely -$\beta$ (reduction of functional application), $\delta$ (unfolding of -transparent constants, see \ref{Transparent}), $\iota$ (reduction of -pattern-matching over a constructed term, and unfolding of {\tt fix} -and {\tt cofix} expressions) and $\zeta$ (contraction of local -definitions), the flag are either {\tt beta}, {\tt delta}, {\tt iota} -or {\tt zeta}. The {\tt delta} flag itself can be refined into {\tt -delta [\qualid$_1$\ldots\qualid$_k$]} or {\tt delta --[\qualid$_1$\ldots\qualid$_k$]}, restricting in the first case the -constants to unfold to the constants listed, and restricting in the -second case the constant to unfold to all but the ones explicitly -mentioned. Notice that the {\tt delta} flag does not apply to -variables bound by a let-in construction inside the term itself (use -here the {\tt zeta} flag). In any cases, opaque constants are not -unfolded (see Section~\ref{Opaque}). +\item{\tt case\_eq \term}\label{case_eq}\tacindex{case\_eq} -The goal may be normalized with two strategies: {\em lazy} ({\tt lazy} -tactic), or {\em call-by-value} ({\tt cbv} tactic). The lazy strategy -is a call-by-need strategy, with sharing of reductions: the arguments of a -function call are partially evaluated only when necessary, and if an -argument is used several times then it is computed only once. This -reduction is efficient for reducing expressions with dead code. For -instance, the proofs of a proposition {\tt exists~$x$. $P(x)$} reduce to a -pair of a witness $t$, and a proof that $t$ satisfies the predicate -$P$. Most of the time, $t$ may be computed without computing the proof -of $P(t)$, thanks to the lazy strategy. + The tactic {\tt case\_eq} is a variant of the {\tt case} tactic that + allow to perform case analysis on a term without completely + forgetting its original form. This is done by generating equalities + between the original form of the term and the outcomes of the case + analysis. -The call-by-value strategy is the one used in ML languages: the -arguments of a function call are evaluated first, using a weak -reduction (no reduction under the $\lambda$-abstractions). Despite the -lazy strategy always performs fewer reductions than the call-by-value -strategy, the latter is generally more efficient for evaluating purely -computational expressions (i.e. with few dead code). - -\begin{Variants} -\item {\tt compute} \tacindex{compute}\\ - {\tt cbv} - - These are synonyms for {\tt cbv beta delta iota zeta}. +% The effect of this tactic is similar to the effect of {\tt +% destruct {\term} in |- *} with the exception that no new hypotheses +% are introduced in the context. -\item {\tt lazy} - - This is a synonym for {\tt lazy beta delta iota zeta}. - -\item {\tt compute [\qualid$_1$\ldots\qualid$_k$]}\\ - {\tt cbv [\qualid$_1$\ldots\qualid$_k$]} +\end{Variants} - These are synonyms of {\tt cbv beta delta - [\qualid$_1$\ldots\qualid$_k$] iota zeta}. - -\item {\tt compute -[\qualid$_1$\ldots\qualid$_k$]}\\ - {\tt cbv -[\qualid$_1$\ldots\qualid$_k$]} +\subsection{\tt induction \term} +\tacindex{induction} +\label{Tac-induction} - These are synonyms of {\tt cbv beta delta - -[\qualid$_1$\ldots\qualid$_k$] iota zeta}. +This tactic applies to any goal. The argument {\term} must be of +inductive type and the tactic {\tt induction} generates subgoals, +one for each possible form of {\term}, i.e. one for each constructor +of the inductive type. -\item {\tt lazy [\qualid$_1$\ldots\qualid$_k$]}\\ - {\tt lazy -[\qualid$_1$\ldots\qualid$_k$]} +If the argument is dependent in either the conclusion or some +hypotheses of the goal, the argument is replaced by the appropriate +constructor form in each of the resulting subgoals and induction +hypotheses are added to the local context using names whose prefix is +{\tt IH}. - These are respectively synonyms of {\tt lazy beta delta - [\qualid$_1$\ldots\qualid$_k$] iota zeta} and {\tt lazy beta delta - -[\qualid$_1$\ldots\qualid$_k$] iota zeta}. +There are particular cases: -\item {\tt vm\_compute} \tacindex{vm\_compute} +\begin{itemize} - This tactic evaluates the goal using the optimized call-by-value - evaluation bytecode-based virtual machine. This algorithm is - dramatically more efficient than the algorithm used for the {\tt - cbv} tactic, but it cannot be fine-tuned. It is specially - interesting for full evaluation of algebraic objects. This includes - the case of reflexion-based tactics. +\item If {\term} is an identifier {\ident} denoting a quantified +variable of the conclusion of the goal, then {\tt induction {\ident}} +behaves as {\tt intros until {\ident}; induction {\ident}}. -\end{Variants} +\item If {\term} is a {\num}, then {\tt induction {\num}} behaves as +{\tt intros until {\num}} followed by {\tt induction} applied to the +last introduced hypothesis. Remark: For simple induction on a numeral, +use syntax {\tt induction ({\num})} (not very interesting anyway). -% Obsolete? Anyway not very important message -%\begin{ErrMsgs} -%\item \errindex{Delta must be specified before} -% -% A list of constants appeared before the {\tt delta} flag. -%\end{ErrMsgs} +\item The argument {\term} can also be a pattern of which holes are + denoted by ``\_''. In this case, the tactic checks that all subterms + matching the pattern in the conclusion and the hypotheses are + compatible and performs induction using this subterm. +\end{itemize} -\subsection{{\tt red} -\tacindex{red}} +\Example -This tactic applies to a goal which has the form {\tt - forall (x:T1)\dots(xk:Tk), c t1 \dots\ tn} where {\tt c} is a constant. If -{\tt c} is transparent then it replaces {\tt c} with its definition -(say {\tt t}) and then reduces {\tt (t t1 \dots\ tn)} according to -$\beta\iota\zeta$-reduction rules. +\begin{coq_example} +Lemma induction_test : forall n:nat, n = n -> n <= n. +intros n H. +induction n. +\end{coq_example} \begin{ErrMsgs} -\item \errindex{Not reducible} -\end{ErrMsgs} +\item \errindex{Not an inductive product} +\item \errindex{Unable to find an instance for the variables +{\ident} \ldots {\ident}} -\subsection{{\tt hnf} -\tacindex{hnf}} + Use in this case + the variant {\tt elim \dots\ with \dots} below. +\end{ErrMsgs} -This tactic applies to any goal. It replaces the current goal with its -head normal form according to the $\beta\delta\iota\zeta$-reduction -rules, i.e. it reduces the head of the goal until it becomes a -product or an irreducible term. +\begin{Variants} +\item{\tt induction {\term} as {\disjconjintropattern}} -\Example -The term \verb+forall n:nat, (plus (S n) (S n))+ is not reduced by {\tt hnf}. + This behaves as {\tt induction {\term}} but uses the names in + {\disjconjintropattern} to name the variables introduced in the context. + The {\disjconjintropattern} must typically be of the form + {\tt [} $p_{11}$ \ldots + $p_{1n_1}$ {\tt |} {\ldots} {\tt |} $p_{m1}$ \ldots $p_{mn_m}$ {\tt + ]} with $m$ being the number of constructors of the type of + {\term}. Each variable introduced by {\tt induction} in the context + of the $i^{th}$ goal gets its name from the list $p_{i1}$ \ldots + $p_{in_i}$ in order. If there are not enough names, {\tt induction} + invents names for the remaining variables to introduce. More + generally, the $p_{ij}$ can be any disjunctive/conjunctive + introduction pattern (see Section~\ref{intros-pattern}). For instance, + for an inductive type with one constructor, the pattern notation + {\tt ($p_{1}$,\ldots,$p_{n}$)} can be used instead of + {\tt [} $p_{1}$ \ldots $p_{n}$ {\tt ]}. -\Rem The $\delta$ rule only applies to transparent constants -(see Section~\ref{Opaque} on transparency and opacity). +%\item{\tt induction {\term} as {\namingintropattern}} -\subsection{\tt simpl -\tacindex{simpl}} +% This behaves as {\tt induction {\term}} but adds an equation between +% {\term} and the value that {\term} takes in each of the induction +% case. The name of the equation is built according to +% {\namingintropattern} which can be an identifier, a ``?'', etc, as +% indicated in Section~\ref{intros-pattern}. -This tactic applies to any goal. The tactic {\tt simpl} first applies -$\beta\iota$-reduction rule. Then it expands transparent constants -and tries to reduce {\tt T'} according, once more, to $\beta\iota$ -rules. But when the $\iota$ rule is not applicable then possible -$\delta$-reductions are not applied. For instance trying to use {\tt -simpl} on {\tt (plus n O)=n} changes nothing. Notice that only -transparent constants whose name can be reused as such in the -recursive calls are possibly unfolded. For instance a constant defined -by {\tt plus' := plus} is possibly unfolded and reused in the -recursive calls, but a constant such as {\tt succ := plus (S O)} is -never unfolded. +%\item{\tt induction {\term} as {\namingintropattern} {\disjconjintropattern}} -The behaviour of {\tt simpl} can be tuned using the {\tt Arguments} vernacular -command as follows: -\begin{itemize} -\item -A constant can be marked to be never unfolded by {\tt simpl}: -\begin{coq_example*} -Arguments minus x y : simpl never -\end{coq_example*} -After that command an expression like {\tt (minus (S x) y)} is left untouched by -the {\tt simpl} tactic. -\item -A constant can be marked to be unfolded only if applied to enough arguments. -The number of arguments required can be specified using -the {\tt /} symbol in the arguments list of the {\tt Arguments} vernacular -command. -\begin{coq_example*} -Definition fcomp A B C f (g : A -> B) (x : A) : C := f (g x). -Notation "f \o g" := (fcomp f g) (at level 50). -Arguments fcomp {A B C} f g x /. -\end{coq_example*} -After that command the expression {\tt (f \verb+\+o g)} is left untouched by -{\tt simpl} while {\tt ((f \verb+\+o g) t)} is reduced to {\tt (f (g t))}. -The same mechanism can be used to make a constant volatile, i.e. always -unfolded by {\tt simpl}. -\begin{coq_example*} -Definition volatile := fun x : nat => x. -Arguments volatile / x. -\end{coq_example*} -\item -A constant can be marked to be unfolded only if an entire set of arguments -evaluates to a constructor. The {\tt !} symbol can be used to mark such -arguments. -\begin{coq_example*} -Arguments minus !x !y. -\end{coq_example*} -After that command, the expression {\tt (minus (S x) y)} is left untouched by -{\tt simpl}, while {\tt (minus (S x) (S y))} is reduced to {\tt (minus x y)}. -\item -A special heuristic to determine if a constant has to be unfolded can be -activated with the following command: -\begin{coq_example*} -Arguments minus x y : simpl nomatch -\end{coq_example*} -The heuristic avoids to perform a simplification step that would -expose a {\tt match} construct in head position. For example the -expression {\tt (minus (S (S x)) (S y))} is simplified to -{\tt (minus (S x) y)} even if an extra simplification is possible. -\end{itemize} +% This combines the two previous forms. -\tacindex{simpl \dots\ in} -\begin{Variants} -\item {\tt simpl {\term}} - - This applies {\tt simpl} only to the occurrences of {\term} in the - current goal. +\item{\tt induction {\term} with \bindinglist} -\item {\tt simpl {\term} at \num$_1$ \dots\ \num$_i$} - - This applies {\tt simpl} only to the \num$_1$, \dots, \num$_i$ - occurrences of {\term} in the current goal. + This behaves like \texttt{induction {\term}} providing explicit + instances for the premises of the type of {\term} (see the syntax of + bindings in Section~\ref{Binding-list}). - \ErrMsg {\tt Too few occurrences} +\item{\tt einduction {\term}\tacindex{einduction}} -\item {\tt simpl {\ident}} - - This applies {\tt simpl} only to the applicative subterms whose head - occurrence is {\ident}. + This tactic behaves like \texttt{induction {\term}} excepts that it + does not fail if some dependent premise of the type of {\term} is + not inferable. Instead, the unresolved premises are posed as + existential variables to be inferred later, in the same way as {\tt + eapply} does (see Section~\ref{eapply-example}). -\item {\tt simpl {\ident} at \num$_1$ \dots\ \num$_i$} - - This applies {\tt simpl} only to the \num$_1$, \dots, \num$_i$ -applicative subterms whose head occurrence is {\ident}. +\item {\tt induction {\term$_1$} using {\term$_2$}} -\end{Variants} + This behaves as {\tt induction {\term$_1$}} but using {\term$_2$} as + induction scheme. It does not expect the conclusion of the type of + {\term$_1$} to be inductive. -\subsection{\tt unfold \qualid -\tacindex{unfold} -\label{unfold}} +\item {\tt induction {\term$_1$} using {\term$_2$} with {\bindinglist}} -This tactic applies to any goal. The argument {\qualid} must denote a -defined transparent constant or local definition (see Sections~\ref{Basic-definitions} and~\ref{Transparent}). The tactic {\tt - unfold} applies the $\delta$ rule to each occurrence of the constant -to which {\qualid} refers in the current goal and then replaces it -with its $\beta\iota$-normal form. + This behaves as {\tt induction {\term$_1$} using {\term$_2$}} but + also providing instances for the premises of the type of {\term$_2$}. -\begin{ErrMsgs} -\item {\qualid} \errindex{does not denote an evaluable constant} +\item \texttt{induction {\term}$_1$ $\ldots$ {\term}$_n$ using {\qualid}} -\end{ErrMsgs} + This syntax is used for the case {\qualid} denotes an induction principle + with complex predicates as the induction principles generated by + {\tt Function} or {\tt Functional Scheme} may be. -\begin{Variants} -\item {\tt unfold {\qualid}$_1$, \dots, \qualid$_n$} - \tacindex{unfold \dots\ in} - - Replaces {\em simultaneously} {\qualid}$_1$, \dots, {\qualid}$_n$ - with their definitions and replaces the current goal with its - $\beta\iota$ normal form. +\item \texttt{induction {\term} in {\occgoalset}} -\item {\tt unfold {\qualid}$_1$ at \num$_1^1$, \dots, \num$_i^1$, -\dots,\ \qualid$_n$ at \num$_1^n$ \dots\ \num$_j^n$} - - The lists \num$_1^1$, \dots, \num$_i^1$ and \num$_1^n$, \dots, - \num$_j^n$ specify the occurrences of {\qualid}$_1$, \dots, - \qualid$_n$ to be unfolded. Occurrences are located from left to - right. + This syntax is used for selecting which occurrences of {\term} the + induction has to be carried on. The {\tt in \occgoalset} clause is an + occurrence clause whose syntax and behavior is described in + Section~\ref{Occurrences clauses}. - \ErrMsg {\tt bad occurrence number of {\qualid}$_i$} +% When an occurrence clause is given, an equation between {\term} and +% the value it gets in each case of the induction is added to the +% context of the subgoals corresponding to the induction cases (even +% if no clause {\tt as {\namingintropattern}} is given). - \ErrMsg {\qualid}$_i$ {\tt does not occur} +\item {\tt induction {\term$_1$} with {\bindinglist$_1$} as {\namingintropattern} {\disjconjintropattern} using {\term$_2$} with {\bindinglist$_2$} in {\occgoalset}}\\ + {\tt einduction {\term$_1$} with {\bindinglist$_1$} as {\namingintropattern} {\disjconjintropattern} using {\term$_2$} with {\bindinglist$_2$} in {\occgoalset}} -\item {\tt unfold {\qstring}} + These are the most general forms of {\tt induction} and {\tt + einduction}. It combines the effects of the {\tt with}, {\tt as}, + {\tt using}, and {\tt in} clauses. - If {\qstring} denotes the discriminating symbol of a notation (e.g. {\tt - "+"}) or an expression defining a notation (e.g. \verb!"_ + _"!), and - this notation refers to an unfoldable constant, then the tactic - unfolds it. +\item {\tt elim \term}\label{elim} -\item {\tt unfold {\qstring}\%{\delimkey}} + This is a more basic induction tactic. Again, the type of the + argument {\term} must be an inductive type. Then, according to + the type of the goal, the tactic {\tt elim} chooses the appropriate + destructor and applies it as the tactic {\tt apply} + would do. For instance, if the proof context contains {\tt + n:nat} and the current goal is {\tt T} of type {\tt + Prop}, then {\tt elim n} is equivalent to {\tt apply nat\_ind with + (n:=n)}. The tactic {\tt elim} does not modify the context of + the goal, neither introduces the induction loading into the context + of hypotheses. - This is variant of {\tt unfold {\qstring}} where {\qstring} gets its - interpretation from the scope bound to the delimiting key - {\delimkey} instead of its default interpretation (see - Section~\ref{scopechange}). - -\item {\tt unfold \qualidorstring$_1$ at \num$_1^1$, \dots, \num$_i^1$, -\dots,\ \qualidorstring$_n$ at \num$_1^n$ \dots\ \num$_j^n$} + More generally, {\tt elim \term} also works when the type of {\term} + is a statement with premises and whose conclusion is inductive. In + that case the tactic performs induction on the conclusion of the + type of {\term} and leaves the non-dependent premises of the type as + subgoals. In the case of dependent products, the tactic tries to + find an instance for which the elimination lemma applies and fails + otherwise. - This is the most general form, where {\qualidorstring} is either a - {\qualid} or a {\qstring} referring to a notation. +\item {\tt elim {\term} with {\bindinglist}} -\end{Variants} + Allows to give explicit instances to the premises of the type + of {\term} (see Section~\ref{Binding-list}). -\subsection{{\tt fold} \term -\tacindex{fold}} +\item{\tt eelim {\term}\tacindex{eelim}} -This tactic applies to any goal. The term \term\ is reduced using the {\tt red} -tactic. Every occurrence of the resulting term in the goal is then -replaced by \term. + In case the type of {\term} has dependent premises, this turns them into + existential variables to be resolved later on. -\begin{Variants} -\item {\tt fold} \term$_1$ \dots\ \term$_n$ - - Equivalent to {\tt fold} \term$_1${\tt;}\ldots{\tt; fold} \term$_n$. -\end{Variants} +\item{\tt elim {\term$_1$} using {\term$_2$}}\\ + {\tt elim {\term$_1$} using {\term$_2$} with {\bindinglist}\tacindex{elim \dots\ using}} -\subsection{{\tt pattern {\term}} -\tacindex{pattern} -\label{pattern}} +Allows the user to give explicitly an elimination predicate +{\term$_2$} which is not the standard one for the underlying inductive +type of {\term$_1$}. The {\bindinglist} clause allows to +instantiate premises of the type of {\term$_2$}. -This command applies to any goal. The argument {\term} must be a free -subterm of the current goal. The command {\tt pattern} performs -$\beta$-expansion (the inverse of $\bt$-reduction) of the current goal -(say \T) by -\begin{enumerate} -\item replacing all occurrences of {\term} in {\T} with a fresh variable -\item abstracting this variable -\item applying the abstracted goal to {\term} -\end{enumerate} +\item{\tt elim {\term$_1$} with {\bindinglist$_1$} using {\term$_2$} with {\bindinglist$_2$}}\\ + {\tt eelim {\term$_1$} with {\bindinglist$_1$} using {\term$_2$} with {\bindinglist$_2$}} -For instance, if the current goal $T$ is expressible has $\phi(t)$ -where the notation captures all the instances of $t$ in $\phi(t)$, -then {\tt pattern $t$} transforms it into {\tt (fun x:$A$ => $\phi(${\tt -x}$)$) $t$}. This command can be used, for instance, when the tactic -{\tt apply} fails on matching. + These are the most general forms of {\tt elim} and {\tt eelim}. It + combines the effects of the {\tt using} clause and of the two uses + of the {\tt with} clause. -\begin{Variants} -\item {\tt pattern {\term} at {\num$_1$} \dots\ {\num$_n$}} - - Only the occurrences {\num$_1$} \dots\ {\num$_n$} of {\term} are - considered for $\beta$-expansion. Occurrences are located from left - to right. +\item {\tt elimtype \form}\tacindex{elimtype} -\item {\tt pattern {\term} at - {\num$_1$} \dots\ {\num$_n$}} - - All occurrences except the occurrences of indexes {\num$_1$} \dots\ - {\num$_n$} of {\term} are considered for - $\beta$-expansion. Occurrences are located from left to right. + The argument {\form} must be inductively defined. {\tt elimtype I} + is equivalent to {\tt cut I. intro H{\rm\sl n}; elim H{\rm\sl n}; + clear H{\rm\sl n}}. Therefore the hypothesis {\tt H{\rm\sl n}} will + not appear in the context(s) of the subgoal(s). Conversely, if {\tt + t} is a term of (inductive) type {\tt I} and which does not occur + in the goal then {\tt elim t} is equivalent to {\tt elimtype I; 2: + exact t.} -\item {\tt pattern {\term$_1$}, \dots, {\term$_m$}} - - Starting from a goal $\phi(t_1 \dots\ t_m)$, the tactic - {\tt pattern $t_1$, \dots,\ $t_m$} generates the equivalent goal {\tt - (fun (x$_1$:$A_1$) \dots\ (x$_m$:$A_m$) => $\phi(${\tt x$_1$\dots\ - x$_m$}$)$) $t_1$ \dots\ $t_m$}.\\ If $t_i$ occurs in one of the - generated types $A_j$ these occurrences will also be considered and - possibly abstracted. +\item {\tt simple induction \ident}\tacindex{simple induction} -\item {\tt pattern {\term$_1$} at {\num$_1^1$} \dots\ {\num$_{n_1}^1$}, \dots, - {\term$_m$} at {\num$_1^m$} \dots\ {\num$_{n_m}^m$}} - - This behaves as above but processing only the occurrences \num$_1^1$, - \dots, \num$_i^1$ of \term$_1$, \dots, \num$_1^m$, \dots, \num$_j^m$ - of \term$_m$ starting from \term$_m$. + This tactic behaves as {\tt intros until + {\ident}; elim {\tt {\ident}}} when {\ident} is a quantified + variable of the goal. -\item {\tt pattern} {\term$_1$} \zeroone{{\tt at \zeroone{-}} {\num$_1^1$} \dots\ {\num$_{n_1}^1$}} {\tt ,} \dots {\tt ,} - {\term$_m$} \zeroone{{\tt at \zeroone{-}} {\num$_1^m$} \dots\ {\num$_{n_m}^m$}} - - This is the most general syntax that combines the different variants. +\item {\tt simple induction {\num}} -\end{Variants} + This tactic behaves as {\tt intros until + {\num}; elim {\tt {\ident}}} where {\ident} is the name given by + {\tt intros until {\num}} to the {\num}-th non-dependent premise of + the goal. -\subsection{Conversion tactics applied to hypotheses} +%% \item {\tt simple induction {\term}}\tacindex{simple induction} -{\convtactic} {\tt in} \ident$_1$ \dots\ \ident$_n$ +%% If {\term} is an {\ident} corresponding to a quantified variable of +%% the goal then the tactic behaves as {\tt intros until {\ident}; elim +%% {\tt {\ident}}}. If {\term} is a {\num} then the tactic behaves as +%% {\tt intros until {\ident}; elim {\tt {\ident}}}. Otherwise, it is +%% a synonym for {\tt elim {\term}}. -Applies the conversion tactic {\convtactic} to the -hypotheses \ident$_1$, \ldots, \ident$_n$. The tactic {\convtactic} is -any of the conversion tactics listed in this section. +%% \Rem For simple induction on a numeral, use syntax {\tt simple +%% induction ({\num})}. -If \ident$_i$ is a local definition, then \ident$_i$ can be replaced -by (Type of \ident$_i$) to address not the body but the type of the -local definition. Example: {\tt unfold not in (Type of H1) (Type of H3).} +\end{Variants} -\begin{ErrMsgs} -\item \errindex{No such hypothesis} : {\ident}. -\end{ErrMsgs} +%\subsection[\tt FixPoint \dots]{\tt FixPoint \dots\tacindex{Fixpoint}} +%Not yet documented. +\subsection{\tt double induction \ident$_1$ \ident$_2$} +\tacindex{double induction} -\section{Introductions} +This tactic is deprecated and should be replaced by {\tt induction \ident$_1$; induction \ident$_2$} (or {\tt induction \ident$_1$; destruct \ident$_2$} depending on the exact needs). -Introduction tactics address goals which are inductive constants. -They are used when one guesses that the goal can be obtained with one -of its constructors' type. +%% This tactic applies to any goal. If the variables {\ident$_1$} and +%% {\ident$_2$} of the goal have an inductive type, then this tactic +%% performs double induction on these variables. For instance, if the +%% current goal is \verb+forall n m:nat, P n m+ then, {\tt double induction n +%% m} yields the four cases with their respective inductive hypotheses. -\subsection{\tt constructor \num -\label{constructor} -\tacindex{constructor}} +%% In particular, for proving \verb+(P (S n) (S m))+, the generated induction +%% hypotheses are \verb+(P (S n) m)+ and \verb+(m:nat)(P n m)+ (of the latter, +%% \verb+(P n m)+ and \verb+(P n (S m))+ are derivable). -This tactic applies to a goal such that the head of its conclusion is -an inductive constant (say {\tt I}). The argument {\num} must be less -or equal to the numbers of constructor(s) of {\tt I}. Let {\tt ci} be -the {\tt i}-th constructor of {\tt I}, then {\tt constructor i} is -equivalent to {\tt intros; apply ci}. +%% \Rem When the induction hypothesis \verb+(P (S n) m)+ is not +%% needed, {\tt induction \ident$_1$; destruct \ident$_2$} produces +%% more concise subgoals. -\begin{ErrMsgs} -\item \errindex{Not an inductive product} -\item \errindex{Not enough constructors} -\end{ErrMsgs} +\begin{Variant} -\begin{Variants} -\item \texttt{constructor} - - This tries \texttt{constructor 1} then \texttt{constructor 2}, - \dots\ , then \texttt{constructor} \textit{n} where \textit{n} if - the number of constructors of the head of the goal. +\item {\tt double induction \num$_1$ \num$_2$} -\item {\tt constructor \num~with} {\bindinglist} - - Let {\tt ci} be the {\tt i}-th constructor of {\tt I}, then {\tt - constructor i with \bindinglist} is equivalent to {\tt intros; - apply ci with \bindinglist}. +This tactic is deprecated and should be replaced by {\tt induction + \num$_1$; induction \num$_3$} where \num$_3$ is the result of +\num$_2$-\num$_1$. - \Warning the terms in the \bindinglist\ are checked - in the context where {\tt constructor} is executed and not in the - context where {\tt apply} is executed (the introductions are not - taken into account). +%% This tactic applies to any goal. If the variables {\ident$_1$} and -% To document? -% \item {\tt constructor {\tactic}} +%% This applies double induction on the \num$_1^{th}$ and \num$_2^{th}$ {\it +%% non dependent} premises of the goal. More generally, any combination of an +%% {\ident} and a {\num} is valid. -\item {\tt split}\tacindex{split} +\end{Variant} - Applies if {\tt I} has only one constructor, typically in the case - of conjunction $A\land B$. Then, it is equivalent to {\tt constructor 1}. +\subsection{\tt dependent induction \ident} +\tacindex{dependent induction} +\label{DepInduction} -\item {\tt exists {\bindinglist}}\tacindex{exists} +The \emph{experimental} tactic \texttt{dependent induction} performs +induction-inversion on an instantiated inductive predicate. +One needs to first require the {\tt Coq.Program.Equality} module to use +this tactic. The tactic is based on the BasicElim tactic by Conor +McBride \cite{DBLP:conf/types/McBride00} and the work of Cristina Cornes +around inversion \cite{DBLP:conf/types/CornesT95}. From an instantiated +inductive predicate and a goal, it generates an equivalent goal where the +hypothesis has been generalized over its indexes which are then +constrained by equalities to be the right instances. This permits to +state lemmas without resorting to manually adding these equalities and +still get enough information in the proofs. - Applies if {\tt I} has only one constructor, for instance in the - case of existential quantification $\exists x\cdot P(x)$. - Then, it is equivalent to {\tt intros; constructor 1 with \bindinglist}. +\Example -\item {\tt exists \nelist{\bindinglist}{,}} +\begin{coq_eval} +Reset Initial. +\end{coq_eval} +\begin{coq_example} +Lemma le_minus : forall n:nat, n < 1 -> n = 0. +intros n H ; induction H. +\end{coq_example} - This iteratively applies {\tt exists {\bindinglist}}. +Here we did not get any information on the indexes to help fulfill this +proof. The problem is that, when we use the \texttt{induction} tactic, +we lose information on the hypothesis instance, notably that the second +argument is \texttt{1} here. Dependent induction solves this problem by +adding the corresponding equality to the context. -\item {\tt left}\tacindex{left}\\ - {\tt right}\tacindex{right} +\begin{coq_eval} +Reset Initial. +\end{coq_eval} +\begin{coq_example} +Require Import Coq.Program.Equality. +Lemma le_minus : forall n:nat, n < 1 -> n = 0. +intros n H ; dependent induction H. +\end{coq_example} - Apply if {\tt I} has two constructors, for instance in the case of - disjunction $A\lor B$. Then, they are respectively equivalent to {\tt - constructor 1} and {\tt constructor 2}. - -\item {\tt left with \bindinglist}\\ - {\tt right with \bindinglist}\\ - {\tt split with \bindinglist} - - As soon as the inductive type has the right number of constructors, - these expressions are equivalent to calling {\tt - constructor $i$ with \bindinglist} for the appropriate $i$. +The subgoal is cleaned up as the tactic tries to automatically +simplify the subgoals with respect to the generated equalities. +In this enriched context, it becomes possible to solve this subgoal. +\begin{coq_example} +reflexivity. +\end{coq_example} -\item \texttt{econstructor}\tacindex{econstructor}\\ - \texttt{eexists}\tacindex{eexists}\\ - \texttt{esplit}\tacindex{esplit}\\ - \texttt{eleft}\tacindex{eleft}\\ - \texttt{eright}\tacindex{eright}\\ +Now we are in a contradictory context and the proof can be solved. +\begin{coq_example} +inversion H. +\end{coq_example} - These tactics and their variants behave like \texttt{constructor}, - \texttt{exists}, \texttt{split}, \texttt{left}, \texttt{right} and - their variants but they introduce existential variables instead of - failing when the instantiation of a variable cannot be found (cf - \texttt{eapply} and Section~\ref{eapply-example}). +This technique works with any inductive predicate. +In fact, the \texttt{dependent induction} tactic is just a wrapper around +the \texttt{induction} tactic. One can make its own variant by just +writing a new tactic based on the definition found in +\texttt{Coq.Program.Equality}. -\end{Variants} +\begin{Variants} +\item {\tt dependent induction {\ident} generalizing {\ident$_1$} \dots + {\ident$_n$}}\tacindex{dependent induction \dots\ generalizing} -\section[Induction and Case Analysis]{Induction and Case Analysis -\label{Tac-induction}} + This performs dependent induction on the hypothesis {\ident} but first + generalizes the goal by the given variables so that they are + universally quantified in the goal. This is generally what one wants + to do with the variables that are inside some constructors in the + induction hypothesis. The other ones need not be further generalized. -The tactics presented in this section implement induction or case -analysis on inductive or coinductive objects (see -Section~\ref{Cic-inductive-definitions}). +\item {\tt dependent destruction {\ident}}\tacindex{dependent destruction} -\subsection{\tt induction \term -\tacindex{induction}} + This performs the generalization of the instance {\ident} but uses {\tt destruct} + instead of {\tt induction} on the generalized hypothesis. This gives + results equivalent to {\tt inversion} or {\tt dependent inversion} if + the hypothesis is dependent. +\end{Variants} -This tactic applies to any goal. The argument {\term} must be of -inductive type and the tactic {\tt induction} generates subgoals, -one for each possible form of {\term}, i.e. one for each constructor -of the inductive type. +\SeeAlso \ref{dependent-induction-example} for a larger example of +dependent induction and an explanation of the underlying technique. -If the argument is dependent in either the conclusion or some -hypotheses of the goal, the argument is replaced by the appropriate -constructor form in each of the resulting subgoals and induction -hypotheses are added to the local context using names whose prefix is -{\tt IH}. +\subsection{\tt functional induction (\qualid\ \term$_1$ \dots\ \term$_n$)} +\tacindex{functional induction} +\label{FunInduction} -There are particular cases: +The \emph{experimental} tactic \texttt{functional induction} performs +case analysis and induction following the definition of a function. It +makes use of a principle generated by \texttt{Function} +(see Section~\ref{Function}) or \texttt{Functional Scheme} +(see Section~\ref{FunScheme}). -\begin{itemize} - -\item If {\term} is an identifier {\ident} denoting a quantified -variable of the conclusion of the goal, then {\tt induction {\ident}} -behaves as {\tt intros until {\ident}; induction {\ident}}. +\begin{coq_eval} +Reset Initial. +\end{coq_eval} +\begin{coq_example} +Functional Scheme minus_ind := Induction for minus Sort Prop. +Check minus_ind. +Lemma le_minus (n m:nat) : n - m <= n. +functional induction (minus n m); simpl; auto. +\end{coq_example} +\begin{coq_example*} +Qed. +\end{coq_example*} -\item If {\term} is a {\num}, then {\tt induction {\num}} behaves as -{\tt intros until {\num}} followed by {\tt induction} applied to the -last introduced hypothesis. Remark: For simple induction on a numeral, -use syntax {\tt induction ({\num})} (not very interesting anyway). +\Rem \texttt{(\qualid\ \term$_1$ \dots\ \term$_n$)} must be a correct +full application of \qualid. In particular, the rules for implicit +arguments are the same as usual. For example use \texttt{@\qualid} if +you want to write implicit arguments explicitly. -\item The argument {\term} can also be a pattern of which holes are - denoted by ``\_''. In this case, the tactic checks that all subterms - matching the pattern in the conclusion and the hypotheses are - compatible and performs induction using this subterm. +\Rem Parentheses over \qualid \dots \term$_n$ are mandatory. -\end{itemize} +\Rem \texttt{functional induction (f x1 x2 x3)} is actually a wrapper +for \texttt{induction x1 x2 x3 (f x1 x2 x3) using \qualid} followed by +a cleaning phase, where {\qualid} is the induction principle +registered for $f$ (by the \texttt{Function} (see Section~\ref{Function}) +or \texttt{Functional Scheme} (see Section~\ref{FunScheme}) command) +corresponding to the sort of the goal. Therefore \texttt{functional + induction} may fail if the induction scheme {\qualid} is +not defined. See also Section~\ref{Function} for the function terms +accepted by \texttt{Function}. -\Example +\Rem There is a difference between obtaining an induction scheme for a +function by using \texttt{Function} (see Section~\ref{Function}) and by +using \texttt{Functional Scheme} after a normal definition using +\texttt{Fixpoint} or \texttt{Definition}. See \ref{Function} for +details. -\begin{coq_example} -Lemma induction_test : forall n:nat, n = n -> n <= n. -intros n H. -induction n. -\end{coq_example} +\SeeAlso{\ref{Function},\ref{FunScheme},\ref{FunScheme-examples}, + \ref{sec:functional-inversion}} \begin{ErrMsgs} -\item \errindex{Not an inductive product} -\item \errindex{Unable to find an instance for the variables -{\ident} \ldots {\ident}} - - Use in this case - the variant {\tt elim \dots\ with \dots} below. +\item \errindex{Cannot find induction information on \qualid} +\item \errindex{Not the right number of induction arguments} \end{ErrMsgs} \begin{Variants} -\item{\tt induction {\term} as {\disjconjintropattern}} - - This behaves as {\tt induction {\term}} but uses the names in - {\disjconjintropattern} to name the variables introduced in the context. - The {\disjconjintropattern} must typically be of the form - {\tt [} $p_{11}$ \ldots - $p_{1n_1}$ {\tt |} {\ldots} {\tt |} $p_{m1}$ \ldots $p_{mn_m}$ {\tt - ]} with $m$ being the number of constructors of the type of - {\term}. Each variable introduced by {\tt induction} in the context - of the $i^{th}$ goal gets its name from the list $p_{i1}$ \ldots - $p_{in_i}$ in order. If there are not enough names, {\tt induction} - invents names for the remaining variables to introduce. More - generally, the $p_{ij}$ can be any disjunctive/conjunctive - introduction pattern (see Section~\ref{intros-pattern}). For instance, - for an inductive type with one constructor, the pattern notation - {\tt ($p_{1}$,\ldots,$p_{n}$)} can be used instead of - {\tt [} $p_{1}$ \ldots $p_{n}$ {\tt ]}. +\item {\tt functional induction (\qualid\ \term$_1$ \dots\ \term$_n$) + as {\disjconjintropattern} using \term$_{m+1}$ with \bindinglist} -\item{\tt induction {\term} as {\namingintropattern}} + Similarly to \texttt{Induction} and \texttt{elim} + (see Section~\ref{Tac-induction}), this allows to give explicitly the + name of the introduced variables, the + induction principle, and the values of dependent premises of the + elimination scheme, including \emph{predicates} for mutual induction + when {\qualid} is part of a mutually recursive definition. - This behaves as {\tt induction {\term}} but adds an equation between - {\term} and the value that {\term} takes in each of the induction - case. The name of the equation is built according to - {\namingintropattern} which can be an identifier, a ``?'', etc, as - indicated in Section~\ref{intros-pattern}. +\end{Variants} -\item{\tt induction {\term} as {\namingintropattern} {\disjconjintropattern}} +\subsection{\tt discriminate \term} +\label{discriminate} +\tacindex{discriminate} - This combines the two previous forms. -\item{\tt induction {\term} with \bindinglist} +This tactic proves any goal from an assumption stating that two +structurally different terms of an inductive set are equal. For +example, from {\tt (S (S O))=(S O)} we can derive by absurdity any +proposition. - This behaves like \texttt{induction {\term}} providing explicit - instances for the premises of the type of {\term} (see the syntax of - bindings in Section~\ref{Binding-list}). +The argument {\term} is assumed to be a proof of a statement +of conclusion {\tt{\term$_1$} = {\term$_2$}} with {\term$_1$} and +{\term$_2$} being elements of an inductive set. To build the proof, +the tactic traverses the normal forms\footnote{Reminder: opaque + constants will not be expanded by $\delta$ reductions.} of +{\term$_1$} and {\term$_2$} looking for a couple of subterms {\tt u} +and {\tt w} ({\tt u} subterm of the normal form of {\term$_1$} and +{\tt w} subterm of the normal form of {\term$_2$}), placed at the same +positions and whose head symbols are two different constructors. If +such a couple of subterms exists, then the proof of the current goal +is completed, otherwise the tactic fails. -\item{\tt einduction {\term}\tacindex{einduction}} +\Rem The syntax {\tt discriminate {\ident}} can be used to refer to a +hypothesis quantified in the goal. In this case, the quantified +hypothesis whose name is {\ident} is first introduced in the local +context using \texttt{intros until \ident}. - This tactic behaves like \texttt{induction {\term}} excepts that it - does not fail if some dependent premise of the type of {\term} is - not inferable. Instead, the unresolved premises are posed as - existential variables to be inferred later, in the same way as {\tt - eapply} does (see Section~\ref{eapply-example}). +\begin{ErrMsgs} +\item \errindex{No primitive equality found} +\item \errindex{Not a discriminable equality} +\end{ErrMsgs} -\item {\tt induction {\term$_1$} using {\term$_2$}} +\begin{Variants} +\item \texttt{discriminate \num} - This behaves as {\tt induction {\term$_1$}} but using {\term$_2$} as - induction scheme. It does not expect the conclusion of the type of - {\term$_1$} to be inductive. + This does the same thing as \texttt{intros until \num} followed by + \texttt{discriminate \ident} where {\ident} is the identifier for + the last introduced hypothesis. -\item {\tt induction {\term$_1$} using {\term$_2$} with {\bindinglist}} +\item \texttt{discriminate {\term} with \bindinglist} - This behaves as {\tt induction {\term$_1$} using {\term$_2$}} but - also providing instances for the premises of the type of {\term$_2$}. + This does the same thing as \texttt{discriminate {\term}} but using +the given bindings to instantiate parameters or hypotheses of {\term}. -\item \texttt{induction {\term}$_1$ $\ldots$ {\term}$_n$ using {\qualid}} +\item \texttt{ediscriminate \num}\tacindex{ediscriminate}\\ + \texttt{ediscriminate {\term} \zeroone{with \bindinglist}} - This syntax is used for the case {\qualid} denotes an induction principle - with complex predicates as the induction principles generated by - {\tt Function} or {\tt Functional Scheme} may be. + This works the same as {\tt discriminate} but if the type of {\term}, + or the type of the hypothesis referred to by {\num}, has uninstantiated + parameters, these parameters are left as existential variables. -\item \texttt{induction {\term} in {\occgoalset}} +\item \texttt{discriminate} - This syntax is used for selecting which occurrences of {\term} the - induction has to be carried on. The {\tt in {\atoccurrences}} clause is an - occurrence clause whose syntax and behavior is described in - Section~\ref{Occurrences clauses}. + This behaves like {\tt discriminate {\ident}} if {\ident} is the + name of an hypothesis to which {\tt discriminate} is applicable; if + the current goal is of the form {\term$_1$} {\tt <>} {\term$_2$}, + this behaves as {\tt intro {\ident}; injection {\ident}}. - When an occurrence clause is given, an equation between {\term} and - the value it gets in each case of the induction is added to the - context of the subgoals corresponding to the induction cases (even - if no clause {\tt as {\namingintropattern}} is given). + \ErrMsg \errindex{No discriminable equalities} +\end{Variants} -\item {\tt induction {\term$_1$} with {\bindinglist$_1$} as {\namingintropattern} {\disjconjintropattern} using {\term$_2$} with {\bindinglist$_2$} in {\occgoalset}}\\ - {\tt einduction {\term$_1$} with {\bindinglist$_1$} as {\namingintropattern} {\disjconjintropattern} using {\term$_2$} with {\bindinglist$_2$} in {\occgoalset}} +\subsection{\tt injection \term} +\label{injection} +\tacindex{injection} - These are the most general forms of {\tt induction} and {\tt - einduction}. It combines the effects of the {\tt with}, {\tt as}, - {\tt using}, and {\tt in} clauses. +The {\tt injection} tactic is based on the fact that constructors of +inductive sets are injections. That means that if $c$ is a constructor +of an inductive set, and if $(c~\vec{t_1})$ and $(c~\vec{t_2})$ are two +terms that are equal then $~\vec{t_1}$ and $~\vec{t_2}$ are equal +too. -\item {\tt elim \term}\label{elim} - - This is a more basic induction tactic. Again, the type of the - argument {\term} must be an inductive type. Then, according to - the type of the goal, the tactic {\tt elim} chooses the appropriate - destructor and applies it as the tactic {\tt apply} - would do. For instance, if the proof context contains {\tt - n:nat} and the current goal is {\tt T} of type {\tt - Prop}, then {\tt elim n} is equivalent to {\tt apply nat\_ind with - (n:=n)}. The tactic {\tt elim} does not modify the context of - the goal, neither introduces the induction loading into the context - of hypotheses. +If {\term} is a proof of a statement of conclusion + {\tt {\term$_1$} = {\term$_2$}}, +then {\tt injection} applies injectivity as deep as possible to +derive the equality of all the subterms of {\term$_1$} and {\term$_2$} +placed in the same positions. For example, from {\tt (S + (S n))=(S (S (S m)))} we may derive {\tt n=(S m)}. To use this +tactic {\term$_1$} and {\term$_2$} should be elements of an inductive +set and they should be neither explicitly equal, nor structurally +different. We mean by this that, if {\tt n$_1$} and {\tt n$_2$} are +their respective normal forms, then: +\begin{itemize} +\item {\tt n$_1$} and {\tt n$_2$} should not be syntactically equal, +\item there must not exist any pair of subterms {\tt u} and {\tt w}, + {\tt u} subterm of {\tt n$_1$} and {\tt w} subterm of {\tt n$_2$} , + placed in the same positions and having different constructors as + head symbols. +\end{itemize} +If these conditions are satisfied, then, the tactic derives the +equality of all the subterms of {\term$_1$} and {\term$_2$} placed in +the same positions and puts them as antecedents of the current goal. - More generally, {\tt elim \term} also works when the type of {\term} - is a statement with premises and whose conclusion is inductive. In - that case the tactic performs induction on the conclusion of the - type of {\term} and leaves the non-dependent premises of the type as - subgoals. In the case of dependent products, the tactic tries to - find an instance for which the elimination lemma applies and fails - otherwise. +\Example Consider the following goal: -\item {\tt elim {\term} with {\bindinglist}} - - Allows to give explicit instances to the premises of the type - of {\term} (see Section~\ref{Binding-list}). +\begin{coq_example*} +Inductive list : Set := + | nil : list + | cons : nat -> list -> list. +Variable P : list -> Prop. +\end{coq_example*} +\begin{coq_eval} +Lemma ex : + forall (l:list) (n:nat), P nil -> cons n l = cons 0 nil -> P l. +intros l n H H0. +\end{coq_eval} +\begin{coq_example} +Show. +injection H0. +\end{coq_example} +\begin{coq_eval} +Abort. +\end{coq_eval} -\item{\tt eelim {\term}\tacindex{eelim}} +Beware that \texttt{injection} yields always an equality in a sigma type +whenever the injected object has a dependent type. - In case the type of {\term} has dependent premises, this turns them into - existential variables to be resolved later on. +\Rem There is a special case for dependent pairs. If we have a decidable +equality over the type of the first argument, then it is safe to do +the projection on the second one, and so {\tt injection} will work fine. +To define such an equality, you have to use the {\tt Scheme} command +(see \ref{Scheme}). -\item{\tt elim {\term$_1$} using {\term$_2$}}\\ - {\tt elim {\term$_1$} using {\term$_2$} with {\bindinglist}\tacindex{elim \dots\ using}} +\Rem If some quantified hypothesis of the goal is named {\ident}, then +{\tt injection {\ident}} first introduces the hypothesis in the local +context using \texttt{intros until \ident}. -Allows the user to give explicitly an elimination predicate -{\term$_2$} which is not the standard one for the underlying inductive -type of {\term$_1$}. The {\bindinglist} clause allows to -instantiate premises of the type of {\term$_2$}. +\begin{ErrMsgs} +\item \errindex{Not a projectable equality but a discriminable one} +\item \errindex{Nothing to do, it is an equality between convertible terms} +\item \errindex{Not a primitive equality} +\end{ErrMsgs} -\item{\tt elim {\term$_1$} with {\bindinglist$_1$} using {\term$_2$} with {\bindinglist$_2$}}\\ - {\tt eelim {\term$_1$} with {\bindinglist$_1$} using {\term$_2$} with {\bindinglist$_2$}} +\begin{Variants} +\item \texttt{injection \num} - These are the most general forms of {\tt elim} and {\tt eelim}. It - combines the effects of the {\tt using} clause and of the two uses - of the {\tt with} clause. + This does the same thing as \texttt{intros until \num} followed by +\texttt{injection \ident} where {\ident} is the identifier for the last +introduced hypothesis. -\item {\tt elimtype \form}\tacindex{elimtype} - - The argument {\form} must be inductively defined. {\tt elimtype I} - is equivalent to {\tt cut I. intro H{\rm\sl n}; elim H{\rm\sl n}; - clear H{\rm\sl n}}. Therefore the hypothesis {\tt H{\rm\sl n}} will - not appear in the context(s) of the subgoal(s). Conversely, if {\tt - t} is a term of (inductive) type {\tt I} and which does not occur - in the goal then {\tt elim t} is equivalent to {\tt elimtype I; 2: - exact t.} +\item \texttt{injection {\term} with \bindinglist} -\item {\tt simple induction \ident}\tacindex{simple induction} - - This tactic behaves as {\tt intros until - {\ident}; elim {\tt {\ident}}} when {\ident} is a quantified - variable of the goal. + This does the same as \texttt{injection {\term}} but using + the given bindings to instantiate parameters or hypotheses of {\term}. -\item {\tt simple induction {\num}} - - This tactic behaves as {\tt intros until - {\num}; elim {\tt {\ident}}} where {\ident} is the name given by - {\tt intros until {\num}} to the {\num}-th non-dependent premise of - the goal. +\item \texttt{einjection \num}\tacindex{einjection}\\ + \texttt{einjection {\term} \zeroone{with \bindinglist}} -%% \item {\tt simple induction {\term}}\tacindex{simple induction} - -%% If {\term} is an {\ident} corresponding to a quantified variable of -%% the goal then the tactic behaves as {\tt intros until {\ident}; elim -%% {\tt {\ident}}}. If {\term} is a {\num} then the tactic behaves as -%% {\tt intros until {\ident}; elim {\tt {\ident}}}. Otherwise, it is -%% a synonym for {\tt elim {\term}}. + This works the same as {\tt injection} but if the type of {\term}, + or the type of the hypothesis referred to by {\num}, has uninstantiated + parameters, these parameters are left as existential variables. -%% \Rem For simple induction on a numeral, use syntax {\tt simple -%% induction ({\num})}. +\item{\tt injection} + + If the current goal is of the form {\term$_1$} {\tt <>} {\term$_2$}, + this behaves as {\tt intro {\ident}; injection {\ident}}. + + \ErrMsg \errindex{goal does not satisfy the expected preconditions} + +\item \texttt{injection {\term} \zeroone{with \bindinglist} as \nelist{\intropattern}{}}\\ +\texttt{injection {\num} as {\intropattern} \dots\ \intropattern}\\ +\texttt{injection as {\intropattern} \dots\ \intropattern}\\ +\texttt{einjection {\term} \zeroone{with \bindinglist} as \nelist{\intropattern}{}}\\ +\texttt{einjection {\num} as {\intropattern} \dots\ \intropattern}\\ +\texttt{einjection as {\intropattern} \dots\ \intropattern} +\tacindex{injection \dots\ as} + +These variants apply \texttt{intros} \nelist{\intropattern}{} after +the call to \texttt{injection} or \texttt{einjection}. \end{Variants} -\subsection{\tt destruct \term -\tacindex{destruct}} -\label{destruct} +\subsection{\tt inversion \ident} +\tacindex{inversion} -This tactic applies to any goal. The argument {\term} must be of -inductive or coinductive type and the tactic generates subgoals, one -for each possible form of {\term}, i.e. one for each constructor of -the inductive or coinductive type. Unlike {\tt induction}, no -induction hypothesis is generated by {\tt destruct}. +Let the type of {\ident} in the local context be $(I~\vec{t})$, +where $I$ is a (co)inductive predicate. Then, +\texttt{inversion} applied to \ident~ derives for each possible +constructor $c_i$ of $(I~\vec{t})$, {\bf all} the necessary +conditions that should hold for the instance $(I~\vec{t})$ to be +proved by $c_i$. -If the argument is dependent in either the conclusion or some -hypotheses of the goal, the argument is replaced by the appropriate -constructor form in each of the resulting subgoals, thus performing -case analysis. If non dependent, the tactic simply exposes the -inductive or coinductive structure of the argument. +\Rem If {\ident} does not denote a hypothesis in the local context +but refers to a hypothesis quantified in the goal, then the +latter is first introduced in the local context using +\texttt{intros until \ident}. -There are special cases: +\Rem As inversion proofs may be large in size, we recommend the user to +stock the lemmas whenever the same instance needs to be inverted +several times. See Section~\ref{Derive-Inversion}. -\begin{itemize} +\begin{Variants} +\item \texttt{inversion \num} -\item If {\term} is an identifier {\ident} denoting a quantified -variable of the conclusion of the goal, then {\tt destruct {\ident}} -behaves as {\tt intros until {\ident}; destruct {\ident}}. + This does the same thing as \texttt{intros until \num} then + \texttt{inversion \ident} where {\ident} is the identifier for the + last introduced hypothesis. -\item If {\term} is a {\num}, then {\tt destruct {\num}} behaves as -{\tt intros until {\num}} followed by {\tt destruct} applied to the -last introduced hypothesis. Remark: For destruction of a numeral, use -syntax {\tt destruct ({\num})} (not very interesting anyway). +\item \tacindex{inversion\_clear} \texttt{inversion\_clear \ident} -\item The argument {\term} can also be a pattern of which holes are - denoted by ``\_''. In this case, the tactic checks that all subterms - matching the pattern in the conclusion and the hypotheses are - compatible and performs case analysis using this subterm. + This behaves as \texttt{inversion} and then erases \ident~ from the + context. -\end{itemize} +\item \tacindex{inversion \dots\ as} \texttt{inversion {\ident} as \intropattern} -\begin{Variants} -\item{\tt destruct {\term} as {\disjconjintropattern}} - - This behaves as {\tt destruct {\term}} but uses the names in - {\intropattern} to name the variables introduced in the context. - The {\intropattern} must have the form {\tt [} $p_{11}$ \ldots - $p_{1n_1}$ {\tt |} {\ldots} {\tt |} $p_{m1}$ \ldots $p_{mn_m}$ {\tt - ]} with $m$ being the number of constructors of the type of - {\term}. Each variable introduced by {\tt destruct} in the context - of the $i^{th}$ goal gets its name from the list $p_{i1}$ \ldots - $p_{in_i}$ in order. If there are not enough names, {\tt destruct} - invents names for the remaining variables to introduce. More - generally, the $p_{ij}$ can be any disjunctive/conjunctive - introduction pattern (see Section~\ref{intros-pattern}). This - provides a concise notation for nested destruction. + This behaves as \texttt{inversion} but using names in + {\intropattern} for naming hypotheses. The {\intropattern} must have + the form {\tt [} $p_{11}$ \ldots $p_{1n_1}$ {\tt |} {\ldots} {\tt |} + $p_{m1}$ \ldots $p_{mn_m}$ {\tt ]} with $m$ being the number of + constructors of the type of {\ident}. Be careful that the list must + be of length $m$ even if {\tt inversion} discards some cases (which + is precisely one of its roles): for the discarded cases, just use an + empty list (i.e. $n_i=0$). -% It is recommended to use this variant of {\tt destruct} for -% robust proof scripts. + The arguments of the $i^{th}$ constructor and the + equalities that {\tt inversion} introduces in the context of the + goal corresponding to the $i^{th}$ constructor, if it exists, get + their names from the list $p_{i1}$ \ldots $p_{in_i}$ in order. If + there are not enough names, {\tt induction} invents names for the + remaining variables to introduce. In case an equation splits into + several equations (because {\tt inversion} applies {\tt injection} + on the equalities it generates), the corresponding name $p_{ij}$ in + the list must be replaced by a sublist of the form {\tt [$p_{ij1}$ + \ldots $p_{ijq}$]} (or, equivalently, {\tt ($p_{ij1}$, + \ldots, $p_{ijq}$)}) where $q$ is the number of subequalities + obtained from splitting the original equation. Here is an example. -\item{\tt destruct {\term} as {\disjconjintropattern} \_eqn} +\begin{coq_eval} +Require Import List. +\end{coq_eval} - This behaves as {\tt destruct {\term}} but adds an equation between - {\term} and the value that {\term} takes in each of the possible - cases. The name of the equation is chosen by Coq. If - {\disjconjintropattern} is simply {\tt []}, it is automatically considered - as a disjunctive pattern of the appropriate size. +\begin{coq_example} +Inductive contains0 : list nat -> Prop := + | in_hd : forall l, contains0 (0 :: l) + | in_tl : forall l b, contains0 l -> contains0 (b :: l). +Goal forall l:list nat, contains0 (1 :: l) -> contains0 l. +intros l H; inversion H as [ | l' p Hl' [Heqp Heql'] ]. +\end{coq_example} -\item{\tt destruct {\term} as {\disjconjintropattern} \_eqn: {\namingintropattern}} +\begin{coq_eval} +Abort. +\end{coq_eval} - This behaves as {\tt destruct {\term} as - {\disjconjintropattern} \_eqn} but use {\namingintropattern} to - name the equation (see Section~\ref{intros-pattern}). Note that spaces - can generally be removed around {\tt \_eqn}. +\item \texttt{inversion {\num} as \intropattern} -\item{\tt destruct {\term} with \bindinglist} + This allows to name the hypotheses introduced by + \texttt{inversion \num} in the context. - This behaves like \texttt{destruct {\term}} providing explicit - instances for the dependent premises of the type of {\term} (see - syntax of bindings in Section~\ref{Binding-list}). +\item \tacindex{inversion\_clear \dots\ as} \texttt{inversion\_clear + {\ident} as \intropattern} -\item{\tt edestruct {\term}\tacindex{edestruct}} + This allows to name the hypotheses introduced by + \texttt{inversion\_clear} in the context. - This tactic behaves like \texttt{destruct {\term}} excepts that it - does not fail if the instance of a dependent premises of the type of - {\term} is not inferable. Instead, the unresolved instances are left - as existential variables to be inferred later, in the same way as - {\tt eapply} does (see Section~\ref{eapply-example}). +\item \tacindex{inversion \dots\ in} \texttt{inversion {\ident} + in \ident$_1$ \dots\ \ident$_n$} -\item{\tt destruct {\term$_1$} using {\term$_2$}}\\ - {\tt destruct {\term$_1$} using {\term$_2$} with {\bindinglist}} + Let \ident$_1$ \dots\ \ident$_n$, be identifiers in the local context. This + tactic behaves as generalizing \ident$_1$ \dots\ \ident$_n$, and + then performing \texttt{inversion}. - These are synonyms of {\tt induction {\term$_1$} using {\term$_2$}} and - {\tt induction {\term$_1$} using {\term$_2$} with {\bindinglist}}. +\item \tacindex{inversion \dots\ as \dots\ in} \texttt{inversion + {\ident} as {\intropattern} in \ident$_1$ \dots\ + \ident$_n$} -\item \texttt{destruct {\term} in {\occgoalset}} + This allows to name the hypotheses introduced in the context by + \texttt{inversion {\ident} in \ident$_1$ \dots\ \ident$_n$}. - This syntax is used for selecting which occurrences of {\term} the - case analysis has to be done on. The {\tt in {\occgoalset}} clause is an - occurrence clause whose syntax and behavior is described in - Section~\ref{Occurrences clauses}. +\item \tacindex{inversion\_clear \dots\ in} \texttt{inversion\_clear + {\ident} in \ident$_1$ \dots\ \ident$_n$} - When an occurrence clause is given, an equation between {\term} and - the value it gets in each case of the analysis is added to the - context of the subgoals corresponding to the cases (even - if no clause {\tt as {\namingintropattern}} is given). + Let \ident$_1$ \dots\ \ident$_n$, be identifiers in the local context. This + tactic behaves as generalizing \ident$_1$ \dots\ \ident$_n$, and + then performing {\tt inversion\_clear}. -\item{\tt destruct {\term$_1$} with {\bindinglist$_1$} as {\disjconjintropattern} \_eqn: {\namingintropattern} using {\term$_2$} with {\bindinglist$_2$} in {\occgoalset}}\\ - {\tt edestruct {\term$_1$} with {\bindinglist$_1$} as {\disjconjintropattern} \_eqn: {\namingintropattern} using {\term$_2$} with {\bindinglist$_2$} in {\occgoalset}} +\item \tacindex{inversion\_clear \dots\ as \dots\ in} + \texttt{inversion\_clear {\ident} as {\intropattern} + in \ident$_1$ \dots\ \ident$_n$} - These are the general forms of {\tt destruct} and {\tt edestruct}. - They combine the effects of the {\tt with}, {\tt as}, {\tt using}, - and {\tt in} clauses. + This allows to name the hypotheses introduced in the context by + \texttt{inversion\_clear {\ident} in \ident$_1$ \dots\ \ident$_n$}. -\item{\tt case \term}\label{case}\tacindex{case} - - The tactic {\tt case} is a more basic tactic to perform case - analysis without recursion. It behaves as {\tt elim \term} but using - a case-analysis elimination principle and not a recursive one. +\item \tacindex{dependent inversion} \texttt{dependent inversion \ident} -\item{\tt case\_eq \term}\label{case_eq}\tacindex{case\_eq} + That must be used when \ident\ appears in the current goal. It acts + like \texttt{inversion} and then substitutes \ident\ for the + corresponding term in the goal. - The tactic {\tt case\_eq} is a variant of the {\tt case} tactic that - allow to perform case analysis on a term without completely - forgetting its original form. This is done by generating equalities - between the original form of the term and the outcomes of the case - analysis. The effect of this tactic is similar to the effect of {\tt - destruct {\term} in |- *} with the exception that no new hypotheses - are introduced in the context. +\item \tacindex{dependent inversion \dots\ as } \texttt{dependent + inversion {\ident} as \intropattern} -\item {\tt case {\term} with {\bindinglist}} + This allows to name the hypotheses introduced in the context by + \texttt{dependent inversion} {\ident}. - Analogous to {\tt elim {\term} with {\bindinglist}} above. +\item \tacindex{dependent inversion\_clear} \texttt{dependent + inversion\_clear \ident} -\item{\tt ecase {\term}\tacindex{ecase}}\\ - {\tt ecase {\term} with {\bindinglist}} - - In case the type of {\term} has dependent premises, or dependent - premises whose values are not inferable from the {\tt with - {\bindinglist}} clause, {\tt ecase} turns them into existential - variables to be resolved later on. + Like \texttt{dependent inversion}, except that {\ident} is cleared + from the local context. -\item {\tt simple destruct \ident}\tacindex{simple destruct} - - This tactic behaves as {\tt intros until - {\ident}; case {\tt {\ident}}} when {\ident} is a quantified - variable of the goal. +\item \tacindex{dependent inversion\_clear \dots\ as} + \texttt{dependent inversion\_clear {\ident} as \intropattern} -\item {\tt simple destruct {\num}} - - This tactic behaves as {\tt intros until - {\num}; case {\tt {\ident}}} where {\ident} is the name given by - {\tt intros until {\num}} to the {\num}-th non-dependent premise of - the goal. + This allows to name the hypotheses introduced in the context by + \texttt{dependent inversion\_clear} {\ident}. + +\item \tacindex{dependent inversion \dots\ with} \texttt{dependent + inversion {\ident} with \term} + + This variant allows you to specify the generalization of the goal. It + is useful when the system fails to generalize the goal automatically. If + {\ident} has type $(I~\vec{t})$ and $I$ has type + $\forall (\vec{x}:\vec{T}), s$, then \term~ must be of type + $I:\forall (\vec{x}:\vec{T}), I~\vec{x}\to s'$ where $s'$ is the + type of the goal. + +\item \tacindex{dependent inversion \dots\ as \dots\ with} + \texttt{dependent inversion {\ident} as {\intropattern} + with \term} + + This allows to name the hypotheses introduced in the context by + \texttt{dependent inversion {\ident} with \term}. + +\item \tacindex{dependent inversion\_clear \dots\ with} + \texttt{dependent inversion\_clear {\ident} with \term} + + Like \texttt{dependent inversion \dots\ with} but clears {\ident} from + the local context. + +\item \tacindex{dependent inversion\_clear \dots\ as \dots\ with} + \texttt{dependent inversion\_clear {\ident} as + {\intropattern} with \term} + + This allows to name the hypotheses introduced in the context by + \texttt{dependent inversion\_clear {\ident} with \term}. + +\item \tacindex{simple inversion} \texttt{simple inversion \ident} + It is a very primitive inversion tactic that derives all the necessary + equalities but it does not simplify the constraints as + \texttt{inversion} does. + +\item \tacindex{simple inversion \dots\ as} \texttt{simple inversion + {\ident} as \intropattern} + + This allows to name the hypotheses introduced in the context by + \texttt{simple inversion}. + +\item \tacindex{inversion \dots\ using} \texttt{inversion {\ident} + using \ident$'$} + + Let {\ident} have type $(I~\vec{t})$ ($I$ an inductive + predicate) in the local context, and \ident$'$ be a (dependent) inversion + lemma. Then, this tactic refines the current goal with the specified + lemma. + +\item \tacindex{inversion \dots\ using \dots\ in} \texttt{inversion + {\ident} using \ident$'$ in \ident$_1$\dots\ \ident$_n$} + + This tactic behaves as generalizing \ident$_1$\dots\ \ident$_n$, + then doing \texttt{inversion {\ident} using \ident$'$}. \end{Variants} -\subsection{\tt intros {\intropattern} {\ldots} {\intropattern} -\label{intros-pattern} -\tacindex{intros \intropattern}} -\index{Introduction patterns} -\index{Naming introduction patterns} -\index{Disjunctive/conjunctive introduction patterns} +\firstexample +\example{Non-dependent inversion} +\label{inversion-examples} -This extension of the tactic {\tt intros} combines introduction of -variables or hypotheses and case analysis. An {\em introduction pattern} is -either: -\begin{itemize} -\item A {\em naming introduction pattern}, i.e. either one of: - \begin{itemize} - \item the pattern \texttt{?} - \item the pattern \texttt{?\ident} - \item an identifier - \end{itemize} -\item A {\em disjunctive/conjunctive introduction pattern}, i.e. either one of: - \begin{itemize} - \item a disjunction of lists of patterns: - {\tt [$p_{11}$ {\ldots} $p_{1m_1}$ | {\ldots} | $p_{11}$ {\ldots} $p_{nm_n}$]} - \item a conjunction of patterns: {\tt (} $p_1$ {\tt ,} {\ldots} {\tt ,} $p_n$ {\tt )} - \item a list of patterns {\tt (} $p_1$\ {\tt \&}\ {\ldots}\ {\tt \&}\ $p_n$ {\tt )} - for sequence of right-associative binary constructs - \end{itemize} -\item the wildcard: {\tt \_} -\item the rewriting orientations: {\tt ->} or {\tt <-} -\end{itemize} +Let us consider the relation \texttt{Le} over natural numbers and the +following variables: -Assuming a goal of type {\tt $Q$ -> $P$} (non dependent product), or -of type {\tt forall $x$:$T$, $P$} (dependent product), the behavior of -{\tt intros $p$} is defined inductively over the structure of the -introduction pattern $p$: -\begin{itemize} -\item introduction on \texttt{?} performs the introduction, and lets {\Coq} - choose a fresh name for the variable; -\item introduction on \texttt{?\ident} performs the introduction, and - lets {\Coq} choose a fresh name for the variable based on {\ident}; -\item introduction on \texttt{\ident} behaves as described in - Section~\ref{intro}; -\item introduction over a disjunction of list of patterns {\tt - [$p_{11}$ {\ldots} $p_{1m_1}$ | {\ldots} | $p_{11}$ {\ldots} - $p_{nm_n}$]} expects the product to be over an inductive type - whose number of constructors is $n$ (or more generally over a type - of conclusion an inductive type built from $n$ constructors, - e.g. {\tt C -> A$\backslash$/B if $n=2$}): it destructs the introduced - hypothesis as {\tt destruct} (see Section~\ref{destruct}) would and - applies on each generated subgoal the corresponding tactic; - \texttt{intros}~$p_{i1}$ {\ldots} $p_{im_i}$; if the disjunctive - pattern is part of a sequence of patterns and is not the last - pattern of the sequence, then {\Coq} completes the pattern so as all - the argument of the constructors of the inductive type are - introduced (for instance, the list of patterns {\tt [$\;$|$\;$] H} - applied on goal {\tt forall x:nat, x=0 -> 0=x} behaves the same as - the list of patterns {\tt [$\,$|$\,$?$\,$] H}); -\item introduction over a conjunction of patterns {\tt ($p_1$, \ldots, - $p_n$)} expects the goal to be a product over an inductive type $I$ with a - single constructor that itself has at least $n$ arguments: it - performs a case analysis over the hypothesis, as {\tt destruct} - would, and applies the patterns $p_1$~\ldots~$p_n$ to the arguments - of the constructor of $I$ (observe that {\tt ($p_1$, {\ldots}, - $p_n$)} is an alternative notation for {\tt [$p_1$ {\ldots} - $p_n$]}); -\item introduction via {\tt ( $p_1$ \& \ldots \& $p_n$ )} - is a shortcut for introduction via - {\tt ($p_1$,(\ldots,(\dots,$p_n$)\ldots))}; it expects the - hypothesis to be a sequence of right-associative binary inductive - constructors such as {\tt conj} or {\tt ex\_intro}; for instance, an - hypothesis with type {\tt A\verb|/\|exists x, B\verb|/\|C\verb|/\|D} can be - introduced via pattern {\tt (a \& x \& b \& c \& d)}; -\item introduction on the wildcard depends on whether the product is - dependent or not: in the non dependent case, it erases the - corresponding hypothesis (i.e. it behaves as an {\tt intro} followed - by a {\tt clear}, cf Section~\ref{clear}) while in the dependent - case, it succeeds and erases the variable only if the wildcard is - part of a more complex list of introduction patterns that also - erases the hypotheses depending on this variable; -\item introduction over {\tt ->} (respectively {\tt <-}) expects the - hypothesis to be an equality and the right-hand-side (respectively - the left-hand-side) is replaced by the left-hand-side (respectively - the right-hand-side) in both the conclusion and the context of the goal; - if moreover the term to substitute is a variable, the hypothesis is - removed. -\end{itemize} +\begin{coq_eval} +Reset Initial. +\end{coq_eval} -\Rem {\tt intros $p_1~\ldots~p_n$} is not equivalent to \texttt{intros - $p_1$;\ldots; intros $p_n$} for the following reasons: -\begin{itemize} -\item A wildcard pattern never succeeds when applied isolated on a - dependent product, while it succeeds as part of a list of - introduction patterns if the hypotheses that depends on it are - erased too. -\item A disjunctive or conjunctive pattern followed by an introduction - pattern forces the introduction in the context of all arguments of - the constructors before applying the next pattern while a terminal - disjunctive or conjunctive pattern does not. Here is an example +\begin{coq_example*} +Inductive Le : nat -> nat -> Set := + | LeO : forall n:nat, Le 0 n + | LeS : forall n m:nat, Le n m -> Le (S n) (S m). +Variable P : nat -> nat -> Prop. +Variable Q : forall n m:nat, Le n m -> Prop. +\end{coq_example*} -\begin{coq_example} -Goal forall n:nat, n = 0 -> n = 0. -intros [ | ] H. -Show 2. -Undo. -intros [ | ]; intros H. -Show 2. -\end{coq_example} +Let us consider the following goal: -\end{itemize} +\begin{coq_eval} +Lemma ex : forall n m:nat, Le (S n) m -> P n m. +intros. +\end{coq_eval} \begin{coq_example} -Lemma intros_test : forall A B C:Prop, A \/ B /\ C -> (A -> C) -> C. -intros A B C [a| [_ c]] f. -apply (f a). -exact c. -Qed. +Show. \end{coq_example} -%\subsection[\tt FixPoint \dots]{\tt FixPoint \dots\tacindex{Fixpoint}} -%Not yet documented. - -\subsection{\tt double induction \ident$_1$ \ident$_2$} -%\tacindex{double induction}} -This tactic is deprecated and should be replaced by {\tt induction \ident$_1$; induction \ident$_2$} (or {\tt induction \ident$_1$; destruct \ident$_2$} depending on the exact needs). - -%% This tactic applies to any goal. If the variables {\ident$_1$} and -%% {\ident$_2$} of the goal have an inductive type, then this tactic -%% performs double induction on these variables. For instance, if the -%% current goal is \verb+forall n m:nat, P n m+ then, {\tt double induction n -%% m} yields the four cases with their respective inductive hypotheses. - -%% In particular, for proving \verb+(P (S n) (S m))+, the generated induction -%% hypotheses are \verb+(P (S n) m)+ and \verb+(m:nat)(P n m)+ (of the latter, -%% \verb+(P n m)+ and \verb+(P n (S m))+ are derivable). - -%% \Rem When the induction hypothesis \verb+(P (S n) m)+ is not -%% needed, {\tt induction \ident$_1$; destruct \ident$_2$} produces -%% more concise subgoals. +To prove the goal, we may need to reason by cases on \texttt{H} and to +derive that \texttt{m} is necessarily of +the form $(S~m_0)$ for certain $m_0$ and that $(Le~n~m_0)$. +Deriving these conditions corresponds to prove that the +only possible constructor of \texttt{(Le (S n) m)} is +\texttt{LeS} and that we can invert the +\texttt{->} in the type of \texttt{LeS}. +This inversion is possible because \texttt{Le} is the smallest set closed by +the constructors \texttt{LeO} and \texttt{LeS}. -\begin{Variant} +\begin{coq_example} +inversion_clear H. +\end{coq_example} -\item {\tt double induction \num$_1$ \num$_2$} +Note that \texttt{m} has been substituted in the goal for \texttt{(S m0)} +and that the hypothesis \texttt{(Le n m0)} has been added to the +context. -This tactic is deprecated and should be replaced by {\tt induction - \num$_1$; induction \num$_3$} where \num$_3$ is the result of -\num$_2$-\num$_1$. +Sometimes it is +interesting to have the equality \texttt{m=(S m0)} in the +context to use it after. In that case we can use \texttt{inversion} that +does not clear the equalities: -%% This tactic applies to any goal. If the variables {\ident$_1$} and +\begin{coq_eval} +Undo. +\end{coq_eval} -%% This applies double induction on the \num$_1^{th}$ and \num$_2^{th}$ {\it -%% non dependent} premises of the goal. More generally, any combination of an -%% {\ident} and a {\num} is valid. +\begin{coq_example} +inversion H. +\end{coq_example} -\end{Variant} +\begin{coq_eval} +Abort. +\end{coq_eval} -\subsection{\tt dependent induction \ident - \tacindex{dependent induction} - \label{DepInduction}} +\example{Dependent inversion} -The \emph{experimental} tactic \texttt{dependent induction} performs -induction-inversion on an instantiated inductive predicate. -One needs to first require the {\tt Coq.Program.Equality} module to use -this tactic. The tactic is based on the BasicElim tactic by Conor -McBride \cite{DBLP:conf/types/McBride00} and the work of Cristina Cornes -around inversion \cite{DBLP:conf/types/CornesT95}. From an instantiated -inductive predicate and a goal it generates an equivalent goal where the -hypothesis has been generalized over its indexes which are then -constrained by equalities to be the right instances. This permits to -state lemmas without resorting to manually adding these equalities and -still get enough information in the proofs. -A simple example is the following: +Let us consider the following goal: \begin{coq_eval} -Reset Initial. +Lemma ex_dep : forall (n m:nat) (H:Le (S n) m), Q (S n) m H. +intros. \end{coq_eval} + \begin{coq_example} -Lemma le_minus : forall n:nat, n < 1 -> n = 0. -intros n H ; induction H. +Show. \end{coq_example} -Here we didn't get any information on the indexes to help fulfill this -proof. The problem is that when we use the \texttt{induction} tactic -we lose information on the hypothesis instance, notably that the second -argument is \texttt{1} here. Dependent induction solves this problem by -adding the corresponding equality to the context. +As \texttt{H} occurs in the goal, we may want to reason by cases on its +structure and so, we would like inversion tactics to +substitute \texttt{H} by the corresponding term in constructor form. +Neither \texttt{Inversion} nor {\tt Inversion\_clear} make such a +substitution. +To have such a behavior we use the dependent inversion tactics: -\begin{coq_eval} -Reset Initial. -\end{coq_eval} \begin{coq_example} -Require Import Coq.Program.Equality. -Lemma le_minus : forall n:nat, n < 1 -> n = 0. -intros n H ; dependent induction H. +dependent inversion_clear H. \end{coq_example} -The subgoal is cleaned up as the tactic tries to automatically -simplify the subgoals with respect to the generated equalities. -In this enriched context it becomes possible to solve this subgoal. -\begin{coq_example} -reflexivity. -\end{coq_example} +Note that \texttt{H} has been substituted by \texttt{(LeS n m0 l)} and +\texttt{m} by \texttt{(S m0)}. -Now we are in a contradictory context and the proof can be solved. -\begin{coq_example} -inversion H. -\end{coq_example} +\subsection{\tt fix {\ident} {\num}} +\tacindex{fix} +\label{tactic:fix} -This technique works with any inductive predicate. -In fact, the \texttt{dependent induction} tactic is just a wrapper around -the \texttt{induction} tactic. One can make its own variant by just -writing a new tactic based on the definition found in -\texttt{Coq.Program.Equality}. Common useful variants are the following, -defined in the same file: +This tactic is a primitive tactic to start a proof by induction. In +general, it is easier to rely on higher-level induction tactics such +as the ones described in Section~\ref{Tac-induction}. + +In the syntax of the tactic, the identifier {\ident} is the name given +to the induction hypothesis. The natural number {\num} tells on which +premise of the current goal the induction acts, starting +from 1 and counting both dependent and non dependent +products. Especially, the current lemma must be composed of at least +{\num} products. + +Like in a {\tt fix} expression, the induction +hypotheses have to be used on structurally smaller arguments. +The verification that inductive proof arguments are correct is done +only at the time of registering the lemma in the environment. To know +if the use of induction hypotheses is correct at some +time of the interactive development of a proof, use the command {\tt + Guarded} (see Section~\ref{Guarded}). \begin{Variants} -\item {\tt dependent induction {\ident} generalizing {\ident$_1$} \dots - {\ident$_n$}}\tacindex{dependent induction \dots\ generalizing} - - Does dependent induction on the hypothesis {\ident} but first - generalizes the goal by the given variables so that they are - universally quantified in the goal. This is generally what one wants - to do with the variables that are inside some constructors in the - induction hypothesis. The other ones need not be further generalized. + \item {\tt fix \ident$_1$ {\num} with ( \ident$_2$ + \nelist{\binder$_2$}{} \zeroone{\{ struct \ident$'_2$ + \}} :~\type$_2$ ) \dots\ ( \ident$_n$ + \nelist{\binder$_n$}{} \zeroone{\{ struct \ident$'_n$ \}} :~\type$_n$ )} + +This starts a proof by mutual induction. The statements to be +simultaneously proved are respectively {\tt forall} + \nelist{{\binder}$_2$}{}{\tt ,} {\type}$_2$, {\ldots}, {\tt forall} + \nelist{{\binder}$_n$}{}{\tt ,} {\type}$_n$. The identifiers +{\ident}$_1$ {\ldots} {\ident}$_n$ are the names of the induction +hypotheses. The identifiers {\ident}$'_2$ {\ldots} {\ident}$'_n$ are the +respective names of the premises on which the induction is performed +in the statements to be simultaneously proved (if not given, the +system tries to guess itself what they are). -\item {\tt dependent destruction {\ident}}\tacindex{dependent destruction} - - Does the generalization of the instance {\ident} but uses {\tt destruct} - instead of {\tt induction} on the generalized hypothesis. This gives - results equivalent to {\tt inversion} or {\tt dependent inversion} if - the hypothesis is dependent. \end{Variants} -A larger example of dependent induction and an explanation of the -underlying technique are developed in section~\ref{dependent-induction-example}. +\subsection{\tt cofix \ident} +\tacindex{cofix} +\label{tactic:cofix} -\subsection{\tt decompose [ {\qualid$_1$} \dots\ {\qualid$_n$} ] \term -\label{decompose} -\tacindex{decompose}} +This tactic starts a proof by coinduction. The identifier {\ident} is +the name given to the coinduction hypothesis. Like in a {\tt cofix} +expression, the use of induction hypotheses have to guarded by a +constructor. The verification that the use of co-inductive hypotheses +is correct is done only at the time of registering the lemma in the +environment. To know if the use of coinduction hypotheses is correct +at some time of the interactive development of a proof, use the +command {\tt Guarded} (see Section~\ref{Guarded}). -This tactic allows to recursively decompose a -complex proposition in order to obtain atomic ones. -Example: -\begin{coq_eval} -Reset Initial. -\end{coq_eval} -\begin{coq_example} -Lemma ex1 : forall A B C:Prop, A /\ B /\ C \/ B /\ C \/ C /\ A -> C. -intros A B C H; decompose [and or] H; assumption. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} +\begin{Variants} + \item {\tt cofix \ident$_1$ with ( \ident$_2$ + \nelist{\binder$_2$}{} :~\type$_2$ ) \dots\ ( + \ident$_n$ \nelist{\binder$_n$}{} :~\type$_n$ )} -{\tt decompose} does not work on right-hand sides of implications or products. +This starts a proof by mutual coinduction. The statements to be +simultaneously proved are respectively {\tt forall} +\nelist{{\binder}$_2$}{}{\tt ,} {\type}$_2$, {\ldots}, {\tt forall} + \nelist{{\binder}$_n$}{}{\tt ,} {\type}$_n$. The identifiers + {\ident}$_1$ {\ldots} {\ident}$_n$ are the names of the + coinduction hypotheses. -\begin{Variants} - -\item {\tt decompose sum \term}\tacindex{decompose sum} - This decomposes sum types (like \texttt{or}). -\item {\tt decompose record \term}\tacindex{decompose record} - This decomposes record types (inductive types with one constructor, - like \texttt{and} and \texttt{exists} and those defined with the - \texttt{Record} macro, see Section~\ref{Record}). \end{Variants} +\section{Rewriting expressions} -\subsection{\tt functional induction (\qualid\ \term$_1$ \dots\ \term$_n$). -\tacindex{functional induction} -\label{FunInduction}} - -The \emph{experimental} tactic \texttt{functional induction} performs -case analysis and induction following the definition of a function. It -makes use of a principle generated by \texttt{Function} -(see Section~\ref{Function}) or \texttt{Functional Scheme} -(see Section~\ref{FunScheme}). -\begin{coq_eval} -Reset Initial. -\end{coq_eval} -\begin{coq_example} -Functional Scheme minus_ind := Induction for minus Sort Prop. +These tactics use the equality {\tt eq:forall A:Type, A->A->Prop} +defined in file {\tt Logic.v} (see Section~\ref{Equality}). The +notation for {\tt eq}~$T~t~u$ is simply {\tt $t$=$u$} dropping the +implicit type of $t$ and $u$. -Lemma le_minus : forall n m:nat, (n - m <= n). -intros n m. -functional induction (minus n m); simpl; auto. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} +\subsection{\tt rewrite \term +\label{rewrite} +\tacindex{rewrite}} -\Rem \texttt{(\qualid\ \term$_1$ \dots\ \term$_n$)} must be a correct -full application of \qualid. In particular, the rules for implicit -arguments are the same as usual. For example use \texttt{@\qualid} if -you want to write implicit arguments explicitly. +This tactic applies to any goal. The type of {\term} +must have the form -\Rem Parenthesis over \qualid \dots \term$_n$ are mandatory. +\texttt{forall (x$_1$:A$_1$) \dots\ (x$_n$:A$_n$)}\texttt{eq} \term$_1$ \term$_2$. -\Rem \texttt{functional induction (f x1 x2 x3)} is actually a wrapper -for \texttt{induction x1 x2 x3 (f x1 x2 x3) using \qualid} followed by -a cleaning phase, where $\qualid$ is the induction principle -registered for $f$ (by the \texttt{Function} (see Section~\ref{Function}) -or \texttt{Functional Scheme} (see Section~\ref{FunScheme}) command) -corresponding to the sort of the goal. Therefore \texttt{functional - induction} may fail if the induction scheme (\texttt{\qualid}) is -not defined. See also Section~\ref{Function} for the function terms -accepted by \texttt{Function}. - -\Rem There is a difference between obtaining an induction scheme for a -function by using \texttt{Function} (see Section~\ref{Function}) and by -using \texttt{Functional Scheme} after a normal definition using -\texttt{Fixpoint} or \texttt{Definition}. See \ref{Function} for -details. - -\SeeAlso{\ref{Function},\ref{FunScheme},\ref{FunScheme-examples}, - \ref{sec:functional-inversion}} - -\begin{ErrMsgs} -\item \errindex{Cannot find induction information on \qualid} - - ~ - -\item \errindex{Not the right number of induction arguments} -\end{ErrMsgs} - -\begin{Variants} -\item {\tt functional induction (\qualid\ \term$_1$ \dots\ \term$_n$) - using \term$_{m+1}$ with {\term$_{n+1}$} \dots {\term$_m$}} - - Similar to \texttt{Induction} and \texttt{elim} - (see Section~\ref{Tac-induction}), allows to give explicitly the - induction principle and the values of dependent premises of the - elimination scheme, including \emph{predicates} for mutual induction - when {\qualid} is part of a mutually recursive definition. - -\item {\tt functional induction (\qualid\ \term$_1$ \dots\ \term$_n$) - using \term$_{m+1}$ with {\vref$_1$} := {\term$_{n+1}$} \dots\ - {\vref$_m$} := {\term$_n$}} - - Similar to \texttt{induction} and \texttt{elim} - (see Section~\ref{Tac-induction}). - -\item All previous variants can be extended by the usual \texttt{as - \intropattern} construction, similar for example to - \texttt{induction} and \texttt{elim} (see Section~\ref{Tac-induction}). - -\end{Variants} - - - -\section{Equality} - -These tactics use the equality {\tt eq:forall A:Type, A->A->Prop} -defined in file {\tt Logic.v} (see Section~\ref{Equality}). The -notation for {\tt eq}~$T~t~u$ is simply {\tt $t$=$u$} dropping the -implicit type of $t$ and $u$. - -\subsection{\tt rewrite \term -\label{rewrite} -\tacindex{rewrite}} - -This tactic applies to any goal. The type of {\term} -must have the form - -\texttt{forall (x$_1$:A$_1$) \dots\ (x$_n$:A$_n$)}\texttt{eq} \term$_1$ \term$_2$. - -\noindent where \texttt{eq} is the Leibniz equality or a registered -setoid equality. +\noindent where \texttt{eq} is the Leibniz equality or a registered +setoid equality. \noindent Then {\tt rewrite \term} finds the first subterm matching \term$_1$ in the goal, resulting in instances \term$_1'$ and \term$_2'$ @@ -2419,7 +2504,7 @@ Hence, some of the variables x$_i$ are solved by unification, and some of the types \texttt{A}$_1$, \dots, \texttt{A}$_n$ become new subgoals. -% \Rem In case the type of +% \Rem In case the type of % \term$_1$ contains occurrences of variables bound in the % type of \term, the tactic tries first to find a subterm of the goal % which matches this term in order to find a closed instance \term$'_1$ @@ -2449,13 +2534,13 @@ This happens if \term$_1$ does not occur in the goal. \texttt{H1} instead of the current goal. \item \texttt{rewrite H in H1 at 1, H2 at - 2 |- *} means \texttt{rewrite H; rewrite H in H1 at 1; rewrite H in H2 at - 2}. In particular a failure will happen if any of - these three simpler tactics fails. + these three simpler tactics fails. \item \texttt{rewrite H in * |- } will do \texttt{rewrite H in H$_i$} for all hypothesis \texttt{H$_i$ <> H}. A success will happen as soon as at least one of these simpler tactics succeeds. - \item \texttt{rewrite H in *} is a combination of \texttt{rewrite H} + \item \texttt{rewrite H in *} is a combination of \texttt{rewrite H} and \texttt{rewrite H in * |-} that succeeds if at - least one of these two tactics succeeds. + least one of these two tactics succeeds. \end{itemize} Orientation {\tt ->} or {\tt <-} can be inserted before the term to rewrite. @@ -2466,7 +2551,7 @@ This happens if \term$_1$ does not occur in the goal. Rewrite only the given occurrences of \term$_1'$. Occurrences are specified from left to right as for \texttt{pattern} (\S \ref{pattern}). The rewrite is always performed using setoid - rewriting, even for Leibniz's equality, so one has to + rewriting, even for Leibniz's equality, so one has to \texttt{Import Setoid} to use this variant. \item {\tt rewrite {\term} by {\tac}} @@ -2481,7 +2566,7 @@ This happens if \term$_1$ does not occur in the goal. generated by the previous one. Orientation {\tt ->} or {\tt <-} can be inserted before each term to rewrite. One unique \textit{clause} - can be added at the end after the keyword {\tt in}; it will + can be added at the end after the keyword {\tt in}; it will then affect all rewrite operations. \item In all forms of {\tt rewrite} described above, a term to rewrite @@ -2489,13 +2574,13 @@ This happens if \term$_1$ does not occur in the goal. \begin{itemize} \item {\tt ?} : the tactic {\tt rewrite ?$\term$} performs the rewrite of $\term$ as many times as possible (perhaps zero time). - This form never fails. - \item {\tt $n$?} : works similarly, except that it will do at most - $n$ rewrites. - \item {\tt !} : works as {\tt ?}, except that at least one rewrite - should succeed, otherwise the tactic fails. - \item {\tt $n$!} (or simply {\tt $n$}) : precisely $n$ rewrites - of $\term$ will be done, leading to failure if these $n$ rewrites are not possible. + This form never fails. + \item {\tt $n$?} : works similarly, except that it will do at most + $n$ rewrites. + \item {\tt !} : works as {\tt ?}, except that at least one rewrite + should succeed, otherwise the tactic fails. + \item {\tt $n$!} (or simply {\tt $n$}) : precisely $n$ rewrites + of $\term$ will be done, leading to failure if these $n$ rewrites are not possible. \end{itemize} \item {\tt erewrite {\term}\tacindex{erewrite}} @@ -2542,10 +2627,10 @@ n}| assumption || symmetry; try assumption]}. \item {\tt replace <- {\term}}\\ Replace {\term} with {\term'} using the first assumption whose type has the form {\tt \term'=\term} \item {\tt replace {\term$_1$} with {\term$_2$} \textit{clause} }\\ - {\tt replace {\term$_1$} with {\term$_2$} \textit{clause} by \tac }\\ - {\tt replace {\term} \textit{clause}}\\ - {\tt replace -> {\term} \textit{clause}}\\ - {\tt replace <- {\term} \textit{clause}}\\ + {\tt replace {\term$_1$} with {\term$_2$} \textit{clause} by \tac }\\ + {\tt replace {\term} \textit{clause}}\\ + {\tt replace -> {\term} \textit{clause}}\\ + {\tt replace <- {\term} \textit{clause}}\\ Act as before but the replacements take place in \textit{clause}~(see Section~\ref{Conversion-tactics}) and not only in the conclusion of the goal.\\ @@ -2578,7 +2663,7 @@ the tactic changes it to {\tt u=t}. \subsection{\tt transitivity \term \tacindex{transitivity}} This tactic applies to a goal which has the form {\tt t=u} -and transforms it into the two subgoals +and transforms it into the two subgoals {\tt t={\term}} and {\tt {\term}=u}. \subsection{\tt subst {\ident} @@ -2586,13 +2671,13 @@ and transforms it into the two subgoals This tactic applies to a goal which has \ident\ in its context and (at least) one hypothesis, say {\tt H}, of type {\tt - \ident=t} or {\tt t=\ident}. Then it replaces -\ident\ by {\tt t} everywhere in the goal (in the hypotheses + \ident=t} or {\tt t=\ident}. Then it replaces +\ident\ by {\tt t} everywhere in the goal (in the hypotheses and in the conclusion) and clears \ident\ and {\tt H} from the context. -\Rem +\Rem When several hypotheses have the form {\tt \ident=t} or {\tt - t=\ident}, the first one is used. + t=\ident}, the first one is used. \begin{Variants} \item {\tt subst \ident$_1$ \dots \ident$_n$} \\ @@ -2612,7 +2697,7 @@ is typically a setoid equality. The application of {\tt stepl {\term}} then replaces the goal by ``$R$ {\term} {\term}$_2$'' and adds a new goal stating ``$eq$ {\term} {\term}$_1$''. -Lemmas are added to the database using the command +Lemmas are added to the database using the command \comindex{Declare Left Step} \begin{quote} {\tt Declare Left Step {\term}.} @@ -2640,710 +2725,1060 @@ and are registered using the command \end{quote} \end{Variants} +\subsection{\tt change \term +\tacindex{change} +\label{change}} -\subsection{\tt f\_equal -\label{f-equal} -\tacindex{f\_equal}} +This tactic applies to any goal. It implements the rule +``Conv''\index{Typing rules!Conv} given in Section~\ref{Conv}. {\tt + change U} replaces the current goal \T\ with \U\ providing that +\U\ is well-formed and that \T\ and \U\ are convertible. -This tactic applies to a goal of the form $f\ a_1\ \ldots\ a_n = f'\ -a'_1\ \ldots\ a'_n$. Using {\tt f\_equal} on such a goal leads to -subgoals $f=f'$ and $a_1=a'_1$ and so on up to $a_n=a'_n$. Amongst -these subgoals, the simple ones (e.g. provable by -reflexivity or congruence) are automatically solved by {\tt f\_equal}. +\begin{ErrMsgs} +\item \errindex{Not convertible} +\end{ErrMsgs} +\tacindex{change \dots\ in} +\begin{Variants} +\item {\tt change \term$_1$ with \term$_2$} -\section{Equality and inductive sets} + This replaces the occurrences of \term$_1$ by \term$_2$ in the + current goal. The terms \term$_1$ and \term$_2$ must be + convertible. -We describe in this section some special purpose tactics dealing with -equality and inductive sets or types. These tactics use the equality -{\tt eq:forall (A:Type), A->A->Prop}, simply written with the -infix symbol {\tt =}. +\item {\tt change \term$_1$ at \num$_1$ \dots\ \num$_i$ with \term$_2$} -\subsection{\tt decide equality -\label{decideequality} -\tacindex{decide equality}} + This replaces the occurrences numbered \num$_1$ \dots\ \num$_i$ of + \term$_1$ by \term$_2$ in the current goal. + The terms \term$_1$ and \term$_2$ must be convertible. -This tactic solves a goal of the form -{\tt forall $x$ $y$:$R$, \{$x$=$y$\}+\{\verb|~|$x$=$y$\}}, where $R$ -is an inductive type such that its constructors do not take proofs or -functions as arguments, nor objects in dependent types. -It solves goals of the form {\tt \{$x$=$y$\}+\{\verb|~|$x$=$y$\}} as well. + \ErrMsg {\tt Too few occurrences} -\subsection{\tt compare \term$_1$ \term$_2$ -\tacindex{compare}} +\item {\tt change {\term} in {\ident}} -This tactic compares two given objects \term$_1$ and \term$_2$ -of an inductive datatype. If $G$ is the current goal, it leaves the sub-goals -\term$_1${\tt =}\term$_2$ {\tt ->} $G$ and \verb|~|\term$_1${\tt =}\term$_2$ -{\tt ->} $G$. The type -of \term$_1$ and \term$_2$ must satisfy the same restrictions as in the tactic -\texttt{decide equality}. +\item {\tt change \term$_1$ with \term$_2$ in {\ident}} -\subsection{\tt discriminate {\term} -\label{discriminate} -\tacindex{discriminate} -\tacindex{ediscriminate}} +\item {\tt change \term$_1$ at \num$_1$ \dots\ \num$_i$ with \term$_2$ in + {\ident}} -This tactic proves any goal from an assumption stating that two -structurally different terms of an inductive set are equal. For -example, from {\tt (S (S O))=(S O)} we can derive by absurdity any -proposition. + This applies the {\tt change} tactic not to the goal but to the + hypothesis {\ident}. -The argument {\term} is assumed to be a proof of a statement -of conclusion {\tt{\term$_1$} = {\term$_2$}} with {\term$_1$} and -{\term$_2$} being elements of an inductive set. To build the proof, -the tactic traverses the normal forms\footnote{Reminder: opaque - constants will not be expanded by $\delta$ reductions} of -{\term$_1$} and {\term$_2$} looking for a couple of subterms {\tt u} -and {\tt w} ({\tt u} subterm of the normal form of {\term$_1$} and -{\tt w} subterm of the normal form of {\term$_2$}), placed at the same -positions and whose head symbols are two different constructors. If -such a couple of subterms exists, then the proof of the current goal -is completed, otherwise the tactic fails. +\end{Variants} -\Rem The syntax {\tt discriminate {\ident}} can be used to refer to a -hypothesis quantified in the goal. In this case, the quantified -hypothesis whose name is {\ident} is first introduced in the local -context using \texttt{intros until \ident}. +\SeeAlso \ref{Conversion-tactics} -\begin{ErrMsgs} -\item \errindex{No primitive equality found} -\item \errindex{Not a discriminable equality} -\end{ErrMsgs} -\begin{Variants} -\item \texttt{discriminate} \num +\section{Performing computations +\index{Conversion tactics} +\label{Conversion-tactics}} - This does the same thing as \texttt{intros until \num} followed by - \texttt{discriminate \ident} where {\ident} is the identifier for - the last introduced hypothesis. +This set of tactics implements different specialized usages of the +tactic \texttt{change}. -\item \texttt{discriminate} {\term} {\tt with} {\bindinglist} +All conversion tactics (including \texttt{change}) can be +parameterized by the parts of the goal where the conversion can +occur. This is done using \emph{goal clauses} which consists in a list +of hypotheses and, optionally, of a reference to the conclusion of the +goal. For defined hypothesis it is possible to specify if the +conversion should occur on the type part, the body part or both +(default). - This does the same thing as \texttt{discriminate {\term}} but using -the given bindings to instantiate parameters or hypotheses of {\term}. +\index{Clauses} +\index{Goal clauses} +Goal clauses are written after a conversion tactic (tactics +\texttt{set}~\ref{tactic:set}, \texttt{rewrite}~\ref{rewrite}, +\texttt{replace}~\ref{tactic:replace} and +\texttt{autorewrite}~\ref{tactic:autorewrite} also use goal clauses) and +are introduced by the keyword \texttt{in}. If no goal clause is provided, +the default is to perform the conversion only in the conclusion. -\item \texttt{ediscriminate} \num\\ - \texttt{ediscriminate} {\term} \zeroone{{\tt with} {\bindinglist}} +The syntax and description of the various goal clauses is the following: +\begin{description} +\item[]\texttt{in {\ident}$_1$ $\ldots$ {\ident}$_n$ |- } only in hypotheses {\ident}$_1$ + \ldots {\ident}$_n$ +\item[]\texttt{in {\ident}$_1$ $\ldots$ {\ident}$_n$ |- *} in hypotheses {\ident}$_1$ \ldots + {\ident}$_n$ and in the conclusion +\item[]\texttt{in * |-} in every hypothesis +\item[]\texttt{in *} (equivalent to \texttt{in * |- *}) everywhere +\item[]\texttt{in (type of {\ident}$_1$) (value of {\ident}$_2$) $\ldots$ |-} in + type part of {\ident}$_1$, in the value part of {\ident}$_2$, etc. +\end{description} - This works the same as {\tt discriminate} but if the type of {\term}, - or the type of the hypothesis referred to by {\num}, has uninstantiated - parameters, these parameters are left as existential variables. +For backward compatibility, the notation \texttt{in}~{\ident}$_1$\ldots {\ident}$_n$ +performs the conversion in hypotheses {\ident}$_1$\ldots {\ident}$_n$. -\item \texttt{discriminate} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%voir reduction__conv_x : histoires d'univers. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - This behaves like {\tt discriminate {\ident}} if {\ident} is the - name of an hypothesis to which {\tt discriminate} is applicable; if - the current goal is of the form {\term$_1$} {\tt <>} {\term$_2$}, - this behaves as {\tt intro {\ident}; injection {\ident}}. +\subsection[{\tt cbv \flag$_1$ \dots\ \flag$_n$}, {\tt lazy \flag$_1$ +\dots\ \flag$_n$} and {\tt compute}] +{{\tt cbv \flag$_1$ \dots\ \flag$_n$}, {\tt lazy \flag$_1$ +\dots\ \flag$_n$} and {\tt compute} +\tacindex{cbv} +\tacindex{lazy} +\tacindex{compute} +\tacindex{vm\_compute}\label{vmcompute}} - \begin{ErrMsgs} - \item \errindex{No discriminable equalities} \\ - occurs when the goal does not verify the expected preconditions. - \end{ErrMsgs} -\end{Variants} +These parameterized reduction tactics apply to any goal and perform +the normalization of the goal according to the specified flags. In +correspondence with the kinds of reduction considered in \Coq\, namely +$\beta$ (reduction of functional application), $\delta$ (unfolding of +transparent constants, see \ref{Transparent}), $\iota$ (reduction of +pattern-matching over a constructed term, and unfolding of {\tt fix} +and {\tt cofix} expressions) and $\zeta$ (contraction of local +definitions), the flag are either {\tt beta}, {\tt delta}, {\tt iota} +or {\tt zeta}. The {\tt delta} flag itself can be refined into {\tt +delta [\qualid$_1$\ldots\qualid$_k$]} or {\tt delta +-[\qualid$_1$\ldots\qualid$_k$]}, restricting in the first case the +constants to unfold to the constants listed, and restricting in the +second case the constant to unfold to all but the ones explicitly +mentioned. Notice that the {\tt delta} flag does not apply to +variables bound by a let-in construction inside the term itself (use +here the {\tt zeta} flag). In any cases, opaque constants are not +unfolded (see Section~\ref{Opaque}). -\subsection{\tt injection {\term} -\label{injection} -\tacindex{injection} -\tacindex{einjection}} +The goal may be normalized with two strategies: {\em lazy} ({\tt lazy} +tactic), or {\em call-by-value} ({\tt cbv} tactic). The lazy strategy +is a call-by-need strategy, with sharing of reductions: the arguments of a +function call are partially evaluated only when necessary, and if an +argument is used several times then it is computed only once. This +reduction is efficient for reducing expressions with dead code. For +instance, the proofs of a proposition {\tt exists~$x$. $P(x)$} reduce to a +pair of a witness $t$, and a proof that $t$ satisfies the predicate +$P$. Most of the time, $t$ may be computed without computing the proof +of $P(t)$, thanks to the lazy strategy. -The {\tt injection} tactic is based on the fact that constructors of -inductive sets are injections. That means that if $c$ is a constructor -of an inductive set, and if $(c~\vec{t_1})$ and $(c~\vec{t_2})$ are two -terms that are equal then $~\vec{t_1}$ and $~\vec{t_2}$ are equal -too. +The call-by-value strategy is the one used in ML languages: the +arguments of a function call are evaluated first, using a weak +reduction (no reduction under the $\lambda$-abstractions). Despite the +lazy strategy always performs fewer reductions than the call-by-value +strategy, the latter is generally more efficient for evaluating purely +computational expressions (i.e. with few dead code). -If {\term} is a proof of a statement of conclusion - {\tt {\term$_1$} = {\term$_2$}}, -then {\tt injection} applies injectivity as deep as possible to -derive the equality of all the subterms of {\term$_1$} and {\term$_2$} -placed in the same positions. For example, from {\tt (S - (S n))=(S (S (S m)))} we may derive {\tt n=(S m)}. To use this -tactic {\term$_1$} and {\term$_2$} should be elements of an inductive -set and they should be neither explicitly equal, nor structurally -different. We mean by this that, if {\tt n$_1$} and {\tt n$_2$} are -their respective normal forms, then: -\begin{itemize} -\item {\tt n$_1$} and {\tt n$_2$} should not be syntactically equal, -\item there must not exist any pair of subterms {\tt u} and {\tt w}, - {\tt u} subterm of {\tt n$_1$} and {\tt w} subterm of {\tt n$_2$} , - placed in the same positions and having different constructors as - head symbols. -\end{itemize} -If these conditions are satisfied, then, the tactic derives the -equality of all the subterms of {\term$_1$} and {\term$_2$} placed in -the same positions and puts them as antecedents of the current goal. +\begin{Variants} +\item {\tt compute} \tacindex{compute}\\ + {\tt cbv} -\Example Consider the following goal: + These are synonyms for {\tt cbv beta delta iota zeta}. + +\item {\tt lazy} + + This is a synonym for {\tt lazy beta delta iota zeta}. + +\item {\tt compute [\qualid$_1$\ldots\qualid$_k$]}\\ + {\tt cbv [\qualid$_1$\ldots\qualid$_k$]} + + These are synonyms of {\tt cbv beta delta + [\qualid$_1$\ldots\qualid$_k$] iota zeta}. + +\item {\tt compute -[\qualid$_1$\ldots\qualid$_k$]}\\ + {\tt cbv -[\qualid$_1$\ldots\qualid$_k$]} + + These are synonyms of {\tt cbv beta delta + -[\qualid$_1$\ldots\qualid$_k$] iota zeta}. + +\item {\tt lazy [\qualid$_1$\ldots\qualid$_k$]}\\ + {\tt lazy -[\qualid$_1$\ldots\qualid$_k$]} + + These are respectively synonyms of {\tt lazy beta delta + [\qualid$_1$\ldots\qualid$_k$] iota zeta} and {\tt lazy beta delta + -[\qualid$_1$\ldots\qualid$_k$] iota zeta}. + +\item {\tt vm\_compute} \tacindex{vm\_compute} + + This tactic evaluates the goal using the optimized call-by-value + evaluation bytecode-based virtual machine. This algorithm is + dramatically more efficient than the algorithm used for the {\tt + cbv} tactic, but it cannot be fine-tuned. It is specially + interesting for full evaluation of algebraic objects. This includes + the case of reflexion-based tactics. + +\end{Variants} + +% Obsolete? Anyway not very important message +%\begin{ErrMsgs} +%\item \errindex{Delta must be specified before} +% +% A list of constants appeared before the {\tt delta} flag. +%\end{ErrMsgs} + + +\subsection{{\tt red} +\tacindex{red}} + +This tactic applies to a goal which has the form {\tt + forall (x:T1)\dots(xk:Tk), c t1 \dots\ tn} where {\tt c} is a constant. If +{\tt c} is transparent then it replaces {\tt c} with its definition +(say {\tt t}) and then reduces {\tt (t t1 \dots\ tn)} according to +$\beta\iota\zeta$-reduction rules. + +\begin{ErrMsgs} +\item \errindex{Not reducible} +\end{ErrMsgs} + +\subsection{{\tt hnf} +\tacindex{hnf}} + +This tactic applies to any goal. It replaces the current goal with its +head normal form according to the $\beta\delta\iota\zeta$-reduction +rules, i.e. it reduces the head of the goal until it becomes a +product or an irreducible term. + +\Example +The term \verb+forall n:nat, (plus (S n) (S n))+ is not reduced by {\tt hnf}. + +\Rem The $\delta$ rule only applies to transparent constants +(see Section~\ref{Opaque} on transparency and opacity). + +\subsection{\tt simpl +\tacindex{simpl}} + +This tactic applies to any goal. The tactic {\tt simpl} first applies +$\beta\iota$-reduction rule. Then it expands transparent constants +and tries to reduce {\tt T'} according, once more, to $\beta\iota$ +rules. But when the $\iota$ rule is not applicable then possible +$\delta$-reductions are not applied. For instance trying to use {\tt +simpl} on {\tt (plus n O)=n} changes nothing. Notice that only +transparent constants whose name can be reused as such in the +recursive calls are possibly unfolded. For instance a constant defined +by {\tt plus' := plus} is possibly unfolded and reused in the +recursive calls, but a constant such as {\tt succ := plus (S O)} is +never unfolded. + +The behavior of {\tt simpl} can be tuned using the {\tt Arguments} vernacular +command as follows: +\comindex{Arguments} +\begin{itemize} +\item +A constant can be marked to be never unfolded by {\tt simpl}: +\begin{coq_example*} +Arguments minus x y : simpl never +\end{coq_example*} +After that command an expression like {\tt (minus (S x) y)} is left untouched by +the {\tt simpl} tactic. +\item +A constant can be marked to be unfolded only if applied to enough arguments. +The number of arguments required can be specified using +the {\tt /} symbol in the arguments list of the {\tt Arguments} vernacular +command. +\begin{coq_example*} +Definition fcomp A B C f (g : A -> B) (x : A) : C := f (g x). +Notation "f \o g" := (fcomp f g) (at level 50). +Arguments fcomp {A B C} f g x /. +\end{coq_example*} +After that command the expression {\tt (f \verb+\+o g)} is left untouched by +{\tt simpl} while {\tt ((f \verb+\+o g) t)} is reduced to {\tt (f (g t))}. +The same mechanism can be used to make a constant volatile, i.e. always +unfolded by {\tt simpl}. +\begin{coq_example*} +Definition volatile := fun x : nat => x. +Arguments volatile / x. +\end{coq_example*} +\item +A constant can be marked to be unfolded only if an entire set of arguments +evaluates to a constructor. The {\tt !} symbol can be used to mark such +arguments. +\begin{coq_example*} +Arguments minus !x !y. +\end{coq_example*} +After that command, the expression {\tt (minus (S x) y)} is left untouched by +{\tt simpl}, while {\tt (minus (S x) (S y))} is reduced to {\tt (minus x y)}. +\item +A special heuristic to determine if a constant has to be unfolded can be +activated with the following command: +\begin{coq_example*} +Arguments minus x y : simpl nomatch +\end{coq_example*} +The heuristic avoids to perform a simplification step that would +expose a {\tt match} construct in head position. For example the +expression {\tt (minus (S (S x)) (S y))} is simplified to +{\tt (minus (S x) y)} even if an extra simplification is possible. +\end{itemize} + +\tacindex{simpl \dots\ in} +\begin{Variants} +\item {\tt simpl {\term}} + + This applies {\tt simpl} only to the occurrences of {\term} in the + current goal. + +\item {\tt simpl {\term} at \num$_1$ \dots\ \num$_i$} + + This applies {\tt simpl} only to the \num$_1$, \dots, \num$_i$ + occurrences of {\term} in the current goal. + + \ErrMsg {\tt Too few occurrences} + +\item {\tt simpl {\ident}} + + This applies {\tt simpl} only to the applicative subterms whose head + occurrence is {\ident}. + +\item {\tt simpl {\ident} at \num$_1$ \dots\ \num$_i$} + + This applies {\tt simpl} only to the \num$_1$, \dots, \num$_i$ +applicative subterms whose head occurrence is {\ident}. + +\end{Variants} + +\subsection{\tt unfold \qualid +\tacindex{unfold} +\label{unfold}} + +This tactic applies to any goal. The argument {\qualid} must denote a +defined transparent constant or local definition (see Sections~\ref{Basic-definitions} and~\ref{Transparent}). The tactic {\tt + unfold} applies the $\delta$ rule to each occurrence of the constant +to which {\qualid} refers in the current goal and then replaces it +with its $\beta\iota$-normal form. + +\begin{ErrMsgs} +\item {\qualid} \errindex{does not denote an evaluable constant} + +\end{ErrMsgs} + +\begin{Variants} +\item {\tt unfold {\qualid}$_1$, \dots, \qualid$_n$} + \tacindex{unfold \dots\ in} + + Replaces {\em simultaneously} {\qualid}$_1$, \dots, {\qualid}$_n$ + with their definitions and replaces the current goal with its + $\beta\iota$ normal form. + +\item {\tt unfold {\qualid}$_1$ at \num$_1^1$, \dots, \num$_i^1$, +\dots,\ \qualid$_n$ at \num$_1^n$ \dots\ \num$_j^n$} + + The lists \num$_1^1$, \dots, \num$_i^1$ and \num$_1^n$, \dots, + \num$_j^n$ specify the occurrences of {\qualid}$_1$, \dots, + \qualid$_n$ to be unfolded. Occurrences are located from left to + right. + + \ErrMsg {\tt bad occurrence number of {\qualid}$_i$} + + \ErrMsg {\qualid}$_i$ {\tt does not occur} + +\item {\tt unfold {\qstring}} + + If {\qstring} denotes the discriminating symbol of a notation (e.g. {\tt + "+"}) or an expression defining a notation (e.g. \verb!"_ + _"!), and + this notation refers to an unfoldable constant, then the tactic + unfolds it. + +\item {\tt unfold {\qstring}\%{\delimkey}} + + This is variant of {\tt unfold {\qstring}} where {\qstring} gets its + interpretation from the scope bound to the delimiting key + {\delimkey} instead of its default interpretation (see + Section~\ref{scopechange}). + +\item {\tt unfold \qualidorstring$_1$ at \num$_1^1$, \dots, \num$_i^1$, +\dots,\ \qualidorstring$_n$ at \num$_1^n$ \dots\ \num$_j^n$} + + This is the most general form, where {\qualidorstring} is either a + {\qualid} or a {\qstring} referring to a notation. + +\end{Variants} + +\subsection{{\tt fold} \term +\tacindex{fold}} + +This tactic applies to any goal. The term \term\ is reduced using the {\tt red} +tactic. Every occurrence of the resulting term in the goal is then +replaced by \term. + +\begin{Variants} +\item {\tt fold} \term$_1$ \dots\ \term$_n$ + + Equivalent to {\tt fold} \term$_1${\tt;}\ldots{\tt; fold} \term$_n$. +\end{Variants} + +\subsection{{\tt pattern {\term}} +\tacindex{pattern} +\label{pattern}} + +This command applies to any goal. The argument {\term} must be a free +subterm of the current goal. The command {\tt pattern} performs +$\beta$-expansion (the inverse of $\bt$-reduction) of the current goal +(say \T) by +\begin{enumerate} +\item replacing all occurrences of {\term} in {\T} with a fresh variable +\item abstracting this variable +\item applying the abstracted goal to {\term} +\end{enumerate} + +For instance, if the current goal $T$ is expressible has $\phi(t)$ +where the notation captures all the instances of $t$ in $\phi(t)$, +then {\tt pattern $t$} transforms it into {\tt (fun x:$A$ => $\phi(${\tt +x}$)$) $t$}. This command can be used, for instance, when the tactic +{\tt apply} fails on matching. + +\begin{Variants} +\item {\tt pattern {\term} at {\num$_1$} \dots\ {\num$_n$}} + + Only the occurrences {\num$_1$} \dots\ {\num$_n$} of {\term} are + considered for $\beta$-expansion. Occurrences are located from left + to right. + +\item {\tt pattern {\term} at - {\num$_1$} \dots\ {\num$_n$}} + + All occurrences except the occurrences of indexes {\num$_1$} \dots\ + {\num$_n$} of {\term} are considered for + $\beta$-expansion. Occurrences are located from left to right. + +\item {\tt pattern {\term$_1$}, \dots, {\term$_m$}} + + Starting from a goal $\phi(t_1 \dots\ t_m)$, the tactic + {\tt pattern $t_1$, \dots,\ $t_m$} generates the equivalent goal {\tt + (fun (x$_1$:$A_1$) \dots\ (x$_m$:$A_m$) => $\phi(${\tt x$_1$\dots\ + x$_m$}$)$) $t_1$ \dots\ $t_m$}.\\ If $t_i$ occurs in one of the + generated types $A_j$ these occurrences will also be considered and + possibly abstracted. + +\item {\tt pattern {\term$_1$} at {\num$_1^1$} \dots\ {\num$_{n_1}^1$}, \dots, + {\term$_m$} at {\num$_1^m$} \dots\ {\num$_{n_m}^m$}} + + This behaves as above but processing only the occurrences \num$_1^1$, + \dots, \num$_i^1$ of \term$_1$, \dots, \num$_1^m$, \dots, \num$_j^m$ + of \term$_m$ starting from \term$_m$. + +\item {\tt pattern} {\term$_1$} \zeroone{{\tt at \zeroone{-}} {\num$_1^1$} \dots\ {\num$_{n_1}^1$}} {\tt ,} \dots {\tt ,} + {\term$_m$} \zeroone{{\tt at \zeroone{-}} {\num$_1^m$} \dots\ {\num$_{n_m}^m$}} + + This is the most general syntax that combines the different variants. + +\end{Variants} + +\subsection{Conversion tactics applied to hypotheses} + +{\convtactic} {\tt in} \ident$_1$ \dots\ \ident$_n$ + +Applies the conversion tactic {\convtactic} to the +hypotheses \ident$_1$, \ldots, \ident$_n$. The tactic {\convtactic} is +any of the conversion tactics listed in this section. + +If \ident$_i$ is a local definition, then \ident$_i$ can be replaced +by (Type of \ident$_i$) to address not the body but the type of the +local definition. Example: {\tt unfold not in (Type of H1) (Type of H3).} + +\begin{ErrMsgs} +\item \errindex{No such hypothesis} : {\ident}. +\end{ErrMsgs} + + +\section{Automation} +\subsection{\tt auto +\label{auto} +\tacindex{auto}} + +This tactic implements a Prolog-like resolution procedure to solve the +current goal. It first tries to solve the goal using the {\tt + assumption} tactic, then it reduces the goal to an atomic one using +{\tt intros} and introducing the newly generated hypotheses as hints. +Then it looks at the list of tactics associated to the head symbol of +the goal and tries to apply one of them (starting from the tactics +with lower cost). This process is recursively applied to the generated +subgoals. + +By default, \texttt{auto} only uses the hypotheses of the current goal and the +hints of the database named {\tt core}. + +\begin{Variants} + +\item {\tt auto \num} + + Forces the search depth to be \num. The maximal search depth is 5 by + default. + +\item {\tt auto with \ident$_1$ \dots\ \ident$_n$} + + Uses the hint databases $\ident_1$ \dots\ $\ident_n$ in addition to + the database {\tt core}. See Section~\ref{Hints-databases} for the + list of pre-defined databases and the way to create or extend a + database. This option can be combined with the previous one. + +\item {\tt auto with *} + + Uses all existing hint databases, minus the special database + {\tt v62}. See Section~\ref{Hints-databases} + +\item \texttt{auto using \nterm{lemma}$_1$ , \ldots , \nterm{lemma}$_n$} + + Uses \nterm{lemma}$_1$, \ldots, \nterm{lemma}$_n$ in addition to + hints (can be combined with the \texttt{with \ident} option). If + $lemma_i$ is an inductive type, it is the collection of its + constructors which is added as hints. + +\item \texttt{auto using \nterm{lemma}$_1$ , \ldots , \nterm{lemma}$_n$ with \ident$_1$ \dots\ \ident$_n$} + + This combines the effects of the {\tt using} and {\tt with} options. + +\item {\tt trivial}\tacindex{trivial} + + This tactic is a restriction of {\tt auto} that is not recursive and + tries only hints which cost 0. Typically it solves trivial + equalities like $X=X$. + +\item \texttt{trivial with \ident$_1$ \dots\ \ident$_n$} + +\item \texttt{trivial with *} + +\end{Variants} + +\Rem {\tt auto} either solves completely the goal or else leaves it +intact. \texttt{auto} and \texttt{trivial} never fail. + +\SeeAlso Section~\ref{Hints-databases} + +\subsection{\tt eauto +\tacindex{eauto} +\label{eauto}} + +This tactic generalizes {\tt auto}. In contrast with +the latter, {\tt eauto} uses unification of the goal +against the hints rather than pattern-matching +(in other words, it uses {\tt eapply} instead of +{\tt apply}). +As a consequence, {\tt eauto} can solve such a goal: -\begin{coq_example*} -Inductive list : Set := - | nil : list - | cons : nat -> list -> list. -Variable P : list -> Prop. -\end{coq_example*} -\begin{coq_eval} -Lemma ex : - forall (l:list) (n:nat), P nil -> cons n l = cons 0 nil -> P l. -intros l n H H0. -\end{coq_eval} \begin{coq_example} -Show. -injection H0. +Hint Resolve ex_intro. +Goal forall P:nat -> Prop, P 0 -> exists n, P n. +eauto. \end{coq_example} \begin{coq_eval} Abort. \end{coq_eval} -Beware that \texttt{injection} yields always an equality in a sigma type -whenever the injected object has a dependent type. +Note that {\tt ex\_intro} should be declared as an +hint. -\Rem There is a special case for dependent pairs. If we have a decidable -equality over the type of the first argument, then it is safe to do -the projection on the second one, and so {\tt injection} will work fine. -To define such an equality, you have to use the {\tt Scheme} command -(see \ref{Scheme}). +\SeeAlso Section~\ref{Hints-databases} -\Rem If some quantified hypothesis of the goal is named {\ident}, then -{\tt injection {\ident}} first introduces the hypothesis in the local -context using \texttt{intros until \ident}. +\subsection{\tt autounfold with \ident$_1$ \dots\ \ident$_n$ +\tacindex{autounfold} +\label{autounfold}} -\begin{ErrMsgs} -\item \errindex{Not a projectable equality but a discriminable one} -\item \errindex{Nothing to do, it is an equality between convertible terms} -\item \errindex{Not a primitive equality} -\end{ErrMsgs} +This tactic unfolds constants that were declared through a {\tt Hint + Unfold} in the given databases. + +\begin{Variants} +\item {\tt autounfold with \ident$_1$ \dots\ \ident$_n$ in \textit{clause}} + + Perform the unfolding in the given clause. + +\item {\tt autounfold with *} + + Uses the unfold hints declared in all the hint databases. +\end{Variants} + + +\subsection{\tt autorewrite with \ident$_1$ \dots \ident$_n$. +\label{tactic:autorewrite} +\tacindex{autorewrite}} + +This tactic \footnote{The behavior of this tactic has much changed compared to +the versions available in the previous distributions (V6). This may cause +significant changes in your theories to obtain the same result. As a drawback +of the re-engineering of the code, this tactic has also been completely revised +to get a very compact and readable version.} carries out rewritings according +the rewriting rule bases {\tt \ident$_1$ \dots \ident$_n$}. + +Each rewriting rule of a base \ident$_i$ is applied to the main subgoal until +it fails. Once all the rules have been processed, if the main subgoal has +progressed (e.g., if it is distinct from the initial main goal) then the rules +of this base are processed again. If the main subgoal has not progressed then +the next base is processed. For the bases, the behavior is exactly similar to +the processing of the rewriting rules. + +The rewriting rule bases are built with the {\tt Hint~Rewrite} vernacular +command. + +\Warning{} This tactic may loop if you build non terminating rewriting systems. + +\begin{Variant} +\item {\tt autorewrite with \ident$_1$ \dots \ident$_n$ using \tac}\\ +Performs, in the same way, all the rewritings of the bases {\tt \ident$_1$ $...$ +\ident$_n$} applying {\tt \tac} to the main subgoal after each rewriting step. + +\item \texttt{autorewrite with {\ident$_1$} \dots \ident$_n$ in {\qualid}} + + Performs all the rewritings in hypothesis {\qualid}. +\item \texttt{autorewrite with {\ident$_1$} \dots \ident$_n$ in {\qualid} using \tac} + + Performs all the rewritings in hypothesis {\qualid} applying {\tt + \tac} to the main subgoal after each rewriting step. + +\item \texttt{autorewrite with {\ident$_1$} \dots \ident$_n$ in \textit{clause}} + Performs all the rewritings in the clause \textit{clause}. \\ + The \textit{clause} argument must not contain any \texttt{type of} nor \texttt{value of}. + +\end{Variant} + +\SeeAlso Section~\ref{HintRewrite} for feeding the database of lemmas used by {\tt autorewrite}. + +\SeeAlso Section~\ref{autorewrite-example} for examples showing the use of +this tactic. + +% En attente d'un moyen de valoriser les fichiers de demos +%\SeeAlso file \texttt{contrib/Rocq/DEMOS/Demo\_AutoRewrite.v} + +\section{Controlling automation} + +\subsection{The hints databases for {\tt auto} and {\tt eauto} +\index{Hints databases} +\label{Hints-databases} +\comindex{Hint}} + +The hints for \texttt{auto} and \texttt{eauto} are stored in +databases. Each database maps head symbols to a list of hints. One can +use the command \texttt{Print Hint \ident} to display the hints +associated to the head symbol \ident{} (see \ref{PrintHint}). Each +hint has a cost that is an nonnegative integer, and an optional pattern. +The hints with lower cost are tried first. A hint is tried by +\texttt{auto} when the conclusion of the current goal +matches its pattern or when it has no pattern. + +\subsubsection*{Creating Hint databases + \label{CreateHintDb}\comindex{CreateHintDb}} + +One can optionally declare a hint database using the command +\texttt{Create HintDb}. If a hint is added to an unknown database, it +will be automatically created. + +\medskip +\texttt{Create HintDb} {\ident} [\texttt{discriminated}] +\medskip + +This command creates a new database named \ident. +The database is implemented by a Discrimination Tree (DT) that serves as +an index of all the lemmas. The DT can use transparency information to decide +if a constant should be indexed or not (c.f. \ref{HintTransparency}), +making the retrieval more efficient. +The legacy implementation (the default one for new databases) uses the +DT only on goals without existentials (i.e., auto goals), for non-Immediate +hints and do not make use of transparency hints, putting more work on the +unification that is run after retrieval (it keeps a list of the lemmas +in case the DT is not used). The new implementation enabled by +the {\tt discriminated} option makes use of DTs in all cases and takes +transparency information into account. However, the order in which hints +are retrieved from the DT may differ from the order in which they were +inserted, making this implementation observationally different from the +legacy one. + +\begin{Variants} +\item\texttt{Local Hint} \textsl{hint\_definition} \texttt{:} + \ident$_1$ \ldots\ \ident$_n$ + + This is used to declare a hint database that must not be exported to the other + modules that require and import the current module. Inside a + section, the option {\tt Local} is useless since hints do not + survive anyway to the closure of sections. + +\end{Variants} + +The general +command to add a hint to some database \ident$_1$, \dots, \ident$_n$ is: +\begin{tabbing} + \texttt{Hint} \textsl{hint\_definition} \texttt{:} \ident$_1$ \ldots\ \ident$_n$ +\end{tabbing} +where {\sl hint\_definition} is one of the following expressions: + +\begin{itemize} +\item \texttt{Resolve} {\term} + \comindex{Hint Resolve} + + This command adds {\tt apply {\term}} to the hint list + with the head symbol of the type of \term. The cost of that hint is + the number of subgoals generated by {\tt apply {\term}}. + + In case the inferred type of \term\ does not start with a product the + tactic added in the hint list is {\tt exact {\term}}. In case this + type can be reduced to a type starting with a product, the tactic {\tt + apply {\term}} is also stored in the hints list. -\begin{Variants} -\item \texttt{injection} \num{} + If the inferred type of \term\ contains a dependent + quantification on a predicate, it is added to the hint list of {\tt + eapply} instead of the hint list of {\tt apply}. In this case, a + warning is printed since the hint is only used by the tactic {\tt + eauto} (see \ref{eauto}). A typical example of a hint that is used + only by \texttt{eauto} is a transitivity lemma. - This does the same thing as \texttt{intros until \num} followed by -\texttt{injection \ident} where {\ident} is the identifier for the last -introduced hypothesis. + \begin{ErrMsgs} + \item \errindex{Bound head variable} -\item \texttt{injection} \term{} {\tt with} {\bindinglist} + The head symbol of the type of {\term} is a bound variable such + that this tactic cannot be associated to a constant. - This does the same as \texttt{injection {\term}} but using - the given bindings to instantiate parameters or hypotheses of {\term}. + \item \term\ \errindex{cannot be used as a hint} -\item \texttt{einjection} \num\\ - \texttt{einjection} \term{} \zeroone{{\tt with} {\bindinglist}} + The type of \term\ contains products over variables which do not + appear in the conclusion. A typical example is a transitivity axiom. + In that case the {\tt apply} tactic fails, and thus is useless. - This works the same as {\tt injection} but if the type of {\term}, - or the type of the hypothesis referred to by {\num}, has uninstantiated - parameters, these parameters are left as existential variables. + \end{ErrMsgs} -\item{\tt injection} - - If the current goal is of the form {\term$_1$} {\tt <>} {\term$_2$}, - this behaves as {\tt intro {\ident}; injection {\ident}}. - - \ErrMsg \errindex{goal does not satisfy the expected preconditions} + \begin{Variants} -\item \texttt{injection} \term{} \zeroone{{\tt with} {\bindinglist}} \texttt{as} \nelist{\intropattern}{}\\ -\texttt{injection} \num{} \texttt{as} {\intropattern} {\ldots} {\intropattern}\\ -\texttt{injection} \texttt{as} {\intropattern} {\ldots} {\intropattern}\\ -\texttt{einjection} \term{} \zeroone{{\tt with} {\bindinglist}} \texttt{as} \nelist{\intropattern}{}\\ -\texttt{einjection} \num{} \texttt{as} {\intropattern} {\ldots} {\intropattern}\\ -\texttt{einjection} \texttt{as} {\intropattern} {\ldots} {\intropattern}\\ -\tacindex{injection \ldots{} as} - -These variants apply \texttt{intros} \nelist{\intropattern}{} after -the call to \texttt{injection} or \texttt{einjection}. + \item \texttt{Resolve} {\term$_1$} \dots {\term$_m$} -\end{Variants} + Adds each \texttt{Resolve} {\term$_i$}. -\subsection{\tt simplify\_eq {\term} -\tacindex{simplify\_eq} -\tacindex{esimplify\_eq} -\label{simplify-eq}} + \end{Variants} -Let {\term} be the proof of a statement of conclusion {\tt - {\term$_1$}={\term$_2$}}. If {\term$_1$} and -{\term$_2$} are structurally different (in the sense described for the -tactic {\tt discriminate}), then the tactic {\tt simplify\_eq} behaves as {\tt - discriminate {\term}}, otherwise it behaves as {\tt injection - {\term}}. +\item \texttt{Immediate {\term}} +\comindex{Hint Immediate} -\Rem If some quantified hypothesis of the goal is named {\ident}, then -{\tt simplify\_eq {\ident}} first introduces the hypothesis in the local -context using \texttt{intros until \ident}. + This command adds {\tt apply {\term}; trivial} to the hint list + associated with the head symbol of the type of {\ident} in the given + database. This tactic will fail if all the subgoals generated by + {\tt apply {\term}} are not solved immediately by the {\tt trivial} + tactic (which only tries tactics with cost $0$). -\begin{Variants} -\item \texttt{simplify\_eq} \num + This command is useful for theorems such as the symmetry of equality + or $n+1=m+1 \to n=m$ that we may like to introduce with a + limited use in order to avoid useless proof-search. - This does the same thing as \texttt{intros until \num} then -\texttt{simplify\_eq \ident} where {\ident} is the identifier for the last -introduced hypothesis. + The cost of this tactic (which never generates subgoals) is always 1, + so that it is not used by {\tt trivial} itself. -\item \texttt{simplify\_eq} \term{} {\tt with} {\bindinglist} + \begin{ErrMsgs} - This does the same as \texttt{simplify\_eq {\term}} but using - the given bindings to instantiate parameters or hypotheses of {\term}. + \item \errindex{Bound head variable} -\item \texttt{esimplify\_eq} \num\\ - \texttt{esimplify\_eq} \term{} \zeroone{{\tt with} {\bindinglist}} + \item \term\ \errindex{cannot be used as a hint} - This works the same as {\tt simplify\_eq} but if the type of {\term}, - or the type of the hypothesis referred to by {\num}, has uninstantiated - parameters, these parameters are left as existential variables. + \end{ErrMsgs} -\item{\tt simplify\_eq} + \begin{Variants} -If the current goal has form $t_1\verb=<>=t_2$, it behaves as -\texttt{intro {\ident}; simplify\_eq {\ident}}. -\end{Variants} + \item \texttt{Immediate} {\term$_1$} \dots {\term$_m$} -\subsection{\tt dependent rewrite -> {\ident} -\tacindex{dependent rewrite ->} -\label{dependent-rewrite}} + Adds each \texttt{Immediate} {\term$_i$}. -This tactic applies to any goal. If \ident\ has type -\verb+(existT B a b)=(existT B a' b')+ -in the local context (i.e. each term of the -equality has a sigma type $\{ a:A~ \&~(B~a)\}$) this tactic rewrites -\verb+a+ into \verb+a'+ and \verb+b+ into \verb+b'+ in the current -goal. This tactic works even if $B$ is also a sigma type. This kind -of equalities between dependent pairs may be derived by the injection -and inversion tactics. + \end{Variants} -\begin{Variants} -\item{\tt dependent rewrite <- {\ident}} -\tacindex{dependent rewrite <-} \\ -Analogous to {\tt dependent rewrite ->} but uses the equality from -right to left. -\end{Variants} +\item \texttt{Constructors} {\ident} +\comindex{Hint Constructors} -\section{Inversion -\label{inversion}} + If {\ident} is an inductive type, this command adds all its + constructors as hints of type \texttt{Resolve}. Then, when the + conclusion of current goal has the form \texttt{({\ident} \dots)}, + \texttt{auto} will try to apply each constructor. -\subsection{\tt inversion {\ident} -\tacindex{inversion}} + \begin{ErrMsgs} -Let the type of \ident~ in the local context be $(I~\vec{t})$, -where $I$ is a (co)inductive predicate. Then, -\texttt{inversion} applied to \ident~ derives for each possible -constructor $c_i$ of $(I~\vec{t})$, {\bf all} the necessary -conditions that should hold for the instance $(I~\vec{t})$ to be -proved by $c_i$. + \item {\ident} \errindex{is not an inductive type} -\Rem If {\ident} does not denote a hypothesis in the local context -but refers to a hypothesis quantified in the goal, then the -latter is first introduced in the local context using -\texttt{intros until \ident}. + \item {\ident} \errindex{not declared} -\begin{Variants} -\item \texttt{inversion} \num - - This does the same thing as \texttt{intros until \num} then - \texttt{inversion \ident} where {\ident} is the identifier for the - last introduced hypothesis. + \end{ErrMsgs} -\item \tacindex{inversion\_clear} \texttt{inversion\_clear} \ident + \begin{Variants} - This behaves as \texttt{inversion} and then erases \ident~ from the - context. + \item \texttt{Constructors} {\ident$_1$} \dots {\ident$_m$} -\item \tacindex{inversion \dots\ as} \texttt{inversion} {\ident} \texttt{as} {\intropattern} - - This behaves as \texttt{inversion} but using names in - {\intropattern} for naming hypotheses. The {\intropattern} must have - the form {\tt [} $p_{11}$ \ldots $p_{1n_1}$ {\tt |} {\ldots} {\tt |} - $p_{m1}$ \ldots $p_{mn_m}$ {\tt ]} with $m$ being the number of - constructors of the type of {\ident}. Be careful that the list must - be of length $m$ even if {\tt inversion} discards some cases (which - is precisely one of its roles): for the discarded cases, just use an - empty list (i.e. $n_i=0$). + Adds each \texttt{Constructors} {\ident$_i$}. - The arguments of the $i^{th}$ constructor and the - equalities that {\tt inversion} introduces in the context of the - goal corresponding to the $i^{th}$ constructor, if it exists, get - their names from the list $p_{i1}$ \ldots $p_{in_i}$ in order. If - there are not enough names, {\tt induction} invents names for the - remaining variables to introduce. In case an equation splits into - several equations (because {\tt inversion} applies {\tt injection} - on the equalities it generates), the corresponding name $p_{ij}$ in - the list must be replaced by a sublist of the form {\tt [$p_{ij1}$ - \ldots $p_{ijq}$]} (or, equivalently, {\tt ($p_{ij1}$, - \ldots, $p_{ijq}$)}) where $q$ is the number of subequalities - obtained from splitting the original equation. Here is an example. + \end{Variants} -\begin{coq_eval} -Require Import List. -\end{coq_eval} +\item \texttt{Unfold} {\qualid} +\comindex{Hint Unfold} -\begin{coq_example} -Inductive contains0 : list nat -> Prop := - | in_hd : forall l, contains0 (0 :: l) - | in_tl : forall l b, contains0 l -> contains0 (b :: l). -Goal forall l:list nat, contains0 (1 :: l) -> contains0 l. -intros l H; inversion H as [ | l' p Hl' [Heqp Heql'] ]. -\end{coq_example} + This adds the tactic {\tt unfold {\qualid}} to the hint list that + will only be used when the head constant of the goal is \ident. Its + cost is 4. -\begin{coq_eval} -Abort. -\end{coq_eval} + \begin{Variants} -\item \texttt{inversion} {\num} {\tt as} {\intropattern} + \item \texttt{Unfold} {\ident$_1$} \dots {\ident$_m$} - This allows to name the hypotheses introduced by - \texttt{inversion} {\num} in the context. + Adds each \texttt{Unfold} {\ident$_i$}. -\item \tacindex{inversion\_cleardots\ as} \texttt{inversion\_clear} - {\ident} {\tt as} {\intropattern} + \end{Variants} - This allows to name the hypotheses introduced by - \texttt{inversion\_clear} in the context. - -\item \tacindex{inversion \dots\ in} \texttt{inversion } {\ident} - \texttt{in} \ident$_1$ \dots\ \ident$_n$ +\item \texttt{Transparent}, \texttt{Opaque} {\qualid} +\label{HintTransparency} +\comindex{Hint Transparent} +\comindex{Hint Opaque} - Let \ident$_1$ \dots\ \ident$_n$, be identifiers in the local context. This - tactic behaves as generalizing \ident$_1$ \dots\ \ident$_n$, and - then performing \texttt{inversion}. - -\item \tacindex{inversion \dots\ as \dots\ in} \texttt{inversion } - {\ident} {\tt as} {\intropattern} \texttt{in} \ident$_1$ \dots\ - \ident$_n$ - - This allows to name the hypotheses introduced in the context by - \texttt{inversion} {\ident} \texttt{in} \ident$_1$ \dots\ - \ident$_n$. - -\item \tacindex{inversion\_clear \dots\ in} \texttt{inversion\_clear} - {\ident} \texttt{in} \ident$_1$ \ldots \ident$_n$ - - Let \ident$_1$ \dots\ \ident$_n$, be identifiers in the local context. This - tactic behaves as generalizing \ident$_1$ \dots\ \ident$_n$, and - then performing {\tt inversion\_clear}. - -\item \tacindex{inversion\_clear \dots\ as \dots\ in} - \texttt{inversion\_clear} {\ident} \texttt{as} {\intropattern} - \texttt{in} \ident$_1$ \ldots \ident$_n$ + This adds a transparency hint to the database, making {\tt {\qualid}} + a transparent or opaque constant during resolution. This information + is used during unification of the goal with any lemma in the database + and inside the discrimination network to relax or constrain it in the + case of \texttt{discriminated} databases. - This allows to name the hypotheses introduced in the context by - \texttt{inversion\_clear} {\ident} \texttt{in} \ident$_1$ \ldots - \ident$_n$. + \begin{Variants} -\item \tacindex{dependent inversion} \texttt{dependent inversion} - {\ident} - - That must be used when \ident\ appears in the current goal. It acts - like \texttt{inversion} and then substitutes \ident\ for the - corresponding term in the goal. - -\item \tacindex{dependent inversion \dots\ as } \texttt{dependent - inversion} {\ident} \texttt{as} {\intropattern} - - This allows to name the hypotheses introduced in the context by - \texttt{dependent inversion} {\ident}. + \item \texttt{Transparent}, \texttt{Opaque} {\ident$_1$} \dots {\ident$_m$} -\item \tacindex{dependent inversion\_clear} \texttt{dependent - inversion\_clear} {\ident} - - Like \texttt{dependent inversion}, except that {\ident} is cleared - from the local context. + Declares each {\ident$_i$} as a transparent or opaque constant. -\item \tacindex{dependent inversion\_clear \dots\ as} - \texttt{dependent inversion\_clear} {\ident}\texttt{as} {\intropattern} - - This allows to name the hypotheses introduced in the context by - \texttt{dependent inversion\_clear} {\ident}. + \end{Variants} -\item \tacindex{dependent inversion \dots\ with} \texttt{dependent - inversion } {\ident} \texttt{ with } \term - - This variant allows you to specify the generalization of the goal. It - is useful when the system fails to generalize the goal automatically. If - {\ident} has type $(I~\vec{t})$ and $I$ has type - $forall (\vec{x}:\vec{T}), s$, then \term~ must be of type - $I:forall (\vec{x}:\vec{T}), I~\vec{x}\to s'$ where $s'$ is the - type of the goal. +\item \texttt{Extern \num\ [\pattern]\ => }\textsl{tactic} +\comindex{Hint Extern} -\item \tacindex{dependent inversion \dots\ as \dots\ with} - \texttt{dependent inversion } {\ident} \texttt{as} {\intropattern} - \texttt{ with } \term - - This allows to name the hypotheses introduced in the context by - \texttt{dependent inversion } {\ident} \texttt{ with } \term. + This hint type is to extend \texttt{auto} with tactics other than + \texttt{apply} and \texttt{unfold}. For that, we must specify a + cost, an optional pattern and a tactic to execute. Here is an example: -\item \tacindex{dependent inversion\_clear \dots\ with} - \texttt{dependent inversion\_clear } {\ident} \texttt{ with } \term - - Like \texttt{dependent inversion \dots\ with} but clears {\ident} from - the local context. +\begin{quotation} +\begin{verbatim} +Hint Extern 4 (~(_ = _)) => discriminate. +\end{verbatim} +\end{quotation} -\item \tacindex{dependent inversion\_clear \dots\ as \dots\ with} - \texttt{dependent inversion\_clear } {\ident} \texttt{as} - {\intropattern} \texttt{ with } \term - - This allows to name the hypotheses introduced in the context by - \texttt{dependent inversion\_clear } {\ident} \texttt{ with } \term. + Now, when the head of the goal is a disequality, \texttt{auto} will + try \texttt{discriminate} if it does not manage to solve the goal + with hints with a cost less than 4. -\item \tacindex{simple inversion} \texttt{simple inversion} {\ident} - - It is a very primitive inversion tactic that derives all the necessary - equalities but it does not simplify the constraints as - \texttt{inversion} does. + One can even use some sub-patterns of the pattern in the tactic + script. A sub-pattern is a question mark followed by an ident, like + \texttt{?X1} or \texttt{?X2}. Here is an example: -\item \tacindex{simple inversion \dots\ as} \texttt{simple inversion} - {\ident} \texttt{as} {\intropattern} - - This allows to name the hypotheses introduced in the context by - \texttt{simple inversion}. +% Require EqDecide. +\begin{coq_example*} +Require Import List. +\end{coq_example*} +\begin{coq_example} +Hint Extern 5 ({?X1 = ?X2} + {?X1 <> ?X2}) => + generalize X1, X2; decide equality : eqdec. +Goal +forall a b:list (nat * nat), {a = b} + {a <> b}. +info auto with eqdec. +\end{coq_example} +\begin{coq_eval} +Abort. +\end{coq_eval} -\item \tacindex{inversion \dots\ using} \texttt{inversion} \ident - \texttt{ using} \ident$'$ - - Let {\ident} have type $(I~\vec{t})$ ($I$ an inductive - predicate) in the local context, and \ident$'$ be a (dependent) inversion - lemma. Then, this tactic refines the current goal with the specified - lemma. +\end{itemize} -\item \tacindex{inversion \dots\ using \dots\ in} \texttt{inversion} - {\ident} \texttt{using} \ident$'$ \texttt{in} \ident$_1$\dots\ \ident$_n$ - - This tactic behaves as generalizing \ident$_1$\dots\ \ident$_n$, - then doing \texttt{inversion} {\ident} \texttt{using} \ident$'$. +\Rem One can use an \texttt{Extern} hint with no pattern to do +pattern-matching on hypotheses using \texttt{match goal with} inside +the tactic. -\end{Variants} +\begin{Variants} +\item \texttt{Hint} \textsl{hint\_definition} -\SeeAlso~\ref{inversion-examples} for detailed examples + No database name is given: the hint is registered in the {\tt core} + database. -\subsection{\tt Derive Inversion {\ident} with - ${\tt forall (}\vec{x}{\tt :}\vec{T}{\tt),} I~\vec{t}$ Sort \sort -\label{Derive-Inversion} -\comindex{Derive Inversion}} +\item\texttt{Hint Local} \textsl{hint\_definition} \texttt{:} + \ident$_1$ \ldots\ \ident$_n$ -This command generates an inversion principle for the -\texttt{inversion \dots\ using} tactic. -Let $I$ be an inductive predicate and $\vec{x}$ the variables -occurring in $\vec{t}$. This command generates and stocks the -inversion lemma for the sort \sort~ corresponding to the instance -$forall (\vec{x}:\vec{T}), I~\vec{t}$ with the name {\ident} in the {\bf -global} environment. When applied it is equivalent to have inverted -the instance with the tactic {\tt inversion}. + This is used to declare hints that must not be exported to the other + modules that require and import the current module. Inside a + section, the option {\tt Local} is useless since hints do not + survive anyway to the closure of sections. -\begin{Variants} -\item \texttt{Derive Inversion\_clear} {\ident} \texttt{with} - \comindex{Derive Inversion\_clear} - $forall (\vec{x}:\vec{T}), I~\vec{t}$ \texttt{Sort} \sort~ \\ - \index{Derive Inversion\_clear \dots\ with} - When applied it is equivalent to having - inverted the instance with the tactic \texttt{inversion} - replaced by the tactic \texttt{inversion\_clear}. -\item \texttt{Derive Dependent Inversion} {\ident} \texttt{with} - $forall (\vec{x}:\vec{T}), I~\vec{t}$ \texttt{Sort} \sort~\\ - \comindex{Derive Dependent Inversion} - When applied it is equivalent to having - inverted the instance with the tactic \texttt{dependent inversion}. -\item \texttt{Derive Dependent Inversion\_clear} {\ident} \texttt{with} - $forall (\vec{x}:\vec{T}), I~\vec{t}$ \texttt{Sort} \sort~\\ - \comindex{Derive Dependent Inversion\_clear} - When applied it is equivalent to having - inverted the instance with the tactic \texttt{dependent inversion\_clear}. -\end{Variants} +\item\texttt{Hint Local} \textsl{hint\_definition} -\SeeAlso \ref{inversion-examples} for examples + Idem for the {\tt core} database. +\end{Variants} +% There are shortcuts that allow to define several goal at once: -\subsection[\tt functional inversion \ident]{\tt functional inversion \ident\label{sec:functional-inversion}} +% \begin{itemize} +% \item \comindex{Hints Resolve}\texttt{Hints Resolve \ident$_1$ \dots\ \ident$_n$ : \ident.}\\ +% This command is a shortcut for the following ones: +% \begin{quotation} +% \noindent\texttt{Hint \ident$_1$ : \ident\ := Resolve \ident$_1$}\\ +% \dots\\ +% \texttt{Hint \ident$_1$ : \ident := Resolve \ident$_1$} +% \end{quotation} +% Notice that the hint name is the same that the theorem given as +% hint. +% \item \comindex{Hints Immediate}\texttt{Hints Immediate \ident$_1$ \dots\ \ident$_n$ : \ident.}\\ +% \item \comindex{Hints Unfold}\texttt{Hints Unfold \qualid$_1$ \dots\ \qualid$_n$ : \ident.}\\ +% \end{itemize} -\texttt{functional inversion} is a \emph{highly} experimental tactic -which performs inversion on hypothesis \ident\ of the form -\texttt{\qualid\ \term$_1$\dots\term$_n$\ = \term} or \texttt{\term\ = - \qualid\ \term$_1$\dots\term$_n$} where \qualid\ must have been -defined using \texttt{Function} (see Section~\ref{Function}). +%\begin{Warnings} +% \item \texttt{Overriding hint named \dots\ in database \dots} +%\end{Warnings} -\begin{ErrMsgs} -\item \errindex{Hypothesis {\ident} must contain at least one Function} -\item \errindex{Cannot find inversion information for hypothesis \ident} - This error may be raised when some inversion lemma failed to be - generated by Function. -\end{ErrMsgs} -\begin{Variants} -\item {\tt functional inversion \num} - This does the same thing as \texttt{intros until \num} then - \texttt{functional inversion \ident} where {\ident} is the - identifier for the last introduced hypothesis. -\item {\tt functional inversion \ident\ \qualid}\\ - {\tt functional inversion \num\ \qualid} +\subsection{Hint databases defined in the \Coq\ standard library} - In case the hypothesis {\ident} (or {\num}) has a type of the form - \texttt{\qualid$_1$\ \term$_1$\dots\term$_n$\ =\ \qualid$_2$\ - \term$_{n+1}$\dots\term$_{n+m}$} where \qualid$_1$ and \qualid$_2$ - are valid candidates to functional inversion, this variant allows to - choose which must be inverted. -\end{Variants} +Several hint databases are defined in the \Coq\ standard library. The +actual content of a database is the collection of the hints declared +to belong to this database in each of the various modules currently +loaded. Especially, requiring new modules potentially extend a +database. At {\Coq} startup, only the {\tt core} and {\tt v62} +databases are non empty and can be used. +\begin{description} +\item[\tt core] This special database is automatically used by + \texttt{auto}, except when pseudo-database \texttt{nocore} is + given to \texttt{auto}. The \texttt{core} database contains + only basic lemmas about negation, + conjunction, and so on from. Most of the hints in this database come + from the \texttt{Init} and \texttt{Logic} directories. -\subsection{\tt quote \ident -\tacindex{quote} -\index{2-level approach}} +\item[\tt arith] This database contains all lemmas about Peano's + arithmetic proved in the directories \texttt{Init} and + \texttt{Arith} -This kind of inversion has nothing to do with the tactic -\texttt{inversion} above. This tactic does \texttt{change (\ident\ - t)}, where \texttt{t} is a term built in order to ensure the -convertibility. In other words, it does inversion of the function -\ident. This function must be a fixpoint on a simple recursive -datatype: see~\ref{quote-examples} for the full details. +\item[\tt zarith] contains lemmas about binary signed integers from + the directories \texttt{theories/ZArith}. When required, the module + {\tt Omega} also extends the database {\tt zarith} with a high-cost + hint that calls {\tt omega} on equations and inequalities in {\tt + nat} or {\tt Z}. -\begin{ErrMsgs} -\item \errindex{quote: not a simple fixpoint}\\ - Happens when \texttt{quote} is not able to perform inversion properly. -\end{ErrMsgs} +\item[\tt bool] contains lemmas about booleans, mostly from directory + \texttt{theories/Bool}. -\begin{Variants} -\item \texttt{quote {\ident} [ \ident$_1$ \dots \ident$_n$ ]}\\ - All terms that are built only with \ident$_1$ \dots \ident$_n$ will be - considered by \texttt{quote} as constants rather than variables. -\end{Variants} +\item[\tt datatypes] is for lemmas about lists, streams and so on that + are mainly proved in the \texttt{Lists} subdirectory. -% En attente d'un moyen de valoriser les fichiers de demos -% \SeeAlso file \texttt{theories/DEMOS/DemoQuote.v} in the distribution +\item[\tt sets] contains lemmas about sets and relations from the + directories \texttt{Sets} and \texttt{Relations}. -\section[Classical tactics]{Classical tactics\label{ClassicalTactics}} +\item[\tt typeclass\_instances] contains all the type class instances + declared in the environment, including those used for \texttt{setoid\_rewrite}, + from the \texttt{Classes} directory. +\end{description} -In order to ease the proving process, when the {\tt Classical} module is loaded. A few more tactics are available. Make sure to load the module using the \texttt{Require Import} command. +There is also a special database called {\tt v62}. It collects all +hints that were declared in the versions of {\Coq} prior to version +6.2.4 when the databases {\tt core}, {\tt arith}, and so on were +introduced. The purpose of the database {\tt v62} is to ensure +compatibility with further versions of {\Coq} for developments done in +versions prior to 6.2.4 ({\tt auto} being replaced by {\tt auto with v62}). +The database {\tt v62} is intended not to be extended (!). It is not +included in the hint databases list used in the {\tt auto with *} tactic. -\subsection{{\tt classical\_left, classical\_right} \tacindex{classical\_left} \tacindex{classical\_right}} +Furthermore, you are advised not to put your own hints in the +{\tt core} database, but use one or several databases specific to your +development. -The tactics \texttt{classical\_left} and \texttt{classical\_right} are the analog of the \texttt{left} and \texttt{right} but using classical logic. They can only be used for disjunctions. -Use \texttt{classical\_left} to prove the left part of the disjunction with the assumption that the negation of right part holds. -Use \texttt{classical\_right} to prove the right part of the disjunction with the assumption that the negation of left part holds. +\subsection{\tt Print Hint +\label{PrintHint} +\comindex{Print Hint}} -\section{Automatizing -\label{Automatizing}} +This command displays all hints that apply to the current goal. It +fails if no proof is being edited, while the two variants can be used at +every moment. -\subsection{\tt auto -\label{auto} -\tacindex{auto}} +\begin{Variants} -This tactic implements a Prolog-like resolution procedure to solve the -current goal. It first tries to solve the goal using the {\tt - assumption} tactic, then it reduces the goal to an atomic one using -{\tt intros} and introducing the newly generated hypotheses as hints. -Then it looks at the list of tactics associated to the head symbol of -the goal and tries to apply one of them (starting from the tactics -with lower cost). This process is recursively applied to the generated -subgoals. +\item {\tt Print Hint {\ident} } -By default, \texttt{auto} only uses the hypotheses of the current goal and the -hints of the database named {\tt core}. + This command displays only tactics associated with \ident\ in the + hints list. This is independent of the goal being edited, so this + command will not fail if no goal is being edited. -\begin{Variants} +\item {\tt Print Hint *} -\item {\tt auto \num} + This command displays all declared hints. - Forces the search depth to be \num. The maximal search depth is 5 by - default. +\item {\tt Print HintDb {\ident} } +\label{PrintHintDb} +\comindex{Print HintDb} -\item {\tt auto with \ident$_1$ \dots\ \ident$_n$} - - Uses the hint databases $\ident_1$ \dots\ $\ident_n$ in addition to - the database {\tt core}. See Section~\ref{Hints-databases} for the - list of pre-defined databases and the way to create or extend a - database. This option can be combined with the previous one. + This command displays all hints from database \ident. -\item {\tt auto with *} +\end{Variants} - Uses all existing hint databases, minus the special database - {\tt v62}. See Section~\ref{Hints-databases} +\subsection{\tt Hint Rewrite \term$_1$ \dots \term$_n$ : \ident +\label{HintRewrite} +\comindex{Hint Rewrite}} -\item \texttt{auto using \nterm{lemma}$_1$ , \ldots , \nterm{lemma}$_n$} +This vernacular command adds the terms {\tt \term$_1$ \dots \term$_n$} +(their types must be equalities) in the rewriting base {\tt \ident} +with the default orientation (left to right). Notice that the +rewriting bases are distinct from the {\tt auto} hint bases and that +{\tt auto} does not take them into account. - Uses \nterm{lemma}$_1$, \ldots, \nterm{lemma}$_n$ in addition to - hints (can be combined with the \texttt{with \ident} option). If - $lemma_i$ is an inductive type, it is the collection of its - constructors which is added as hints. +This command is synchronous with the section mechanism (see \ref{Section}): +when closing a section, all aliases created by \texttt{Hint Rewrite} in that +section are lost. Conversely, when loading a module, all \texttt{Hint Rewrite} +declarations at the global level of that module are loaded. -\item \texttt{auto using \nterm{lemma}$_1$ , \ldots , \nterm{lemma}$_n$ with \ident$_1$ \dots\ \ident$_n$} +\begin{Variants} +\item {\tt Hint Rewrite -> \term$_1$ \dots \term$_n$ : \ident}\\ +This is strictly equivalent to the command above (we only make explicit the +orientation which otherwise defaults to {\tt ->}). - This combines the effects of the {\tt using} and {\tt with} options. +\item {\tt Hint Rewrite <- \term$_1$ \dots \term$_n$ : \ident}\\ +Adds the rewriting rules {\tt \term$_1$ \dots \term$_n$} with a right-to-left +orientation in the base {\tt \ident}. -\item {\tt trivial}\tacindex{trivial} +\item {\tt Hint Rewrite \term$_1$ \dots \term$_n$ using {\tac} : {\ident}}\\ +When the rewriting rules {\tt \term$_1$ \dots \term$_n$} in {\tt \ident} will +be used, the tactic {\tt \tac} will be applied to the generated subgoals, the +main subgoal excluded. - This tactic is a restriction of {\tt auto} that is not recursive and - tries only hints which cost 0. Typically it solves trivial - equalities like $X=X$. +%% \item +%% {\tt Hint Rewrite [ \term$_1$ \dots \term$_n$ ] in \ident}\\ +%% {\tt Hint Rewrite [ \term$_1$ \dots \term$_n$ ] in {\ident} using {\tac}}\\ +%% These are deprecated syntactic variants for +%% {\tt Hint Rewrite \term$_1$ \dots \term$_n$ : \ident} and +%% {\tt Hint Rewrite \term$_1$ \dots \term$_n$ using {\tac} : {\ident}}. -\item \texttt{trivial with \ident$_1$ \dots\ \ident$_n$} +\item \texttt{Print Rewrite HintDb {\ident}} -\item \texttt{trivial with *} + This command displays all rewrite hints contained in {\ident}. \end{Variants} -\Rem {\tt auto} either solves completely the goal or else leaves it -intact. \texttt{auto} and \texttt{trivial} never fail. +\subsection{Hints and sections +\label{Hint-and-Section}} -\SeeAlso Section~\ref{Hints-databases} +Hints provided by the \texttt{Hint} commands are erased when closing a +section. Conversely, all hints of a module \texttt{A} that are not +defined inside a section (and not defined with option {\tt Local}) become +available when the module {\tt A} is imported (using +e.g. \texttt{Require Import A.}). -\subsection{\tt eauto -\tacindex{eauto} -\label{eauto}} +\subsection{Setting implicit automation tactics} -This tactic generalizes {\tt auto}. In contrast with -the latter, {\tt eauto} uses unification of the goal -against the hints rather than pattern-matching -(in other words, it uses {\tt eapply} instead of -{\tt apply}). -As a consequence, {\tt eauto} can solve such a goal: +\subsubsection[\tt Proof with {\tac}.]{\tt Proof with {\tac}.\label{ProofWith} +\comindex{Proof with}} -\begin{coq_example} -Hint Resolve ex_intro. -Goal forall P:nat -> Prop, P 0 -> exists n, P n. -eauto. -\end{coq_example} -\begin{coq_eval} -Abort. -\end{coq_eval} + This command may be used to start a proof. It defines a default + tactic to be used each time a tactic command {\tac$_1$} is ended by + ``\verb#...#''. In this case the tactic command typed by the user is + equivalent to \tac$_1$;{\tac}. -Note that {\tt ex\_intro} should be declared as an -hint. +\SeeAlso {\tt Proof.} in Section~\ref{BeginProof}. -\SeeAlso Section~\ref{Hints-databases} +\begin{Variants} +\item {\tt Proof with {\tac} using {\ident$_1$ \dots {\ident$_n$}}} + Combines in a single line {\tt Proof with} and {\tt Proof using}, + see~\ref{ProofUsing} +\item {\tt Proof using {\ident$_1$ \dots {\ident$_n$}} with {\tac}} + Combines in a single line {\tt Proof with} and {\tt Proof using}, + see~\ref{ProofUsing} -\subsection{\tt autounfold with \ident$_1$ \dots\ \ident$_n$ -\tacindex{autounfold} -\label{autounfold}} +\end{Variants} -This tactic unfolds constants that were declared through a {\tt Hint - Unfold} in the given databases. +\subsubsection[\tt Declare Implicit Tactic {\tac}.]{\tt Declare Implicit Tactic {\tac}.\comindex{Declare Implicit Tactic}} + +This command declares a tactic to be used to solve implicit arguments +that {\Coq} does not know how to solve by unification. It is used +every time the term argument of a tactic has one of its holes not +fully resolved. -\begin{Variants} -\item {\tt autounfold with \ident$_1$ \dots\ \ident$_n$ in \textit{clause}} - - Perform the unfolding in the given clause. +Here is an example: -\item {\tt autounfold with *} - - Uses the unfold hints declared in all the hint databases. -\end{Variants} +\begin{coq_example} +Parameter quo : nat -> forall n:nat, n<>0 -> nat. +Notation "x // y" := (quo x y _) (at level 40). +Declare Implicit Tactic assumption. +Goal forall n m, m<>0 -> { q:nat & { r | q * m + r = n } }. +intros. +exists (n // m). +\end{coq_example} -% EXISTE ENCORE ? -% -% \subsection{\tt Prolog [ \term$_1$ \dots\ \term$_n$ ] \num} -% \tacindex{Prolog}\label{Prolog} -% This tactic, implemented by Chet Murthy, is based upon the concept of -% existential variables of Gilles Dowek, stating that resolution is a -% kind of unification. It tries to solve the current goal using the {\tt -% Assumption} tactic, the {\tt intro} tactic, and applying hypotheses -% of the local context and terms of the given list {\tt [ \term$_1$ -% \dots\ \term$_n$\ ]}. It is more powerful than {\tt auto} since it -% may apply to any theorem, even those of the form {\tt (x:A)(P x) -> Q} -% where {\tt x} does not appear free in {\tt Q}. The maximal search -% depth is {\tt \num}. +The tactic {\tt exists (n // m)} did not fail. The hole was solved by +{\tt assumption} so that it behaved as {\tt exists (quo n m H)}. -% \begin{ErrMsgs} -% \item \errindex{Prolog failed}\\ -% The Prolog tactic was not able to prove the subgoal. -% \end{ErrMsgs} +\section{Decision procedures} \subsection{\tt tauto \tacindex{tauto} @@ -3402,7 +3837,7 @@ instantiation of \verb=x= is necessary. The tactic \texttt{intuition} takes advantage of the search-tree built by the decision procedure involved in the tactic {\tt tauto}. It uses this information to generate a set of subgoals equivalent to the -original one (but simpler than it) and applies the tactic +original one (but simpler than it) and applies the tactic {\tac} to them \cite{Mun94}. If this tactic fails on some goals then {\tt intuition} fails. In fact, {\tt tauto} is simply {\tt intuition fail}. @@ -3438,17 +3873,17 @@ incompatibilities. \tacindex{rtauto} \label{rtauto}} -The {\tt rtauto} tactic solves propositional tautologies similarly to what {\tt tauto} does. The main difference is that the proof term is built using a reflection scheme applied to a sequent calculus proof of the goal. The search procedure is also implemented using a different technique. +The {\tt rtauto} tactic solves propositional tautologies similarly to what {\tt tauto} does. The main difference is that the proof term is built using a reflection scheme applied to a sequent calculus proof of the goal. The search procedure is also implemented using a different technique. -Users should be aware that this difference may result in faster proof-search but slower proof-checking, and {\tt rtauto} might not solve goals that {\tt tauto} would be able to solve (e.g. goals involving universal quantifiers). +Users should be aware that this difference may result in faster proof-search but slower proof-checking, and {\tt rtauto} might not solve goals that {\tt tauto} would be able to solve (e.g. goals involving universal quantifiers). \subsection{{\tt firstorder} \tacindex{firstorder} \label{firstorder}} The tactic \texttt{firstorder} is an {\it experimental} extension of -\texttt{tauto} to -first-order reasoning, written by Pierre Corbineau. +\texttt{tauto} to +first-order reasoning, written by Pierre Corbineau. It is not restricted to usual logical connectives but instead may reason about any first-order class inductive definition. @@ -3478,910 +3913,587 @@ instead may reason about any first-order class inductive definition. \end{Variants} Proof-search is bounded by a depth parameter which can be set by typing the -{\nobreak \tt Set Firstorder Depth $n$} \comindex{Set Firstorder Depth} +{\nobreak \tt Set Firstorder Depth $n$} \comindex{Set Firstorder Depth} vernacular command. -%% \subsection{{\tt jp} {\em (Jprover)} -%% \tacindex{jp} -%% \label{jprover}} - -%% The tactic \texttt{jp}, due to Huang Guan-Shieng, is an experimental -%% port of the {\em Jprover}\cite{SLKN01} semi-decision procedure for -%% first-order intuitionistic logic implemented in {\em -%% NuPRL}\cite{Kre02}. - -%% The tactic \texttt{jp}, due to Huang Guan-Shieng, is an {\it -%% experimental} port of the {\em Jprover}\cite{SLKN01} semi-decision -%% procedure for first-order intuitionistic logic implemented in {\em -%% NuPRL}\cite{Kre02}. - -%% Search may optionnaly be bounded by a multiplicity parameter -%% indicating how many (at most) copies of a formula may be used in -%% the proof process, its absence may lead to non-termination of the tactic. - -%% %\begin{coq_eval} -%% %Variable S:Set. -%% %Variables P Q:S->Prop. -%% %Variable f:S->S. -%% %\end{coq_eval} - -%% %\begin{coq_example*} -%% %Lemma example: (exists x |P x\/Q x)->(exists x |P x)\/(exists x |Q x). -%% %jp. -%% %Qed. - -%% %Lemma example2: (forall x ,P x->P (f x))->forall x,P x->P (f(f x)). -%% %jp. -%% %Qed. -%% %\end{coq_example*} - -%% \begin{Variants} -%% \item {\tt jp $n$}\\ -%% \tacindex{jp $n$} -%% Tries the {\em Jprover} procedure with multiplicities up to $n$, -%% starting from 1. -%% \item {\tt jp}\\ -%% Tries the {\em Jprover} procedure without multiplicity bound, -%% possibly running forever. -%% \end{Variants} - -%% \begin{ErrMsgs} -%% \item \errindex{multiplicity limit reached}\\ -%% The procedure tried all multiplicities below the limit and -%% failed. Goal might be solved by increasing the multiplicity limit. -%% \item \errindex{formula is not provable}\\ -%% The procedure determined that goal was not provable in -%% intuitionistic first-order logic, no matter how big the -%% multiplicity is. -%% \end{ErrMsgs} - - -% \subsection[\tt Linear]{\tt Linear\tacindex{Linear}\label{Linear}} -% The tactic \texttt{Linear}, due to Jean-Christophe Filli{\^a}atre -% \cite{Fil94}, implements a decision procedure for {\em Direct -% Predicate Calculus}, that is first-order Gentzen's Sequent Calculus -% without contraction rules \cite{KeWe84,BeKe92}. Intuitively, a -% first-order goal is provable in Direct Predicate Calculus if it can be -% proved using each hypothesis at most once. - -% Unlike the previous tactics, the \texttt{Linear} tactic does not belong -% to the initial state of the system, and it must be loaded explicitly -% with the command - -% \begin{coq_example*} -% Require Linear. -% \end{coq_example*} - -% For instance, assuming that \texttt{even} and \texttt{odd} are two -% predicates on natural numbers, and \texttt{a} of type \texttt{nat}, the -% tactic \texttt{Linear} solves the following goal - -% \begin{coq_eval} -% Variables even,odd : nat -> Prop. -% Variable a:nat. -% \end{coq_eval} - -% \begin{coq_example*} -% Lemma example : (even a) -% -> ((x:nat)((even x)->(odd (S x)))) -% -> (EX y | (odd y)). -% \end{coq_example*} - -% You can find examples of the use of \texttt{Linear} in -% \texttt{theories/DEMOS/DemoLinear.v}. -% \begin{coq_eval} -% Abort. -% \end{coq_eval} - -% \begin{Variants} -% \item {\tt Linear with \ident$_1$ \dots\ \ident$_n$}\\ -% \tacindex{Linear with} -% Is equivalent to apply first {\tt generalize \ident$_1$ \dots -% \ident$_n$} (see Section~\ref{generalize}) then the \texttt{Linear} -% tactic. So one can use axioms, lemmas or hypotheses of the local -% context with \texttt{Linear} in this way. -% \end{Variants} - -% \begin{ErrMsgs} -% \item \errindex{Not provable in Direct Predicate Calculus} -% \item \errindex{Found $n$ classical proof(s) but no intuitionistic one}\\ -% The decision procedure looks actually for classical proofs of the -% goals, and then checks that they are intuitionistic. In that case, -% classical proofs have been found, which do not correspond to -% intuitionistic ones. -% \end{ErrMsgs} \subsection{\tt congruence -\tacindex{congruence} -\label{congruence}} - -The tactic {\tt congruence}, by Pierre Corbineau, implements the standard Nelson and Oppen -congruence closure algorithm, which is a decision procedure for ground -equalities with uninterpreted symbols. It also include the constructor theory -(see \ref{injection} and \ref{discriminate}). -If the goal is a non-quantified equality, {\tt congruence} tries to -prove it with non-quantified equalities in the context. Otherwise it -tries to infer a discriminable equality from those in the context. Alternatively, congruence tries to prove that a hypothesis is equal to the goal or to the negation of another hypothesis. - -{\tt congruence} is also able to take advantage of hypotheses stating quantified equalities, you have to provide a bound for the number of extra equalities generated that way. Please note that one of the members of the equality must contain all the quantified variables in order for {\tt congruence} to match against it. - -\begin{coq_eval} -Reset Initial. -Variable A:Set. -Variables a b:A. -Variable f:A->A. -Variable g:A->A->A. -\end{coq_eval} - -\begin{coq_example} -Theorem T: - a=(f a) -> (g b (f a))=(f (f a)) -> (g a b)=(f (g b a)) -> (g a b)=a. -intros. -congruence. -\end{coq_example} - -\begin{coq_eval} -Reset Initial. -Variable A:Set. -Variables a c d:A. -Variable f:A->A*A. -\end{coq_eval} - -\begin{coq_example} -Theorem inj : f = pair a -> Some (f c) = Some (f d) -> c=d. -intros. -congruence. -\end{coq_example} - -\begin{Variants} - \item {\tt congruence {\sl n}}\\ - Tries to add at most {\tt \sl n} instances of hypotheses stating quantified equalities to the problem in order to solve it. A bigger value of {\tt \sl n} does not make success slower, only failure. You might consider adding some lemmas as hypotheses using {\tt assert} in order for congruence to use them. - -\end{Variants} - -\begin{Variants} -\item {\tt congruence with \term$_1$ \dots\ \term$_n$}\\ - Adds {\tt \term$_1$ \dots\ \term$_n$} to the pool of terms used by - {\tt congruence}. This helps in case you have partially applied - constructors in your goal. -\end{Variants} - -\begin{ErrMsgs} - \item \errindex{I don't know how to handle dependent equality} \\ - The decision procedure managed to find a proof of the goal or of - a discriminable equality but this proof couldn't be built in {\Coq} - because of dependently-typed functions. - \item \errindex{I couldn't solve goal} \\ - The decision procedure didn't find any way to solve the goal. - \item \errindex{Goal is solvable by congruence but some arguments are missing. Try "congruence with \dots", replacing metavariables by arbitrary terms.} \\ - The decision procedure could solve the goal with the provision - that additional arguments are supplied for some partially applied - constructors. Any term of an appropriate type will allow the - tactic to successfully solve the goal. Those additional arguments - can be given to {\tt congruence} by filling in the holes in the - terms given in the error message, using the {\tt with} variant - described above. -\end{ErrMsgs} - -\subsection{\tt omega -\tacindex{omega} -\label{omega}} - -The tactic \texttt{omega}, due to Pierre Cr{\'e}gut, -is an automatic decision procedure for Presburger -arithmetic. It solves quantifier-free -formulas built with \verb|~|, \verb|\/|, \verb|/\|, -\verb|->| on top of equalities, inequalities and disequalities on -both the type \texttt{nat} of natural numbers and \texttt{Z} of binary -integers. This tactic must be loaded by the command \texttt{Require Import - Omega}. See the additional documentation about \texttt{omega} -(see Chapter~\ref{OmegaChapter}). - -\subsection{{\tt ring} and {\tt ring\_simplify \term$_1$ \dots\ \term$_n$} -\tacindex{ring} -\tacindex{ring\_simplify} -\comindex{Add Ring}} - -The {\tt ring} tactic solves equations upon polynomial expressions of -a ring (or semi-ring) structure. It proceeds by normalizing both hand -sides of the equation (w.r.t. associativity, commutativity and -distributivity, constant propagation) and comparing syntactically the -results. - -{\tt ring\_simplify} applies the normalization procedure described -above to the terms given. The tactic then replaces all occurrences of -the terms given in the conclusion of the goal by their normal -forms. If no term is given, then the conclusion should be an equation -and both hand sides are normalized. - -See Chapter~\ref{ring} for more information on the tactic and how to -declare new ring structures. - -\subsection{{\tt field}, {\tt field\_simplify \term$_1$\dots\ \term$_n$} - and {\tt field\_simplify\_eq} -\tacindex{field} -\tacindex{field\_simplify} -\tacindex{field\_simplify\_eq} -\comindex{Add Field}} - -The {\tt field} tactic is built on the same ideas as {\tt ring}: this -is a reflexive tactic that solves or simplifies equations in a field -structure. The main idea is to reduce a field expression (which is an -extension of ring expressions with the inverse and division -operations) to a fraction made of two polynomial expressions. - -Tactic {\tt field} is used to solve subgoals, whereas {\tt - field\_simplify \term$_1$\dots\term$_n$} replaces the provided terms -by their reduced fraction. {\tt field\_simplify\_eq} applies when the -conclusion is an equation: it simplifies both hand sides and multiplies -so as to cancel denominators. So it produces an equation without -division nor inverse. +\tacindex{congruence} +\label{congruence}} -All of these 3 tactics may generate a subgoal in order to prove that -denominators are different from zero. +The tactic {\tt congruence}, by Pierre Corbineau, implements the standard Nelson and Oppen +congruence closure algorithm, which is a decision procedure for ground +equalities with uninterpreted symbols. It also include the constructor theory +(see \ref{injection} and \ref{discriminate}). +If the goal is a non-quantified equality, {\tt congruence} tries to +prove it with non-quantified equalities in the context. Otherwise it +tries to infer a discriminable equality from those in the context. Alternatively, congruence tries to prove that a hypothesis is equal to the goal or to the negation of another hypothesis. -See Chapter~\ref{ring} for more information on the tactic and how to -declare new field structures. +{\tt congruence} is also able to take advantage of hypotheses stating quantified equalities, you have to provide a bound for the number of extra equalities generated that way. Please note that one of the members of the equality must contain all the quantified variables in order for {\tt congruence} to match against it. -\Example -\begin{coq_example*} -Require Import Reals. -Goal forall x y:R, - (x * y > 0)%R -> - (x * (1 / x + x / (x + y)))%R = - ((- 1 / y) * y * (- x * (x / (x + y)) - 1))%R. -\end{coq_example*} +\begin{coq_eval} +Reset Initial. +Variable A:Set. +Variables a b:A. +Variable f:A->A. +Variable g:A->A->A. +\end{coq_eval} \begin{coq_example} -intros; field. +Theorem T: + a=(f a) -> (g b (f a))=(f (f a)) -> (g a b)=(f (g b a)) -> (g a b)=a. +intros. +congruence. \end{coq_example} \begin{coq_eval} Reset Initial. +Variable A:Set. +Variables a c d:A. +Variable f:A->A*A. \end{coq_eval} -\SeeAlso file {\tt plugins/setoid\_ring/RealField.v} for an example of instantiation,\\ -\phantom{\SeeAlso}theory {\tt theories/Reals} for many examples of use of {\tt -field}. +\begin{coq_example} +Theorem inj : f = pair a -> Some (f c) = Some (f d) -> c=d. +intros. +congruence. +\end{coq_example} -\subsection{\tt fourier -\tacindex{fourier}} +\begin{Variants} + \item {\tt congruence {\sl n}}\\ + Tries to add at most {\tt \sl n} instances of hypotheses stating quantified equalities to the problem in order to solve it. A bigger value of {\tt \sl n} does not make success slower, only failure. You might consider adding some lemmas as hypotheses using {\tt assert} in order for congruence to use them. -This tactic written by Lo{\"\i}c Pottier solves linear inequalities on -real numbers using Fourier's method~\cite{Fourier}. This tactic must -be loaded by {\tt Require Import Fourier}. +\end{Variants} -\Example -\begin{coq_example*} -Require Import Reals. -Require Import Fourier. -Goal forall x y:R, (x < y)%R -> (y + 1 >= x - 1)%R. -\end{coq_example*} +\begin{Variants} +\item {\tt congruence with \term$_1$ \dots\ \term$_n$}\\ + Adds {\tt \term$_1$ \dots\ \term$_n$} to the pool of terms used by + {\tt congruence}. This helps in case you have partially applied + constructors in your goal. +\end{Variants} -\begin{coq_example} -intros; fourier. -\end{coq_example} +\begin{ErrMsgs} + \item \errindex{I don't know how to handle dependent equality} \\ + The decision procedure managed to find a proof of the goal or of + a discriminable equality but this proof couldn't be built in {\Coq} + because of dependently-typed functions. + \item \errindex{I couldn't solve goal} \\ + The decision procedure didn't find any way to solve the goal. + \item \errindex{Goal is solvable by congruence but some arguments are missing. Try "congruence with \dots", replacing metavariables by arbitrary terms.} \\ + The decision procedure could solve the goal with the provision + that additional arguments are supplied for some partially applied + constructors. Any term of an appropriate type will allow the + tactic to successfully solve the goal. Those additional arguments + can be given to {\tt congruence} by filling in the holes in the + terms given in the error message, using the {\tt with} variant + described above. +\end{ErrMsgs} -\begin{coq_eval} -Reset Initial. -\end{coq_eval} -\subsection{\tt autorewrite with \ident$_1$ \dots \ident$_n$. -\label{tactic:autorewrite} -\tacindex{autorewrite}} +\section{Things that do not fit other sections} -This tactic \footnote{The behavior of this tactic has much changed compared to -the versions available in the previous distributions (V6). This may cause -significant changes in your theories to obtain the same result. As a drawback -of the re-engineering of the code, this tactic has also been completely revised -to get a very compact and readable version.} carries out rewritings according -the rewriting rule bases {\tt \ident$_1$ \dots \ident$_n$}. -Each rewriting rule of a base \ident$_i$ is applied to the main subgoal until -it fails. Once all the rules have been processed, if the main subgoal has -progressed (e.g., if it is distinct from the initial main goal) then the rules -of this base are processed again. If the main subgoal has not progressed then -the next base is processed. For the bases, the behavior is exactly similar to -the processing of the rewriting rules. -The rewriting rule bases are built with the {\tt Hint~Rewrite} vernacular -command. -\Warning{} This tactic may loop if you build non terminating rewriting systems. -\begin{Variant} -\item {\tt autorewrite with \ident$_1$ \dots \ident$_n$ using \tac}\\ -Performs, in the same way, all the rewritings of the bases {\tt \ident$_1$ $...$ -\ident$_n$} applying {\tt \tac} to the main subgoal after each rewriting step. -\item \texttt{autorewrite with {\ident$_1$} \dots \ident$_n$ in {\qualid}} - Performs all the rewritings in hypothesis {\qualid}. -\item \texttt{autorewrite with {\ident$_1$} \dots \ident$_n$ in {\qualid} using \tac} - Performs all the rewritings in hypothesis {\qualid} applying {\tt - \tac} to the main subgoal after each rewriting step. -\item \texttt{autorewrite with {\ident$_1$} \dots \ident$_n$ in \textit{clause}} - Performs all the rewritings in the clause \textit{clause}. \\ - The \textit{clause} argument must not contain any \texttt{type of} nor \texttt{value of}. -\end{Variant} -\SeeAlso Section~\ref{HintRewrite} for feeding the database of lemmas used by {\tt autorewrite}. -\SeeAlso Section~\ref{autorewrite-example} for examples showing the use of -this tactic. -% En attente d'un moyen de valoriser les fichiers de demos -%\SeeAlso file \texttt{contrib/Rocq/DEMOS/Demo\_AutoRewrite.v} -\section{Controlling automation} -\subsection{The hints databases for {\tt auto} and {\tt eauto} -\index{Hints databases} -\label{Hints-databases} -\comindex{Hint}} -The hints for \texttt{auto} and \texttt{eauto} are stored in -databases. Each database maps head symbols to a list of hints. One can -use the command \texttt{Print Hint \ident} to display the hints -associated to the head symbol \ident{} (see \ref{PrintHint}). Each -hint has a cost that is an nonnegative integer, and an optional pattern. -The hints with lower cost are tried first. A hint is tried by -\texttt{auto} when the conclusion of the current goal -matches its pattern or when it has no pattern. -\subsubsection*{Creating Hint databases - \label{CreateHintDb}\comindex{CreateHintDb}} -One can optionally declare a hint database using the command -\texttt{Create HintDb}. If a hint is added to an unknown database, it -will be automatically created. -\medskip -\texttt{Create HintDb} {\ident} [\texttt{discriminated}] -\medskip -This command creates a new database named \ident. -The database is implemented by a Discrimination Tree (DT) that serves as -an index of all the lemmas. The DT can use transparency information to decide -if a constant should be indexed or not (c.f. \ref{HintTransparency}), -making the retrieval more efficient. -The legacy implementation (the default one for new databases) uses the -DT only on goals without existentials (i.e., auto goals), for non-Immediate -hints and do not make use of transparency hints, putting more work on the -unification that is run after retrieval (it keeps a list of the lemmas -in case the DT is not used). The new implementation enabled by -the {\tt discriminated} option makes use of DTs in all cases and takes -transparency information into account. However, the order in which hints -are retrieved from the DT may differ from the order in which they were -inserted, making this implementation observationaly different from the -legacy one. -\begin{Variants} -\item\texttt{Local Hint} \textsl{hint\_definition} \texttt{:} - \ident$_1$ \ldots\ \ident$_n$ - - This is used to declare a hint database that must not be exported to the other - modules that require and import the current module. Inside a - section, the option {\tt Local} is useless since hints do not - survive anyway to the closure of sections. -\end{Variants} -The general -command to add a hint to some database \ident$_1$, \dots, \ident$_n$ is: -\begin{tabbing} - \texttt{Hint} \textsl{hint\_definition} \texttt{:} \ident$_1$ \ldots\ \ident$_n$ -\end{tabbing} -where {\sl hint\_definition} is one of the following expressions: -\begin{itemize} -\item \texttt{Resolve} {\term} - \comindex{Hint Resolve} - - This command adds {\tt apply {\term}} to the hint list - with the head symbol of the type of \term. The cost of that hint is - the number of subgoals generated by {\tt apply {\term}}. - - In case the inferred type of \term\ does not start with a product the - tactic added in the hint list is {\tt exact {\term}}. In case this - type can be reduced to a type starting with a product, the tactic {\tt - apply {\term}} is also stored in the hints list. - - If the inferred type of \term\ contains a dependent - quantification on a predicate, it is added to the hint list of {\tt - eapply} instead of the hint list of {\tt apply}. In this case, a - warning is printed since the hint is only used by the tactic {\tt - eauto} (see \ref{eauto}). A typical example of a hint that is used - only by \texttt{eauto} is a transitivity lemma. - \begin{ErrMsgs} - \item \errindex{Bound head variable} - The head symbol of the type of {\term} is a bound variable such - that this tactic cannot be associated to a constant. - \item \term\ \errindex{cannot be used as a hint} - The type of \term\ contains products over variables which do not - appear in the conclusion. A typical example is a transitivity axiom. - In that case the {\tt apply} tactic fails, and thus is useless. - \end{ErrMsgs} - \begin{Variants} - \item \texttt{Resolve} {\term$_1$} \dots {\term$_m$} - Adds each \texttt{Resolve} {\term$_i$}. - \end{Variants} -\item \texttt{Immediate {\term}} -\comindex{Hint Immediate} - - This command adds {\tt apply {\term}; trivial} to the hint list - associated with the head symbol of the type of {\ident} in the given - database. This tactic will fail if all the subgoals generated by - {\tt apply {\term}} are not solved immediately by the {\tt trivial} - tactic (which only tries tactics with cost $0$). - - This command is useful for theorems such as the symmetry of equality - or $n+1=m+1 \to n=m$ that we may like to introduce with a - limited use in order to avoid useless proof-search. - - The cost of this tactic (which never generates subgoals) is always 1, - so that it is not used by {\tt trivial} itself. - \begin{ErrMsgs} - \item \errindex{Bound head variable} - \item \term\ \errindex{cannot be used as a hint} +\section{Everything after this point has yet to be sorted} - \end{ErrMsgs} - \begin{Variants} +\subsection{\tt constr\_eq \term$_1$ \term$_2$ +\tacindex{constr\_eq} +\label{constreq}} - \item \texttt{Immediate} {\term$_1$} \dots {\term$_m$} +This tactic applies to any goal. It checks whether its arguments are +equal modulo alpha conversion and casts. - Adds each \texttt{Immediate} {\term$_i$}. +\ErrMsg \errindex{Not equal} - \end{Variants} +\subsection{\tt unify \term$_1$ \term$_2$ +\tacindex{unify} +\label{unify}} -\item \texttt{Constructors} {\ident} -\comindex{Hint Constructors} - - If {\ident} is an inductive type, this command adds all its - constructors as hints of type \texttt{Resolve}. Then, when the - conclusion of current goal has the form \texttt{({\ident} \dots)}, - \texttt{auto} will try to apply each constructor. +This tactic applies to any goal. It checks whether its arguments are +unifiable, potentially instantiating existential variables. - \begin{ErrMsgs} +\ErrMsg \errindex{Not unifiable} - \item {\ident} \errindex{is not an inductive type} +\begin{Variants} +\item {\tt unify \term$_1$ \term$_2$ with \ident} - \item {\ident} \errindex{not declared} + Unification takes the transparency information defined in the + hint database {\tt \ident} into account (see Section~\ref{HintTransparency}). +\end{Variants} - \end{ErrMsgs} +\subsection{\tt is\_evar \term +\tacindex{is\_evar} +\label{isevar}} - \begin{Variants} +This tactic applies to any goal. It checks whether its argument is an +existential variable. Existential variables are uninstantiated +variables generated by e.g. {\tt eapply} (see Section~\ref{apply}). - \item \texttt{Constructors} {\ident$_1$} \dots {\ident$_m$} +\ErrMsg \errindex{Not an evar} - Adds each \texttt{Constructors} {\ident$_i$}. +\subsection{\tt has\_evar \term +\tacindex{has\_evar} +\label{hasevar}} - \end{Variants} +This tactic applies to any goal. It checks whether its argument has an +existential variable as a subterm. Unlike {\tt context} patterns +combined with {\tt is\_evar}, this tactic scans all subterms, +including those under binders. -\item \texttt{Unfold} {\qualid} -\comindex{Hint Unfold} - - This adds the tactic {\tt unfold {\qualid}} to the hint list that - will only be used when the head constant of the goal is \ident. Its - cost is 4. +\ErrMsg \errindex{No evars} + +\subsection{\tt is\_var \term +\tacindex{is\_var} +\label{isvar}} - \begin{Variants} +This tactic applies to any goal. It checks whether its argument is a +variable or hypothesis in the current goal context or in the opened sections. - \item \texttt{Unfold} {\ident$_1$} \dots {\ident$_m$} +\ErrMsg \errindex{Not a variable or hypothesis} - Adds each \texttt{Unfold} {\ident$_i$}. +\section{Equality} - \end{Variants} +\subsection{\tt f\_equal +\label{f-equal} +\tacindex{f\_equal}} -\item \texttt{Transparent}, \texttt{Opaque} {\qualid} -\label{HintTransparency} -\comindex{Hint Transparent} -\comindex{Hint Opaque} - - This adds a transparency hint to the database, making {\tt {\qualid}} - a transparent or opaque constant during resolution. This information - is used during unification of the goal with any lemma in the database - and inside the discrimination network to relax or constrain it in the - case of \texttt{discriminated} databases. - - \begin{Variants} +This tactic applies to a goal of the form $f\ a_1\ \ldots\ a_n = f'\ +a'_1\ \ldots\ a'_n$. Using {\tt f\_equal} on such a goal leads to +subgoals $f=f'$ and $a_1=a'_1$ and so on up to $a_n=a'_n$. Amongst +these subgoals, the simple ones (e.g. provable by +reflexivity or congruence) are automatically solved by {\tt f\_equal}. - \item \texttt{Transparent}, \texttt{Opaque} {\ident$_1$} \dots {\ident$_m$} - Declares each {\ident$_i$} as a transparent or opaque constant. - - \end{Variants} +\section{Equality and inductive sets} -\item \texttt{Extern \num\ [\pattern]\ => }\textsl{tactic} -\comindex{Hint Extern} +We describe in this section some special purpose tactics dealing with +equality and inductive sets or types. These tactics use the equality +{\tt eq:forall (A:Type), A->A->Prop}, simply written with the +infix symbol {\tt =}. - This hint type is to extend \texttt{auto} with tactics other than - \texttt{apply} and \texttt{unfold}. For that, we must specify a - cost, an optional pattern and a tactic to execute. Here is an example: +\subsection{\tt decide equality +\label{decideequality} +\tacindex{decide equality}} -\begin{quotation} -\begin{verbatim} -Hint Extern 4 (~(_ = _)) => discriminate. -\end{verbatim} -\end{quotation} +This tactic solves a goal of the form +{\tt forall $x$ $y$:$R$, \{$x$=$y$\}+\{\verb|~|$x$=$y$\}}, where $R$ +is an inductive type such that its constructors do not take proofs or +functions as arguments, nor objects in dependent types. +It solves goals of the form {\tt \{$x$=$y$\}+\{\verb|~|$x$=$y$\}} as well. - Now, when the head of the goal is a disequality, \texttt{auto} will - try \texttt{discriminate} if it does not manage to solve the goal - with hints with a cost less than 4. - - One can even use some sub-patterns of the pattern in the tactic - script. A sub-pattern is a question mark followed by an ident, like - \texttt{?X1} or \texttt{?X2}. Here is an example: +\subsection{\tt compare \term$_1$ \term$_2$ +\tacindex{compare}} -% Require EqDecide. -\begin{coq_example*} -Require Import List. -\end{coq_example*} -\begin{coq_example} -Hint Extern 5 ({?X1 = ?X2} + {?X1 <> ?X2}) => - generalize X1, X2; decide equality : eqdec. -Goal -forall a b:list (nat * nat), {a = b} + {a <> b}. -info auto with eqdec. -\end{coq_example} -\begin{coq_eval} -Abort. -\end{coq_eval} +This tactic compares two given objects \term$_1$ and \term$_2$ +of an inductive datatype. If $G$ is the current goal, it leaves the sub-goals +\term$_1${\tt =}\term$_2$ {\tt ->} $G$ and \verb|~|\term$_1${\tt =}\term$_2$ +{\tt ->} $G$. The type +of \term$_1$ and \term$_2$ must satisfy the same restrictions as in the tactic +\texttt{decide equality}. -\end{itemize} +\subsection{\tt simplify\_eq {\term} +\tacindex{simplify\_eq} +\tacindex{esimplify\_eq} +\label{simplify-eq}} -\Rem One can use an \texttt{Extern} hint with no pattern to do -pattern-matching on hypotheses using \texttt{match goal with} inside -the tactic. +Let {\term} be the proof of a statement of conclusion {\tt + {\term$_1$}={\term$_2$}}. If {\term$_1$} and +{\term$_2$} are structurally different (in the sense described for the +tactic {\tt discriminate}), then the tactic {\tt simplify\_eq} behaves as {\tt + discriminate {\term}}, otherwise it behaves as {\tt injection + {\term}}. + +\Rem If some quantified hypothesis of the goal is named {\ident}, then +{\tt simplify\_eq {\ident}} first introduces the hypothesis in the local +context using \texttt{intros until \ident}. \begin{Variants} -\item \texttt{Hint} \textsl{hint\_definition} - - No database name is given: the hint is registered in the {\tt core} - database. +\item \texttt{simplify\_eq} \num -\item\texttt{Hint Local} \textsl{hint\_definition} \texttt{:} - \ident$_1$ \ldots\ \ident$_n$ + This does the same thing as \texttt{intros until \num} then +\texttt{simplify\_eq \ident} where {\ident} is the identifier for the last +introduced hypothesis. - This is used to declare hints that must not be exported to the other - modules that require and import the current module. Inside a - section, the option {\tt Local} is useless since hints do not - survive anyway to the closure of sections. +\item \texttt{simplify\_eq} \term{} {\tt with} {\bindinglist} + + This does the same as \texttt{simplify\_eq {\term}} but using + the given bindings to instantiate parameters or hypotheses of {\term}. -\item\texttt{Hint Local} \textsl{hint\_definition} +\item \texttt{esimplify\_eq} \num\\ + \texttt{esimplify\_eq} \term{} \zeroone{{\tt with} {\bindinglist}} - Idem for the {\tt core} database. - + This works the same as {\tt simplify\_eq} but if the type of {\term}, + or the type of the hypothesis referred to by {\num}, has uninstantiated + parameters, these parameters are left as existential variables. + +\item{\tt simplify\_eq} + +If the current goal has form $t_1\verb=<>=t_2$, it behaves as +\texttt{intro {\ident}; simplify\_eq {\ident}}. \end{Variants} -% There are shortcuts that allow to define several goal at once: +\subsection{\tt dependent rewrite -> {\ident} +\tacindex{dependent rewrite ->} +\label{dependent-rewrite}} -% \begin{itemize} -% \item \comindex{Hints Resolve}\texttt{Hints Resolve \ident$_1$ \dots\ \ident$_n$ : \ident.}\\ -% This command is a shortcut for the following ones: -% \begin{quotation} -% \noindent\texttt{Hint \ident$_1$ : \ident\ := Resolve \ident$_1$}\\ -% \dots\\ -% \texttt{Hint \ident$_1$ : \ident := Resolve \ident$_1$} -% \end{quotation} -% Notice that the hint name is the same that the theorem given as -% hint. -% \item \comindex{Hints Immediate}\texttt{Hints Immediate \ident$_1$ \dots\ \ident$_n$ : \ident.}\\ -% \item \comindex{Hints Unfold}\texttt{Hints Unfold \qualid$_1$ \dots\ \qualid$_n$ : \ident.}\\ -% \end{itemize} +This tactic applies to any goal. If \ident\ has type +\verb+(existT B a b)=(existT B a' b')+ +in the local context (i.e. each term of the +equality has a sigma type $\{ a:A~ \&~(B~a)\}$) this tactic rewrites +\verb+a+ into \verb+a'+ and \verb+b+ into \verb+b'+ in the current +goal. This tactic works even if $B$ is also a sigma type. This kind +of equalities between dependent pairs may be derived by the injection +and inversion tactics. -%\begin{Warnings} -% \item \texttt{Overriding hint named \dots\ in database \dots} -%\end{Warnings} +\begin{Variants} +\item{\tt dependent rewrite <- {\ident}} +\tacindex{dependent rewrite <-} \\ +Analogous to {\tt dependent rewrite ->} but uses the equality from +right to left. +\end{Variants} +\section{Inversion +\label{inversion}} +\subsection[\tt functional inversion \ident]{\tt functional inversion \ident\label{sec:functional-inversion}} -\subsection{Hint databases defined in the \Coq\ standard library} +\texttt{functional inversion} is a \emph{highly} experimental tactic +which performs inversion on hypothesis \ident\ of the form +\texttt{\qualid\ \term$_1$\dots\term$_n$\ = \term} or \texttt{\term\ = + \qualid\ \term$_1$\dots\term$_n$} where \qualid\ must have been +defined using \texttt{Function} (see Section~\ref{Function}). -Several hint databases are defined in the \Coq\ standard library. The -actual content of a database is the collection of the hints declared -to belong to this database in each of the various modules currently -loaded. Especially, requiring new modules potentially extend a -database. At {\Coq} startup, only the {\tt core} and {\tt v62} -databases are non empty and can be used. +\begin{ErrMsgs} +\item \errindex{Hypothesis {\ident} must contain at least one Function} +\item \errindex{Cannot find inversion information for hypothesis \ident} + This error may be raised when some inversion lemma failed to be + generated by Function. +\end{ErrMsgs} -\begin{description} +\begin{Variants} +\item {\tt functional inversion \num} -\item[\tt core] This special database is automatically used by - \texttt{auto}, except when pseudo-database \texttt{nocore} is - given to \texttt{auto}. The \texttt{core} database contains - only basic lemmas about negation, - conjunction, and so on from. Most of the hints in this database come - from the \texttt{Init} and \texttt{Logic} directories. + This does the same thing as \texttt{intros until \num} then + \texttt{functional inversion \ident} where {\ident} is the + identifier for the last introduced hypothesis. +\item {\tt functional inversion \ident\ \qualid}\\ + {\tt functional inversion \num\ \qualid} -\item[\tt arith] This database contains all lemmas about Peano's - arithmetic proved in the directories \texttt{Init} and - \texttt{Arith} + In case the hypothesis {\ident} (or {\num}) has a type of the form + \texttt{\qualid$_1$\ \term$_1$\dots\term$_n$\ =\ \qualid$_2$\ + \term$_{n+1}$\dots\term$_{n+m}$} where \qualid$_1$ and \qualid$_2$ + are valid candidates to functional inversion, this variant allows to + choose which must be inverted. +\end{Variants} -\item[\tt zarith] contains lemmas about binary signed integers from - the directories \texttt{theories/ZArith}. When required, the module - {\tt Omega} also extends the database {\tt zarith} with a high-cost - hint that calls {\tt omega} on equations and inequalities in {\tt - nat} or {\tt Z}. -\item[\tt bool] contains lemmas about booleans, mostly from directory - \texttt{theories/Bool}. -\item[\tt datatypes] is for lemmas about lists, streams and so on that - are mainly proved in the \texttt{Lists} subdirectory. +\subsection{\tt quote \ident +\tacindex{quote} +\index{2-level approach}} -\item[\tt sets] contains lemmas about sets and relations from the - directories \texttt{Sets} and \texttt{Relations}. +This kind of inversion has nothing to do with the tactic +\texttt{inversion} above. This tactic does \texttt{change (\ident\ + t)}, where \texttt{t} is a term built in order to ensure the +convertibility. In other words, it does inversion of the function +\ident. This function must be a fixpoint on a simple recursive +datatype: see~\ref{quote-examples} for the full details. -\item[\tt typeclass\_instances] contains all the type class instances - declared in the environment, including those used for \texttt{setoid\_rewrite}, - from the \texttt{Classes} directory. -\end{description} +\begin{ErrMsgs} +\item \errindex{quote: not a simple fixpoint}\\ + Happens when \texttt{quote} is not able to perform inversion properly. +\end{ErrMsgs} -There is also a special database called {\tt v62}. It collects all -hints that were declared in the versions of {\Coq} prior to version -6.2.4 when the databases {\tt core}, {\tt arith}, and so on were -introduced. The purpose of the database {\tt v62} is to ensure -compatibility with further versions of {\Coq} for developments done in -versions prior to 6.2.4 ({\tt auto} being replaced by {\tt auto with v62}). -The database {\tt v62} is intended not to be extended (!). It is not -included in the hint databases list used in the {\tt auto with *} tactic. +\begin{Variants} +\item \texttt{quote {\ident} [ \ident$_1$ \dots \ident$_n$ ]}\\ + All terms that are built only with \ident$_1$ \dots \ident$_n$ will be + considered by \texttt{quote} as constants rather than variables. +\end{Variants} -Furthermore, you are advised not to put your own hints in the -{\tt core} database, but use one or several databases specific to your -development. +% En attente d'un moyen de valoriser les fichiers de demos +% \SeeAlso file \texttt{theories/DEMOS/DemoQuote.v} in the distribution -\subsection{\tt Print Hint -\label{PrintHint} -\comindex{Print Hint}} +\section[Classical tactics]{Classical tactics\label{ClassicalTactics}} -This command displays all hints that apply to the current goal. It -fails if no proof is being edited, while the two variants can be used at -every moment. +In order to ease the proving process, when the {\tt Classical} module is loaded. A few more tactics are available. Make sure to load the module using the \texttt{Require Import} command. -\begin{Variants} +\subsection{{\tt classical\_left, classical\_right} \tacindex{classical\_left} \tacindex{classical\_right}} -\item {\tt Print Hint {\ident} } +The tactics \texttt{classical\_left} and \texttt{classical\_right} are the analog of the \texttt{left} and \texttt{right} but using classical logic. They can only be used for disjunctions. +Use \texttt{classical\_left} to prove the left part of the disjunction with the assumption that the negation of right part holds. +Use \texttt{classical\_right} to prove the right part of the disjunction with the assumption that the negation of left part holds. - This command displays only tactics associated with \ident\ in the - hints list. This is independent of the goal being edited, so this - command will not fail if no goal is being edited. +\section{Automatizing +\label{Automatizing}} -\item {\tt Print Hint *} +% EXISTE ENCORE ? +% +% \subsection{\tt Prolog [ \term$_1$ \dots\ \term$_n$ ] \num} +% \tacindex{Prolog}\label{Prolog} +% This tactic, implemented by Chet Murthy, is based upon the concept of +% existential variables of Gilles Dowek, stating that resolution is a +% kind of unification. It tries to solve the current goal using the {\tt +% Assumption} tactic, the {\tt intro} tactic, and applying hypotheses +% of the local context and terms of the given list {\tt [ \term$_1$ +% \dots\ \term$_n$\ ]}. It is more powerful than {\tt auto} since it +% may apply to any theorem, even those of the form {\tt (x:A)(P x) -> Q} +% where {\tt x} does not appear free in {\tt Q}. The maximal search +% depth is {\tt \num}. - This command displays all declared hints. +% \begin{ErrMsgs} +% \item \errindex{Prolog failed}\\ +% The Prolog tactic was not able to prove the subgoal. +% \end{ErrMsgs} -\item {\tt Print HintDb {\ident} } -\label{PrintHintDb} -\comindex{Print HintDb} - This command displays all hints from database \ident. +%% \subsection{{\tt jp} {\em (Jprover)} +%% \tacindex{jp} +%% \label{jprover}} -\end{Variants} +%% The tactic \texttt{jp}, due to Huang Guan-Shieng, is an experimental +%% port of the {\em Jprover}\cite{SLKN01} semi-decision procedure for +%% first-order intuitionistic logic implemented in {\em +%% NuPRL}\cite{Kre02}. -\subsection{\tt Hint Rewrite \term$_1$ \dots \term$_n$ : \ident -\label{HintRewrite} -\comindex{Hint Rewrite}} +%% The tactic \texttt{jp}, due to Huang Guan-Shieng, is an {\it +%% experimental} port of the {\em Jprover}\cite{SLKN01} semi-decision +%% procedure for first-order intuitionistic logic implemented in {\em +%% NuPRL}\cite{Kre02}. -This vernacular command adds the terms {\tt \term$_1$ \dots \term$_n$} -(their types must be equalities) in the rewriting base {\tt \ident} -with the default orientation (left to right). Notice that the -rewriting bases are distinct from the {\tt auto} hint bases and that -{\tt auto} does not take them into account. +%% Search may optionnaly be bounded by a multiplicity parameter +%% indicating how many (at most) copies of a formula may be used in +%% the proof process, its absence may lead to non-termination of the tactic. -This command is synchronous with the section mechanism (see \ref{Section}): -when closing a section, all aliases created by \texttt{Hint Rewrite} in that -section are lost. Conversely, when loading a module, all \texttt{Hint Rewrite} -declarations at the global level of that module are loaded. +%% %\begin{coq_eval} +%% %Variable S:Set. +%% %Variables P Q:S->Prop. +%% %Variable f:S->S. +%% %\end{coq_eval} -\begin{Variants} -\item {\tt Hint Rewrite -> \term$_1$ \dots \term$_n$ : \ident}\\ -This is strictly equivalent to the command above (we only make explicit the -orientation which otherwise defaults to {\tt ->}). +%% %\begin{coq_example*} +%% %Lemma example: (exists x |P x\/Q x)->(exists x |P x)\/(exists x |Q x). +%% %jp. +%% %Qed. -\item {\tt Hint Rewrite <- \term$_1$ \dots \term$_n$ : \ident}\\ -Adds the rewriting rules {\tt \term$_1$ \dots \term$_n$} with a right-to-left -orientation in the base {\tt \ident}. +%% %Lemma example2: (forall x ,P x->P (f x))->forall x,P x->P (f(f x)). +%% %jp. +%% %Qed. +%% %\end{coq_example*} -\item {\tt Hint Rewrite \term$_1$ \dots \term$_n$ using {\tac} : {\ident}}\\ -When the rewriting rules {\tt \term$_1$ \dots \term$_n$} in {\tt \ident} will -be used, the tactic {\tt \tac} will be applied to the generated subgoals, the -main subgoal excluded. +%% \begin{Variants} +%% \item {\tt jp $n$}\\ +%% \tacindex{jp $n$} +%% Tries the {\em Jprover} procedure with multiplicities up to $n$, +%% starting from 1. +%% \item {\tt jp}\\ +%% Tries the {\em Jprover} procedure without multiplicity bound, +%% possibly running forever. +%% \end{Variants} -%% \item -%% {\tt Hint Rewrite [ \term$_1$ \dots \term$_n$ ] in \ident}\\ -%% {\tt Hint Rewrite [ \term$_1$ \dots \term$_n$ ] in {\ident} using {\tac}}\\ -%% These are deprecated syntactic variants for -%% {\tt Hint Rewrite \term$_1$ \dots \term$_n$ : \ident} and -%% {\tt Hint Rewrite \term$_1$ \dots \term$_n$ using {\tac} : {\ident}}. +%% \begin{ErrMsgs} +%% \item \errindex{multiplicity limit reached}\\ +%% The procedure tried all multiplicities below the limit and +%% failed. Goal might be solved by increasing the multiplicity limit. +%% \item \errindex{formula is not provable}\\ +%% The procedure determined that goal was not provable in +%% intuitionistic first-order logic, no matter how big the +%% multiplicity is. +%% \end{ErrMsgs} -\item \texttt{Print Rewrite HintDb {\ident}} - This command displays all rewrite hints contained in {\ident}. +% \subsection[\tt Linear]{\tt Linear\tacindex{Linear}\label{Linear}} +% The tactic \texttt{Linear}, due to Jean-Christophe Filli{\^a}atre +% \cite{Fil94}, implements a decision procedure for {\em Direct +% Predicate Calculus}, that is first-order Gentzen's Sequent Calculus +% without contraction rules \cite{KeWe84,BeKe92}. Intuitively, a +% first-order goal is provable in Direct Predicate Calculus if it can be +% proved using each hypothesis at most once. -\end{Variants} +% Unlike the previous tactics, the \texttt{Linear} tactic does not belong +% to the initial state of the system, and it must be loaded explicitly +% with the command -\subsection{Hints and sections -\label{Hint-and-Section}} +% \begin{coq_example*} +% Require Linear. +% \end{coq_example*} -Hints provided by the \texttt{Hint} commands are erased when closing a -section. Conversely, all hints of a module \texttt{A} that are not -defined inside a section (and not defined with option {\tt Local}) become -available when the module {\tt A} is imported (using -e.g. \texttt{Require Import A.}). +% For instance, assuming that \texttt{even} and \texttt{odd} are two +% predicates on natural numbers, and \texttt{a} of type \texttt{nat}, the +% tactic \texttt{Linear} solves the following goal -\subsection{Setting implicit automation tactics} +% \begin{coq_eval} +% Variables even,odd : nat -> Prop. +% Variable a:nat. +% \end{coq_eval} -\subsubsection[\tt Proof with {\tac}.]{\tt Proof with {\tac}.\label{ProofWith} -\comindex{Proof with}} +% \begin{coq_example*} +% Lemma example : (even a) +% -> ((x:nat)((even x)->(odd (S x)))) +% -> (EX y | (odd y)). +% \end{coq_example*} - This command may be used to start a proof. It defines a default - tactic to be used each time a tactic command {\tac$_1$} is ended by - ``\verb#...#''. In this case the tactic command typed by the user is - equivalent to \tac$_1$;{\tac}. +% You can find examples of the use of \texttt{Linear} in +% \texttt{theories/DEMOS/DemoLinear.v}. +% \begin{coq_eval} +% Abort. +% \end{coq_eval} -\SeeAlso {\tt Proof.} in Section~\ref{BeginProof}. +% \begin{Variants} +% \item {\tt Linear with \ident$_1$ \dots\ \ident$_n$}\\ +% \tacindex{Linear with} +% Is equivalent to apply first {\tt generalize \ident$_1$ \dots +% \ident$_n$} (see Section~\ref{generalize}) then the \texttt{Linear} +% tactic. So one can use axioms, lemmas or hypotheses of the local +% context with \texttt{Linear} in this way. +% \end{Variants} -\begin{Variants} -\item {\tt Proof with {\tac} using {\ident$_1$ \dots {\ident$_n$}}} - Combines in a single line {\tt Proof with} and {\tt Proof using}, - see~\ref{ProofUsing} -\item {\tt Proof using {\ident$_1$ \dots {\ident$_n$}} with {\tac}} - Combines in a single line {\tt Proof with} and {\tt Proof using}, - see~\ref{ProofUsing} +% \begin{ErrMsgs} +% \item \errindex{Not provable in Direct Predicate Calculus} +% \item \errindex{Found $n$ classical proof(s) but no intuitionistic one}\\ +% The decision procedure looks actually for classical proofs of the +% goals, and then checks that they are intuitionistic. In that case, +% classical proofs have been found, which do not correspond to +% intuitionistic ones. +% \end{ErrMsgs} -\end{Variants} -\subsubsection[\tt Declare Implicit Tactic {\tac}.]{\tt Declare Implicit Tactic {\tac}.\comindex{Declare Implicit Tactic}} +\subsection{\tt omega +\tacindex{omega} +\label{omega}} -This command declares a tactic to be used to solve implicit arguments -that {\Coq} does not know how to solve by unification. It is used -every time the term argument of a tactic has one of its holes not -fully resolved. +The tactic \texttt{omega}, due to Pierre Cr{\'e}gut, +is an automatic decision procedure for Presburger +arithmetic. It solves quantifier-free +formulas built with \verb|~|, \verb|\/|, \verb|/\|, +\verb|->| on top of equalities, inequalities and disequalities on +both the type \texttt{nat} of natural numbers and \texttt{Z} of binary +integers. This tactic must be loaded by the command \texttt{Require Import + Omega}. See the additional documentation about \texttt{omega} +(see Chapter~\ref{OmegaChapter}). -Here is an example: +\subsection{{\tt ring} and {\tt ring\_simplify \term$_1$ \dots\ \term$_n$} +\tacindex{ring} +\tacindex{ring\_simplify} +\comindex{Add Ring}} -\begin{coq_example} -Parameter quo : nat -> forall n:nat, n<>0 -> nat. -Notation "x // y" := (quo x y _) (at level 40). +The {\tt ring} tactic solves equations upon polynomial expressions of +a ring (or semi-ring) structure. It proceeds by normalizing both hand +sides of the equation (w.r.t. associativity, commutativity and +distributivity, constant propagation) and comparing syntactically the +results. -Declare Implicit Tactic assumption. -Goal forall n m, m<>0 -> { q:nat & { r | q * m + r = n } }. -intros. -exists (n // m). -\end{coq_example} +{\tt ring\_simplify} applies the normalization procedure described +above to the terms given. The tactic then replaces all occurrences of +the terms given in the conclusion of the goal by their normal +forms. If no term is given, then the conclusion should be an equation +and both hand sides are normalized. -The tactic {\tt exists (n // m)} did not fail. The hole was solved by -{\tt assumption} so that it behaved as {\tt exists (quo n m H)}. +See Chapter~\ref{ring} for more information on the tactic and how to +declare new ring structures. -\section{Generation of induction principles with {\tt Scheme} -\label{Scheme} -\index{Schemes} -\comindex{Scheme}} +\subsection{{\tt field}, {\tt field\_simplify \term$_1$\dots\ \term$_n$} + and {\tt field\_simplify\_eq} +\tacindex{field} +\tacindex{field\_simplify} +\tacindex{field\_simplify\_eq} +\comindex{Add Field}} -The {\tt Scheme} command is a high-level tool for generating -automatically (possibly mutual) induction principles for given types -and sorts. Its syntax follows the schema: -\begin{quote} -{\tt Scheme {\ident$_1$} := Induction for \ident'$_1$ Sort {\sort$_1$} \\ - with\\ - \mbox{}\hspace{0.1cm} \dots\\ - with {\ident$_m$} := Induction for {\ident'$_m$} Sort - {\sort$_m$}} -\end{quote} -where \ident'$_1$ \dots\ \ident'$_m$ are different inductive type -identifiers belonging to the same package of mutual inductive -definitions. This command generates {\ident$_1$}\dots{} {\ident$_m$} -to be mutually recursive definitions. Each term {\ident$_i$} proves a -general principle of mutual induction for objects in type {\term$_i$}. +The {\tt field} tactic is built on the same ideas as {\tt ring}: this +is a reflexive tactic that solves or simplifies equations in a field +structure. The main idea is to reduce a field expression (which is an +extension of ring expressions with the inverse and division +operations) to a fraction made of two polynomial expressions. -\begin{Variants} -\item {\tt Scheme {\ident$_1$} := Minimality for \ident'$_1$ Sort {\sort$_1$} \\ - with\\ - \mbox{}\hspace{0.1cm} \dots\ \\ - with {\ident$_m$} := Minimality for {\ident'$_m$} Sort - {\sort$_m$}} +Tactic {\tt field} is used to solve subgoals, whereas {\tt + field\_simplify \term$_1$\dots\term$_n$} replaces the provided terms +by their reduced fraction. {\tt field\_simplify\_eq} applies when the +conclusion is an equation: it simplifies both hand sides and multiplies +so as to cancel denominators. So it produces an equation without +division nor inverse. - Same as before but defines a non-dependent elimination principle more - natural in case of inductively defined relations. +All of these 3 tactics may generate a subgoal in order to prove that +denominators are different from zero. -\item {\tt Scheme Equality for \ident$_1$\comindex{Scheme Equality}} +See Chapter~\ref{ring} for more information on the tactic and how to +declare new field structures. - Tries to generate a boolean equality and a proof of the - decidability of the usual equality. If \ident$_i$ involves - some other inductive types, their equality has to be defined first. +\Example +\begin{coq_example*} +Require Import Reals. +Goal forall x y:R, + (x * y > 0)%R -> + (x * (1 / x + x / (x + y)))%R = + ((- 1 / y) * y * (- x * (x / (x + y)) - 1))%R. +\end{coq_example*} -\item {\tt Scheme Induction for \ident$_1$ Sort {\sort$_1$} \\ - with\\ - \mbox{}\hspace{0.1cm} \dots\\ - with Induction for {\ident$_m$} Sort - {\sort$_m$}} +\begin{coq_example} +intros; field. +\end{coq_example} - If you do not provide the name of the schemes, they will be automatically - computed from the sorts involved (works also with Minimality). +\begin{coq_eval} +Reset Initial. +\end{coq_eval} -\end{Variants} +\SeeAlso file {\tt plugins/setoid\_ring/RealField.v} for an example of instantiation,\\ +\phantom{\SeeAlso}theory {\tt theories/Reals} for many examples of use of {\tt +field}. -\SeeAlso Section~\ref{Scheme-examples} - -\subsection{Automatic declaration of schemes} -\comindex{Set Equality Schemes} -\comindex{Set Elimination Schemes} -It is possible to deactivate the automatic declaration of the induction - principles when defining a new inductive type with the - {\tt Unset Elimination Schemes} command. It may be -reactivated at any time with {\tt Set Elimination Schemes}. -\\ - -You can also activate the automatic declaration of those boolean equalities -(see the second variant of {\tt Scheme}) with the {\tt Set Equality Schemes} - command. However you have to be careful with this option since -\Coq~ may now reject well-defined inductive types because it cannot compute -a boolean equality for them. - -\subsection{\tt Combined Scheme\label{CombinedScheme} -\comindex{Combined Scheme}} -The {\tt Combined Scheme} command is a tool for combining -induction principles generated by the {\tt Scheme} command. -Its syntax follows the schema : - -\noindent -{\tt Combined Scheme {\ident$_0$} from {\ident$_1$}, .., {\ident$_n$}}\\ -\ident$_1$ \ldots \ident$_n$ are different inductive principles that must belong to -the same package of mutual inductive principle definitions. This command -generates {\ident$_0$} to be the conjunction of the principles: it is -built from the common premises of the principles and concluded by the -conjunction of their conclusions. - -\SeeAlso Section~\ref{CombinedScheme-examples} - -\section{Generation of induction principles with {\tt Functional Scheme} -\label{FunScheme} -\comindex{Functional Scheme}} - -The {\tt Functional Scheme} command is a high-level experimental -tool for generating automatically induction principles -corresponding to (possibly mutually recursive) functions. Its -syntax follows the schema: -\begin{quote} -{\tt Functional Scheme {\ident$_1$} := Induction for \ident'$_1$ Sort {\sort$_1$} \\ - with\\ - \mbox{}\hspace{0.1cm} \dots\ \\ - with {\ident$_m$} := Induction for {\ident'$_m$} Sort - {\sort$_m$}} -\end{quote} -where \ident'$_1$ \dots\ \ident'$_m$ are different mutually defined function -names (they must be in the same order as when they were defined). -This command generates the induction principles -\ident$_1$\dots\ident$_m$, following the recursive structure and case -analyses of the functions \ident'$_1$ \dots\ \ident'$_m$. +\subsection{\tt fourier +\tacindex{fourier}} +This tactic written by Lo{\"\i}c Pottier solves linear inequalities on +real numbers using Fourier's method~\cite{Fourier}. This tactic must +be loaded by {\tt Require Import Fourier}. -\paragraph{\texttt{Functional Scheme}} -There is a difference between obtaining an induction scheme by using -\texttt{Functional Scheme} on a function defined by \texttt{Function} -or not. Indeed \texttt{Function} generally produces smaller -principles, closer to the definition written by the user. +\Example +\begin{coq_example*} +Require Import Reals. +Require Import Fourier. +Goal forall x y:R, (x < y)%R -> (y + 1 >= x - 1)%R. +\end{coq_example*} +\begin{coq_example} +intros; fourier. +\end{coq_example} -\SeeAlso Section~\ref{FunScheme-examples} +\begin{coq_eval} +Reset Initial. +\end{coq_eval} \section{Simple tactic macros @@ -4389,7 +4501,7 @@ principles, closer to the definition written by the user. \comindex{Tactic Definition} \label{TacticDefinition}} -A simple example has more value than a long explanation: +A simple example has more value than a long explanation: \begin{coq_example} Ltac Solve := simpl; intros; auto. @@ -4399,7 +4511,7 @@ Ltac ElimBoolRewrite b H1 H2 := The tactics macros are synchronous with the \Coq\ section mechanism: a tactic definition is deleted from the current environment -when you close the section (see also \ref{Section}) +when you close the section (see also \ref{Section}) where it was defined. If you want that a tactic macro defined in a module is usable in the modules that require it, you should put it outside of any section. @@ -4408,8 +4520,8 @@ Chapter~\ref{TacticLanguage} gives examples of more complex user-defined tactics. -%%% Local Variables: +%%% Local Variables: %%% mode: latex %%% TeX-master: "Reference-Manual" %%% TeX-master: "Reference-Manual" -%%% End: +%%% End: diff --git a/doc/refman/RefMan-tacex.tex b/doc/refman/RefMan-tacex.tex index 8330a434..83a8cd11 100644 --- a/doc/refman/RefMan-tacex.tex +++ b/doc/refman/RefMan-tacex.tex @@ -3,590 +3,6 @@ This chapter presents detailed examples of certain tactics, to illustrate their behavior. -\section[\tt refine]{\tt refine\tacindex{refine} -\label{refine-example}} - -This tactic applies to any goal. It behaves like {\tt exact} with a -big difference : the user can leave some holes (denoted by \texttt{\_} or -{\tt (\_:}{\it type}{\tt )}) in the term. -{\tt refine} will generate as many -subgoals as they are holes in the term. The type of holes must be -either synthesized by the system or declared by an -explicit cast like \verb|(\_:nat->Prop)|. This low-level -tactic can be useful to advanced users. - -%\firstexample -\Example - -\begin{coq_example*} -Inductive Option : Set := - | Fail : Option - | Ok : bool -> Option. -\end{coq_example} -\begin{coq_example} -Definition get : forall x:Option, x <> Fail -> bool. -refine - (fun x:Option => - match x return x <> Fail -> bool with - | Fail => _ - | Ok b => fun _ => b - end). -intros; absurd (Fail = Fail); trivial. -\end{coq_example} -\begin{coq_example*} -Defined. -\end{coq_example*} - -% \example{Using Refine to build a poor-man's ``Cases'' tactic} - -% \texttt{Refine} is actually the only way for the user to do -% a proof with the same structure as a {\tt Cases} definition. Actually, -% the tactics \texttt{case} (see \ref{case}) and \texttt{Elim} (see -% \ref{elim}) only allow one step of elementary induction. - -% \begin{coq_example*} -% Require Bool. -% Require Arith. -% \end{coq_example*} -% %\begin{coq_eval} -% %Abort. -% %\end{coq_eval} -% \begin{coq_example} -% Definition one_two_or_five := [x:nat] -% Cases x of -% (1) => true -% | (2) => true -% | (5) => true -% | _ => false -% end. -% Goal (x:nat)(Is_true (one_two_or_five x)) -> x=(1)\/x=(2)\/x=(5). -% \end{coq_example} - -% A traditional script would be the following: - -% \begin{coq_example*} -% Destruct x. -% Tauto. -% Destruct n. -% Auto. -% Destruct n0. -% Auto. -% Destruct n1. -% Tauto. -% Destruct n2. -% Tauto. -% Destruct n3. -% Auto. -% Intros; Inversion H. -% \end{coq_example*} - -% With the tactic \texttt{Refine}, it becomes quite shorter: - -% \begin{coq_example*} -% Restart. -% \end{coq_example*} -% \begin{coq_example} -% Refine [x:nat] -% <[y:nat](Is_true (one_two_or_five y))->(y=(1)\/y=(2)\/y=(5))> -% Cases x of -% (1) => [H]? -% | (2) => [H]? -% | (5) => [H]? -% | n => [H](False_ind ? H) -% end; Auto. -% \end{coq_example} -% \begin{coq_eval} -% Abort. -% \end{coq_eval} - -\section[\tt eapply]{\tt eapply\tacindex{eapply} -\label{eapply-example}} -\Example -Assume we have a relation on {\tt nat} which is transitive: - -\begin{coq_example*} -Variable R : nat -> nat -> Prop. -Hypothesis Rtrans : forall x y z:nat, R x y -> R y z -> R x z. -Variables n m p : nat. -Hypothesis Rnm : R n m. -Hypothesis Rmp : R m p. -\end{coq_example*} - -Consider the goal {\tt (R n p)} provable using the transitivity of -{\tt R}: - -\begin{coq_example*} -Goal R n p. -\end{coq_example*} - -The direct application of {\tt Rtrans} with {\tt apply} fails because -no value for {\tt y} in {\tt Rtrans} is found by {\tt apply}: - -\begin{coq_eval} -Set Printing Depth 50. -(********** The following is not correct and should produce **********) -(**** Error: generated subgoal (R n ?17) has metavariables in it *****) -\end{coq_eval} -\begin{coq_example} -apply Rtrans. -\end{coq_example} - -A solution is to rather apply {\tt (Rtrans n m p)}. - -\begin{coq_example} -apply (Rtrans n m p). -\end{coq_example} - -\begin{coq_eval} -Undo. -\end{coq_eval} - -More elegantly, {\tt apply Rtrans with (y:=m)} allows to only mention -the unknown {\tt m}: - -\begin{coq_example} - - apply Rtrans with (y := m). -\end{coq_example} - -\begin{coq_eval} -Undo. -\end{coq_eval} - -Another solution is to mention the proof of {\tt (R x y)} in {\tt -Rtrans}... - -\begin{coq_example} - - apply Rtrans with (1 := Rnm). -\end{coq_example} - -\begin{coq_eval} -Undo. -\end{coq_eval} - -... or the proof of {\tt (R y z)}: - -\begin{coq_example} - - apply Rtrans with (2 := Rmp). -\end{coq_example} - -\begin{coq_eval} -Undo. -\end{coq_eval} - -On the opposite, one can use {\tt eapply} which postpone the problem -of finding {\tt m}. Then one can apply the hypotheses {\tt Rnm} and {\tt -Rmp}. This instantiates the existential variable and completes the proof. - -\begin{coq_example} -eapply Rtrans. -apply Rnm. -apply Rmp. -\end{coq_example} - -\begin{coq_eval} -Reset R. -\end{coq_eval} - -\section[{\tt Scheme}]{{\tt Scheme}\comindex{Scheme} -\label{Scheme-examples}} - -\firstexample -\example{Induction scheme for \texttt{tree} and \texttt{forest}} - -The definition of principle of mutual induction for {\tt tree} and -{\tt forest} over the sort {\tt Set} is defined by the command: - -\begin{coq_eval} -Reset Initial. -Variables A B : - Set. -\end{coq_eval} - -\begin{coq_example*} -Inductive tree : Set := - node : A -> forest -> tree -with forest : Set := - | leaf : B -> forest - | cons : tree -> forest -> forest. - -Scheme tree_forest_rec := Induction for tree Sort Set - with forest_tree_rec := Induction for forest Sort Set. -\end{coq_example*} - -You may now look at the type of {\tt tree\_forest\_rec}: - -\begin{coq_example} -Check tree_forest_rec. -\end{coq_example} - -This principle involves two different predicates for {\tt trees} and -{\tt forests}; it also has three premises each one corresponding to a -constructor of one of the inductive definitions. - -The principle {\tt forest\_tree\_rec} shares exactly the same -premises, only the conclusion now refers to the property of forests. - -\begin{coq_example} -Check forest_tree_rec. -\end{coq_example} - -\example{Predicates {\tt odd} and {\tt even} on naturals} - -Let {\tt odd} and {\tt even} be inductively defined as: - -% Reset Initial. -\begin{coq_eval} -Open Scope nat_scope. -\end{coq_eval} - -\begin{coq_example*} -Inductive odd : nat -> Prop := - oddS : forall n:nat, even n -> odd (S n) -with even : nat -> Prop := - | evenO : even 0 - | evenS : forall n:nat, odd n -> even (S n). -\end{coq_example*} - -The following command generates a powerful elimination -principle: - -\begin{coq_example} -Scheme odd_even := Minimality for odd Sort Prop - with even_odd := Minimality for even Sort Prop. -\end{coq_example} - -The type of {\tt odd\_even} for instance will be: - -\begin{coq_example} -Check odd_even. -\end{coq_example} - -The type of {\tt even\_odd} shares the same premises but the -conclusion is {\tt (n:nat)(even n)->(Q n)}. - -\subsection[{\tt Combined Scheme}]{{\tt Combined Scheme}\comindex{Combined Scheme} -\label{CombinedScheme-examples}} - -We can define the induction principles for trees and forests using: -\begin{coq_example} -Scheme tree_forest_ind := Induction for tree Sort Prop - with forest_tree_ind := Induction for forest Sort Prop. -\end{coq_example} - -Then we can build the combined induction principle which gives the -conjunction of the conclusions of each individual principle: -\begin{coq_example} -Combined Scheme tree_forest_mutind from tree_forest_ind, forest_tree_ind. -\end{coq_example} - -The type of {\tt tree\_forest\_mutrec} will be: -\begin{coq_example} -Check tree_forest_mutind. -\end{coq_example} - -\section[{\tt Functional Scheme} and {\tt functional induction}]{{\tt Functional Scheme} and {\tt functional induction}\comindex{Functional Scheme}\tacindex{functional induction} -\label{FunScheme-examples}} - -\firstexample -\example{Induction scheme for \texttt{div2}} - -We define the function \texttt{div2} as follows: - -\begin{coq_eval} -Reset Initial. -\end{coq_eval} - -\begin{coq_example*} -Require Import Arith. -Fixpoint div2 (n:nat) : nat := - match n with - | O => 0 - | S O => 0 - | S (S n') => S (div2 n') - end. -\end{coq_example*} - -The definition of a principle of induction corresponding to the -recursive structure of \texttt{div2} is defined by the command: - -\begin{coq_example} -Functional Scheme div2_ind := Induction for div2 Sort Prop. -\end{coq_example} - -You may now look at the type of {\tt div2\_ind}: - -\begin{coq_example} -Check div2_ind. -\end{coq_example} - -We can now prove the following lemma using this principle: - - -\begin{coq_example*} -Lemma div2_le' : forall n:nat, div2 n <= n. -intro n. - pattern n , (div2 n). -\end{coq_example*} - - -\begin{coq_example} -apply div2_ind; intros. -\end{coq_example} - -\begin{coq_example*} -auto with arith. -auto with arith. -simpl; auto with arith. -Qed. -\end{coq_example*} - -We can use directly the \texttt{functional induction} -(\ref{FunInduction}) tactic instead of the pattern/apply trick: - -\begin{coq_example*} -Reset div2_le'. -Lemma div2_le : forall n:nat, div2 n <= n. -intro n. -\end{coq_example*} - -\begin{coq_example} -functional induction (div2 n). -\end{coq_example} - -\begin{coq_example*} -auto with arith. -auto with arith. -auto with arith. -Qed. -\end{coq_example*} - -\Rem There is a difference between obtaining an induction scheme for a -function by using \texttt{Function} (see Section~\ref{Function}) and by -using \texttt{Functional Scheme} after a normal definition using -\texttt{Fixpoint} or \texttt{Definition}. See \ref{Function} for -details. - - -\example{Induction scheme for \texttt{tree\_size}} - -\begin{coq_eval} -Reset Initial. -\end{coq_eval} - -We define trees by the following mutual inductive type: - -\begin{coq_example*} -Variable A : Set. -Inductive tree : Set := - node : A -> forest -> tree -with forest : Set := - | empty : forest - | cons : tree -> forest -> forest. -\end{coq_example*} - -We define the function \texttt{tree\_size} that computes the size -of a tree or a forest. Note that we use \texttt{Function} which -generally produces better principles. - -\begin{coq_example*} -Function tree_size (t:tree) : nat := - match t with - | node A f => S (forest_size f) - end - with forest_size (f:forest) : nat := - match f with - | empty => 0 - | cons t f' => (tree_size t + forest_size f') - end. -\end{coq_example*} - -Remark: \texttt{Function} generates itself non mutual induction -principles {\tt tree\_size\_ind} and {\tt forest\_size\_ind}: - -\begin{coq_example} -Check tree_size_ind. -\end{coq_example} - -The definition of mutual induction principles following the recursive -structure of \texttt{tree\_size} and \texttt{forest\_size} is defined -by the command: - -\begin{coq_example*} -Functional Scheme tree_size_ind2 := Induction for tree_size Sort Prop -with forest_size_ind2 := Induction for forest_size Sort Prop. -\end{coq_example*} - -You may now look at the type of {\tt tree\_size\_ind2}: - -\begin{coq_example} -Check tree_size_ind2. -\end{coq_example} - - - - -\section[{\tt inversion}]{{\tt inversion}\tacindex{inversion} -\label{inversion-examples}} - -\subsection*{Generalities about inversion} - -When working with (co)inductive predicates, we are very often faced to -some of these situations: -\begin{itemize} -\item we have an inconsistent instance of an inductive predicate in the - local context of hypotheses. Thus, the current goal can be trivially - proved by absurdity. -\item we have a hypothesis that is an instance of an inductive - predicate, and the instance has some variables whose constraints we - would like to derive. -\end{itemize} - -The inversion tactics are very useful to simplify the work in these -cases. Inversion tools can be classified in three groups: - -\begin{enumerate} -\item tactics for inverting an instance without stocking the inversion - lemma in the context; this includes the tactics - (\texttt{dependent}) \texttt{inversion} and - (\texttt{dependent}) \texttt{inversion\_clear}. -\item commands for generating and stocking in the context the inversion - lemma corresponding to an instance; this includes \texttt{Derive} - (\texttt{Dependent}) \texttt{Inversion} and \texttt{Derive} - (\texttt{Dependent}) \texttt{Inversion\_clear}. -\item tactics for inverting an instance using an already defined - inversion lemma; this includes the tactic \texttt{inversion \ldots using}. -\end{enumerate} - -As inversion proofs may be large in size, we recommend the user to -stock the lemmas whenever the same instance needs to be inverted -several times. - -\firstexample -\example{Non-dependent inversion} - -Let's consider the relation \texttt{Le} over natural numbers and the -following variables: - -\begin{coq_eval} -Reset Initial. -\end{coq_eval} - -\begin{coq_example*} -Inductive Le : nat -> nat -> Set := - | LeO : forall n:nat, Le 0 n - | LeS : forall n m:nat, Le n m -> Le (S n) (S m). -Variable P : nat -> nat -> Prop. -Variable Q : forall n m:nat, Le n m -> Prop. -\end{coq_example*} - -For example, consider the goal: - -\begin{coq_eval} -Lemma ex : forall n m:nat, Le (S n) m -> P n m. -intros. -\end{coq_eval} - -\begin{coq_example} -Show. -\end{coq_example} - -To prove the goal we may need to reason by cases on \texttt{H} and to - derive that \texttt{m} is necessarily of -the form $(S~m_0)$ for certain $m_0$ and that $(Le~n~m_0)$. -Deriving these conditions corresponds to prove that the -only possible constructor of \texttt{(Le (S n) m)} is -\texttt{LeS} and that we can invert the -\texttt{->} in the type of \texttt{LeS}. -This inversion is possible because \texttt{Le} is the smallest set closed by -the constructors \texttt{LeO} and \texttt{LeS}. - -\begin{coq_example} -inversion_clear H. -\end{coq_example} - -Note that \texttt{m} has been substituted in the goal for \texttt{(S m0)} -and that the hypothesis \texttt{(Le n m0)} has been added to the -context. - -Sometimes it is -interesting to have the equality \texttt{m=(S m0)} in the -context to use it after. In that case we can use \texttt{inversion} that -does not clear the equalities: - -\begin{coq_example*} -Undo. -\end{coq_example*} - -\begin{coq_example} -inversion H. -\end{coq_example} - -\begin{coq_eval} -Undo. -\end{coq_eval} - -\example{Dependent Inversion} - -Let us consider the following goal: - -\begin{coq_eval} -Lemma ex_dep : forall (n m:nat) (H:Le (S n) m), Q (S n) m H. -intros. -\end{coq_eval} - -\begin{coq_example} -Show. -\end{coq_example} - -As \texttt{H} occurs in the goal, we may want to reason by cases on its -structure and so, we would like inversion tactics to -substitute \texttt{H} by the corresponding term in constructor form. -Neither \texttt{Inversion} nor {\tt Inversion\_clear} make such a -substitution. -To have such a behavior we use the dependent inversion tactics: - -\begin{coq_example} -dependent inversion_clear H. -\end{coq_example} - -Note that \texttt{H} has been substituted by \texttt{(LeS n m0 l)} and -\texttt{m} by \texttt{(S m0)}. - -\example{using already defined inversion lemmas} - -\begin{coq_eval} -Abort. -\end{coq_eval} - -For example, to generate the inversion lemma for the instance -\texttt{(Le (S n) m)} and the sort \texttt{Prop} we do: - -\begin{coq_example*} -Derive Inversion_clear leminv with (forall n m:nat, Le (S n) m) Sort - Prop. -\end{coq_example*} - -\begin{coq_example} -Check leminv. -\end{coq_example} - -Then we can use the proven inversion lemma: - -\begin{coq_example} -Show. -\end{coq_example} - -\begin{coq_example} -inversion H using leminv. -\end{coq_example} - -\begin{coq_eval} -Reset Initial. -\end{coq_eval} - \section[\tt dependent induction]{\tt dependent induction\label{dependent-induction-example}} \def\depind{{\tt dependent induction}~} \def\depdestr{{\tt dependent destruction}~} diff --git a/doc/refman/RefMan-uti.tex b/doc/refman/RefMan-uti.tex index bda4cff9..f5178445 100644 --- a/doc/refman/RefMan-uti.tex +++ b/doc/refman/RefMan-uti.tex @@ -78,47 +78,47 @@ See the man page of {\tt coqdep} for more details and options. \index{Makefile@{\tt Makefile}} \index{CoqMakefile@{\tt coq\_Makefile}}} -When a proof development becomes large and is split into several files, -it becomes crucial to use a tool like {\tt make} to compile \Coq\ -modules. +When a proof development becomes large, is split into several files or contains +Ocaml plugins, it becomes crucial to use a tool like {\tt make} to compile +\Coq\ modules. The writing of a generic and complete {\tt Makefile} may be a tedious work and that's why \Coq\ provides a tool to automate its creation, {\tt coq\_makefile}. -Arguments are explain by \texttt{\% coq\_makefile --help}. They can be directly -written in the command line but it is recommended to write them in a file (called -for example {\tt Make}) and then call {\tt coq\_makefile -f Make -o - Makefile}. That means options are in {\tt Make} file and output is {\tt - Makefile} This way, {\tt Makefile} will be automatically regenerated if -something changes in {\tt Make}. +You can get a description of the arguments by the command \texttt{\% coq\_makefile + --help}. Arguments can be directly written on the command line interface but it is recommended +to write them in a file ({\tt \_CoqProject} by default) and then call {\tt + coq\_makefile -f \_CoqProject -o Makefile}. That means options are read from {\tt + \_CoqProject} and written in {\tt Makefile}. This way, {\tt Makefile} will be +automagically regenerated when something changes in {\tt \_CoqProject}. The first time you use this tool, you may be happy with: \begin{quotation} \texttt{\% \{ echo '-R .} {\em MyFancyLib} \texttt{' ; find -name '*.v' -print \} > - Make \&\& coq\_makefile -f Make -o Makefile} + \_CoqProject \&\& coq\_makefile -f \_CoqProject -o Makefile} \end{quotation} -To customize things afterwards, remember: +To customize things further, remember the following: \begin{itemize} -\item Coq files must end in {\tt .v}, caml modules in {\tt .ml4} if they - require camlp preproccessing (and in {\tt .ml} otherwise), and caml module signatures in {\tt - .mli}. -\item If you give a directory directly as argument, it is because you provide a - Makefile for it in it. -\item {\tt -R} option is for Coq, {\tt -I} for caml. The same directory can +\item \Coq files must end in {\tt .v}, \ocaml modules in {\tt .ml4} if they + require camlp preproccessing (and in {\tt .ml} otherwise), and \ocaml module + signatures in {\tt .mli}. +\item Whenever a directory is passed as argument, any inner {\tt Makefile} will be + recursively called. +\item {\tt -R} option is for \Coq, {\tt -I} for \ocaml. The same directory can be ``included'' by both. - Using {\tt -R} option gives a right logical path and a correct installation + + Using {\tt -R} option gives a correct logical path and a correct installation emplacement to your coq files. -\item If your files depend on an external library that isn't install somewhere - looked by coqc, use {\tt OTHERFLAGS = '-R path/to/lib lib\_name'} option in your {\tt - Make} but don't do {\tt -R \dots} directly, the {\em make clean} command would - erase it! +\item If your files depend on an external library, never use {\tt -R \dots} to + include it in the path, the {\em make clean} command would erase it! Take + advantage of the \verb:COQPATH: variable (see \ref{envars}) instead if + necessary. \end{itemize} -\Warning To compile a project containing \ocaml{} files you must keep -the sources of \Coq{} somewhere and have an environment variable named -\texttt{COQTOP} that points to that directory. +Under normal circumstances, the only other variable that you may use is +\verb:$COQBIN: to specify the directory where the binaries are. \section[Documenting \Coq\ files with coqdoc]{Documenting \Coq\ files with coqdoc\label{coqdoc} \index{Coqdoc@{\sf coqdoc}}} @@ -142,7 +142,7 @@ after each phrase. Starting with a file {\em file}{\tt.tex} containing \Coq\ phrases, the {\tt coq-tex} filter produces a file named {\em file}{\tt.v.tex} with -the \Coq\ outcome. +the \Coq\ outcome. There are options to produce the \Coq\ parts in smaller font, italic, between horizontal rules, etc. diff --git a/doc/refman/Reference-Manual.tex b/doc/refman/Reference-Manual.tex index cc42c2ef..4380f544 100644 --- a/doc/refman/Reference-Manual.tex +++ b/doc/refman/Reference-Manual.tex @@ -35,7 +35,7 @@ \input{../common/title.tex}% extension .tex pour htmlgen %\input{headers} -\usepackage[linktocpage,colorlinks,bookmarks=false]{hyperref} +\usepackage[linktocpage,colorlinks]{hyperref} % The manual advises to load hyperref package last to be able to redefine % necessary commands. % The above should work for both latex and pdflatex. Even if PDF is produced @@ -88,15 +88,16 @@ Options A and B of the licence are {\em not} elected.} \part{The proof engine} \include{RefMan-oth.v}% Vernacular commands -\include{RefMan-pro}% Proof handling +\include{RefMan-pro.v}% Proof handling \include{RefMan-tac.v}% Tactics and tacticals \include{RefMan-ltac.v}% Writing tactics \include{RefMan-tacex.v}% Detailed Examples of tactics \include{RefMan-decl.v}% The mathematical proof language \part{User extensions} -\include{RefMan-syn.v}% The Syntax and the Grammad commands +\include{RefMan-syn.v}% The Syntax and the Grammar commands %%SUPPRIME \include{RefMan-tus.v}% Writing tactics +\include{RefMan-sch.v}% The Scheme commands \part{Practical tools} \include{RefMan-com}% The coq commands (coqc coqtop) diff --git a/doc/refman/coqdoc.tex b/doc/refman/coqdoc.tex index 271a13f7..c2591a7b 100644 --- a/doc/refman/coqdoc.tex +++ b/doc/refman/coqdoc.tex @@ -43,8 +43,8 @@ remember: ``garbage in, garbage out''. \Coq\ material is quoted between the delimiters \texttt{[} and \texttt{]}. Square brackets may be nested, the inner ones being understood as being part of the quoted code (thus -you can quote a term like $[x:T]u$ by writing -\texttt{[[x:T]u]}). Inside quotations, the code is pretty-printed in +you can quote a term like \texttt{fun x => u} by writing +\texttt{[fun x => u]}). Inside quotations, the code is pretty-printed in the same way as it is in code parts. Pre-formatted vernacular is enclosed by \texttt{[[} and @@ -63,7 +63,7 @@ or (** printing \emph{token} $...\LaTeX\ math...$ #...HTML...# *) \end{alltt} It gives the \LaTeX\ and HTML texts to be produced for the given \Coq\ -token. One of the \LaTeX\ or HTML text may be ommitted, causing the +token. One of the \LaTeX\ or HTML text may be omitted, causing the default pretty-printing to be used for this token. The printing for one token can be removed with @@ -94,7 +94,7 @@ Any of these can be overwritten or suppressed using the Important note: the recognition of tokens is done by a (ocaml)lex automaton and thus applies the longest-match rule. For instance, \verb!->~! is recognized as a single token, where \Coq\ sees two -tokens. It is the responsability of the user to insert space between +tokens. It is the responsibility of the user to insert space between tokens \emph{or} to give pretty-printing rules for the possible combinations, e.g. \begin{verbatim} @@ -153,7 +153,7 @@ emphasis. Usually, these are spaces or punctuation. This sentence contains some _emphasized text_. \end{verbatim} -\paragraph{Escapings to \LaTeX\ and HTML.} +\paragraph{Escaping to \LaTeX\ and HTML.} Pure \LaTeX\ or HTML material can be inserted using the following escape sequences: \begin{itemize} @@ -318,7 +318,7 @@ suffix \verb!.tex!. \item[\texttt{\mm{}files-from }\textit{file}] ~\par Read file names to process in file `\textit{file}' as if they were - given on the command line. Useful for program sources splitted in + given on the command line. Useful for program sources split up into several directories. \item[\texttt{-q}, \texttt{\mm{}quiet}] ~\par diff --git a/doc/stdlib/hidden-files b/doc/stdlib/hidden-files new file mode 100644 index 00000000..e69de29b diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index 35c13f3b..0ee101c8 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -1,17 +1,5 @@ - - - - - -The Coq Standard Library - - - - -

    The Coq Standard Library

    +

    The Coq Standard Library

    Here is a short description of the Coq standard library, which is distributed with the system. @@ -68,6 +56,7 @@ through the Require Import command.

    theories/Logic/Epsilon.v theories/Logic/IndefiniteDescription.v theories/Logic/FunctionalExtensionality.v + theories/Logic/ExtensionalityFacts.v
    Structures: @@ -184,6 +173,8 @@ through the Require Import command.

    theories/ZArith/Zpow_def.v theories/ZArith/Zpow_alt.v theories/ZArith/Zpower.v + theories/ZArith/ZOdiv_def.v + theories/ZArith/ZOdiv.v theories/ZArith/Zdiv.v theories/ZArith/Zquot.v theories/ZArith/Zeuclid.v @@ -414,6 +405,16 @@ through the Require Import command.

    theories/Lists/ListTactics.v +
    Vectors: + Dependent datastructures storing their length +
    +
    + theories/Vectors/Fin.v + theories/Vectors/VectorDef.v + theories/Vectors/VectorSpec.v + (theories/Vectors/Vector.v) +
    +
    Sorting: Axiomatizations of sorts
    @@ -454,7 +455,9 @@ through the Require Import command.

    theories/MSets/MSetEqProperties.v theories/MSets/MSetWeakList.v theories/MSets/MSetList.v + theories/MSets/MSetGenTree.v theories/MSets/MSetAVL.v + theories/MSets/MSetRBT.v theories/MSets/MSetPositive.v theories/MSets/MSetToFiniteSet.v (theories/MSets/MSets.v) @@ -576,4 +579,11 @@ through the Require Import command.

    theories/Program/Combinators.v +
    Unicode: + Unicode-based notations +
    +
    + theories/Unicode/Utf8_core.v + theories/Unicode/Utf8.v +
    diff --git a/doc/stdlib/index-trailer.html b/doc/stdlib/index-trailer.html deleted file mode 100644 index 308b1d01..00000000 --- a/doc/stdlib/index-trailer.html +++ /dev/null @@ -1,2 +0,0 @@ - - diff --git a/doc/stdlib/make-library-index b/doc/stdlib/make-library-index index 8e496fdd..1a70567f 100755 --- a/doc/stdlib/make-library-index +++ b/doc/stdlib/make-library-index @@ -3,37 +3,55 @@ # Instantiate links to library files in index template FILE=$1 +HIDDEN=$2 cp -f $FILE.template tmp echo -n Building file index-list.prehtml ... -LIBDIRS="Init Logic Structures Bool Arith PArith NArith ZArith QArith Relations Sets Classes Setoids Lists Sorting Wellfounded MSets FSets Reals Program Numbers Numbers/Natural/Abstract Numbers/Natural/Peano Numbers/Natural/Binary Numbers/Natural/BigN Numbers/Natural/SpecViaZ Numbers/Integer/Abstract Numbers/Integer/NatPairs Numbers/Integer/Binary Numbers/Integer/SpecViaZ Numbers/Integer/BigZ Numbers/NatInt Numbers/Cyclic/Abstract Numbers/Cyclic/Int31 Numbers/Cyclic/ZModulo Numbers/Cyclic/DoubleCyclic Numbers/Rational/BigQ Numbers/Rational/SpecViaQ Strings" +#LIBDIRS="Init Logic Structures Bool Arith PArith NArith ZArith QArith Relations Sets Classes Setoids Lists Vectors Sorting Wellfounded MSets FSets Reals Program Numbers Numbers/Natural/Abstract Numbers/Natural/Peano Numbers/Natural/Binary Numbers/Natural/BigN Numbers/Natural/SpecViaZ Numbers/Integer/Abstract Numbers/Integer/NatPairs Numbers/Integer/Binary Numbers/Integer/SpecViaZ Numbers/Integer/BigZ Numbers/NatInt Numbers/Cyclic/Abstract Numbers/Cyclic/Int31 Numbers/Cyclic/ZModulo Numbers/Cyclic/DoubleCyclic Numbers/Rational/BigQ Numbers/Rational/SpecViaQ Strings" +LIBDIRS=`find theories/* -type d | sed -e "s:^theories/::"` for k in $LIBDIRS; do i=theories/$k echo $i d=`basename $i` - if [ "$d" != "Num" -a "$d" != "CVS" ]; then + if [ "$d" != "CVS" ]; then + ls $i | grep -q \.v'$' + if [ $? = 0 ]; then for j in $i/*.v; do b=`basename $j .v` rm -f tmp2 grep -q theories/$k/$b.v tmp a=$? + grep -q theories/$k/$b.v $HIDDEN + h=$? if [ $a = 0 ]; then - p=`echo $k | sed 's:/:.:g'` - sed -e "s:theories/$k/$b.v:$b:g" tmp > tmp2 - mv -f tmp2 tmp + if [ $h = 0 ]; then + echo Error: $FILE and $HIDDEN both mention theories/$k/$b.v; exit 1 + else + p=`echo $k | sed 's:/:.:g'` + sed -e "s:theories/$k/$b.v:$b:g" tmp > tmp2 + mv -f tmp2 tmp + fi else - echo Warning: theories/$k/$b.v is missing in the template file - fi + if [ $h = 0 ]; then + echo Error: theories/$k/$b.v is missing in the template file + exit 1 + else + echo Error: none of $FILE and $HIDDEN mention theories/$k/$b.v + exit 1 + fi + + fi done + fi fi rm -f tmp2 sed -e "s/#$d#//" tmp > tmp2 mv -f tmp2 tmp done a=`grep theories tmp` -if [ $? = 0 ]; then echo Warning: extra files:; echo $a; fi +if [ $? = 0 ]; then echo Error: extra files:; echo $a; exit 1; fi mv tmp $FILE echo Done diff --git a/ide/command_windows.ml b/ide/command_windows.ml index 939238d3..a34e5ebe 100644 --- a/ide/command_windows.ml +++ b/ide/command_windows.ml @@ -13,6 +13,7 @@ class command_window coqtop current = ~position:`CENTER ~title:"CoqIde queries" ~show:false () in *) + let views = ref [] in let frame = GBin.frame ~label:"Command Pane" ~shadow_type:`IN () in let _ = frame#misc#hide () in let _ = GtkData.AccelGroup.create () in @@ -49,12 +50,17 @@ class command_window coqtop current = () in + let remove_cb () = + let index = notebook#current_page in + let () = notebook#remove_page index in + views := Minilib.list_filter_i (fun i x -> i <> index) !views + in let _ = toolbar#insert_button ~tooltip:"Delete Page" ~text:"Delete Page" ~icon:(Ideutils.stock_to_widget `DELETE) - ~callback:(fun () -> notebook#remove_page notebook#current_page) + ~callback:remove_cb () in object(self) @@ -63,14 +69,14 @@ object(self) val new_page_menu = new_page_menu val notebook = notebook + method frame = frame method new_command ?command ?term () = - let appendp x = ignore (notebook#append_page x) in let frame = GBin.frame ~shadow_type:`ETCHED_OUT - ~packing:appendp () in + let _ = notebook#append_page frame#coerce in notebook#goto_page (notebook#page_num frame#coerce); let vbox = GPack.vbox ~homogeneous:false ~packing:frame#add () in let hbox = GPack.hbox ~homogeneous:false ~packing:vbox#pack () in @@ -91,7 +97,10 @@ object(self) ~packing:(vbox#pack ~fill:true ~expand:true) () in let ok_b = GButton.button ~label:"Ok" ~packing:(hbox#pack ~expand:false) () in let result = GText.view ~packing:r_bin#add () in + let () = views := !views @ [result] in result#misc#modify_font !current.Preferences.text_font; + let clr = Tags.color_of_string !current.Preferences.background_color in + result#misc#modify_base [`NORMAL, `COLOR clr]; result#misc#set_can_focus true; (* false causes problems for selection *) result#set_editable false; let callback () = @@ -134,6 +143,15 @@ object(self) ignore (combo#entry#connect#activate ~callback); self#frame#misc#show () + method refresh_font () = + let iter view = view#misc#modify_font !current.Preferences.text_font in + List.iter iter !views + + method refresh_color () = + let clr = Tags.color_of_string !current.Preferences.background_color in + let iter view = view#misc#modify_base [`NORMAL, `COLOR clr] in + List.iter iter !views + initializer ignore (new_page_menu#connect#clicked ~callback:self#new_command); (* ignore (window#event#connect#delete (fun _ -> window#misc#hide(); true));*) diff --git a/ide/command_windows.mli b/ide/command_windows.mli index 8c7319aa..c34b6cf6 100644 --- a/ide/command_windows.mli +++ b/ide/command_windows.mli @@ -11,4 +11,6 @@ class command_window : object method new_command : ?command:string -> ?term:string -> unit -> unit method frame : GBin.frame + method refresh_font : unit -> unit + method refresh_color : unit -> unit end diff --git a/ide/coq.ml b/ide/coq.ml index 16a07b01..76dc5650 100644 --- a/ide/coq.ml +++ b/ide/coq.ml @@ -54,36 +54,106 @@ let rec read_all_lines in_chan = arg::(read_all_lines in_chan) with End_of_file -> [] -let filter_coq_opts args = +let fatal_error_popup msg = + let popup = GWindow.message_dialog ~buttons:GWindow.Buttons.ok + ~message_type:`ERROR ~message:msg () + in ignore (popup#run ()); exit 1 + +let final_info_popup small msg = + if small then + let popup = GWindow.message_dialog ~buttons:GWindow.Buttons.ok + ~message_type:`INFO ~message:msg () + in + let _ = popup#run () in + exit 0 + else + let popup = GWindow.dialog () in + let button = GButton.button ~label:"ok" ~packing:popup#action_area#add () + in + let scroll = GBin.scrolled_window ~hpolicy:`NEVER ~vpolicy:`AUTOMATIC + ~packing:popup#vbox#add ~height:500 () + in + let _ = GMisc.label ~text:msg ~packing:scroll#add_with_viewport () in + let _ = popup#connect#destroy ~callback:(fun _ -> exit 0) in + let _ = button#connect#clicked ~callback:(fun _ -> exit 0) in + let _ = popup#run () in + exit 0 + +let connection_error cmd lines exn = + fatal_error_popup + ("Connection with coqtop failed!\n"^ + "Command was: "^cmd^"\n"^ + "Answer was: "^(String.concat "\n " lines)^"\n"^ + "Exception was: "^Printexc.to_string exn) + +let display_coqtop_answer cmd lines = + final_info_popup (List.length lines < 30) + ("Coqtop exited\n"^ + "Command was: "^cmd^"\n"^ + "Answer was: "^(String.concat "\n " lines)) + +let check_remaining_opt arg = + if arg <> "" && arg.[0] = '-' then fatal_error_popup ("Illegal option: "^arg) + +let rec filter_coq_opts args = let argstr = String.concat " " (List.map Filename.quote args) in - let cmd = Filename.quote !Minilib.coqtop_path ^" -nois -filteropts " ^ argstr in - let oc,ic,ec = Unix.open_process_full cmd (Unix.environment ()) in - let filtered_args = read_all_lines oc in - let message = read_all_lines ec in - match Unix.close_process_full (oc,ic,ec) with - | Unix.WEXITED 0 -> true,filtered_args - | Unix.WEXITED 2 -> false,filtered_args - | _ -> false,message - -exception Coqtop_output of string list + let cmd = Filename.quote (coqtop_path ()) ^" -nois -filteropts " ^ argstr in + let cmd = requote cmd in + let filtered_args = ref [] in + let errlines = ref [] in + try + let oc,ic,ec = Unix.open_process_full cmd (Unix.environment ()) in + filtered_args := read_all_lines oc; + errlines := read_all_lines ec; + match Unix.close_process_full (oc,ic,ec) with + | Unix.WEXITED 0 -> + List.iter check_remaining_opt !filtered_args; !filtered_args + | Unix.WEXITED 127 -> asks_for_coqtop args + | _ -> display_coqtop_answer cmd (!filtered_args @ !errlines) + with Sys_error _ -> asks_for_coqtop args + | e -> connection_error cmd (!filtered_args @ !errlines) e + +and asks_for_coqtop args = + let pb_mes = GWindow.message_dialog + ~message:"Failed to load coqtop. Reset the preference to default ?" + ~message_type:`QUESTION ~buttons:GWindow.Buttons.yes_no () in + match pb_mes#run () with + | `YES -> + let () = !Preferences.current.Preferences.cmd_coqtop <- None in + let () = custom_coqtop := None in + let () = pb_mes#destroy () in + filter_coq_opts args + | `DELETE_EVENT | `NO -> + let () = pb_mes#destroy () in + let cmd_sel = GWindow.file_selection + ~title:"Coqtop to execute (edit your preference then)" + ~filename:(coqtop_path ()) ~urgency_hint:true () in + match cmd_sel#run () with + | `OK -> + let () = custom_coqtop := (Some cmd_sel#filename) in + let () = cmd_sel#destroy () in + filter_coq_opts args + | `CANCEL | `DELETE_EVENT | `HELP -> exit 0 + +exception WrongExitStatus of string + +let print_status = function + | Unix.WEXITED n -> "WEXITED "^string_of_int n + | Unix.WSIGNALED n -> "WSIGNALED "^string_of_int n + | Unix.WSTOPPED n -> "WSTOPPED "^string_of_int n let check_connection args = + let lines = ref [] in + let argstr = String.concat " " (List.map Filename.quote args) in + let cmd = Filename.quote (coqtop_path ()) ^ " -batch " ^ argstr in + let cmd = requote cmd in try - let argstr = String.concat " " (List.map Filename.quote args) in - let cmd = Filename.quote !Minilib.coqtop_path ^ " -batch " ^ argstr in let ic = Unix.open_process_in cmd in - let lines = read_all_lines ic in + lines := read_all_lines ic; match Unix.close_process_in ic with - | Unix.WEXITED 0 -> prerr_endline "coqtop seems ok" - | _ -> raise (Coqtop_output lines) - with - | End_of_file -> - Minilib.safe_prerr_endline "Cannot start connection with coqtop"; - exit 1 - | Coqtop_output lines -> - Minilib.safe_prerr_endline "Connection with coqtop failed:"; - List.iter Minilib.safe_prerr_endline lines; - exit 1 + | Unix.WEXITED 0 -> () (* coqtop seems ok *) + | st -> raise (WrongExitStatus (print_status st)) + with e -> connection_error cmd !lines e (** * The structure describing a coqtop sub-process *) @@ -139,7 +209,7 @@ let open_process_pid prog args = let spawn_coqtop sup_args = Mutex.lock toplvl_ctr_mtx; try - let prog = !Minilib.coqtop_path in + let prog = coqtop_path () in let args = Array.of_list (prog :: "-ideslave" :: sup_args) in let (pid,ic,oc) = open_process_pid prog args in incr toplvl_ctr; diff --git a/ide/coq.mli b/ide/coq.mli index 9d64da6c..7f61521e 100644 --- a/ide/coq.mli +++ b/ide/coq.mli @@ -13,11 +13,15 @@ val short_version : unit -> string val version : unit -> string -(** * Initial checks by launching test coqtop processes *) - -val filter_coq_opts : string list -> bool * string list - -(** A mock coqtop launch, checking in particular that initial.coq is found *) +(** * Launch a test coqtop processes, ask for a correct coqtop if it fails. + @return the list of arguments that coqtop did not understand + (the files probably ..). This command may terminate coqide in + case of trouble. *) +val filter_coq_opts : string list -> string list + +(** Launch a coqtop with the user args in order to be sure that it works, + checking in particular that initial.coq is found. This command + may terminate coqide in case of trouble *) val check_connection : string list -> unit (** * The structure describing a coqtop sub-process *) diff --git a/ide/coq_commands.ml b/ide/coq_commands.ml index b9e14145..256426d2 100644 --- a/ide/coq_commands.ml +++ b/ide/coq_commands.ml @@ -127,7 +127,6 @@ let commands = [ "Show Script"; "Show Tree";*) "Structure"; - (* "Suspend"; *) "Syntactic Definition"; "Syntax";]; [ diff --git a/ide/coq_lex.mll b/ide/coq_lex.mll index f0f1afb7..c9a9a826 100644 --- a/ide/coq_lex.mll +++ b/ide/coq_lex.mll @@ -24,7 +24,7 @@ let one_word_commands = [ "Add" ; "Check"; "Eval"; "Extraction" ; "Load" ; "Undo"; "Goal"; - "Proof" ; "Print";"Save" ; + "Proof" ; "Print";"Save" ; "Restart"; "End" ; "Section"; "Chapter"; "Transparent"; "Opaque"; "Comments" ] in let one_word_declarations = @@ -37,7 +37,8 @@ (* Inductive *) "Inductive" ; "CoInductive" ; "Record" ; "Structure" ; (* Other *) - "Ltac" ; "Typeclasses"; "Instance"; "Include"; "Context"; "Class" ] + "Ltac" ; "Instance"; "Include"; "Context"; "Class" ; + "Arguments" ] in let proof_declarations = [ "Theorem" ; "Lemma" ; " Fact" ; "Remark" ; "Corollary" ; @@ -85,33 +86,28 @@ let multiword_declaration = | "Existing" space+ "Instance" "s"? | "Canonical" space+ "Structure" -let locality = ("Local" space+)? +let locality = (space+ "Local")? let multiword_command = - "Set" (space+ ident)* -| "Unset" (space+ ident)* -| "Open" space+ locality "Scope" -| "Close" space+ locality "Scope" -| "Bind" space+ "Scope" -| "Arguments" space+ "Scope" -| "Reserved" space+ "Notation" space+ locality -| "Delimit" space+ "Scope" + ("Uns" | "S")" et" (space+ ident)* +| (("Open" | "Close") locality | "Bind" | " Delimit" ) + space+ "Scope" +| (("Reserved" space+)? "Notation" | "Infix") locality space+ | "Next" space+ "Obligation" | "Solve" space+ "Obligations" | "Require" space+ ("Import"|"Export")? -| "Infix" space+ locality -| "Notation" space+ locality -| "Hint" space+ locality ident +| "Hint" locality space+ ident | "Reset" (space+ "Initial")? | "Tactic" space+ "Notation" -| "Implicit" space+ "Arguments" -| "Implicit" space+ ("Type"|"Types") +| "Implicit" space+ "Type" "s"? | "Combined" space+ "Scheme" | "Extraction" space+ (("Language" space+ ("Ocaml"|"Haskell"|"Scheme"|"Toplevel"))| ("Library"|"Inline"|"NoInline"|"Blacklist")) | "Recursive" space+ "Extraction" (space+ "Library")? | ("Print"|"Reset") space+ "Extraction" space+ ("Inline"|"Blacklist") | "Extract" space+ (("Inlined" space+) "Constant"| "Inductive") +| "Typeclasses" space+ ("eauto" | "Transparent" | "Opaque") +| ("Generalizable" space+) ("All" | "No")? "Variable" "s"? (* At least still missing: "Inline" + decl, variants of "Identity Coercion", variants of Print, Add, ... *) diff --git a/ide/coqide-gtk2rc b/ide/coqide-gtk2rc index 621d4e84..9da99551 100644 --- a/ide/coqide-gtk2rc +++ b/ide/coqide-gtk2rc @@ -23,16 +23,6 @@ binding "text" { class "GtkTextView" binding "text" -style "views" { -base[NORMAL] = "CornSilk" -# bg_pixmap[NORMAL] = "background.jpg" -} -class "GtkTextView" style "views" - -widget "*.*.*.*.*.ScriptWindow" style "views" -widget "*.*.*.*.GoalWindow" style "views" -widget "*.*.*.*.MessageWindow" style "views" - gtk-font-name = "Sans 12" style "location" { diff --git a/ide/coqide.ml b/ide/coqide.ml index 009a1989..61280fd9 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -27,7 +27,6 @@ let safety_tag = function class type analyzed_views= object val mutable act_id : GtkSignal.id option - val mutable deact_id : GtkSignal.id option val input_buffer : GText.buffer val input_view : Undo.undoable_view val last_array : string array @@ -65,7 +64,6 @@ object method backtrack_to : GText.iter -> unit method backtrack_to_no_lock : GText.iter -> unit method clear_message : unit - method disconnected_keypress_handler : GdkEvent.Key.t -> bool method find_phrase_starting_at : GText.iter -> (GText.iter * GText.iter) option method get_insert : GText.iter @@ -84,6 +82,7 @@ object method reset_initial : unit method force_reset_initial : unit method set_message : string -> unit + method raw_coq_query : string -> unit method show_goals : unit method show_goals_full : unit method undo_last_step : unit @@ -889,11 +888,32 @@ object(self) raise RestartCoqtop | e -> sync display_error (None, Printexc.to_string e); None + (* This method is intended to perform stateless commands *) + method raw_coq_query phrase = + let () = prerr_endline "raw_coq_query starting now" in + let display_error s = + if not (Glib.Utf8.validate s) then + flash_info "This error is so nasty that I can't even display it." + else begin + self#insert_message s; + message_view#misc#draw None + end + in + try + match Coq.interp !mycoqtop ~raw:true ~verbose:false phrase with + | Interface.Fail (_, err) -> sync display_error err + | Interface.Good msg -> sync self#insert_message msg + with + | End_of_file -> raise RestartCoqtop + | e -> sync display_error (Printexc.to_string e) + method find_phrase_starting_at (start:GText.iter) = try let start = grab_sentence_start start self#get_start_of_input in let stop = grab_sentence_stop start in - if is_sentence_end stop#backward_char then Some (start,stop) + (* Is this phrase non-empty and complete ? *) + if stop#compare start > 0 && is_sentence_end stop#backward_char + then Some (start,stop) else None with Not_found -> None @@ -1217,22 +1237,6 @@ object(self) let state = GdkEvent.Key.state k in begin match state with - | l when List.mem `MOD1 l -> - let k = GdkEvent.Key.keyval k in - if GdkKeysyms._Return=k - then ignore( - if (input_buffer#insert_interactive "\n") then - begin - let i= self#get_insert#backward_word_start in - prerr_endline "active_kp_hf: Placing cursor"; - self#process_until_iter_or_error i - end); - true - | l when List.mem `CONTROL l -> - let k = GdkEvent.Key.keyval k in - if GdkKeysyms._Break=k - then break (); - false | l -> if GdkEvent.Key.keyval k = GdkKeysyms._Tab then begin prerr_endline "active_kp_handler for Tab"; @@ -1241,18 +1245,6 @@ object(self) end else false end - - method disconnected_keypress_handler k = - match GdkEvent.Key.state k with - | l when List.mem `CONTROL l -> - let k = GdkEvent.Key.keyval k in - if GdkKeysyms._c=k - then break (); - false - | l -> false - - - val mutable deact_id = None val mutable act_id = None method activate () = if not is_active then begin @@ -1523,9 +1515,15 @@ let create_session file = script#buffer#place_cursor ~where:(script#buffer#start_iter); proof#misc#set_can_focus true; message#misc#set_can_focus true; + (* setting fonts *) script#misc#modify_font !current.text_font; proof#misc#modify_font !current.text_font; message#misc#modify_font !current.text_font; + (* setting colors *) + script#misc#modify_base [`NORMAL, `NAME !current.background_color]; + proof#misc#modify_base [`NORMAL, `NAME !current.background_color]; + message#misc#modify_base [`NORMAL, `NAME !current.background_color]; + { tab_label=basename; filename=begin match file with None -> "" |Some f -> f end; script=script; @@ -1798,12 +1796,6 @@ let forbid_quit_to_save () = else false) let main files = - (* Statup preferences *) - begin - try load_pref () - with e -> - flash_info ("Could not load preferences ("^Printexc.to_string e^")."); - end; (* Main window *) let w = GWindow.window @@ -1823,9 +1815,9 @@ let main files = let vbox = GPack.vbox ~homogeneous:false ~packing:w#add () in let new_f _ = - match select_file_for_save ~title:"Create file" () with - | None -> () - | Some f -> do_load f + let session = create_session None in + let index = session_notebook#append_term session in + session_notebook#goto_page index in let load_f _ = match select_file_for_open ~title:"Load file" () with @@ -2181,6 +2173,7 @@ let main files = true)) in reset_auto_save_timer (); (* to enable statup preferences timer *) (* end Preferences *) + let do_or_activate f () = do_if_not_computing "do_or_activate" (fun current -> @@ -2327,13 +2320,13 @@ let main files = in let file_actions = GAction.action_group ~name:"File" () in - let export_actions = GAction.action_group ~name:"Export" () in let edit_actions = GAction.action_group ~name:"Edit" () in + let view_actions = GAction.action_group ~name:"View" () in + let export_actions = GAction.action_group ~name:"Export" () in let navigation_actions = GAction.action_group ~name:"Navigation" () in let tactics_actions = GAction.action_group ~name:"Tactics" () in let templates_actions = GAction.action_group ~name:"Templates" () in let queries_actions = GAction.action_group ~name:"Queries" () in - let display_actions = GAction.action_group ~name:"Display" () in let compile_actions = GAction.action_group ~name:"Compile" () in let windows_actions = GAction.action_group ~name:"Windows" () in let help_actions = GAction.action_group ~name:"Help" () in @@ -2362,10 +2355,18 @@ let main files = ~accel:(!current.modifier_for_tactics^sc) ~callback:(do_if_active (fun a -> a#insert_command ("progress "^s^".\n") (s^".\n"))) in - let query_shortcut s accel = GAction.add_action s ~label:("_"^s) ?accel - ~callback:(fun _ -> let term = get_current_word () in - session_notebook#current_term.command#new_command ~command:s ~term ()) - in let add_complex_template (name, label, text, offset, len, key) = + let query_callback command _ = + let word = get_current_word () in + if not (word = "") then + let term = session_notebook#current_term in + let query = command ^ " " ^ word ^ "." in + term.message_view#buffer#set_text ""; + term.analyzed_view#raw_coq_query query + in + let query_shortcut s accel = + GAction.add_action s ~label:("_"^s) ?accel ~callback:(query_callback s) + in + let add_complex_template (name, label, text, offset, len, key) = (* Templates/Lemma *) let callback _ = let {script = view } = session_notebook#current_term in @@ -2450,6 +2451,31 @@ let main files = end; reset_revert_timer ()) ~stock:`PREFERENCES; (* GAction.add_action "Save preferences" ~label:"_Save preferences" ~callback:(fun _ -> save_pref ()); *) ]; + GAction.add_actions view_actions [ + GAction.add_action "View" ~label:"_View"; + GAction.add_action "Previous tab" ~label:"_Previous tab" ~accel:("Left") ~stock:`GO_BACK + ~callback:(fun _ -> session_notebook#previous_page ()); + GAction.add_action "Next tab" ~label:"_Next tab" ~accel:("Right") ~stock:`GO_FORWARD + ~callback:(fun _ -> session_notebook#next_page ()); + GAction.add_toggle_action "Show Toolbar" ~label:"Show _Toolbar" + ~active:(!current.show_toolbar) ~callback: + (fun _ -> !current.show_toolbar <- not !current.show_toolbar; + !refresh_toolbar_hook ()); + GAction.add_toggle_action "Show Query Pane" ~label:"Show _Query Pane" + ~callback:(fun _ -> let ccw = session_notebook#current_term.command in + if ccw#frame#misc#visible + then ccw#frame#misc#hide () + else ccw#frame#misc#show ()) + ~accel:"Escape"; + ]; + List.iter + (fun (opts,name,label,key,dflt) -> + GAction.add_toggle_action name ~active:dflt ~label + ~accel:(!current.modifier_for_display^key) + ~callback:(fun v -> do_or_activate (fun a -> + let () = setopts !(session_notebook#current_term.toplvl) opts v#get_active in + a#show_goals) ()) view_actions) + print_items; GAction.add_actions navigation_actions [ GAction.add_action "Navigation" ~label:"_Navigation"; GAction.add_action "Forward" ~label:"_Forward" ~stock:`GO_DOWN @@ -2532,15 +2558,6 @@ let main files = query_shortcut "Locate" None; query_shortcut "Whelp Locate" None; ]; - GAction.add_action "Display" ~label:"_Display" display_actions; - List.iter - (fun (opts,name,label,key,dflt) -> - GAction.add_toggle_action name ~active:dflt ~label - ~accel:(!current.modifier_for_display^key) - ~callback:(fun v -> do_or_activate (fun a -> - let () = setopts !(session_notebook#current_term.toplvl) opts v#get_active in - a#show_goals) ()) display_actions) - print_items; GAction.add_actions compile_actions [ GAction.add_action "Compile" ~label:"_Compile"; GAction.add_action "Compile buffer" ~label:"_Compile buffer" ~callback:compile_f; @@ -2551,16 +2568,6 @@ let main files = ]; GAction.add_actions windows_actions [ GAction.add_action "Windows" ~label:"_Windows"; - GAction.add_toggle_action "Show/Hide Query Pane" ~label:"Show/Hide _Query Pane" - ~callback:(fun _ -> let ccw = session_notebook#current_term.command in - if ccw#frame#misc#visible - then ccw#frame#misc#hide () - else ccw#frame#misc#show ()) - ~accel:"Escape"; - GAction.add_toggle_action "Show/Hide Toolbar" ~label:"Show/Hide _Toolbar" - ~active:(!current.show_toolbar) ~callback: - (fun _ -> !current.show_toolbar <- not !current.show_toolbar; - !show_toolbar !current.show_toolbar); GAction.add_action "Detach View" ~label:"Detach _View" ~callback:(fun _ -> do_if_not_computing "detach view" (function {script=v;analyzed_view=av} -> @@ -2608,11 +2615,11 @@ let main files = Coqide_ui.ui_m#insert_action_group file_actions 0; Coqide_ui.ui_m#insert_action_group export_actions 0; Coqide_ui.ui_m#insert_action_group edit_actions 0; + Coqide_ui.ui_m#insert_action_group view_actions 0; Coqide_ui.ui_m#insert_action_group navigation_actions 0; Coqide_ui.ui_m#insert_action_group tactics_actions 0; Coqide_ui.ui_m#insert_action_group templates_actions 0; Coqide_ui.ui_m#insert_action_group queries_actions 0; - Coqide_ui.ui_m#insert_action_group display_actions 0; Coqide_ui.ui_m#insert_action_group compile_actions 0; Coqide_ui.ui_m#insert_action_group windows_actions 0; Coqide_ui.ui_m#insert_action_group help_actions 0; @@ -2625,9 +2632,6 @@ let main files = let toolbar = new GObj.widget tbar in vbox#pack toolbar; - show_toolbar := - (fun b -> if b then toolbar#misc#show () else toolbar#misc#hide ()); - ignore (w#event#connect#delete ~callback:(fun _ -> quit_f (); true)); (* The vertical Separator between Scripts and Goals *) @@ -2790,17 +2794,39 @@ let main files = (* Progress Bar *) lower_hbox#pack pbar#coerce; pbar#set_text "CoqIde started"; - (* XXX *) - change_font := - (fun fd -> - List.iter - (fun {script=view; proof_view=prf_v; message_view=msg_v} -> - view#misc#modify_font fd; - prf_v#misc#modify_font fd; - msg_v#misc#modify_font fd - ) - session_notebook#pages; + + (* Initializing hooks *) + + refresh_toolbar_hook := + (fun () -> if !current.show_toolbar then toolbar#misc#show () else toolbar#misc#hide ()); + refresh_font_hook := + (fun () -> + let fd = !current.text_font in + let iter_page p = + p.script#misc#modify_font fd; + p.proof_view#misc#modify_font fd; + p.message_view#misc#modify_font fd; + p.command#refresh_font () + in + List.iter iter_page session_notebook#pages; ); + refresh_background_color_hook := + (fun () -> + let clr = Tags.color_of_string !current.background_color in + let iter_page p = + p.script#misc#modify_base [`NORMAL, `COLOR clr]; + p.proof_view#misc#modify_base [`NORMAL, `COLOR clr]; + p.message_view#misc#modify_base [`NORMAL, `COLOR clr]; + p.command#refresh_color () + in + List.iter iter_page session_notebook#pages; + ); + resize_window_hook := (fun () -> + w#resize + ~width:!current.window_width + ~height:!current.window_height); + refresh_tabs_hook := update_notebook_pos; + let about_full_string = "\nCoq is developed by the Coq Development Team\ \n(INRIA - CNRS - LIX - LRI - PPS)\ @@ -2865,10 +2891,12 @@ let main files = (* *) - resize_window := (fun () -> - w#resize - ~width:!current.window_width - ~height:!current.window_height); +(* Begin Color configuration *) + + Tags.set_processing_color (Tags.color_of_string !current.processing_color); + Tags.set_processed_color (Tags.color_of_string !current.processed_color); + +(* End of color configuration *) ignore(nb#connect#switch_page ~callback: (fun i -> @@ -2892,7 +2920,7 @@ let main files = session_notebook#goto_page index; end; initial_about session_notebook#current_term.proof_view#buffer; - !show_toolbar !current.show_toolbar; + !refresh_toolbar_hook (); session_notebook#current_term.script#misc#grab_focus ();; (* This function check every half of second if GeoProof has send @@ -2921,43 +2949,24 @@ let rec check_for_geoproof_input () = in the path. Note that the -coqtop option to coqide allows to override this default coqtop path *) -let default_coqtop_path () = - let prog = Sys.executable_name in - try - let pos = String.length prog - 6 in - let i = Str.search_backward (Str.regexp_string "coqide") prog pos in - String.blit "coqtop" 0 prog i 6; - prog - with _ -> "coqtop" - let read_coqide_args argv = let rec filter_coqtop coqtop project_files out = function | "-coqtop" :: prog :: args -> - if coqtop = "" then filter_coqtop prog project_files out args + if coqtop = None then filter_coqtop (Some prog) project_files out args else - (output_string stderr "Error: multiple -coqtop options"; exit 1) + (output_string stderr "Error: multiple -coqtop options"; exit 1) | "-f" :: file :: args -> filter_coqtop coqtop ((Minilib.canonical_path_name (Filename.dirname file), Project_file.read_project_file file) :: project_files) out args | "-f" :: [] -> output_string stderr "Error: missing project file name"; exit 1 + | "-coqtop" :: [] -> output_string stderr "Error: missing argument after -coqtop"; exit 1 + | "-debug"::args -> Ideutils.debug := true; + filter_coqtop coqtop project_files ("-debug"::out) args | arg::args -> filter_coqtop coqtop project_files (arg::out) args - | [] -> ((if coqtop = "" then default_coqtop_path () else coqtop), - List.rev project_files,List.rev out) + | [] -> (coqtop,List.rev project_files,List.rev out) in - let coqtop,project_files,argv = filter_coqtop "" [] [] argv in - Minilib.coqtop_path := coqtop; + let coqtop,project_files,argv = filter_coqtop None [] [] argv in + Ideutils.custom_coqtop := coqtop; custom_project_files := project_files; argv - -let process_argv argv = - try - let continue,filtered = Coq.filter_coq_opts (List.tl argv) in - if not continue then - (List.iter Minilib.safe_prerr_endline filtered; exit 0); - let opts = List.filter (fun arg -> String.get arg 0 == '-') filtered in - if opts <> [] then - (Minilib.safe_prerr_endline ("Illegal option: "^List.hd opts); exit 1); - filtered - with _ -> - (Minilib.safe_prerr_endline "coqtop choked on one of your option"; exit 1) diff --git a/ide/coqide.mli b/ide/coqide.mli index 38b0fab0..57158a6a 100644 --- a/ide/coqide.mli +++ b/ide/coqide.mli @@ -16,9 +16,6 @@ val sup_args : string list ref Minilib.coqtop_path accordingly *) val read_coqide_args : string list -> string list -(** Ask coqtop the remaining options it doesn't recognize *) -val process_argv : string list -> string list - (** Prepare the widgets, load the given files in tabs *) val main : string list -> unit diff --git a/ide/coqide_main.ml4 b/ide/coqide_main.ml4 index 3fec0631..6f4b8b13 100644 --- a/ide/coqide_main.ml4 +++ b/ide/coqide_main.ml4 @@ -65,21 +65,21 @@ let () = END let () = - let argl = Array.to_list Sys.argv in - let argl = Coqide.read_coqide_args argl in - let files = Coqide.process_argv argl in - let args = List.filter (fun x -> not (List.mem x files)) (List.tl argl) in - Coq.check_connection args; - Coqide.sup_args := args; Coqide.ignore_break (); + ignore (GtkMain.Main.init ()); + initmac () ; (try let gtkrcdir = List.find (fun x -> Sys.file_exists (Filename.concat x "coqide-gtk2rc")) Minilib.xdg_config_dirs in GtkMain.Rc.add_default_file (Filename.concat gtkrcdir "coqide-gtk2rc"); with Not_found -> ()); - ignore (GtkMain.Main.init ()); - initmac () ; + (* Statup preferences *) + begin + try Preferences.load_pref () + with e -> + Ideutils.flash_info ("Could not load preferences ("^Printexc.to_string e^")."); + end; (* GtkData.AccelGroup.set_default_mod_mask (Some [`CONTROL;`SHIFT;`MOD1;`MOD3;`MOD4]);*) ignore ( @@ -89,7 +89,13 @@ let () = if level land Glib.Message.log_level `WARNING <> 0 then Printf.eprintf "Warning: %s\n" msg else failwith ("Coqide internal error: " ^ msg))); - Coqide.main files; + let argl = Array.to_list Sys.argv in + let argl = Coqide.read_coqide_args argl in + let files = Coq.filter_coq_opts (List.tl argl) in + let args = List.filter (fun x -> not (List.mem x files)) (List.tl argl) in + Coq.check_connection args; + Coqide.sup_args := args; + Coqide.main files; if !Coq_config.with_geoproof then ignore (Thread.create Coqide.check_for_geoproof_input ()); macready (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar") (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar/Edit/Prefs") (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar/Help/Abt"); diff --git a/ide/coqide_ui.ml b/ide/coqide_ui.ml index 0d7c67ac..eaf1e934 100644 --- a/ide/coqide_ui.ml +++ b/ide/coqide_ui.ml @@ -56,6 +56,22 @@ let init () = + + + + + + + + + + + + + + + + @@ -100,16 +116,6 @@ let init () = - - - - - - - - - - @@ -117,8 +123,6 @@ let init () = - - diff --git a/ide/ideproof.ml b/ide/ideproof.ml index 3c3324cb..b79d6469 100644 --- a/ide/ideproof.ml +++ b/ide/ideproof.ml @@ -53,7 +53,7 @@ let mode_tactic sel_cb (proof:GText.view) goals hints = match goals with "%d subgoal%s\n" goals_cnt (if 1 < goals_cnt then "" else "s") in let goal_str index total = Printf.sprintf - "\n______________________________________(%d/%d)\n" index total + "______________________________________(%d/%d)\n" index total in (* Insert current goal and its hypotheses *) let hyps_hints, goal_hints = match hints with @@ -76,14 +76,15 @@ let mode_tactic sel_cb (proof:GText.view) goals hints = match goals with let () = proof#buffer#insert head_str in let () = insert_hyp hyps_hints hyps in let () = - let tags = if goal_hints <> [] then + let tags = Tags.Proof.goal :: if goal_hints <> [] then let tag = proof#buffer#create_tag [] in let () = hook_tag_cb tag goal_hints sel_cb on_hover in [tag] else [] in proof#buffer#insert (goal_str 1 goals_cnt); - proof#buffer#insert ~tags (cur_goal ^ "\n") + proof#buffer#insert ~tags cur_goal; + proof#buffer#insert "\n" in (* Insert remaining goals (no hypotheses) *) let fold_goal i _ { Interface.goal_ccl = g } = @@ -91,10 +92,11 @@ let mode_tactic sel_cb (proof:GText.view) goals hints = match goals with proof#buffer#insert (g ^ "\n") in let () = Minilib.list_fold_left_i fold_goal 2 () rem_goals in - ignore(proof#buffer#place_cursor - ~where:((proof#buffer#get_iter_at_mark `INSERT)#backward_lines (3*goals_cnt - 2))); - ignore(proof#scroll_to_mark `INSERT) + ignore(proof#buffer#place_cursor + ~where:(proof#buffer#end_iter#backward_to_tag_toggle + (Some Tags.Proof.goal))); + ignore(proof#scroll_to_mark ~use_align:true ~yalign:0.95 `INSERT) let mode_cesar (proof:GText.view) = function | [] -> assert false @@ -123,7 +125,7 @@ let display mode (view:GText.view) goals hints evars = in List.iter iter evs | _ -> - view#buffer#insert "Proof Completed." + view#buffer#insert "No more subgoals." end | Some { Interface.fg_goals = []; Interface.bg_goals = bg } -> (* No foreground proofs, but still unfocused ones *) diff --git a/ide/ideutils.ml b/ide/ideutils.ml index fd460c4e..a208ad0e 100644 --- a/ide/ideutils.ml +++ b/ide/ideutils.ml @@ -63,28 +63,25 @@ let print_id id = let do_convert s = Utf8_convert.f (if Glib.Utf8.validate s then begin - prerr_endline "Input is UTF-8";s - end else - let from_loc () = - let _,char_set = Glib.Convert.get_charset () in - flash_info - ("Converting from locale ("^char_set^")"); - Glib.Convert.convert_with_fallback ~to_codeset:"UTF-8" ~from_codeset:char_set s - in - let from_manual () = - flash_info - ("Converting from "^ !current.encoding_manual); - Glib.Convert.convert s ~to_codeset:"UTF-8" ~from_codeset:!current.encoding_manual - in - if !current.encoding_use_utf8 || !current.encoding_use_locale then begin - try - from_loc () - with _ -> from_manual () - end else begin - try - from_manual () - with _ -> from_loc () - end) + prerr_endline "Input is UTF-8";s + end else + let from_loc () = + let _,char_set = Glib.Convert.get_charset () in + flash_info + ("Converting from locale ("^char_set^")"); + Glib.Convert.convert_with_fallback ~to_codeset:"UTF-8" ~from_codeset:char_set s + in + let from_manual enc = + flash_info + ("Converting from "^ enc); + Glib.Convert.convert s ~to_codeset:"UTF-8" ~from_codeset:enc + in + match !current.encoding with + |Preferences.Eutf8 | Preferences.Elocale -> from_loc () + |Emanual enc -> + try + from_manual enc + with _ -> from_loc ()) let try_convert s = try @@ -96,18 +93,21 @@ Please choose a correct encoding in the preference panel.*)";; let try_export file_name s = try let s = - try if !current.encoding_use_utf8 then begin - (prerr_endline "UTF-8 is enforced" ;s) - end else if !current.encoding_use_locale then begin - let is_unicode,char_set = Glib.Convert.get_charset () in - if is_unicode then - (prerr_endline "Locale is UTF-8" ;s) - else - (prerr_endline ("Locale is "^char_set); - Glib.Convert.convert_with_fallback ~from_codeset:"UTF-8" ~to_codeset:char_set s) - end else - (prerr_endline ("Manual charset is "^ !current.encoding_manual); - Glib.Convert.convert_with_fallback ~from_codeset:"UTF-8" ~to_codeset:!current.encoding_manual s) + try match !current.encoding with + |Eutf8 -> begin + (prerr_endline "UTF-8 is enforced" ;s) + end + |Elocale -> begin + let is_unicode,char_set = Glib.Convert.get_charset () in + if is_unicode then + (prerr_endline "Locale is UTF-8" ;s) + else + (prerr_endline ("Locale is "^char_set); + Glib.Convert.convert_with_fallback ~from_codeset:"UTF-8" ~to_codeset:char_set s) + end + |Emanual enc -> + (prerr_endline ("Manual charset is "^ enc); + Glib.Convert.convert_with_fallback ~from_codeset:"UTF-8" ~to_codeset:enc s) with e -> (prerr_endline ("Error ("^(Printexc.to_string e)^") in transcoding: falling back to UTF-8") ;s) in let oc = open_out file_name in @@ -252,14 +252,40 @@ let stock_to_widget ?(size=`DIALOG) s = in img#set_stock s; img#coerce +let custom_coqtop = ref None + +let coqtop_path () = + let file = match !custom_coqtop with + | Some s -> s + | None -> + match !current.cmd_coqtop with + | Some s -> s + | None -> + let prog = String.copy Sys.executable_name in + try + let pos = String.length prog - 6 in + let i = Str.search_backward (Str.regexp_string "coqide") prog pos in + String.blit "coqtop" 0 prog i 6; + prog + with Not_found -> "coqtop" + in file + let rec print_list print fmt = function | [] -> () | [x] -> print fmt x | x :: r -> print fmt x; print_list print fmt r +(* In win32, when a command-line is to be executed via cmd.exe + (i.e. Sys.command, Unix.open_process, ...), it cannot contain several + quoted "..." zones otherwise some quotes are lost. Solution: we re-quote + everything. Reference: http://ss64.com/nt/cmd.html *) + +let requote cmd = if Sys.os_type = "Win32" then "\""^cmd^"\"" else cmd + (* TODO: allow to report output as soon as it comes (user-fiendlier for long commands like make...) *) let run_command f c = + let c = requote c in let result = Buffer.create 127 in let cin,cout,cerr = Unix.open_process_full c (Unix.environment ()) in let buff = String.make 127 ' ' in @@ -279,11 +305,12 @@ let run_command f c = let browse f url = let com = Minilib.subst_command_placeholder !current.cmd_browse url in - let s = Sys.command com in + let _ = Unix.open_process_out com in () +(* This beautiful message will wait for twt ... if s = 127 then f ("Could not execute\n\""^com^ "\"\ncheck your preferences for setting a valid browser command\n") - +*) let doc_url () = if !current.doc_url = use_default_doc_url || !current.doc_url = "" then let addr = List.fold_left Filename.concat (Coq_config.docdir) ["html";"refman";"index.html"] in diff --git a/ide/ideutils.mli b/ide/ideutils.mli index 1e29d323..c433d92a 100644 --- a/ide/ideutils.mli +++ b/ide/ideutils.mli @@ -52,6 +52,12 @@ val print_list : (formatter -> 'a -> unit) -> formatter -> 'a list -> unit val run_command : (string -> unit) -> string -> Unix.process_status*string +val custom_coqtop : string option ref +(* @return command to call coqtop + - custom_coqtop if set + - from the prefs is set + - try to infer it else *) +val coqtop_path : unit -> string val status : GMisc.statusbar @@ -67,3 +73,10 @@ val pbar : GRange.progress_bar returns an absolute filename equivalent to given filename *) val absolute_filename : string -> string + +(* In win32, when a command-line is to be executed via cmd.exe + (i.e. Sys.command, Unix.open_process, ...), it cannot contain several + quoted "..." zones otherwise some quotes are lost. Solution: we re-quote + everything. Reference: http://ss64.com/nt/cmd.html *) + +val requote : string -> string diff --git a/ide/minilib.ml b/ide/minilib.ml index cec77f3b..4ccb1ccb 100644 --- a/ide/minilib.ml +++ b/ide/minilib.ml @@ -64,9 +64,10 @@ let string_map f s = let subst_command_placeholder s t = Str.global_replace (Str.regexp_string "%s") t s -let path_to_list p = - let sep = Str.regexp (if Sys.os_type = "Win32" then ";" else ":") in - Str.split sep p +(* Split the content of a variable such as $PATH in a list of directories. + The separators are either ":" in unix or ";" in win32 *) + +let path_to_list = Str.split (Str.regexp "[:;]") (* On win32, the home directory is probably not in $HOME, but in some other environment variable *) @@ -76,28 +77,50 @@ let home = try (Sys.getenv "HOMEDRIVE")^(Sys.getenv "HOMEPATH") with Not_found -> try Sys.getenv "USERPROFILE" with Not_found -> Filename.current_dir_name +let opt2list = function None -> [] | Some x -> [x] + +let rec lconcat = function + | [] -> assert false + | [x] -> x + | x::l -> Filename.concat x (lconcat l) + let xdg_config_home = try Filename.concat (Sys.getenv "XDG_CONFIG_HOME") "coq" with Not_found -> - Filename.concat home "/.config/coq" + lconcat [home;".config";"coq"] + +let static_xdg_config_dirs = + if Sys.os_type = "Win32" then + let base = Filename.dirname (Filename.dirname Sys.executable_name) in + [Filename.concat base "config"] + else ["/etc/xdg/coq"] let xdg_config_dirs = - xdg_config_home :: (try - List.map (fun dir -> Filename.concat dir "coq") (path_to_list (Sys.getenv "XDG_CONFIG_DIRS")) - with Not_found -> "/etc/xdg/coq"::(match Coq_config.configdir with |None -> [] |Some d -> [d])) + xdg_config_home :: + try + List.map (fun dir -> Filename.concat dir "coq") + (path_to_list (Sys.getenv "XDG_CONFIG_DIRS")) + with Not_found -> static_xdg_config_dirs @ opt2list Coq_config.configdir let xdg_data_home = try Filename.concat (Sys.getenv "XDG_DATA_HOME") "coq" with Not_found -> - Filename.concat home "/.local/share/coq" + lconcat [home;".local";"share";"coq"] + +let static_xdg_data_dirs = + if Sys.os_type = "Win32" then + let base = Filename.dirname (Filename.dirname Sys.executable_name) in + [Filename.concat base "share"] + else ["/usr/local/share/coq";"/usr/share/coq"] let xdg_data_dirs = - xdg_data_home :: (try - List.map (fun dir -> Filename.concat dir "coq") (path_to_list (Sys.getenv "XDG_DATA_DIRS")) - with Not_found -> - "/usr/local/share/coq"::"/usr/share/coq"::(match Coq_config.datadir with |None -> [] |Some d -> [d])) + xdg_data_home :: + try + List.map (fun dir -> Filename.concat dir "coq") + (path_to_list (Sys.getenv "XDG_DATA_DIRS")) + with Not_found -> static_xdg_data_dirs @ opt2list Coq_config.datadir let coqtop_path = ref "" diff --git a/ide/preferences.ml b/ide/preferences.ml index 02673098..d320ddda 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -10,9 +10,22 @@ open Configwin open Printf let pref_file = Filename.concat Minilib.xdg_config_home "coqiderc" - let accel_file = Filename.concat Minilib.xdg_config_home "coqide.keys" +let get_config_file name = + let find_config dir = Sys.file_exists (Filename.concat dir name) in + let config_dir = List.find find_config Minilib.xdg_config_dirs in + Filename.concat config_dir name + +(* Small hack to handle v8.3 to v8.4 change in configuration file *) +let loaded_pref_file = + try get_config_file "coqiderc" + with Not_found -> Filename.concat Minilib.home ".coqiderc" + +let loaded_accel_file = + try get_config_file "coqide.keys" + with Not_found -> Filename.concat Minilib.home ".coqide.keys" + let mod_to_str (m:Gdk.Tags.modifier) = match m with | `MOD1 -> "" @@ -40,8 +53,32 @@ let project_behavior_of_string s = else if s = "appended to arguments" then Append_args else Ignore_args +type inputenc = Elocale | Eutf8 | Emanual of string + +let string_of_inputenc = function + |Elocale -> "LOCALE" + |Eutf8 -> "UTF-8" + |Emanual s -> s + +let inputenc_of_string s = + (if s = "UTF-8" then Eutf8 + else if s = "LOCALE" then Elocale + else Emanual s) + + +(** Hooks *) + +let refresh_font_hook = ref (fun () -> ()) +let refresh_background_color_hook = ref (fun () -> ()) +let refresh_toolbar_hook = ref (fun () -> ()) +let auto_complete_hook = ref (fun x -> ()) +let contextual_menus_on_goal_hook = ref (fun x -> ()) +let resize_window_hook = ref (fun () -> ()) +let refresh_tabs_hook = ref (fun () -> ()) + type pref = { + mutable cmd_coqtop : string option; mutable cmd_coqc : string; mutable cmd_make : string; mutable cmd_coqmakefile : string; @@ -57,9 +94,7 @@ type pref = mutable read_project : project_behavior; mutable project_file_name : string; - mutable encoding_use_locale : bool; - mutable encoding_use_utf8 : bool; - mutable encoding_manual : string; + mutable encoding : inputenc; mutable automatic_tactics : string list; mutable cmd_print : string; @@ -89,15 +124,20 @@ type pref = *) mutable auto_complete : bool; mutable stop_before : bool; - mutable lax_syntax : bool; mutable vertical_tabs : bool; mutable opposite_tabs : bool; + + mutable background_color : string; + mutable processing_color : string; + mutable processed_color : string; + } let use_default_doc_url = "(automatic)" let (current:pref ref) = ref { + cmd_coqtop = None; cmd_coqc = "coqc"; cmd_make = "make"; cmd_coqmakefile = "coq_makefile -o makefile *.v"; @@ -114,9 +154,7 @@ let (current:pref ref) = read_project = Ignore_args; project_file_name = "_CoqProject"; - encoding_use_locale = true; - encoding_use_utf8 = false; - encoding_manual = "ISO_8859-1"; + encoding = if Sys.os_type = "Win32" then Eutf8 else Elocale; automatic_tactics = ["trivial"; "tauto"; "auto"; "omega"; "auto with *"; "intuition" ]; @@ -150,32 +188,25 @@ let (current:pref ref) = *) auto_complete = false; stop_before = true; - lax_syntax = true; vertical_tabs = false; opposite_tabs = false; - } - - -let change_font = ref (fun f -> ()) -let show_toolbar = ref (fun x -> ()) + background_color = "cornsilk"; + processed_color = "light green"; + processing_color = "light blue"; -let auto_complete = ref (fun x -> ()) - -let contextual_menus_on_goal = ref (fun x -> ()) - -let resize_window = ref (fun () -> ()) + } let save_pref () = if not (Sys.file_exists Minilib.xdg_config_home) then Unix.mkdir Minilib.xdg_config_home 0o700; - (try GtkData.AccelMap.save accel_file - with _ -> ()); + let () = try GtkData.AccelMap.save accel_file with _ -> () in let p = !current in let add = Minilib.Stringmap.add in let (++) x f = f x in Minilib.Stringmap.empty ++ + add "cmd_coqtop" (match p.cmd_coqtop with | None -> [] | Some v-> [v]) ++ add "cmd_coqc" [p.cmd_coqc] ++ add "cmd_make" [p.cmd_make] ++ add "cmd_coqmakefile" [p.cmd_coqmakefile] ++ @@ -190,9 +221,7 @@ let save_pref () = add "project_options" [string_of_project_behavior p.read_project] ++ add "project_file_name" [p.project_file_name] ++ - add "encoding_use_locale" [string_of_bool p.encoding_use_locale] ++ - add "encoding_use_utf8" [string_of_bool p.encoding_use_utf8] ++ - add "encoding_manual" [p.encoding_manual] ++ + add "encoding" [string_of_inputenc p.encoding] ++ add "automatic_tactics" p.automatic_tactics ++ add "cmd_print" [p.cmd_print] ++ @@ -217,19 +246,18 @@ let save_pref () = add "query_window_width" [string_of_int p.query_window_width] ++ add "auto_complete" [string_of_bool p.auto_complete] ++ add "stop_before" [string_of_bool p.stop_before] ++ - add "lax_syntax" [string_of_bool p.lax_syntax] ++ add "vertical_tabs" [string_of_bool p.vertical_tabs] ++ add "opposite_tabs" [string_of_bool p.opposite_tabs] ++ + add "background_color" [p.background_color] ++ + add "processing_color" [p.processing_color] ++ + add "processed_color" [p.processed_color] ++ Config_lexer.print_file pref_file let load_pref () = - let accel_dir = List.find - (fun x -> Sys.file_exists (Filename.concat x "coqide.keys")) - Minilib.xdg_config_dirs in - GtkData.AccelMap.load (Filename.concat accel_dir "coqide.keys"); + let () = try GtkData.AccelMap.load loaded_accel_file with _ -> () in let p = !current in - let m = Config_lexer.load_file pref_file in + let m = Config_lexer.load_file loaded_pref_file in let np = { p with cmd_coqc = p.cmd_coqc } in let set k f = try let v = Minilib.Stringmap.find k m in f v with _ -> () in let set_hd k f = set k (fun v -> f (List.hd v)) in @@ -239,6 +267,8 @@ let load_pref () = let set_command_with_pair_compat k f = set k (function [v1;v2] -> f (v1^"%s"^v2) | [v] -> f v | _ -> raise Exit) in + let set_option k f = set k (fun v -> f (match v with |[] -> None |h::_ -> Some h)) in + set_option "cmd_coqtop" (fun v -> np.cmd_coqtop <- v); set_hd "cmd_coqc" (fun v -> np.cmd_coqc <- v); set_hd "cmd_make" (fun v -> np.cmd_make <- v); set_hd "cmd_coqmakefile" (fun v -> np.cmd_coqmakefile <- v); @@ -249,9 +279,7 @@ let load_pref () = set_bool "auto_save" (fun v -> np.auto_save <- v); set_int "auto_save_delay" (fun v -> np.auto_save_delay <- v); set_pair "auto_save_name" (fun v1 v2 -> np.auto_save_name <- (v1,v2)); - set_bool "encoding_use_locale" (fun v -> np.encoding_use_locale <- v); - set_bool "encoding_use_utf8" (fun v -> np.encoding_use_utf8 <- v); - set_hd "encoding_manual" (fun v -> np.encoding_manual <- v); + set_hd "encoding_manual" (fun v -> np.encoding <- (inputenc_of_string v)); set_hd "project_options" (fun v -> np.read_project <- (project_behavior_of_string v)); set_hd "project_file_name" (fun v -> np.project_file_name <- v); @@ -290,15 +318,21 @@ let load_pref () = set_int "query_window_height" (fun v -> np.query_window_height <- v); set_bool "auto_complete" (fun v -> np.auto_complete <- v); set_bool "stop_before" (fun v -> np.stop_before <- v); - set_bool "lax_syntax" (fun v -> np.lax_syntax <- v); set_bool "vertical_tabs" (fun v -> np.vertical_tabs <- v); set_bool "opposite_tabs" (fun v -> np.opposite_tabs <- v); + set_hd "background_color" (fun v -> np.background_color <- v); + set_hd "processing_color" (fun v -> np.processing_color <- v); + set_hd "processed_color" (fun v -> np.processed_color <- v); current := np (* Format.printf "in load_pref: current.text_font = %s@." (Pango.Font.to_string !current.text_font); *) let configure ?(apply=(fun () -> ())) () = + let cmd_coqtop = + string + ~f:(fun s -> !current.cmd_coqtop <- if s = "AUTO" then None else Some s) + " coqtop" (match !current.cmd_coqtop with |None -> "AUTO" | Some x -> x) in let cmd_coqc = string ~f:(fun s -> !current.cmd_coqc <- s) @@ -325,7 +359,7 @@ let configure ?(apply=(fun () -> ())) () = let w = GMisc.font_selection () in w#set_preview_text "Goal (∃n : nat, n ≤ 0)∧(∀x,y,z, x∈y⋃z↔x∈y∨x∈z)."; - box#pack w#coerce; + box#pack ~expand:true w#coerce; ignore (w#misc#connect#realize ~callback:(fun () -> w#set_font_name (Pango.Font.to_string !current.text_font))); @@ -338,9 +372,67 @@ let configure ?(apply=(fun () -> ())) () = (* Format.printf "in config_font: current.text_font = %s@." (Pango.Font.to_string !current.text_font); *) - !change_font !current.text_font) + !refresh_font_hook ()) true in + + let config_color = + let box = GPack.vbox () in + let table = GPack.table + ~row_spacings:5 + ~col_spacings:5 + ~border_width:2 + ~packing:(box#pack ~expand:true) () + in + let background_label = GMisc.label + ~text:"Background color" + ~packing:(table#attach ~expand:`X ~left:0 ~top:0) () + in + let processed_label = GMisc.label + ~text:"Background color of processed text" + ~packing:(table#attach ~expand:`X ~left:0 ~top:1) () + in + let processing_label = GMisc.label + ~text:"Background color of text being processed" + ~packing:(table#attach ~expand:`X ~left:0 ~top:2) () + in + let () = background_label#set_xalign 0. in + let () = processed_label#set_xalign 0. in + let () = processing_label#set_xalign 0. in + let background_button = GButton.color_button + ~color:(Tags.color_of_string (!current.background_color)) + ~packing:(table#attach ~left:1 ~top:0) () + in + let processed_button = GButton.color_button + ~color:(Tags.get_processed_color ()) + ~packing:(table#attach ~left:1 ~top:1) () + in + let processing_button = GButton.color_button + ~color:(Tags.get_processing_color ()) + ~packing:(table#attach ~left:1 ~top:2) () + in + let reset_button = GButton.button + ~label:"Reset" + ~packing:box#pack () + in + let reset_cb () = + background_button#set_color (Tags.color_of_string "cornsilk"); + processing_button#set_color (Tags.color_of_string "light blue"); + processed_button#set_color (Tags.color_of_string "light green"); + in + let _ = reset_button#connect#clicked ~callback:reset_cb in + let label = "Color configuration" in + let callback () = + !current.background_color <- Tags.string_of_color background_button#color; + !current.processing_color <- Tags.string_of_color processing_button#color; + !current.processed_color <- Tags.string_of_color processed_button#color; + !refresh_background_color_hook (); + Tags.set_processing_color processing_button#color; + Tags.set_processed_color processed_button#color + in + custom ~label box callback true + in + (* let show_toolbar = bool @@ -369,7 +461,7 @@ let configure ?(apply=(fun () -> ())) () = bool ~f:(fun s -> !current.auto_complete <- s; - !auto_complete s) + !auto_complete_hook s) "Auto Complete" !current.auto_complete in @@ -416,44 +508,28 @@ let configure ?(apply=(fun () -> ())) () = "Stop interpreting before the current point" !current.stop_before in - let lax_syntax = - bool - ~f:(fun s -> !current.lax_syntax <- s) - "Relax read-only constraint at end of command" !current.lax_syntax - in - let vertical_tabs = bool - ~f:(fun s -> !current.vertical_tabs <- s) + ~f:(fun s -> !current.vertical_tabs <- s; !refresh_tabs_hook ()) "Vertical tabs" !current.vertical_tabs in let opposite_tabs = bool - ~f:(fun s -> !current.opposite_tabs <- s) + ~f:(fun s -> !current.opposite_tabs <- s; !refresh_tabs_hook ()) "Tabs on opposite side" !current.opposite_tabs in let encodings = combo "File charset encoding " - ~f:(fun s -> - match s with - | "UTF-8" -> - !current.encoding_use_utf8 <- true; - !current.encoding_use_locale <- false - | "LOCALE" -> - !current.encoding_use_utf8 <- false; - !current.encoding_use_locale <- true - | _ -> - !current.encoding_use_utf8 <- false; - !current.encoding_use_locale <- false; - !current.encoding_manual <- s; - ) + ~f:(fun s -> !current.encoding <- (inputenc_of_string s)) ~new_allowed: true - ["UTF-8";"LOCALE";!current.encoding_manual] - (if !current.encoding_use_utf8 then "UTF-8" - else if !current.encoding_use_locale then "LOCALE" else !current.encoding_manual) + ("UTF-8"::"LOCALE":: match !current.encoding with + |Emanual s -> [s] + |_ -> [] + ) + (string_of_inputenc !current.encoding) in let read_project = combo @@ -579,11 +655,11 @@ let configure ?(apply=(fun () -> ())) () = bool ~f:(fun s -> !current.contextual_menus_on_goal <- s; - !contextual_menus_on_goal s) + !contextual_menus_on_goal_hook s) "Contextual menus on goal" !current.contextual_menus_on_goal in - let misc = [contextual_menus_on_goal;auto_complete;stop_before;lax_syntax; + let misc = [contextual_menus_on_goal;auto_complete;stop_before; vertical_tabs;opposite_tabs] in (* ATTENTION !!!!! L'onglet Fonts doit etre en premier pour eviter un bug !!!! @@ -591,6 +667,7 @@ let configure ?(apply=(fun () -> ())) () = let cmds = [Section("Fonts", Some `SELECT_FONT, [config_font]); + Section("Colors", Some `SELECT_COLOR, [config_color]); Section("Files", Some `DIRECTORY, [global_auto_revert;global_auto_revert_delay; auto_save; auto_save_delay; (* auto_save_name*) @@ -604,9 +681,8 @@ let configure ?(apply=(fun () -> ())) () = config_appearance); *) Section("Externals", None, - [cmd_coqc;cmd_make;cmd_coqmakefile; cmd_coqdoc; cmd_print; - cmd_editor; - cmd_browse;doc_url;library_url]); + [cmd_coqtop;cmd_coqc;cmd_make;cmd_coqmakefile; cmd_coqdoc; + cmd_print;cmd_editor;cmd_browse;doc_url;library_url]); Section("Tactics Wizard", None, [automatic_tactics]); Section("Shortcuts", Some `PREFERENCES, @@ -618,7 +694,7 @@ let configure ?(apply=(fun () -> ())) () = (* Format.printf "before edit: current.text_font = %s@." (Pango.Font.to_string !current.text_font); *) - let x = edit ~apply ~width:500 "Customizations" cmds in + let x = edit ~apply "Customizations" cmds in (* Format.printf "after edit: current.text_font = %s@." (Pango.Font.to_string !current.text_font); *) diff --git a/ide/preferences.mli b/ide/preferences.mli index f55088f1..b680c6f0 100644 --- a/ide/preferences.mli +++ b/ide/preferences.mli @@ -7,9 +7,11 @@ (************************************************************************) type project_behavior = Ignore_args | Append_args | Subst_args +type inputenc = Elocale | Eutf8 | Emanual of string type pref = { + mutable cmd_coqtop : string option; mutable cmd_coqc : string; mutable cmd_make : string; mutable cmd_coqmakefile : string; @@ -25,9 +27,7 @@ type pref = mutable read_project : project_behavior; mutable project_file_name : string; - mutable encoding_use_locale : bool; - mutable encoding_use_utf8 : bool; - mutable encoding_manual : string; + mutable encoding : inputenc; mutable automatic_tactics : string list; mutable cmd_print : string; @@ -57,9 +57,12 @@ type pref = *) mutable auto_complete : bool; mutable stop_before : bool; - mutable lax_syntax : bool; mutable vertical_tabs : bool; mutable opposite_tabs : bool; + + mutable background_color : string; + mutable processing_color : string; + mutable processed_color : string; } val save_pref : unit -> unit @@ -69,9 +72,11 @@ val current : pref ref val configure : ?apply:(unit -> unit) -> unit -> unit -val change_font : ( Pango.font_description -> unit) ref -val show_toolbar : (bool -> unit) ref -val auto_complete : (bool -> unit) ref -val resize_window : (unit -> unit) ref +(* Hooks *) +val refresh_font_hook : (unit -> unit) ref +val refresh_background_color_hook : (unit -> unit) ref +val refresh_toolbar_hook : (unit -> unit) ref +val resize_window_hook : (unit -> unit) ref +val refresh_tabs_hook : (unit -> unit) ref val use_default_doc_url : string diff --git a/ide/tags.ml b/ide/tags.ml index 52ba54dc..eeace465 100644 --- a/ide/tags.ml +++ b/ide/tags.ml @@ -13,6 +13,9 @@ let make_tag (tt:GText.tag_table) ~name prop = tt#add new_tag#as_tag; new_tag +let processed_color = ref "light green" +let processing_color = ref "light blue" + module Script = struct let table = GText.tag_table () @@ -23,8 +26,8 @@ struct let comment = make_tag table ~name:"comment" [`FOREGROUND "brown"] let reserved = make_tag table ~name:"reserved" [`FOREGROUND "dark red"] let error = make_tag table ~name:"error" [`UNDERLINE `DOUBLE ; `FOREGROUND "red"] - let to_process = make_tag table ~name:"to_process" [`BACKGROUND "light blue" ;`EDITABLE false] - let processed = make_tag table ~name:"processed" [`BACKGROUND "light green" ;`EDITABLE false] + let to_process = make_tag table ~name:"to_process" [`BACKGROUND !processing_color ;`EDITABLE false] + let processed = make_tag table ~name:"processed" [`BACKGROUND !processed_color;`EDITABLE false] let unjustified = make_tag table ~name:"unjustified" [`UNDERLINE `SINGLE; `FOREGROUND "red"; `BACKGROUND "gold";`EDITABLE false] let found = make_tag table ~name:"found" [`BACKGROUND "blue"; `FOREGROUND "white"] let hidden = make_tag table ~name:"hidden" [`INVISIBLE true; `EDITABLE false] @@ -35,7 +38,7 @@ end module Proof = struct let table = GText.tag_table () - let highlight = make_tag table ~name:"highlight" [`BACKGROUND "light green"] + let highlight = make_tag table ~name:"highlight" [`BACKGROUND !processed_color] let hypothesis = make_tag table ~name:"hypothesis" [] let goal = make_tag table ~name:"goal" [] end @@ -45,3 +48,27 @@ struct let error = make_tag table ~name:"error" [`FOREGROUND "red"] end +let string_of_color clr = + let r = Gdk.Color.red clr in + let g = Gdk.Color.green clr in + let b = Gdk.Color.blue clr in + Printf.sprintf "#%04X%04X%04X" r g b + +let color_of_string s = + let colormap = Gdk.Color.get_system_colormap () in + Gdk.Color.alloc ~colormap (`NAME s) + +let get_processed_color () = color_of_string !processed_color + +let set_processed_color clr = + let s = string_of_color clr in + processed_color := s; + Script.processed#set_property (`BACKGROUND s); + Proof.highlight#set_property (`BACKGROUND s) + +let get_processing_color () = color_of_string !processing_color + +let set_processing_color clr = + let s = string_of_color clr in + processing_color := s; + Script.to_process#set_property (`BACKGROUND s) diff --git a/ide/tags.mli b/ide/tags.mli new file mode 100644 index 00000000..53a8c493 --- /dev/null +++ b/ide/tags.mli @@ -0,0 +1,50 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(*
    - -
    - - +
    + +
    + +
    + + - diff --git a/doc/common/styles/html/coqremote/header.html b/doc/common/styles/html/coqremote/header.html index afcdbe73..891fb328 100644 --- a/doc/common/styles/html/coqremote/header.html +++ b/doc/common/styles/html/coqremote/header.html @@ -6,44 +6,40 @@ Standard Library | The Coq Proof Assistant - + - - - + + + - - + +
    - - - - -
    + + + + +
    diff --git a/ide/coq.ml b/ide/coq.ml index 8b1fa0a3..07f0ece8 100644 --- a/ide/coq.ml +++ b/ide/coq.ml @@ -191,11 +191,29 @@ let coqtop_zombies () = Note: we use Unix.stderr in Unix.create_process to get debug messages from the coqtop's Ide_slave loop. + + NB: it's important to close coqide's descriptors (ide2top_w and top2ide_r) + in coqtop. We do this indirectly via [Unix.set_close_on_exec]. + This way, coqide has the only remaining copies of these descriptors, + and closing them later will have visible effects in coqtop. Cf man 7 pipe : + + - If all file descriptors referring to the write end of a pipe have been + closed, then an attempt to read(2) from the pipe will see end-of-file + (read(2) will return 0). + - If all file descriptors referring to the read end of a pipe have been + closed, then a write(2) will cause a SIGPIPE signal to be generated for + the calling process. If the calling process is ignoring this signal, + then write(2) fails with the error EPIPE. + + Symmetrically, coqtop's descriptors (ide2top_r and top2ide_w) should be + closed in coqide. *) let open_process_pid prog args = let (ide2top_r,ide2top_w) = Unix.pipe () in let (top2ide_r,top2ide_w) = Unix.pipe () in + Unix.set_close_on_exec ide2top_w; + Unix.set_close_on_exec top2ide_r; let pid = Unix.create_process prog args ide2top_r top2ide_w Unix.stderr in assert (pid <> 0); Unix.close ide2top_r; @@ -250,7 +268,7 @@ let eval_call coqtop (c:'a Ide_intf.call) = Xml_utils.print_xml coqtop.cin (Ide_intf.of_call c); flush coqtop.cin; let xml = Xml_parser.parse p (Xml_parser.SChannel coqtop.cout) in - (Ide_intf.to_answer xml : 'a Interface.value) + (Ide_intf.to_answer xml c : 'a Interface.value) let interp coqtop ?(raw=false) ?(verbose=true) s = eval_call coqtop (Ide_intf.interp (raw,verbose,s)) diff --git a/ide/coqide.ml b/ide/coqide.ml index 1bd490ab..07de4daf 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -41,14 +41,9 @@ object val mutable read_only : bool val mutable filename : string option val mutable stats : Unix.stats option - val mutable detached_views : GWindow.window list method without_auto_complete : 'a 'b. ('a -> 'b) -> 'a -> 'b method set_auto_complete : bool -> unit - method kill_detached_views : unit -> unit - method add_detached_view : GWindow.window -> unit - method remove_detached_view : GWindow.window -> unit - method filename : string option method stats : Unix.stats option method update_stats : unit @@ -104,7 +99,10 @@ type viewable_script = } let kill_session s = - s.analyzed_view#kill_detached_views (); + (* To close the detached views of this script, we call manually + [destroy] on it, triggering some callbacks in [detach_view]. + In a more modern lablgtk, rather use the page-removed signal ? *) + s.script#destroy (); Coq.kill_coqtop !(s.toplvl) let build_session s = @@ -442,6 +440,7 @@ let remove_tags (buffer:GText.buffer) from upto = Tags.Script.proof_decl; Tags.Script.qed ] (** Cut a part of the buffer in sentences and tag them. + Invariant: either this slice ends the buffer, or it ends with ".". May raise [Coq_lex.Unterminated] when the zone ends with an unterminated sentence. *) @@ -480,14 +479,18 @@ let is_char s c = s#char = Char.code c (** Search backward the first character of a sentence, starting at [iter] and going at most up to [soi] (meant to be the end of the locked zone). - Raise [Not_found] when no proper sentence start has been found, - in particular when the final "." of the locked zone is followed - by a non-blank character outside the locked zone. This non-blank - character will be signaled as erroneous in [tag_on_insert] below. *) + Raise [StartError] when no proper sentence start has been found. + A character following a ending "." is considered as a sentence start + only if this character is a blank. In particular, when a final "." + at the end of the locked zone isn't followed by a blank, then this + non-blank character will be signaled as erroneous in [tag_on_insert] below. +*) + +exception StartError let grab_sentence_start (iter:GText.iter) soi = let cond iter = - if iter#compare soi < 0 then raise Not_found; + if iter#compare soi < 0 then raise StartError; let prev = iter#backward_char in is_sentence_end prev && (not (is_char prev '.') || @@ -509,42 +512,35 @@ let rec grab_ending_dot (start:GText.iter) = (** Retag a zone that has been edited *) -let tag_on_insert = - (* possible race condition here : editing two buffers with a timedelta smaller - * than 1.5s might break the error recovery mechanism. *) - let skip_last = ref (ref true) in (* ref to the mutable flag created on last call *) - fun buffer -> - try - (* the start of the non-locked zone *) - let soi = buffer#get_iter_at_mark (`NAME "start_of_input") in - (* the inserted zone is between [prev_insert] and [insert] *) - let insert = buffer#get_iter_at_mark `INSERT in - let prev_insert = buffer#get_iter_at_mark (`NAME "prev_insert") in - (* [prev_insert] is normally always before [insert] even when deleting. - Let's check this nonetheless *) - let prev_insert = - if insert#compare prev_insert < 0 then insert else prev_insert - in - let start = grab_sentence_start prev_insert soi in - (** The status of "{" "}" as sentence delimiters is too fragile. - We retag up to the next "." instead. *) - let stop = grab_ending_dot insert in - let skip_curr = ref true in (* shall the callback be skipped ? by default yes*) - (!skip_last) := true; (* skip the previously created callback *) - skip_last := skip_curr; - try split_slice_lax buffer start stop - with Coq_lex.Unterminated -> - skip_curr := false; - let callback () = - if not !skip_curr then begin - try split_slice_lax buffer start buffer#end_iter - with Coq_lex.Unterminated -> () - end; false - in - ignore (Glib.Timeout.add ~ms:1500 ~callback) - with Not_found -> - let err_pos = buffer#get_iter_at_mark (`NAME "start_of_input") in - buffer#apply_tag Tags.Script.error ~start:err_pos ~stop:err_pos#forward_char +let tag_on_insert buffer = + (* the start of the non-locked zone *) + let soi = buffer#get_iter_at_mark (`NAME "start_of_input") in + (* the inserted zone is between [prev_insert] and [insert] *) + let insert = buffer#get_iter_at_mark `INSERT in + let prev = buffer#get_iter_at_mark (`NAME "prev_insert") in + (* [prev] is normally always before [insert] even when deleting. + Let's check this nonetheless *) + let prev, insert = + if insert#compare prev < 0 then insert, prev else prev, insert + in + try + let start = grab_sentence_start prev soi in + (** The status of "{" "}" as sentence delimiters is too fragile. + We retag up to the next "." instead. *) + let stop = grab_ending_dot insert in + try split_slice_lax buffer start stop + with Coq_lex.Unterminated -> + (* This shouldn't happen frequently. Either: + - we are at eof, with indeed an unfinished sentence. + - we have just inserted an opening of comment or string. + - the inserted text ends with a "." that interacts with the "." + found by [grab_ending_dot] to form a non-ending "..". + In any case, we retag up to eof, since this isn't that costly. *) + if not stop#is_end then + try split_slice_lax buffer start buffer#end_iter + with Coq_lex.Unterminated -> () + with StartError -> + buffer#apply_tag Tags.Script.error ~start:soi ~stop:soi#forward_char let force_retag buffer = try split_slice_lax buffer buffer#start_iter buffer#end_iter @@ -591,7 +587,6 @@ object(self) val mutable stats = None val mutable last_modification_time = 0. val mutable last_auto_save_time = 0. - val mutable detached_views = [] val mutable find_forward_instead_of_backward = false val mutable auto_complete_on = !current.auto_complete @@ -606,14 +601,6 @@ object(self) let y = f x in self#set_auto_complete old; y - method add_detached_view (w:GWindow.window) = - detached_views <- w::detached_views - method remove_detached_view (w:GWindow.window) = - detached_views <- List.filter (fun e -> w#misc#get_oid<>e#misc#get_oid) detached_views - - method kill_detached_views () = - List.iter (fun w -> w#destroy ()) detached_views; - detached_views <- [] method filename = filename method stats = stats @@ -820,7 +807,7 @@ object(self) begin let menu_callback = if !current.contextual_menus_on_goal then (fun s () -> ignore (self#insert_this_phrase_on_success - true true false ("progress "^s) s)) + true true false ("progress "^s) s)) else (fun _ _ -> ()) in try @@ -1007,6 +994,7 @@ object(self) if stop#starts_line then input_buffer#insert ~iter:stop insertphrase else input_buffer#insert ~iter:stop ("\n"^insertphrase); + tag_on_insert input_buffer; let start = self#get_start_of_input in input_buffer#move_mark ~where:stop (`NAME "start_of_input"); input_buffer#apply_tag (safety_tag safe) ~start ~stop; @@ -1231,7 +1219,7 @@ object(self) (List.exists (fun p -> self#insert_this_phrase_on_success true false false - ("progress "^p^".\n") (p^".\n")) l) + ("progress "^p^".") (p^".")) l) method active_keypress_handler k = let state = GdkEvent.Key.state k in @@ -1382,23 +1370,15 @@ object(self) ); ignore (input_buffer#connect#begin_user_action ~callback:(fun () -> - let here = input_buffer#get_iter_at_mark `INSERT in - input_buffer#move_mark (`NAME "prev_insert") here - ) + let where = self#get_insert in + input_buffer#move_mark (`NAME "prev_insert") ~where; + let start = self#get_start_of_input in + let stop = input_buffer#end_iter in + input_buffer#remove_tag Tags.Script.error ~start ~stop) ); ignore (input_buffer#connect#end_user_action ~callback:(fun () -> last_modification_time <- Unix.time (); - let r = input_view#visible_rect in - let stop = - input_view#get_iter_at_location - ~x:(Gdk.Rectangle.x r + Gdk.Rectangle.width r) - ~y:(Gdk.Rectangle.y r + Gdk.Rectangle.height r) - in - input_buffer#remove_tag - Tags.Script.error - ~start:self#get_start_of_input - ~stop; tag_on_insert input_buffer ) ); @@ -1795,6 +1775,8 @@ let forbid_quit_to_save () = end else false) +let logfile = ref None + let main files = (* Main window *) @@ -2354,7 +2336,7 @@ let main files = let tactic_shortcut s sc = GAction.add_action s ~label:("_"^s) ~accel:(!current.modifier_for_tactics^sc) ~callback:(do_if_active (fun a -> a#insert_command - ("progress "^s^".\n") (s^".\n"))) in + ("progress "^s^".") (s^"."))) in let query_callback command _ = let word = get_current_word () in if not (word = "") then @@ -2380,6 +2362,24 @@ let main files = match key with |Some ac -> GAction.add_action name ~label ~callback ~accel:(!current.modifier_for_templates^ac) |None -> GAction.add_action name ~label ~callback ?accel:None + in + let detach_view _ = + (* Open a separate window containing the current buffer *) + let trm = session_notebook#current_term in + let w = GWindow.window ~show:true + ~width:(!current.window_width*2/3) + ~height:(!current.window_height*2/3) + ~position:`CENTER + ~title:(if trm.filename = "" then "*scratch*" else trm.filename) + () + in + let sb = GBin.scrolled_window ~packing:w#add () + in + let nv = GText.view ~buffer:trm.script#buffer ~packing:sb#add () + in + nv#misc#modify_font !current.text_font; + (* If the buffer in the main window is closed, destroy this detached view *) + ignore (trm.script#connect#destroy ~callback:w#destroy) in GAction.add_actions file_actions [ GAction.add_action "File" ~label:"_File"; @@ -2568,33 +2568,7 @@ let main files = ]; GAction.add_actions windows_actions [ GAction.add_action "Windows" ~label:"_Windows"; - GAction.add_action "Detach View" ~label:"Detach _View" - ~callback:(fun _ -> do_if_not_computing "detach view" - (function {script=v;analyzed_view=av} -> - let w = GWindow.window ~show:true - ~width:(!current.window_width*2/3) - ~height:(!current.window_height*2/3) - ~position:`CENTER - ~title:(match av#filename with - | None -> "*Unnamed*" - | Some f -> f) - () - in - let sb = GBin.scrolled_window - ~packing:w#add () - in - let nv = GText.view - ~buffer:v#buffer - ~packing:sb#add - () - in - nv#misc#modify_font - !current.text_font; - ignore (w#connect#destroy - ~callback: - (fun () -> av#remove_detached_view w)); - av#add_detached_view w) - [session_notebook#current_term]); + GAction.add_action "Detach View" ~label:"Detach _View" ~callback:detach_view ]; GAction.add_actions help_actions [ GAction.add_action "Help" ~label:"_Help"; @@ -2846,12 +2820,17 @@ let main files = \n-------------------\ \n" in + let display_log_file (b:GText.buffer) = + if !debug then + let file = match !logfile with None -> "stderr" | Some f -> f in + b#insert ("Debug mode is on, log file is "^file) + in let initial_about (b:GText.buffer) = let initial_string = "Welcome to CoqIDE, an Integrated Development Environment for Coq\n" in let coq_version = Coq.short_version () in - b#insert ~iter:b#start_iter "\n\n"; + display_log_file b; if Glib.Utf8.validate ("You are running " ^ coq_version) then b#insert ~iter:b#start_iter ("You are running " ^ coq_version); if Glib.Utf8.validate initial_string then @@ -2881,8 +2860,8 @@ let main files = then b#insert about_full_string; let coq_version = Coq.version () in if Glib.Utf8.validate coq_version - then b#insert coq_version - + then b#insert coq_version; + display_log_file b; in (* Remove default pango menu for textviews *) w#show (); diff --git a/ide/coqide.mli b/ide/coqide.mli index 18df1f6a..44de77f7 100644 --- a/ide/coqide.mli +++ b/ide/coqide.mli @@ -12,6 +12,9 @@ no /bin/sh when using create_process instead of open_process. *) val sup_args : string list ref +(** In debug mode under win32, messages are written to a log file *) +val logfile : string option ref + (** Filter the argv from coqide specific options, and set Minilib.coqtop_path accordingly *) val read_coqide_args : string list -> string list diff --git a/ide/coqide_main.ml4 b/ide/coqide_main.ml4 index f5138311..ebcecc17 100644 --- a/ide/coqide_main.ml4 +++ b/ide/coqide_main.ml4 @@ -6,18 +6,37 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -IFDEF QUARTZ THEN -external gtk_mac_init : (string -> unit) -> (unit -> bool) -> unit - = "caml_gtk_mac_init" +let _ = Coqide.ignore_break () +let _ = GtkMain.Main.init () -external gtk_mac_ready : ([> Gtk.widget ] as 'a) Gtk.obj -> ([> Gtk.widget ] as 'a) Gtk.obj -> - ([> Gtk.widget ] as 'a) Gtk.obj -> unit - = "caml_gtk_mac_ready" -END +(* We handle Gtk warning messages ourselves : + - on win32, we don't want them to end on a non-existing console + - we display critical messages via pop-ups *) -let initmac () = IFDEF QUARTZ THEN gtk_mac_init Coqide.do_load Coqide.forbid_quit_to_save ELSE () END +let catch_gtk_messages () = + let all_levels = + [`FLAG_RECURSION;`FLAG_FATAL;`ERROR;`CRITICAL;`WARNING; + `MESSAGE;`INFO;`DEBUG] + in + let handler ~level msg = + let header = "Coqide internal error: " in + let level_is tag = (level land Glib.Message.log_level tag) <> 0 in + if level_is `ERROR then + let () = GToolbox.message_box ~title:"Error" (header ^ msg) in + Coqide.crash_save 1 + else if level_is `CRITICAL then + GToolbox.message_box ~title:"Error" (header ^ msg) + else if level_is `DEBUG || Sys.os_type = "Win32" then + Ideutils.prerr_endline msg (* no-op unless in debug mode *) + else + Printf.eprintf "%s\n" msg + in + let catch domain = + ignore (Glib.Message.set_log_handler ~domain ~levels:all_levels handler) + in + List.iter catch ["GLib";"Gtk";"Gdk";"Pango"] -let macready x y z = IFDEF QUARTZ THEN gtk_mac_ready x#as_widget y#as_widget z#as_widget ELSE () END +let () = catch_gtk_messages () (* On win32, we add the directory of coqide to the PATH at launch-time (this used to be done in a .bat script). *) @@ -33,12 +52,18 @@ let set_win32_path () = *) let reroute_stdout_stderr () = + (* We anticipate a bit the argument parsing and look for -debug *) + let debug = List.mem "-debug" (Array.to_list Sys.argv) in + Ideutils.debug := debug; let out_descr = - if !Ideutils.debug then - Unix.descr_of_out_channel (snd (Filename.open_temp_file "coqide_" ".log")) + if debug then + let (name,chan) = Filename.open_temp_file "coqide_" ".log" in + Coqide.logfile := Some name; + Unix.descr_of_out_channel chan else snd (Unix.pipe ()) in + Unix.set_close_on_exec out_descr; Unix.dup2 out_descr Unix.stdout; Unix.dup2 out_descr Unix.stderr @@ -64,10 +89,17 @@ let () = reroute_stdout_stderr () END +IFDEF QUARTZ THEN + let osx = GosxApplication.osxapplication () + + let _ = + osx#connect#ns_application_open_file ~callback:(fun x -> Coqide.do_load x; true) in + let _ = + osx#connect#ns_application_block_termination ~callback:Coqide.forbid_quit_to_save in + () +END + let () = - Coqide.ignore_break (); - ignore (GtkMain.Main.init ()); - initmac () ; (try let gtkrcdir = List.find (fun x -> Sys.file_exists (Filename.concat x "coqide-gtk2rc")) @@ -82,13 +114,6 @@ let () = end; (* GtkData.AccelGroup.set_default_mod_mask (Some [`CONTROL;`SHIFT;`MOD1;`MOD3;`MOD4]);*) - ignore ( - Glib.Message.set_log_handler ~domain:"Gtk" ~levels:[`ERROR;`FLAG_FATAL; - `WARNING;`CRITICAL] - (fun ~level msg -> - if level land Glib.Message.log_level `WARNING <> 0 - then Printf.eprintf "Warning: %s\n" msg - else failwith ("Coqide internal error: " ^ msg))); let argl = Array.to_list Sys.argv in let argl = Coqide.read_coqide_args argl in let files = Coq.filter_coq_opts (List.tl argl) in @@ -96,9 +121,18 @@ let () = Coq.check_connection args; Coqide.sup_args := args; Coqide.main files; - if !Coq_config.with_geoproof then ignore (Thread.create Coqide.check_for_geoproof_input ()); - macready (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar") (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar/Edit/Prefs") - (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar/Help/Abt"); + if !Coq_config.with_geoproof then ignore (Thread.create Coqide.check_for_geoproof_input ()) + +IFDEF QUARTZ THEN + let () = + GtkosxApplication.Application.set_menu_bar osx#as_osxapplication (GtkMenu.MenuShell.cast (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar")#as_widget) in + let () = + GtkosxApplication.Application.insert_app_menu_item osx#as_osxapplication (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar/Edit/Prefs")#as_widget 1 in + let () = + GtkosxApplication.Application.set_help_menu osx#as_osxapplication (Some (GtkMenu.MenuItem.cast (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar/Help")#as_widget)) in + osx#ready () +END + while true do try GtkThread.main () diff --git a/ide/ide_mac_stubs.c b/ide/ide_mac_stubs.c deleted file mode 100644 index 2aeb2bf4..00000000 --- a/ide/ide_mac_stubs.c +++ /dev/null @@ -1,85 +0,0 @@ -#include -#include -#include -#include -#include - -#include -#include -#include -#include -#include - -GtkOSXApplication *theApp; -value open_file_fun, forbid_quit_fun, themenubar, pref_item, about_item; - -static void osx_accel_map_foreach_lcb(gpointer data,const gchar *accel_path, - guint accel_key, GdkModifierType accel_mods, - gboolean changed) { - if (accel_mods & GDK_CONTROL_MASK) { - accel_mods |= GDK_META_MASK; - accel_mods &= (accel_mods & GDK_MOD1_MASK) ? ~GDK_MOD1_MASK : ~GDK_CONTROL_MASK; - if (!gtk_accel_map_change_entry(accel_path,accel_key,accel_mods,FALSE)) { - g_print("could not change accelerator %s\n",accel_path); - } - } - if (accel_mods & GDK_MOD1_MASK) { - accel_mods &= ~ GDK_MOD1_MASK; - accel_mods |= GDK_CONTROL_MASK; - if (!gtk_accel_map_change_entry(accel_path,accel_key,accel_mods,FALSE)) { - g_print("could not change accelerator %s\n",accel_path); - } - } -} - -static gboolean deal_with_open(GtkOSXApplication *app, gchar *path, gpointer user_data) -{ - CAMLparam0(); - CAMLlocal2(string_path, res); - string_path = caml_copy_string(path); - res = caml_callback_exn(open_file_fun,string_path); - gboolean truc = !(Is_exception_result(res)); - CAMLreturnT(gboolean, truc); -} - -static gboolean deal_with_quit(GtkOSXApplication *app, gpointer user_data) -{ - CAMLparam0(); - CAMLlocal1(res); - res = caml_callback_exn(forbid_quit_fun,Val_unit); - gboolean truc = (Bool_val(res))||((Is_exception_result(res))); - CAMLreturnT(gboolean, truc); -} - -CAMLprim value caml_gtk_mac_init(value open_file_the_fun, value forbid_quit_the_fun) -{ - CAMLparam2(open_file_the_fun,forbid_quit_the_fun); - open_file_fun = open_file_the_fun; - caml_register_generational_global_root(&open_file_fun); - forbid_quit_fun = forbid_quit_the_fun; - caml_register_generational_global_root(&forbid_quit_fun); - theApp = g_object_new(GTK_TYPE_OSX_APPLICATION, NULL); - g_signal_connect(theApp, "NSApplicationOpenFile", G_CALLBACK(deal_with_open), NULL); - g_signal_connect(theApp, "NSApplicationBlockTermination", G_CALLBACK(deal_with_quit), NULL); - CAMLreturn (Val_unit); -} - -CAMLprim value caml_gtk_mac_ready(value menubar, value prefs, value about) -{ - GtkOSXApplicationMenuGroup * pref_grp, * about_grp; - CAMLparam3(menubar,prefs,about); - themenubar = menubar; - pref_item = prefs; - about_item = about; - caml_register_generational_global_root(&themenubar); - caml_register_generational_global_root(&pref_item); - caml_register_generational_global_root(&about_item); - /* gtk_accel_map_foreach(NULL, osx_accel_map_foreach_lcb);*/ - gtk_osxapplication_set_menu_bar(theApp,check_cast(GTK_MENU_SHELL,themenubar)); - gtk_osxapplication_insert_app_menu_item(theApp,check_cast(GTK_WIDGET,about_item),1); - gtk_osxapplication_insert_app_menu_item(theApp,gtk_separator_menu_item_new(),2); - gtk_osxapplication_insert_app_menu_item(theApp,check_cast(GTK_WIDGET,pref_item),3); - gtk_osxapplication_insert_app_menu_item(theApp,gtk_separator_menu_item_new(),4); - gtk_osxapplication_ready(theApp); - CAMLreturn(Val_unit); -} diff --git a/ide/preferences.ml b/ide/preferences.ml index 17216b92..2fb5023f 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -35,6 +35,10 @@ let mod_to_str (m:Gdk.Tags.modifier) = | `MOD5 -> "" | `CONTROL -> "" | `SHIFT -> "" + | `HYPER -> "" + | `META -> "" + | `RELEASE -> "" + | `SUPER -> "" | `BUTTON1| `BUTTON2| `BUTTON3| `BUTTON4| `BUTTON5| `LOCK -> "" let mod_list_to_str l = List.fold_left (fun s m -> (mod_to_str m)^s) "" l diff --git a/ide/utils/okey.ml b/ide/utils/okey.ml index 57939266..905c3485 100644 --- a/ide/utils/okey.ml +++ b/ide/utils/okey.ml @@ -47,6 +47,10 @@ let int_of_modifier = function | `BUTTON3 -> 1024 | `BUTTON4 -> 2048 | `BUTTON5 -> 4096 + | `HYPER -> 1 lsl 22 + | `META -> 1 lsl 20 + | `RELEASE -> 1 lsl 30 + | `SUPER -> 1 lsl 21 let print_modifier l = List.iter @@ -65,7 +69,11 @@ let print_modifier l = | `BUTTON2 -> "B2" | `BUTTON3 -> "B3" | `BUTTON4 -> "B4" - | `BUTTON5 -> "B5") + | `BUTTON5 -> "B5" + | `HYPER -> "HYPER" + | `META -> "META" + | `RELEASE -> "" + | `SUPER -> "SUPER") m)^" ") ) l; diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 19e1fef5..20b9c2a3 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -250,7 +250,9 @@ and check_same_fix_binder bl1 bl2 = check_same_binder ([na1],default_binder_kind,def1) ([na2],default_binder_kind,def2) | _ -> failwith "not same binder") bl1 bl2 -let is_same_type c d = try let () = check_same_type c d in true with Failure _ -> false +let is_same_type c d = + try let () = check_same_type c d in true + with Failure _ | Invalid_argument _ -> false (**********************************************************************) (* mapping patterns to cases_pattern_expr *) @@ -374,11 +376,12 @@ and extern_symbol_pattern (tmp_scope,scopes as allscopes) vars t = function | (keyrule,pat,n as _rule)::rules -> try match t,n with - | PatCstr (loc,(ind,_),l,na), n when n = Some 0 or n = None or - n = Some(fst(Global.lookup_inductive ind)).Declarations.mind_nparams -> + | PatCstr (loc,(ind,_),l,na), n when (n = Some 0 or n = None or + n = Some(fst(Global.lookup_inductive ind)).Declarations.mind_nparams) + && (match keyrule with SynDefRule _ -> true | _ -> false) -> (* Abbreviation for the constructor name only *) (match keyrule with - | NotationRule (sc,ntn) -> raise No_match + | NotationRule _ -> assert false | SynDefRule kn -> let qid = Qualid (loc, shortest_qualid_of_syndef vars kn) in let l = List.map (extern_cases_pattern_in_scope allscopes vars) l in diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 45df005c..81e4501a 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -1411,7 +1411,8 @@ let internalize sigma globalenv env allow_patvar lvar c = | None -> [], None in let na = match tm', na with - | GVar (loc,id), None when Idset.mem id env.ids -> loc,Name id + | GVar (loc,id), None when not (List.mem_assoc id (snd lvar)) -> + loc,Name id | GRef (loc, VarRef id), None -> loc,Name id | _, None -> dummy_loc,Anonymous | _, Some (loc,na) -> loc,na in diff --git a/kernel/univ.ml b/kernel/univ.ml index 6aeb7390..028eaeb4 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -125,9 +125,12 @@ let sup u v = (* Comparison on this type is pointer equality *) type canonical_arc = - { univ: UniverseLevel.t; lt: UniverseLevel.t list; le: UniverseLevel.t list } + { univ: UniverseLevel.t; + lt: UniverseLevel.t list; + le: UniverseLevel.t list; + rank: int } -let terminal u = {univ=u; lt=[]; le=[]} +let terminal u = {univ=u; lt=[]; le=[]; rank=0} (* A UniverseLevel.t is either an alias for another one, or a canonical one, for which we know the universes that are above *) @@ -405,24 +408,46 @@ let setleq_if (g,arcu) v = (* we assume compare(u,v) = LE *) (* merge u v forces u ~ v with repr u as canonical repr *) let merge g arcu arcv = - match between g arcu arcv with - | arcu::v -> (* arcu is chosen as canonical and all others (v) are *) - (* redirected to it *) - let redirect (g,w,w') arcv = - let g' = enter_equiv_arc arcv.univ arcu.univ g in - (g',list_unionq arcv.lt w,arcv.le@w') - in - let (g',w,w') = List.fold_left redirect (g,[],[]) v in - let g_arcu = (g',arcu) in - let g_arcu = List.fold_left setlt_if g_arcu w in - let g_arcu = List.fold_left setleq_if g_arcu w' in - fst g_arcu - | [] -> anomaly "Univ.between" + (* we find the arc with the biggest rank, and we redirect all others to it *) + let arcu, g, v = + let best_ranked (max_rank, old_max_rank, best_arc, rest) arc = + if arc.rank >= max_rank + then (arc.rank, max_rank, arc, best_arc::rest) + else (max_rank, old_max_rank, best_arc, arc::rest) + in + match between g arcu arcv with + | [] -> anomaly "Univ.between" + | arc::rest -> + let (max_rank, old_max_rank, best_arc, rest) = + List.fold_left best_ranked (arc.rank, min_int, arc, []) rest in + if max_rank > old_max_rank then best_arc, g, rest + else begin + (* one redirected node also has max_rank *) + let arcu = {best_arc with rank = max_rank + 1} in + arcu, enter_arc arcu g, rest + end + in + let redirect (g,w,w') arcv = + let g' = enter_equiv_arc arcv.univ arcu.univ g in + (g',list_unionq arcv.lt w,arcv.le@w') + in + let (g',w,w') = List.fold_left redirect (g,[],[]) v in + let g_arcu = (g',arcu) in + let g_arcu = List.fold_left setlt_if g_arcu w in + let g_arcu = List.fold_left setleq_if g_arcu w' in + fst g_arcu (* merge_disc : UniverseLevel.t -> UniverseLevel.t -> unit *) (* we assume compare(u,v) = compare(v,u) = NLE *) (* merge_disc u v forces u ~ v with repr u as canonical repr *) -let merge_disc g arcu arcv = +let merge_disc g arc1 arc2 = + let arcu, arcv = if arc1.rank < arc2.rank then arc2, arc1 else arc1, arc2 in + let arcu, g = + if arc1.rank <> arc2.rank then arcu, g + else + let arcu = {arcu with rank = succ arcu.rank} in + arcu, enter_arc arcu g + in let g' = enter_equiv_arc arcv.univ arcu.univ g in let g_arcu = (g',arcu) in let g_arcu = List.fold_left setlt_if g_arcu arcv.lt in @@ -563,7 +588,7 @@ let normalize_universes g = in let canonicalize u = function | Equiv _ -> Equiv (repr u) - | Canonical {univ=v; lt=lt; le=le} -> + | Canonical {univ=v; lt=lt; le=le; rank=rank} -> assert (u == v); (* avoid duplicates and self-loops *) let lt = lrepr lt and le = lrepr le in @@ -575,6 +600,7 @@ let normalize_universes g = univ = v; lt = UniverseLSet.elements lt; le = UniverseLSet.elements le; + rank = rank } in UniverseLMap.mapi canonicalize g @@ -632,7 +658,8 @@ let bellman_ford bottom g = let node = Canonical { univ = bottom; lt = []; - le = UniverseLSet.elements vertices + le = UniverseLSet.elements vertices; + rank = 0 } in UniverseLMap.add bottom node g in let rec iter count accu = @@ -692,12 +719,12 @@ let sort_universes orig = | false, true -> push res v | false, false -> res end - | Canonical {univ=v; lt=lt; le=le} -> + | Canonical {univ=v; lt=lt; le=le; rank=r} -> assert (u == v); if filter u then let lt = List.filter filter lt in let le = List.filter filter le in - UniverseLMap.add u (Canonical {univ=u; lt=lt; le=le}) res + UniverseLMap.add u (Canonical {univ=u; lt=lt; le=le; rank=r}) res else let res = List.fold_left (fun g u -> if filter u then push g u else g) res lt in let res = List.fold_left (fun g u -> if filter u then push g u else g) res le in @@ -717,7 +744,8 @@ let sort_universes orig = let g = UniverseLMap.add u (Canonical { univ = u; le = []; - lt = [types.(i+1)] + lt = [types.(i+1)]; + rank = 1 }) g in aux (i+1) g else g in aux 0 g diff --git a/lib/xml_parser.ml b/lib/xml_parser.ml index bf931d75..19bab4f6 100644 --- a/lib/xml_parser.ml +++ b/lib/xml_parser.ml @@ -42,6 +42,7 @@ type error_msg = | AttributeValueExpected | EndOfTagExpected of string | EOFExpected + | Empty type error = error_msg * error_pos @@ -117,13 +118,13 @@ let rec read_node s = | Xml_lexer.PCData s -> PCData s | Xml_lexer.Tag (tag, attr, true) -> Element (tag, attr, []) | Xml_lexer.Tag (tag, attr, false) -> - let elements = read_elems ~tag s in + let elements = read_elems tag s in Element (tag, attr, canonicalize elements) | t -> push t s; raise NoMoreData and - read_elems ?tag s = + read_elems tag s = let elems = ref [] in (try while true do @@ -137,12 +138,8 @@ and with NoMoreData -> ()); match pop s with - | Xml_lexer.Endtag s when Some s = tag -> List.rev !elems - | Xml_lexer.Eof when tag = None -> List.rev !elems - | t -> - match tag with - | None -> raise (Internal_error EOFExpected) - | Some s -> raise (Internal_error (EndOfTagExpected s)) + | Xml_lexer.Endtag s when s = tag -> List.rev !elems + | t -> raise (Internal_error (EndOfTagExpected tag)) let rec read_xml s = let node = read_node s in @@ -162,24 +159,25 @@ let convert = function | Xml_lexer.EAttributeValueExpected -> AttributeValueExpected | Xml_lexer.EUnterminatedEntity -> UnterminatedEntity +let error_of_exn stk = function + | NoMoreData when Stack.pop stk = Xml_lexer.Eof -> Empty + | NoMoreData -> NodeExpected + | Internal_error e -> e + | Xml_lexer.Error e -> convert e + | e -> raise e + let do_parse xparser source = + let stk = Stack.create() in try Xml_lexer.init source; - let s = { source = source; xparser = xparser; stack = Stack.create(); } in + let s = { source = source; xparser = xparser; stack = stk } in let x = read_xml s in if xparser.check_eof && pop s <> Xml_lexer.Eof then raise (Internal_error EOFExpected); Xml_lexer.close source; x - with - | NoMoreData -> - Xml_lexer.close source; - raise (!xml_error NodeExpected source) - | Internal_error e -> - Xml_lexer.close source; - raise (!xml_error e source) - | Xml_lexer.Error e -> - Xml_lexer.close source; - raise (!xml_error (convert e) source) + with e -> + Xml_lexer.close source; + raise (!xml_error (error_of_exn stk e) source) let parse p = function | SChannel ch -> do_parse p (Lexing.from_channel ch) @@ -208,6 +206,7 @@ let error_msg = function | AttributeValueExpected -> "Attribute value expected" | EndOfTagExpected tag -> sprintf "End of tag expected : '%s'" tag | EOFExpected -> "End of file expected" + | Empty -> "Empty" let error (msg,pos) = if pos.emin = pos.emax then diff --git a/lib/xml_parser.mli b/lib/xml_parser.mli index e3e7ac4d..cc9bcd33 100644 --- a/lib/xml_parser.mli +++ b/lib/xml_parser.mli @@ -59,6 +59,7 @@ type error_msg = | AttributeValueExpected | EndOfTagExpected of string | EOFExpected + | Empty type error = error_msg * error_pos diff --git a/myocamlbuild.ml b/myocamlbuild.ml index c866356a..184985b5 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -422,9 +422,9 @@ let extra_rules () = begin if not w32 then N else S ([A"-camlbin";A w32bin;A "-ccopt";P w32ico]) in if opt then rule fo ~prod:fo ~deps:(depsall@depso) ~insert:`top - (cmd [P coqmktop_boot;w32flag;A"-boot";A"-opt";incl fo;A"-o";Px fo]); + (cmd [P coqmktop_boot;w32flag;A"-boot";A"-opt";incl fo;camlp4incl;A"-o";Px fo]); rule fb ~prod:fb ~deps:(depsall@depsb) ~insert:`top - (cmd [P coqmktop_boot;w32flag;A"-boot";A"-top";incl fb;A"-o";Px fb]); + (cmd [P coqmktop_boot;w32flag;A"-boot";A"-top";incl fb;camlp4incl;A"-o";Px fb]); in (** Coq files dependencies *) diff --git a/parsing/pptactic.ml b/parsing/pptactic.ml index 3720eb20..17ef9f85 100644 --- a/parsing/pptactic.ml +++ b/parsing/pptactic.ml @@ -260,7 +260,14 @@ let rec pr_generic prc prlc prtac prpat x = let rec tacarg_using_rule_token pr_gen = function | Some s :: l, al -> str s :: tacarg_using_rule_token pr_gen (l,al) - | None :: l, a :: al -> pr_gen a :: tacarg_using_rule_token pr_gen (l,al) + | None :: l, a :: al -> + let print_it = + match genarg_tag a with + | OptArgType _ -> fold_opt (fun _ -> true) false a + | _ -> true + in + let r = tacarg_using_rule_token pr_gen (l,al) in + if print_it then pr_gen a :: r else r | [], [] -> [] | _ -> failwith "Inconsistent arguments of extended tactic" @@ -423,7 +430,7 @@ let pr_clauses default_is_concl pr_id = function (if occs = no_occurrences_expr then mt () else pr_with_occurrences (fun () -> str" |- *") (occs,()))) -let pr_orient b = if b then mt () else str " <-" +let pr_orient b = if b then mt () else str "<- " let pr_multi = function | Precisely 1 -> mt () @@ -806,17 +813,17 @@ and pr_atom1 = function (* Equivalence relations *) | TacReflexivity as x -> pr_atom0 x - | TacSymmetry cls -> str "symmetry " ++ pr_clauses (Some true) pr_ident cls + | TacSymmetry cls -> str "symmetry" ++ pr_clauses (Some true) pr_ident cls | TacTransitivity (Some c) -> str "transitivity" ++ pr_constrarg c | TacTransitivity None -> str "etransitivity" (* Equality and inversion *) | TacRewrite (ev,l,cl,by) -> - hov 1 (str (with_evars ev "rewrite") ++ + hov 1 (str (with_evars ev "rewrite") ++ spc () ++ prlist_with_sep (fun () -> str ","++spc()) (fun (b,m,c) -> - pr_orient b ++ spc() ++ pr_multi m ++ pr_with_bindings c) + pr_orient b ++ pr_multi m ++ pr_with_bindings c) l ++ pr_clauses (Some true) pr_ident cl ++ (match by with Some by -> pr_by_tactic (pr_tac_level ltop) by | None -> mt())) diff --git a/plugins/extraction/ExtrOcamlNatInt.v b/plugins/extraction/ExtrOcamlNatInt.v index fd134899..956ece79 100644 --- a/plugins/extraction/ExtrOcamlNatInt.v +++ b/plugins/extraction/ExtrOcamlNatInt.v @@ -14,6 +14,10 @@ Require Import ExtrOcamlBasic. (** Disclaimer: trying to obtain efficient certified programs by extracting [nat] into [int] is definitively *not* a good idea: + - This is just a syntactic adaptation, many things can go wrong, + such as name captures (e.g. if you have a constant named "int" + in your development, or a module named "Pervasives"). See bug #2878. + - Since [int] is bounded while [nat] is (theoretically) infinite, you have to make sure by yourself that your program will not manipulate numbers greater than [max_int]. Otherwise you should @@ -34,17 +38,17 @@ Require Import ExtrOcamlBasic. (** Mapping of [nat] into [int]. The last string corresponds to a [nat_case], see documentation of [Extract Inductive]. *) -Extract Inductive nat => int [ "0" "succ" ] +Extract Inductive nat => int [ "0" "Pervasives.succ" ] "(fun fO fS n -> if n=0 then fO () else fS (n-1))". (** Efficient (but uncertified) versions for usual [nat] functions *) Extract Constant plus => "(+)". -Extract Constant pred => "fun n -> max 0 (n-1)". -Extract Constant minus => "fun n m -> max 0 (n-m)". +Extract Constant pred => "fun n -> Pervasives.max 0 (n-1)". +Extract Constant minus => "fun n m -> Pervasives.max 0 (n-m)". Extract Constant mult => "( * )". -Extract Inlined Constant max => max. -Extract Inlined Constant min => min. +Extract Inlined Constant max => "Pervasives.max". +Extract Inlined Constant min => "Pervasives.min". (*Extract Inlined Constant nat_beq => "(=)".*) Extract Inlined Constant EqNat.beq_nat => "(=)". Extract Inlined Constant EqNat.eq_nat_decide => "(=)". diff --git a/plugins/extraction/ExtrOcamlZInt.v b/plugins/extraction/ExtrOcamlZInt.v index c8c40e73..ab634329 100644 --- a/plugins/extraction/ExtrOcamlZInt.v +++ b/plugins/extraction/ExtrOcamlZInt.v @@ -34,12 +34,12 @@ Extract Inductive N => int [ "0" "" ] (** Efficient (but uncertified) versions for usual functions *) Extract Constant Pos.add => "(+)". -Extract Constant Pos.succ => "succ". -Extract Constant Pos.pred => "fun n -> max 1 (n-1)". -Extract Constant Pos.sub => "fun n m -> max 1 (n-m)". +Extract Constant Pos.succ => "Pervasives.succ". +Extract Constant Pos.pred => "fun n -> Pervasives.max 1 (n-1)". +Extract Constant Pos.sub => "fun n m -> Pervasives.max 1 (n-m)". Extract Constant Pos.mul => "( * )". -Extract Constant Pos.min => "min". -Extract Constant Pos.max => "max". +Extract Constant Pos.min => "Pervasives.min". +Extract Constant Pos.max => "Pervasives.max". Extract Constant Pos.compare => "fun x y -> if x=y then Eq else if x @@ -47,12 +47,12 @@ Extract Constant Pos.compare_cont => Extract Constant N.add => "(+)". -Extract Constant N.succ => "succ". -Extract Constant N.pred => "fun n -> max 0 (n-1)". -Extract Constant N.sub => "fun n m -> max 0 (n-m)". +Extract Constant N.succ => "Pervasives.succ". +Extract Constant N.pred => "fun n -> Pervasives.max 0 (n-1)". +Extract Constant N.sub => "fun n m -> Pervasives.max 0 (n-m)". Extract Constant N.mul => "( * )". -Extract Constant N.min => "min". -Extract Constant N.max => "max". +Extract Constant N.min => "Pervasives.min". +Extract Constant N.max => "Pervasives.max". Extract Constant N.div => "fun a b -> if b=0 then 0 else a/b". Extract Constant N.modulo => "fun a b -> if b=0 then a else a mod b". Extract Constant N.compare => @@ -60,19 +60,19 @@ Extract Constant N.compare => Extract Constant Z.add => "(+)". -Extract Constant Z.succ => "succ". -Extract Constant Z.pred => "pred". +Extract Constant Z.succ => "Pervasives.succ". +Extract Constant Z.pred => "Pervasives.pred". Extract Constant Z.sub => "(-)". Extract Constant Z.mul => "( * )". Extract Constant Z.opp => "(~-)". -Extract Constant Z.abs => "abs". -Extract Constant Z.min => "min". -Extract Constant Z.max => "max". +Extract Constant Z.abs => "Pervasives.abs". +Extract Constant Z.min => "Pervasives.min". +Extract Constant Z.max => "Pervasives.max". Extract Constant Z.compare => "fun x y -> if x=y then Eq else if x "fun p -> p". -Extract Constant Z.abs_N => "abs". +Extract Constant Z.abs_N => "Pervasives.abs". (** Z.div and Z.modulo are quite complex to define in terms of (/) and (mod). For the moment we don't even try *) diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index e76c6919..0a17453c 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -130,7 +130,7 @@ let rec nb_default_params env c = (* Enriching a signature with implicit information *) -let sign_with_implicits r s = +let sign_with_implicits r s nb_params = let implicits = implicits_of_global r in let rec add_impl i = function | [] -> [] @@ -139,7 +139,7 @@ let sign_with_implicits r s = if sign = Keep && List.mem i implicits then Kill Kother else sign in sign' :: add_impl (succ i) s in - add_impl 1 s + add_impl (1+nb_params) s (* Enriching a exception message *) @@ -667,20 +667,23 @@ and extract_cst_app env mle mlt kn args = let head = put_magic_if magic1 (MLglob (ConstRef kn)) in (* Now, the extraction of the arguments. *) let s_full = type2signature env (snd schema) in - let s_full = sign_with_implicits (ConstRef kn) s_full in + let s_full = sign_with_implicits (ConstRef kn) s_full 0 in let s = sign_no_final_keeps s_full in let ls = List.length s in let la = List.length args in (* The ml arguments, already expunged from known logical ones *) let mla = make_mlargs env mle s args metas in let mla = - if not magic1 then + if magic1 || lang () <> Ocaml then mla + else try + (* for better optimisations later, we discard dependent args + of projections and replace them by fake args that will be + removed during final pretty-print. *) let l,l' = list_chop (projection_arity (ConstRef kn)) mla in if l' <> [] then (List.map (fun _ -> MLexn "Proj Args") l) @ l' else mla with _ -> mla - else mla in (* For strict languages, purely logical signatures with at least one [Kill Kother] lead to a dummy lam. So a [MLdummy] is left @@ -726,7 +729,7 @@ and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) args = let type_cons = instantiation (nb_tvars, type_cons) in (* Then, the usual variables [s], [ls], [la], ... *) let s = List.map (type2sign env) types in - let s = sign_with_implicits (ConstructRef cp) s in + let s = sign_with_implicits (ConstructRef cp) s params_nb in let ls = List.length s in let la = List.length args in assert (la <= ls + params_nb); @@ -805,7 +808,7 @@ and extract_case env mle ((kn,i) as ip,c,br) mlt = let l = List.map f oi.ip_types.(i) in (* the corresponding signature *) let s = List.map (type2sign env) oi.ip_types.(i) in - let s = sign_with_implicits r s in + let s = sign_with_implicits r s mi.ind_nparams 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. *) @@ -876,7 +879,7 @@ let extract_std_constant env kn body typ = let l,t' = type_decomp (expand env (var2var' t)) in let s = List.map (type2sign env) l in (* Check for user-declared implicit information *) - let s = sign_with_implicits (ConstRef kn) s in + let s = sign_with_implicits (ConstRef kn) s 0 in (* Decomposing the top level lambdas of [body]. If there isn't enough, it's ok, as long as remaining args aren't to be pruned (and initial lambdas aren't to be all @@ -923,6 +926,19 @@ let extract_std_constant env kn body typ = in trm, type_expunge_from_sign env s t +(* Extracts the type of an axiom, honors the Extraction Implicit declaration. *) +let extract_axiom env kn typ = + reset_meta_count (); + (* The short type [t] (i.e. possibly with abbreviations). *) + let t = snd (record_constant_type env kn (Some typ)) in + (* The real type [t']: without head products, expanded, *) + (* and with [Tvar] translated to [Tvar'] (not instantiable). *) + let l,_ = type_decomp (expand env (var2var' t)) in + let s = List.map (type2sign env) l in + (* Check for user-declared implicit information *) + let s = sign_with_implicits (ConstRef kn) s 0 in + type_expunge_from_sign env s t + let extract_fixpoint env vkn (fi,ti,ci) = let n = Array.length vkn in let types = Array.make n (Tdummy Kother) @@ -959,8 +975,8 @@ let extract_constant env kn cb = in Dtype (r, vl, t) in let mk_ax () = - let t = snd (record_constant_type env kn (Some typ)) in - Dterm (r, MLaxiom, type_expunge env t) + let t = extract_axiom env kn typ in + Dterm (r, MLaxiom, t) in let mk_def c = let e,t = extract_std_constant env kn c typ in diff --git a/plugins/extraction/modutil.ml b/plugins/extraction/modutil.ml index 257e1c1c..bd997d2d 100644 --- a/plugins/extraction/modutil.ml +++ b/plugins/extraction/modutil.ml @@ -26,9 +26,9 @@ let rec msid_of_mt = function (*s Apply some functions upon all [ml_decl] and [ml_spec] found in a [ml_structure]. *) -let se_iter do_decl do_spec = +let se_iter do_decl do_spec do_mp = let rec mt_iter = function - | MTident _ -> () + | MTident mp -> do_mp mp | MTfunsig (_,mt,mt') -> mt_iter mt; mt_iter mt' | MTwith (mt,ML_With_type(idl,l,t))-> let mp_mt = msid_of_mt mt in @@ -38,7 +38,12 @@ let se_iter do_decl do_spec = in let r = ConstRef (make_con mp_w empty_dirpath (label_of_id l')) in mt_iter mt; do_decl (Dtype(r,l,t)) - | MTwith (mt,_)->mt_iter mt + | MTwith (mt,ML_With_module(idl,mp))-> + let mp_mt = msid_of_mt mt in + let mp_w = + List.fold_left (fun mp l -> MPdot(mp,label_of_id l)) mp_mt idl + in + mt_iter mt; do_mp mp_w; do_mp mp | MTsig (_, sign) -> List.iter spec_iter sign and spec_iter = function | (_,Spec s) -> do_spec s @@ -51,15 +56,16 @@ let se_iter do_decl do_spec = me_iter m.ml_mod_expr; mt_iter m.ml_mod_type | (_,SEmodtype m) -> mt_iter m and me_iter = function - | MEident _ -> () + | MEident mp -> do_mp mp | MEfunctor (_,mt,me) -> me_iter me; mt_iter mt | MEapply (me,me') -> me_iter me; me_iter me' | MEstruct (msid, sel) -> List.iter se_iter sel in se_iter -let struct_iter do_decl do_spec s = - List.iter (function (_,sel) -> List.iter (se_iter do_decl do_spec) sel) s +let struct_iter do_decl do_spec do_mp s = + List.iter + (function (_,sel) -> List.iter (se_iter do_decl do_spec do_mp) sel) s (*s Apply some fonctions upon all references in [ml_type], [ml_ast], [ml_decl], [ml_spec] and [ml_structure]. *) @@ -141,7 +147,7 @@ let decl_ast_search f = function | _ -> () let struct_ast_search f s = - try struct_iter (decl_ast_search f) (fun _ -> ()) s; false + try struct_iter (decl_ast_search f) (fun _ -> ()) (fun _ -> ()) s; false with Found -> true let rec type_search f = function @@ -165,7 +171,9 @@ let spec_type_search f = function | Sval (_,u) -> type_search f u let struct_type_search f s = - try struct_iter (decl_type_search f) (spec_type_search f) s; false + try + struct_iter (decl_type_search f) (spec_type_search f) (fun _ -> ()) s; + false with Found -> true @@ -247,34 +255,32 @@ let dfix_to_mlfix rv av i = let c = Array.map (subst 0) av in MLfix(i, ids, c) +(* [optim_se] applies the [normalize] function everywhere and does the + inlining of code. The inlined functions are kept for the moment in + order to preserve the global interface, later [depcheck_se] will get + rid of them if possible *) + let rec optim_se top to_appear s = function | [] -> [] | (l,SEdecl (Dterm (r,a,t))) :: lse -> let a = normalize (ast_glob_subst !s a) in let i = inline r a in if i then s := Refmap'.add r a !s; - if top && i && not (library ()) && not (List.mem r to_appear) - then optim_se top to_appear s lse - else - let d = match optimize_fix a with - | MLfix (0, _, [|c|]) -> - Dfix ([|r|], [|ast_subst (MLglob r) c|], [|t|]) - | a -> Dterm (r, a, t) - in (l,SEdecl d) :: (optim_se top to_appear s lse) + let d = match optimize_fix a with + | MLfix (0, _, [|c|]) -> + Dfix ([|r|], [|ast_subst (MLglob r) c|], [|t|]) + | a -> Dterm (r, a, t) + in + (l,SEdecl d) :: (optim_se top to_appear s lse) | (l,SEdecl (Dfix (rv,av,tv))) :: lse -> let av = Array.map (fun a -> normalize (ast_glob_subst !s a)) av in - let all = ref true in (* This fake body ensures that no fixpoint will be auto-inlined. *) let fake_body = MLfix (0,[||],[||]) in for i = 0 to Array.length rv - 1 do if inline rv.(i) fake_body then s := Refmap'.add rv.(i) (dfix_to_mlfix rv av i) !s - else all := false done; - if !all && top && not (library ()) - && (array_for_all (fun r -> not (List.mem r to_appear)) rv) - then optim_se top to_appear s lse - else (l,SEdecl (Dfix (rv, av, tv))) :: (optim_se top to_appear s lse) + (l,SEdecl (Dfix (rv, av, tv))) :: (optim_se top to_appear s lse) | (l,SEmodule m) :: lse -> let m = { m with ml_mod_expr = optim_me to_appear s m.ml_mod_expr} in (l,SEmodule m) :: (optim_se top to_appear s lse) @@ -289,7 +295,7 @@ and optim_me to_appear s = function (* After these optimisations, some dependencies may not be needed anymore. For non-library extraction, we recompute a minimal set of dependencies - for first-level objects *) + for first-level definitions (no module pruning yet). *) exception NoDepCheck @@ -362,7 +368,7 @@ let rec depcheck_se = function end | t :: se -> let se' = depcheck_se se in - se_iter compute_deps_decl compute_deps_spec t; + se_iter compute_deps_decl compute_deps_spec add_needed_mp t; t :: se' let rec depcheck_struct = function @@ -370,7 +376,7 @@ let rec depcheck_struct = function | (mp,lse)::struc -> let struc' = depcheck_struct struc in let lse' = depcheck_se lse in - (mp,lse')::struc' + if lse' = [] then struc' else (mp,lse')::struc' let check_implicits = function | MLexn s -> @@ -389,9 +395,9 @@ let optimize_struct to_appear struc = List.map (fun (mp,lse) -> (mp, optim_se true (fst to_appear) subst lse)) struc in - let opt_struc = List.filter (fun (_,lse) -> lse<>[]) opt_struc in ignore (struct_ast_search check_implicits opt_struc); - if library () then opt_struc + if library () then + List.filter (fun (_,lse) -> lse<>[]) opt_struc else begin reset_needed (); List.iter add_needed (fst to_appear); diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index c88c6669..43b08840 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -308,13 +308,14 @@ let build_constructors_of_type ind' argl = (Global.env ()) construct in - let argl = - if argl = [] - then + let argl = match argl with + | None -> Array.to_list - (Array.init (cst_narg - npar) (fun _ -> mkGHole ()) + (Array.init cst_narg (fun _ -> mkGHole ()) ) - else argl + | Some l -> + Array.to_list + (Array.init npar (fun _ -> mkGHole ()))@l in let pat_as_term = mkGApp(mkGRef (ConstructRef(ind',i+1)),argl) @@ -653,7 +654,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = Printer.pr_glob_constr b ++ str " in " ++ Printer.pr_glob_constr rt ++ str ". try again with a cast") in - let case_pats = build_constructors_of_type ind [] in + let case_pats = build_constructors_of_type ind None in assert (Array.length case_pats = 2); let brl = list_map_i @@ -669,12 +670,12 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = | GLetTuple(_,nal,_,b,e) -> begin let nal_as_glob_constr = - List.map + Some (List.map (function Name id -> mkGVar id | Anonymous -> mkGHole () ) - nal + nal) in let b_as_constr = Pretyping.Default.understand Evd.empty env b in let b_typ = Typing.type_of env Evd.empty b_as_constr in diff --git a/plugins/romega/ReflOmegaCore.v b/plugins/romega/ReflOmegaCore.v index 11d9a071..ab424c22 100644 --- a/plugins/romega/ReflOmegaCore.v +++ b/plugins/romega/ReflOmegaCore.v @@ -14,14 +14,14 @@ Delimit Scope Int_scope with I. Module Type Int. - Parameter int : Set. + Parameter t : Set. - Parameter zero : int. - Parameter one : int. - Parameter plus : int -> int -> int. - Parameter opp : int -> int. - Parameter minus : int -> int -> int. - Parameter mult : int -> int -> int. + Parameter zero : t. + Parameter one : t. + Parameter plus : t -> t -> t. + Parameter opp : t -> t. + Parameter minus : t -> t -> t. + Parameter mult : t -> t -> t. Notation "0" := zero : Int_scope. Notation "1" := one : Int_scope. @@ -33,14 +33,14 @@ Module Type Int. Open Scope Int_scope. (* First, int is a ring: *) - Axiom ring : @ring_theory int 0 1 plus mult minus opp (@eq int). + Axiom ring : @ring_theory t 0 1 plus mult minus opp (@eq t). (* int should also be ordered: *) - Parameter le : int -> int -> Prop. - Parameter lt : int -> int -> Prop. - Parameter ge : int -> int -> Prop. - Parameter gt : int -> int -> Prop. + Parameter le : t -> t -> Prop. + Parameter lt : t -> t -> Prop. + Parameter ge : t -> t -> Prop. + Parameter gt : t -> t -> Prop. Notation "x <= y" := (le x y): Int_scope. Notation "x < y" := (lt x y) : Int_scope. Notation "x >= y" := (ge x y) : Int_scope. @@ -61,7 +61,7 @@ Module Type Int. forall i j k, 0 < k -> i < j -> k*i int -> comparison. + Parameter compare : t -> t -> comparison. Infix "?=" := compare (at level 70, no associativity) : Int_scope. Axiom compare_Eq : forall i j, compare i j = Eq <-> i=j. Axiom compare_Lt : forall i j, compare i j = Lt <-> i t1 = t2. Proof. - simple induction t1; intros until t2; case t2; simpl in *; - try (intros; discriminate; fail); - [ intros; elim beq_true with (1 := H); trivial - | intros t21 t22 H3; elim andb_prop with (1 := H3); intros H4 H5; - elim H with (1 := H4); elim H0 with (1 := H5); - trivial - | intros t21 t22 H3; elim andb_prop with (1 := H3); intros H4 H5; - elim H with (1 := H4); elim H0 with (1 := H5); - trivial - | intros t21 t22 H3; elim andb_prop with (1 := H3); intros H4 H5; - elim H with (1 := H4); elim H0 with (1 := H5); - trivial - | intros t21 H3; elim H with (1 := H3); trivial - | intros; elim beq_nat_true with (1 := H); trivial ]. + induction t1; destruct t2; simpl in *; try discriminate; + (rewrite andb_true_iff; intros (H1,H2)) || intros H; f_equal; + auto using beq_true, beq_nat_true. +Qed. + +Theorem eq_term_refl : forall t0 : term, eq_term t0 t0 = true. +Proof. + induction t0; simpl in *; try (apply andb_true_iff; split); trivial. + - now apply beq_iff. + - now apply beq_nat_true_iff. Qed. Ltac trivial_case := unfold not; intros; discriminate. @@ -1058,31 +1056,7 @@ Ltac trivial_case := unfold not; intros; discriminate. Theorem eq_term_false : forall t1 t2 : term, eq_term t1 t2 = false -> t1 <> t2. Proof. - simple induction t1; - [ intros z t2; case t2; try trivial_case; simpl; unfold not; - intros; elim beq_false with (1 := H); simplify_eq H0; - auto - | intros t11 H1 t12 H2 t2; case t2; try trivial_case; simpl; - intros t21 t22 H3; unfold not; intro H4; - elim andb_false_elim with (1 := H3); intros H5; - [ elim H1 with (1 := H5); simplify_eq H4; auto - | elim H2 with (1 := H5); simplify_eq H4; auto ] - | intros t11 H1 t12 H2 t2; case t2; try trivial_case; simpl; - intros t21 t22 H3; unfold not; intro H4; - elim andb_false_elim with (1 := H3); intros H5; - [ elim H1 with (1 := H5); simplify_eq H4; auto - | elim H2 with (1 := H5); simplify_eq H4; auto ] - | intros t11 H1 t12 H2 t2; case t2; try trivial_case; simpl; - intros t21 t22 H3; unfold not; intro H4; - elim andb_false_elim with (1 := H3); intros H5; - [ elim H1 with (1 := H5); simplify_eq H4; auto - | elim H2 with (1 := H5); simplify_eq H4; auto ] - | intros t11 H1 t2; case t2; try trivial_case; simpl; intros t21 H3; - unfold not; intro H4; elim H1 with (1 := H3); - simplify_eq H4; auto - | intros n t2; case t2; try trivial_case; simpl; unfold not; - intros; elim beq_nat_false with (1 := H); simplify_eq H0; - auto ]. + intros t1 t2 H E. subst t2. now rewrite eq_term_refl in H. Qed. (* \subsubsection{Tactiques pour éliminer ces tests} @@ -1919,9 +1893,9 @@ Fixpoint fusion (trace : list t_fusion) (t : term) {struct trace} : term := end end. -Theorem fusion_stable : forall t : list t_fusion, term_stable (fusion t). +Theorem fusion_stable : forall trace : list t_fusion, term_stable (fusion trace). Proof. - simple induction t; simpl; + simple induction trace; simpl; [ exact reduce_stable | intros stp l H; case stp; [ apply compose_term_stable; @@ -2093,11 +2067,8 @@ Definition constant_not_nul (i : nat) (h : hyps) := Theorem constant_not_nul_valid : forall i : nat, valid_hyps (constant_not_nul i). Proof. - unfold valid_hyps, constant_not_nul; intros; - generalize (nth_valid ep e i lp); Simplify; simpl. - - elim_beq i1 i0; auto; simpl; intros H1 H2; - elim H1; symmetry ; auto. + unfold valid_hyps, constant_not_nul; intros i ep e lp H. + generalize (nth_valid ep e i lp H); Simplify. Qed. (* \paragraph{[O_CONSTANT_NEG]} *) @@ -2131,12 +2102,12 @@ Definition not_exact_divide (k1 k2 : int) (body : term) end. Theorem not_exact_divide_valid : - forall (k1 k2 : int) (body : term) (t i : nat), - valid_hyps (not_exact_divide k1 k2 body t i). + forall (k1 k2 : int) (body : term) (t0 i : nat), + valid_hyps (not_exact_divide k1 k2 body t0 i). Proof. unfold valid_hyps, not_exact_divide; intros; generalize (nth_valid ep e i lp); Simplify. - rewrite (scalar_norm_add_stable t e), <-H1. + rewrite (scalar_norm_add_stable t0 e), <-H1. do 2 rewrite <- scalar_norm_add_stable; simpl in *; intros. absurd (interp_term e body * k1 + k2 = 0); [ now apply OMEGA4 | symmetry; auto ]. @@ -2509,9 +2480,9 @@ Fixpoint execute_omega (t : t_omega) (l : hyps) {struct t} : lhyps := execute_omega cont (apply_oper_2 i1 i2 (state m s) l) end. -Theorem omega_valid : forall t : t_omega, valid_list_hyps (execute_omega t). +Theorem omega_valid : forall tr : t_omega, valid_list_hyps (execute_omega tr). Proof. - simple induction t; simpl; + simple induction tr; simpl; [ unfold valid_list_hyps; simpl; intros; left; apply (constant_not_nul_valid n ep e lp H) | unfold valid_list_hyps; simpl; intros; left; @@ -2522,7 +2493,7 @@ Proof. (apply_oper_1_valid m (divide_and_approx k1 k2 body n) (divide_and_approx_valid k1 k2 body n) ep e lp H) | unfold valid_list_hyps; simpl; intros; left; - apply (not_exact_divide_valid i i0 t0 n n0 ep e lp H) + apply (not_exact_divide_valid _ _ _ _ _ ep e lp H) | unfold valid_list_hyps, valid_hyps; intros k body n t' Ht' m ep e lp H; apply Ht'; apply @@ -2618,10 +2589,10 @@ Qed. (* \subsubsection{Exécution de la trace} *) Theorem execute_goal : - forall (t : t_omega) (ep : list Prop) (env : list int) (l : hyps), - interp_list_goal ep env (execute_omega t l) -> interp_goal ep env l. + forall (tr : t_omega) (ep : list Prop) (env : list int) (l : hyps), + interp_list_goal ep env (execute_omega tr l) -> interp_goal ep env l. Proof. - intros; apply (goal_valid (execute_omega t) (omega_valid t) ep env l H). + intros; apply (goal_valid (execute_omega tr) (omega_valid tr) ep env l H). Qed. @@ -2936,13 +2907,13 @@ Proof. | intro; apply ne_left_2; assumption ] | case p; simpl; intros; auto; generalize H; elim (t_rewrite_stable s); simpl; intro H1; - [ rewrite (plus_0_r_reverse (interp_term e t0)); rewrite H1; + [ rewrite (plus_0_r_reverse (interp_term e t1)); rewrite H1; rewrite plus_permute; rewrite plus_opp_r; rewrite plus_0_r; trivial - | apply (fun a b => plus_le_reg_r a b (- interp_term e t)); + | apply (fun a b => plus_le_reg_r a b (- interp_term e t0)); rewrite plus_opp_r; assumption | rewrite ge_le_iff; - apply (fun a b => plus_le_reg_r a b (- interp_term e t0)); + apply (fun a b => plus_le_reg_r a b (- interp_term e t1)); rewrite plus_opp_r; assumption | rewrite gt_lt_iff; apply lt_left_inv; assumption | apply lt_left_inv; assumption diff --git a/plugins/subtac/subtac_obligations.ml b/plugins/subtac/subtac_obligations.ml index 6a5878b3..dfcc8526 100644 --- a/plugins/subtac/subtac_obligations.ml +++ b/plugins/subtac/subtac_obligations.ml @@ -663,6 +663,7 @@ let add_mutual_definitions l ?tactic ?(kind=Global,Definition) ?(reduce=reduce) let admit_obligations n = let prg = get_prog_err n in let obls, rem = prg.prg_obligations in + let obls = Array.copy obls in Array.iteri (fun i x -> match x.obl_body with diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 1819dc52..38355cf1 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -1763,7 +1763,7 @@ let prepare_predicate loc typing_fun sigma env tomatchs arsign tycon pred = (* First strategy: we build an "inversion" predicate *) let sigma1,pred1 = build_inversion_problem loc env sigma tomatchs t in (* Second strategy: we directly use the evar as a non dependent pred *) - let pred2 = lift (List.length arsign) t in + let pred2 = lift (List.length (List.flatten arsign)) t in [sigma1, pred1; sigma, pred2] (* Some type annotation *) | Some rtntyp, _ -> diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 69ff2af9..a74e4cb4 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -389,6 +389,8 @@ let rec detype (isgoal:bool) avoid env t = with _ -> GVar (dl, id)) | Sort s -> GSort (dl,detype_sort s) + | Cast (c1,REVERTcast,c2) when not !Flags.raw_print -> + detype isgoal avoid env c1 | Cast (c1,k,c2) -> GCast(dl,detype isgoal avoid env c1, CastConv (k, detype isgoal avoid env c2)) | Prod (na,ty,c) -> detype_binder isgoal BProd avoid env na ty c diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml index fa29243a..b0248a84 100644 --- a/pretyping/evarutil.ml +++ b/pretyping/evarutil.ml @@ -135,15 +135,20 @@ let whd_head_evar_stack sigma c = let whd_head_evar sigma c = applist (whd_head_evar_stack sigma c) -let noccur_evar evd evk c = - let rec occur_rec c = match kind_of_term c with - | Evar (evk',_ as ev') -> +let noccur_evar env evd evk c = + let rec occur_rec k c = match kind_of_term c with + | Evar (evk',args' as ev') -> (match safe_evar_value evd ev' with - | Some c -> occur_rec c - | None -> if evk = evk' then raise Occur) - | _ -> iter_constr occur_rec c + | Some c -> occur_rec k c + | None -> + if evk = evk' then raise Occur else Array.iter (occur_rec k) args') + | Rel i when i > k -> + (match pi2 (Environ.lookup_rel (i-k) env) with + | None -> () + | Some b -> occur_rec k (lift i b)) + | _ -> iter_constr_with_binders succ occur_rec k c in - try occur_rec c; true with Occur -> false + try occur_rec 0 c; true with Occur -> false let normalize_evar evd ev = match kind_of_term (whd_evar evd (mkEvar ev)) with @@ -741,7 +746,8 @@ let is_unification_pattern_meta env nb m l t = None let is_unification_pattern_evar env evd (evk,args) l t = - if List.for_all (fun x -> isRel x || isVar x) l & noccur_evar evd evk t then + if List.for_all (fun x -> isRel x || isVar x) l & noccur_evar env evd evk t + then let args = remove_instance_local_defs evd evk (Array.to_list args) in let n = List.length args in match find_unification_pattern_args env (args @ l) t with @@ -1112,10 +1118,11 @@ let invert_arg_from_subst evd aliases k0 subst_in_env_extended_with_k_binders c_ | Not_found -> CannotInvert | NotUnique -> Invertible NoUniqueProjection -let invert_arg evd aliases k evk subst_in_env_extended_with_k_binders c_in_env_extended_with_k_binders = +let invert_arg fullenv evd aliases k evk subst_in_env_extended_with_k_binders c_in_env_extended_with_k_binders = let res = invert_arg_from_subst evd aliases k subst_in_env_extended_with_k_binders c_in_env_extended_with_k_binders in match res with - | Invertible (UniqueProjection (c,_)) when not (noccur_evar evd evk c) -> + | Invertible (UniqueProjection (c,_)) when not (noccur_evar fullenv evd evk c) + -> CannotInvert | _ -> res @@ -1153,10 +1160,11 @@ let extract_candidates sols = let filter_of_projection = function Invertible _ -> true | _ -> false -let invert_invertible_arg evd aliases k (evk,argsv) args' = +let invert_invertible_arg fullenv evd aliases k (evk,argsv) args' = let evi = Evd.find_undefined evd evk in let subst,_ = make_projectable_subst aliases evd evi argsv in - let projs = array_map_to_list (invert_arg evd aliases k evk subst) args' in + let projs = + array_map_to_list (invert_arg fullenv evd aliases k evk subst) args' in Array.of_list (extract_unique_projections projs) (* Redefines an evar with a smaller context (i.e. it may depend on less @@ -1364,12 +1372,14 @@ let has_constrainable_free_vars evd aliases k ev (fv_rels,fv_ids as fvs) t = let ensure_evar_independent g env evd (evk1,argsv1 as ev1) (evk2,argsv2 as ev2)= let filter1 = - restrict_upon_filter evd evk1 (noccur_evar evd evk2) (Array.to_list argsv1) + restrict_upon_filter evd evk1 (noccur_evar env evd evk2) + (Array.to_list argsv1) in let candidates1 = restrict_candidates g env evd filter1 ev1 ev2 in let evd,(evk1,_ as ev1) = do_restrict_hyps evd ev1 filter1 candidates1 in let filter2 = - restrict_upon_filter evd evk2 (noccur_evar evd evk1) (Array.to_list argsv2) + restrict_upon_filter evd evk2 (noccur_evar env evd evk1) + (Array.to_list argsv2) in let candidates2 = restrict_candidates g env evd filter2 ev2 ev1 in let evd,ev2 = do_restrict_hyps evd ev2 filter2 candidates2 in @@ -1389,7 +1399,7 @@ let project_evar_on_evar g env evd aliases k2 (evk1,argsv1 as ev1) (evk2,argsv2 try let candidates1 = restrict_candidates g env evd filter1 ev1 ev2 in let evd,(evk1',args1) = do_restrict_hyps evd ev1 filter1 candidates1 in - evd,mkEvar (evk1',invert_invertible_arg evd aliases k2 ev2 args1) + evd,mkEvar (evk1',invert_invertible_arg env evd aliases k2 ev2 args1) with | EvarSolvedWhileRestricting (evd,ev1) -> raise (EvarSolvedOnTheFly (evd,ev1)) @@ -1585,7 +1595,7 @@ let rec invert_definition conv_algo choose env evd (evk,argsv as ev) rhs = let aliases = lift_aliases k aliases in (try let ev = (evk,Array.map (lift k) argsv) in - let evd,body = project_evar_on_evar conv_algo env !evdref aliases k ev' ev in + let evd,body = project_evar_on_evar conv_algo env' !evdref aliases k ev' ev in evdref := evd; body with diff --git a/pretyping/glob_term.ml b/pretyping/glob_term.ml index 24c5ba5b..8e4b211f 100644 --- a/pretyping/glob_term.ml +++ b/pretyping/glob_term.ml @@ -346,8 +346,38 @@ let rec cases_pattern_of_glob_constr na = function | GHole (loc,_) -> PatVar (loc,na) | GRef (loc,ConstructRef cstr) -> PatCstr (loc,cstr,[],na) - | GApp (loc,GRef (_,ConstructRef cstr),l) -> - PatCstr (loc,cstr,List.map (cases_pattern_of_glob_constr Anonymous) l,na) + | GApp (loc,GRef (_,ConstructRef (ind,_ as cstr)),args) -> + let mib,_ = Global.lookup_inductive ind in + let nparams = mib.Declarations.mind_nparams in + if nparams > List.length args then + user_err_loc (loc,"",Pp.str "Invalid notation for pattern."); + let params,args = list_chop nparams args in + List.iter (function GHole _ -> () + | _ -> user_err_loc (loc,"",Pp.str"Invalid notation for pattern.")) + params; + let args = List.map (cases_pattern_of_glob_constr Anonymous) args in + PatCstr (loc,cstr,args,na) + | _ -> raise Not_found + +let rec cases_pattern_of_glob_constr na = function + | GVar (loc,id) when na<>Anonymous -> + (* Unable to manage the presence of both an alias and a variable *) + raise Not_found + | GVar (loc,id) -> PatVar (loc,Name id) + | GHole (loc,_) -> PatVar (loc,na) + | GRef (loc,ConstructRef cstr) -> + PatCstr (loc,cstr,[],na) + | GApp (loc,GRef (_,ConstructRef (ind,_ as cstr)),args) -> + let mib,_ = Global.lookup_inductive ind in + let nparams = mib.Declarations.mind_nparams in + if nparams > List.length args then + user_err_loc (loc,"",Pp.str "Invalid notation for pattern."); + let params,args = list_chop nparams args in + List.iter (function GHole _ -> () + | _ -> user_err_loc (loc,"",Pp.str"Invalid notation for pattern.")) + params; + let args = List.map (cases_pattern_of_glob_constr Anonymous) args in + PatCstr (loc,cstr,args,na) | _ -> raise Not_found (* Turn a closed cases pattern into a glob_constr *) diff --git a/pretyping/typing.ml b/pretyping/typing.ml index 665491e7..22aacb29 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -42,6 +42,11 @@ let e_type_judgment env evdref j = evdref := evd; { utj_val = j.uj_val; utj_type = s } | _ -> error_not_type env j +let e_assumption_of_judgment env evdref j = + try (e_type_judgment env evdref j).utj_val + with TypeError _ -> + error_assumption env j + let e_judge_of_apply env evdref funj argjv = let rec apply_rec n typ = function | [] -> @@ -150,7 +155,7 @@ let rec execute env evdref cstr = | Evar ev -> let ty = Evd.existential_type !evdref ev in let jty = execute env evdref (whd_evar !evdref ty) in - let jty = assumption_of_judgment env jty in + let jty = e_assumption_of_judgment env evdref jty in { uj_val = cstr; uj_type = jty } | Rel n -> @@ -243,7 +248,7 @@ let rec execute env evdref cstr = and execute_recdef env evdref (names,lar,vdef) = let larj = execute_array env evdref lar in - let lara = Array.map (assumption_of_judgment env) larj in + let lara = Array.map (e_assumption_of_judgment env evdref) larj in let env1 = push_rec_types (names,lara,vdef) env in let vdefj = execute_array env1 evdref vdef in let vdefv = Array.map j_val vdefj in diff --git a/pretyping/unification.ml b/pretyping/unification.ml index c92c183d..63cdb378 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -198,11 +198,18 @@ type unify_flags = { (* (and activated for apply, rewrite but not auto since Feb 2008 for 8.2) *) modulo_delta : Names.transparent_state; - (* This controls which constant are unfoldable; this is on for apply *) + (* This controls which constants are unfoldable; this is on for apply *) (* (but not simple apply) since Feb 2008 for 8.2 *) modulo_delta_types : Names.transparent_state; + modulo_delta_in_merge : Names.transparent_state option; + (* This controls whether unfoldability is different when trying to unify *) + (* several instances of the same metavariable *) + (* Typical situation is when we give a pattern to be matched *) + (* syntactically against a subterm but we want the metas of the *) + (* pattern to be modulo convertibility *) + check_applied_meta_types : bool; (* This controls whether meta's applied to arguments have their *) (* type unified with the type of their instance *) @@ -240,12 +247,13 @@ type unify_flags = { } (* Default flag for unifying a type against a type (e.g. apply) *) -(* We set all conversion flags *) +(* We set all conversion flags (no flag should be modified anymore) *) let default_unify_flags = { modulo_conv_on_closed_terms = Some full_transparent_state; use_metas_eagerly_in_conv_on_closed_terms = true; modulo_delta = full_transparent_state; modulo_delta_types = full_transparent_state; + modulo_delta_in_merge = None; check_applied_meta_types = true; resolve_evars = false; use_pattern_unification = true; @@ -258,24 +266,22 @@ let default_unify_flags = { (* in fact useless when not used in w_unify_to_subterm_list *) } +let set_merge_flags flags = + match flags.modulo_delta_in_merge with + | None -> flags + | Some ts -> + { flags with modulo_delta = ts; modulo_conv_on_closed_terms = Some ts } + (* Default flag for the "simple apply" version of unification of a *) (* type against a type (e.g. apply) *) (* We set only the flags available at the time the new "apply" extends *) (* out of "simple apply" *) -let default_no_delta_unify_flags = { - modulo_conv_on_closed_terms = Some full_transparent_state; - use_metas_eagerly_in_conv_on_closed_terms = true; +let default_no_delta_unify_flags = { default_unify_flags with modulo_delta = empty_transparent_state; - modulo_delta_types = full_transparent_state; check_applied_meta_types = false; - resolve_evars = false; use_pattern_unification = false; use_meta_bound_pattern_unification = true; - frozen_evars = ExistentialSet.empty; - restrict_conv_on_strict_subterms = false; modulo_betaiota = false; - modulo_eta = true; - allow_K_in_toplevel_higher_order_unification = false } (* Default flags for looking for subterms in elimination tactics *) @@ -283,36 +289,16 @@ let default_no_delta_unify_flags = { (* allow_K) because only closed terms are involved in *) (* induction/destruct/case/elim and w_unify_to_subterm_list does not *) (* call w_unify for induction/destruct/case/elim (13/6/2011) *) -let elim_flags = { - modulo_conv_on_closed_terms = Some full_transparent_state; - use_metas_eagerly_in_conv_on_closed_terms = true; - modulo_delta = full_transparent_state; - modulo_delta_types = full_transparent_state; - check_applied_meta_types = true; - resolve_evars = false; - use_pattern_unification = true; - use_meta_bound_pattern_unification = true; - frozen_evars = ExistentialSet.empty; +let elim_flags = { default_unify_flags with restrict_conv_on_strict_subterms = false; (* ? *) modulo_betaiota = false; - modulo_eta = true; allow_K_in_toplevel_higher_order_unification = true } -let elim_no_delta_flags = { - modulo_conv_on_closed_terms = Some full_transparent_state; - use_metas_eagerly_in_conv_on_closed_terms = true; +let elim_no_delta_flags = { elim_flags with modulo_delta = empty_transparent_state; - modulo_delta_types = full_transparent_state; check_applied_meta_types = false; - resolve_evars = false; use_pattern_unification = false; - use_meta_bound_pattern_unification = true; - frozen_evars = ExistentialSet.empty; - restrict_conv_on_strict_subterms = false; (* ? *) - modulo_betaiota = false; - modulo_eta = true; - allow_K_in_toplevel_higher_order_unification = true } let set_no_head_reduction flags = @@ -865,7 +851,7 @@ let w_merge env with_types flags (evd,metas,evars) = if Evd.is_defined evd evk then let v = Evd.existential_value evd ev in let (evd,metas',evars'') = - unify_0 curenv evd CONV flags rhs v in + unify_0 curenv evd CONV (set_merge_flags flags) rhs v in w_merge_rec evd (metas'@metas) (evars''@evars') eqns else begin (* This can make rhs' ill-typed if metas are *) @@ -943,7 +929,7 @@ let w_merge env with_types flags (evd,metas,evars) = let sp_env = Global.env_of_context ev.evar_hyps in let (evd', c) = applyHead sp_env evd nargs hdc in let (evd'',mc,ec) = - unify_0 sp_env evd' CUMUL flags + unify_0 sp_env evd' CUMUL (set_merge_flags flags) (get_type_of sp_env evd' c) ev.evar_concl in let evd''' = w_merge_rec evd'' mc ec [] in if evd' == evd''' diff --git a/pretyping/unification.mli b/pretyping/unification.mli index e3fd46af..1ec5c1a2 100644 --- a/pretyping/unification.mli +++ b/pretyping/unification.mli @@ -15,6 +15,7 @@ type unify_flags = { use_metas_eagerly_in_conv_on_closed_terms : bool; modulo_delta : Names.transparent_state; modulo_delta_types : Names.transparent_state; + modulo_delta_in_merge : Names.transparent_state option; check_applied_meta_types : bool; resolve_evars : bool; use_pattern_unification : bool; diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml index ca8fd6ae..d18ee73f 100644 --- a/proofs/clenvtac.ml +++ b/proofs/clenvtac.ml @@ -105,6 +105,7 @@ let fail_quick_unif_flags = { use_metas_eagerly_in_conv_on_closed_terms = false; modulo_delta = empty_transparent_state; modulo_delta_types = full_transparent_state; + modulo_delta_in_merge = None; check_applied_meta_types = false; resolve_evars = false; use_pattern_unification = false; diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 5e314069..45e4a84e 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -62,9 +62,12 @@ let get_undo _ = None let start_proof id str hyps c ?init_tac ?compute_guard hook = let goals = [ (Global.env_of_context hyps , c) ] in - let init_tac = Option.map Proofview.V82.tactic init_tac in Proof_global.start_proof id str goals ?compute_guard hook; - try Option.iter Proof_global.run_tactic init_tac + let tac = match init_tac with + | Some tac -> Proofview.V82.tactic tac + | None -> Proofview.tclUNIT () + in + try Proof_global.run_tactic tac with e -> Proof_global.discard_current (); raise e let restart_proof () = undo_todepth 1 diff --git a/scripts/coqmktop.ml b/scripts/coqmktop.ml index c8bf689b..5bc77457 100644 --- a/scripts/coqmktop.ml +++ b/scripts/coqmktop.ml @@ -63,16 +63,18 @@ let no_start = ref false let is_ocaml4 = Coq_config.caml_version.[0] <> '3' +(* Since the .cma are given with their relative paths (e.g. "lib/clib.cma"), + we only need to include directories mentionned in the temp main ml file + below (for accessing the corresponding .cmi). *) + let src_dirs = - [ []; ["kernel";"byterun"]; [ "config" ]; [ "toplevel" ] ] + [ []; ["lib"]; ["toplevel"]; ["kernel";"byterun"]; ] let includes () = - (if !Flags.boot then [] (* the include flags are given on the cmdline *) - else - let coqlib = Envars.coqlib () in - let mkdir d = "\"" ^ List.fold_left Filename.concat coqlib d ^ "\"" in - let camlp4incl = ["-I"; "\"" ^ Envars.camlp4lib () ^ "\""] in - List.fold_right (fun d l -> "-I" :: mkdir d :: l) src_dirs camlp4incl) + let coqlib = if !Flags.boot then "." else Envars.coqlib () in + let mkdir d = "\"" ^ List.fold_left Filename.concat coqlib d ^ "\"" in + (List.fold_right (fun d l -> "-I" :: mkdir d :: l) src_dirs []) + @ ["-I"; "\"" ^ Envars.camlp4lib () ^ "\""] @ (if is_ocaml4 then ["-I"; "+compiler-libs"] else []) (* Transform bytecode object file names in native object file names *) @@ -242,8 +244,7 @@ let declare_loading_string () = (* create a temporary main file to link *) let create_tmp_main_file modules = - let main_name = Filename.temp_file "coqmain" ".ml" in - let oc = open_out main_name in + let main_name,oc = Filename.open_temp_file "coqmain" ".ml" in try (* Add the pre-linked modules *) output_string oc "List.iter Mltop.add_known_module [\""; @@ -290,10 +291,10 @@ let main () = [] in (* the list of the loaded modules *) - let main_file = Filename.quote (create_tmp_main_file modules) in + let main_file = create_tmp_main_file modules in try - let args = - options @ (includes ()) @ copts @ tolink @ dynlink @ [ main_file ] in + let args = options @ includes () @ copts @ tolink @ dynlink in + let args = args @ [ Filename.quote main_file ] in (* add topstart.cmo explicitly because we shunted ocamlmktop wrapper *) let args = if !top then args @ [ "topstart.cmo" ] else args in (* Now, with the .cma, we MUST use the -linkall option *) diff --git a/tactics/auto.ml b/tactics/auto.ml index 041bb44b..f7d63dcd 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -1020,6 +1020,7 @@ let auto_unif_flags = { use_metas_eagerly_in_conv_on_closed_terms = false; modulo_delta = empty_transparent_state; modulo_delta_types = full_transparent_state; + modulo_delta_in_merge = None; check_applied_meta_types = false; resolve_evars = true; use_pattern_unification = false; diff --git a/tactics/class_tactics.ml4 b/tactics/class_tactics.ml4 index e8ef545d..cf4a267f 100644 --- a/tactics/class_tactics.ml4 +++ b/tactics/class_tactics.ml4 @@ -77,6 +77,7 @@ let auto_unif_flags = { use_metas_eagerly_in_conv_on_closed_terms = true; modulo_delta = var_full_transparent_state; modulo_delta_types = full_transparent_state; + modulo_delta_in_merge = None; check_applied_meta_types = false; resolve_evars = false; use_pattern_unification = true; diff --git a/tactics/equality.ml b/tactics/equality.ml index 241a8bd2..a352355b 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -87,6 +87,7 @@ let rewrite_unif_flags = { Unification.use_metas_eagerly_in_conv_on_closed_terms = true; Unification.modulo_delta = empty_transparent_state; Unification.modulo_delta_types = empty_transparent_state; + Unification.modulo_delta_in_merge = None; Unification.check_applied_meta_types = true; Unification.resolve_evars = true; Unification.use_pattern_unification = true; @@ -155,6 +156,7 @@ let rewrite_conv_closed_unif_flags = { Unification.modulo_delta = empty_transparent_state; Unification.modulo_delta_types = full_transparent_state; + Unification.modulo_delta_in_merge = None; Unification.check_applied_meta_types = true; Unification.resolve_evars = false; Unification.use_pattern_unification = true; diff --git a/tactics/extraargs.ml4 b/tactics/extraargs.ml4 index d3403a18..613779c2 100644 --- a/tactics/extraargs.ml4 +++ b/tactics/extraargs.ml4 @@ -194,7 +194,7 @@ let pr_in_hyp pr_id (lo,concl) : Pp.std_ppcmds = | None,false -> str "in" ++ spc () ++ str "*" ++ spc () ++ str "|-" | Some l,_ -> str "in" ++ - Util.prlist (fun id -> spc () ++ pr_id id) l ++ + spc () ++ Util.prlist_with_sep Util.pr_comma pr_id l ++ match concl with | true -> spc () ++ str "|-" ++ spc () ++ str "*" | _ -> mt () diff --git a/tactics/hipattern.ml4 b/tactics/hipattern.ml4 index 8a1b5996..47e3b7ca 100644 --- a/tactics/hipattern.ml4 +++ b/tactics/hipattern.ml4 @@ -151,8 +151,9 @@ let match_with_disjunction ?(strict=false) t = | Ind ind -> let car = mis_constr_nargs ind in let (mib,mip) = Global.lookup_inductive ind in - if array_for_all (fun ar -> ar = 1) car && - not (mis_is_recursive (ind,mib,mip)) + if array_for_all (fun ar -> ar = 1) car + && not (mis_is_recursive (ind,mib,mip)) + && (mip.mind_nrealargs = 0) then if strict then if test_strict_disjunction mib.mind_nparams mip.mind_nf_lc then diff --git a/tactics/rewrite.ml4 b/tactics/rewrite.ml4 index dbe61817..b90a911a 100644 --- a/tactics/rewrite.ml4 +++ b/tactics/rewrite.ml4 @@ -294,6 +294,7 @@ let rewrite_unif_flags = { Unification.use_metas_eagerly_in_conv_on_closed_terms = true; Unification.modulo_delta = empty_transparent_state; Unification.modulo_delta_types = full_transparent_state; + Unification.modulo_delta_in_merge = None; Unification.check_applied_meta_types = true; Unification.resolve_evars = true; Unification.use_pattern_unification = true; @@ -305,11 +306,12 @@ let rewrite_unif_flags = { Unification.allow_K_in_toplevel_higher_order_unification = true } -let rewrite2_unif_flags = +let rewrite2_unif_flags = { Unification.modulo_conv_on_closed_terms = Some conv_transparent_state; Unification.use_metas_eagerly_in_conv_on_closed_terms = true; Unification.modulo_delta = empty_transparent_state; Unification.modulo_delta_types = conv_transparent_state; + Unification.modulo_delta_in_merge = None; Unification.check_applied_meta_types = true; Unification.resolve_evars = true; Unification.use_pattern_unification = true; @@ -327,6 +329,7 @@ let general_rewrite_unif_flags () = Unification.use_metas_eagerly_in_conv_on_closed_terms = true; Unification.modulo_delta = ts; Unification.modulo_delta_types = ts; + Unification.modulo_delta_in_merge = None; Unification.check_applied_meta_types = true; Unification.resolve_evars = true; Unification.use_pattern_unification = true; diff --git a/tactics/tactics.ml b/tactics/tactics.ml index ff53bfe8..12292196 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1690,6 +1690,7 @@ let default_matching_flags sigma = { use_metas_eagerly_in_conv_on_closed_terms = false; modulo_delta = empty_transparent_state; modulo_delta_types = full_transparent_state; + modulo_delta_in_merge = Some full_transparent_state; check_applied_meta_types = true; resolve_evars = false; use_pattern_unification = false; diff --git a/test-suite/output/Notations.out b/test-suite/output/Notations.out index beba8df9..66307236 100644 --- a/test-suite/output/Notations.out +++ b/test-suite/output/Notations.out @@ -127,3 +127,12 @@ Identifier 'foo' now a keyword : nat fun _ : nat => 9 : nat -> nat +Identifier 'ONE' now a keyword +fun (x : nat) (p : x = x) => match p with + | ONE => ONE + end = p + : forall x : nat, x = x -> Prop +fun (x : nat) (p : x = x) => match p with + | 1 => 1 + end = p + : forall x : nat, x = x -> Prop diff --git a/test-suite/output/Notations.v b/test-suite/output/Notations.v index 52f499ab..612b5325 100644 --- a/test-suite/output/Notations.v +++ b/test-suite/output/Notations.v @@ -262,3 +262,16 @@ Notation "'foo' n" := (S n) (at level 50): nat_scope. Check (foo 9). Check (fun _ : nat => 9). + +(* Checking parsing and printing of numerical and non-numerical notations for eq_refl *) + +(* This notation was not correctly printed until Pierre B.'s + improvements to the interpretation of patterns *) + +Notation "'ONE'" := eq_refl. +Check fun (x:nat) (p : x=x) => match p with ONE => ONE end = p. + +(* This one used to failed at parsing until now *) + +Notation "1" := eq_refl. +Check fun (x:nat) (p : x=x) => match p with 1 => 1 end = p. diff --git a/test-suite/success/Cases.v b/test-suite/success/Cases.v index f445ca8e..c9a3c08e 100644 --- a/test-suite/success/Cases.v +++ b/test-suite/success/Cases.v @@ -1865,3 +1865,9 @@ Type (fun n => match n with | Z0 => true | _ => false end). + +(* Check that types with unknown sort, as A below, are not fatal to + the pattern-matching compilation *) + +Definition transport {A} (P : A->Type) {x y : A} (p : x=y) (u : P x) : P y := + match p with eq_refl => u end. diff --git a/test-suite/success/set.v b/test-suite/success/set.v index 23019275..8116e897 100644 --- a/test-suite/success/set.v +++ b/test-suite/success/set.v @@ -1,8 +1,19 @@ +(* This used to fail in 8.0pl1 *) + Goal forall n, n+n=0->0=n+n. intros. - -(* This used to fail in 8.0pl1 *) set n in * |-. +Abort. + +(* This works from 8.4pl1, since merging of different instances of the + same metavariable in a pattern is done modulo conversion *) + +Notation "p .+1" := (S p) (at level 1, left associativity, format "p .+1"). + +Goal forall (f:forall n, n=0 -> Prop) n (H:(n+n).+1=0), f (n.+1+n) H. +intros. +set (f _ _). +Abort. diff --git a/theories/FSets/FMapAVL.v b/theories/FSets/FMapAVL.v index 980cfeac..c68216e6 100644 --- a/theories/FSets/FMapAVL.v +++ b/theories/FSets/FMapAVL.v @@ -35,6 +35,7 @@ Module Raw (Import I:Int)(X: OrderedType). Local Open Scope pair_scope. Local Open Scope lazy_bool_scope. Local Open Scope Int_scope. +Local Notation int := I.t. Definition key := X.t. Hint Transparent key. diff --git a/theories/MSets/MSetAVL.v b/theories/MSets/MSetAVL.v index 1e66e2b5..db12ee31 100644 --- a/theories/MSets/MSetAVL.v +++ b/theories/MSets/MSetAVL.v @@ -44,6 +44,7 @@ Local Unset Case Analysis Schemes. Module Ops (Import I:Int)(X:OrderedType) <: MSetInterface.Ops X. Local Open Scope Int_scope. +Local Notation int := I.t. (** ** Generic trees instantiated with integer height *) diff --git a/theories/Numbers/NatInt/NZOrder.v b/theories/Numbers/NatInt/NZOrder.v index 37074aba..5582438b 100644 --- a/theories/Numbers/NatInt/NZOrder.v +++ b/theories/Numbers/NatInt/NZOrder.v @@ -147,18 +147,14 @@ Definition lt_total := lt_trichotomy. Definition le_lteq := lt_eq_cases. Module Private_OrderTac. -Module Elts <: TotalOrder. - Definition t := t. - Definition eq := eq. - Definition lt := lt. - Definition le := le. +Module IsTotal. Definition eq_equiv := eq_equiv. Definition lt_strorder := lt_strorder. Definition lt_compat := lt_compat. Definition lt_total := lt_total. Definition le_lteq := le_lteq. -End Elts. -Module Tac := !MakeOrderTac Elts. +End IsTotal. +Module Tac := !MakeOrderTac NZ IsTotal. End Private_OrderTac. Ltac order := Private_OrderTac.Tac.order. diff --git a/theories/Numbers/Rational/BigQ/BigQ.v b/theories/Numbers/Rational/BigQ/BigQ.v index 3b2a372e..a2bc5e26 100644 --- a/theories/Numbers/Rational/BigQ/BigQ.v +++ b/theories/Numbers/Rational/BigQ/BigQ.v @@ -42,6 +42,7 @@ Module BigQ <: QType <: OrderedTypeFull <: TotalOrder. Bind Scope bigQ_scope with t t_. Include !QProperties <+ HasEqBool2Dec <+ !MinMaxLogicalProperties <+ !MinMaxDecProperties. + Ltac order := Private_Tac.order. End BigQ. (** Notations about [BigQ] *) @@ -144,8 +145,7 @@ End TestField. (** [BigQ] can also benefit from an "order" tactic *) -Module BigQ_Order := !OrdersTac.MakeOrderTac BigQ. -Ltac bigQ_order := BigQ_Order.order. +Ltac bigQ_order := BigQ.order. Section TestOrder. Let test : forall x y : bigQ, x<=y -> y<=x -> x==y. diff --git a/theories/PArith/BinPos.v b/theories/PArith/BinPos.v index 4747cfe1..be585871 100644 --- a/theories/PArith/BinPos.v +++ b/theories/PArith/BinPos.v @@ -1486,6 +1486,8 @@ Qed. Include UsualMinMaxLogicalProperties <+ UsualMinMaxDecProperties. +Ltac order := Private_Tac.order. + (** Minimum, maximum and constant one *) Lemma max_1_l n : max 1 n = n. diff --git a/theories/Structures/GenericMinMax.v b/theories/Structures/GenericMinMax.v index 5583142f..ffd0649a 100644 --- a/theories/Structures/GenericMinMax.v +++ b/theories/Structures/GenericMinMax.v @@ -40,34 +40,34 @@ Module GenericMinMax (Import O:OrderedTypeFull') <: HasMinMax O. Definition max := gmax O.compare. Definition min := gmin O.compare. - Lemma ge_not_lt : forall x y, y<=x -> x False. + Lemma ge_not_lt x y : y<=x -> x False. Proof. - intros x y H H'. + intros H H'. apply (StrictOrder_Irreflexive x). rewrite le_lteq in *; destruct H as [H|H]. transitivity y; auto. rewrite H in H'; auto. Qed. - Lemma max_l : forall x y, y<=x -> max x y == x. + Lemma max_l x y : y<=x -> max x y == x. Proof. intros. unfold max, gmax. case compare_spec; auto with relations. intros; elim (ge_not_lt x y); auto. Qed. - Lemma max_r : forall x y, x<=y -> max x y == y. + Lemma max_r x y : x<=y -> max x y == y. Proof. intros. unfold max, gmax. case compare_spec; auto with relations. intros; elim (ge_not_lt y x); auto. Qed. - Lemma min_l : forall x y, x<=y -> min x y == x. + Lemma min_l x y : x<=y -> min x y == x. Proof. intros. unfold min, gmin. case compare_spec; auto with relations. intros; elim (ge_not_lt y x); auto. Qed. - Lemma min_r : forall x y, y<=x -> min x y == y. + Lemma min_r x y : y<=x -> min x y == y. Proof. intros. unfold min, gmin. case compare_spec; auto with relations. intros; elim (ge_not_lt x y); auto. @@ -76,31 +76,30 @@ Module GenericMinMax (Import O:OrderedTypeFull') <: HasMinMax O. End GenericMinMax. -(** ** Consequences of the minimalist interface: facts about [max]. *) +(** ** Consequences of the minimalist interface: facts about [max] and [min]. *) -Module MaxLogicalProperties (Import O:TotalOrder')(Import M:HasMax O). - Module Import Private_Tac := !MakeOrderTac O. +Module MinMaxLogicalProperties (Import O:TotalOrder')(Import M:HasMinMax O). + Module Import Private_Tac := !MakeOrderTac O O. (** An alternative caracterisation of [max], equivalent to [max_l /\ max_r] *) -Lemma max_spec : forall n m, - (n < m /\ max n m == m) \/ (m <= n /\ max n m == n). +Lemma max_spec n m : + (n < m /\ max n m == m) \/ (m <= n /\ max n m == n). Proof. - intros n m. destruct (lt_total n m); [left|right]. - split; auto. apply max_r. rewrite le_lteq; auto. - assert (m <= n) by (rewrite le_lteq; intuition). - split; auto. apply max_l; auto. + - split; auto. apply max_r. rewrite le_lteq; auto. + - assert (m <= n) by (rewrite le_lteq; intuition). + split; auto. now apply max_l. Qed. (** A more symmetric version of [max_spec], based only on [le]. Beware that left and right alternatives overlap. *) -Lemma max_spec_le : forall n m, +Lemma max_spec_le n m : (n <= m /\ max n m == m) \/ (m <= n /\ max n m == n). Proof. - intros. destruct (max_spec n m); [left|right]; intuition; order. + destruct (max_spec n m); [left|right]; intuition; order. Qed. Instance : Proper (eq==>eq==>iff) le. @@ -108,25 +107,24 @@ Proof. repeat red. intuition order. Qed. Instance max_compat : Proper (eq==>eq==>eq) max. Proof. -intros x x' Hx y y' Hy. -assert (H1 := max_spec x y). assert (H2 := max_spec x' y'). -set (m := max x y) in *; set (m' := max x' y') in *; clearbody m m'. -rewrite <- Hx, <- Hy in *. -destruct (lt_total x y); intuition order. + intros x x' Hx y y' Hy. + assert (H1 := max_spec x y). assert (H2 := max_spec x' y'). + set (m := max x y) in *; set (m' := max x' y') in *; clearbody m m'. + rewrite <- Hx, <- Hy in *. + destruct (lt_total x y); intuition order. Qed. - (** A function satisfying the same specification is equal to [max]. *) -Lemma max_unicity : forall n m p, - ((n < m /\ p == m) \/ (m <= n /\ p == n)) -> p == max n m. +Lemma max_unicity n m p : + ((n < m /\ p == m) \/ (m <= n /\ p == n)) -> p == max n m. Proof. - intros. assert (Hm := max_spec n m). + assert (Hm := max_spec n m). destruct (lt_total n m); intuition; order. Qed. -Lemma max_unicity_ext : forall f, - (forall n m, (n < m /\ f n m == m) \/ (m <= n /\ f n m == n)) -> +Lemma max_unicity_ext f : + (forall n m, (n < m /\ f n m == m) \/ (m <= n /\ f n m == n)) -> (forall n m, f n m == max n m). Proof. intros. apply max_unicity; auto. @@ -134,12 +132,12 @@ Qed. (** [max] commutes with monotone functions. *) -Lemma max_mono: forall f, +Lemma max_mono f : (Proper (eq ==> eq) f) -> (Proper (le ==> le) f) -> forall x y, max (f x) (f y) == f (max x y). Proof. - intros f Eqf Lef x y. + intros Eqf Lef x y. destruct (max_spec x y) as [(H,E)|(H,E)]; rewrite E; destruct (max_spec (f x) (f y)) as [(H',E')|(H',E')]; auto. assert (f x <= f y) by (apply Lef; order). order. @@ -148,239 +146,232 @@ Qed. (** *** Semi-lattice algebraic properties of [max] *) -Lemma max_id : forall n, max n n == n. +Lemma max_id n : max n n == n. Proof. - intros. destruct (max_spec n n); intuition. + apply max_l; order. Qed. Notation max_idempotent := max_id (only parsing). -Lemma max_assoc : forall m n p, max m (max n p) == max (max m n) p. +Lemma max_assoc m n p : max m (max n p) == max (max m n) p. Proof. - intros. - destruct (max_spec n p) as [(H,Eq)|(H,Eq)]; rewrite Eq. - destruct (max_spec m n) as [(H',Eq')|(H',Eq')]; rewrite Eq'. - destruct (max_spec m p); intuition; order. order. - destruct (max_spec m n) as [(H',Eq')|(H',Eq')]; rewrite Eq'. order. - destruct (max_spec m p); intuition; order. + destruct (max_spec n p) as [(H,E)|(H,E)]; rewrite E; + destruct (max_spec m n) as [(H',E')|(H',E')]; rewrite E', ?E; try easy. + - apply max_r; order. + - symmetry. apply max_l; order. Qed. -Lemma max_comm : forall n m, max n m == max m n. +Lemma max_comm n m : max n m == max m n. Proof. - intros. - destruct (max_spec n m) as [(H,Eq)|(H,Eq)]; rewrite Eq. - destruct (max_spec m n) as [(H',Eq')|(H',Eq')]; rewrite Eq'; order. - destruct (max_spec m n) as [(H',Eq')|(H',Eq')]; rewrite Eq'; order. + destruct (max_spec m n) as [(H,E)|(H,E)]; rewrite E; + (apply max_r || apply max_l); order. Qed. +Ltac solve_max := + match goal with |- context [max ?n ?m] => + destruct (max_spec n m); intuition; order + end. + (** *** Least-upper bound properties of [max] *) -Lemma le_max_l : forall n m, n <= max n m. -Proof. - intros; destruct (max_spec n m); intuition; order. -Qed. +Lemma le_max_l n m : n <= max n m. +Proof. solve_max. Qed. -Lemma le_max_r : forall n m, m <= max n m. -Proof. - intros; destruct (max_spec n m); intuition; order. -Qed. +Lemma le_max_r n m : m <= max n m. +Proof. solve_max. Qed. -Lemma max_l_iff : forall n m, max n m == n <-> m <= n. -Proof. - split. intro H; rewrite <- H. apply le_max_r. apply max_l. -Qed. +Lemma max_l_iff n m : max n m == n <-> m <= n. +Proof. solve_max. Qed. -Lemma max_r_iff : forall n m, max n m == m <-> n <= m. -Proof. - split. intro H; rewrite <- H. apply le_max_l. apply max_r. -Qed. +Lemma max_r_iff n m : max n m == m <-> n <= m. +Proof. solve_max. Qed. -Lemma max_le : forall n m p, p <= max n m -> p <= n \/ p <= m. +Lemma max_le n m p : p <= max n m -> p <= n \/ p <= m. Proof. - intros n m p H; destruct (max_spec n m); - [right|left]; intuition; order. + destruct (max_spec n m); [right|left]; intuition; order. Qed. -Lemma max_le_iff : forall n m p, p <= max n m <-> p <= n \/ p <= m. -Proof. - intros. split. apply max_le. - destruct (max_spec n m); intuition; order. -Qed. +Lemma max_le_iff n m p : p <= max n m <-> p <= n \/ p <= m. +Proof. split. apply max_le. solve_max. Qed. -Lemma max_lt_iff : forall n m p, p < max n m <-> p < n \/ p < m. +Lemma max_lt_iff n m p : p < max n m <-> p < n \/ p < m. Proof. - intros. destruct (max_spec n m); intuition; + destruct (max_spec n m); intuition; order || (right; order) || (left; order). Qed. -Lemma max_lub_l : forall n m p, max n m <= p -> n <= p. -Proof. - intros; destruct (max_spec n m); intuition; order. -Qed. +Lemma max_lub_l n m p : max n m <= p -> n <= p. +Proof. solve_max. Qed. -Lemma max_lub_r : forall n m p, max n m <= p -> m <= p. -Proof. - intros; destruct (max_spec n m); intuition; order. -Qed. +Lemma max_lub_r n m p : max n m <= p -> m <= p. +Proof. solve_max. Qed. -Lemma max_lub : forall n m p, n <= p -> m <= p -> max n m <= p. -Proof. - intros; destruct (max_spec n m); intuition; order. -Qed. +Lemma max_lub n m p : n <= p -> m <= p -> max n m <= p. +Proof. solve_max. Qed. -Lemma max_lub_iff : forall n m p, max n m <= p <-> n <= p /\ m <= p. -Proof. - intros; destruct (max_spec n m); intuition; order. -Qed. +Lemma max_lub_iff n m p : max n m <= p <-> n <= p /\ m <= p. +Proof. solve_max. Qed. -Lemma max_lub_lt : forall n m p, n < p -> m < p -> max n m < p. -Proof. - intros; destruct (max_spec n m); intuition; order. -Qed. +Lemma max_lub_lt n m p : n < p -> m < p -> max n m < p. +Proof. solve_max. Qed. -Lemma max_lub_lt_iff : forall n m p, max n m < p <-> n < p /\ m < p. -Proof. - intros; destruct (max_spec n m); intuition; order. -Qed. +Lemma max_lub_lt_iff n m p : max n m < p <-> n < p /\ m < p. +Proof. solve_max. Qed. -Lemma max_le_compat_l : forall n m p, n <= m -> max p n <= max p m. -Proof. - intros. - destruct (max_spec p n) as [(LT,E)|(LE,E)]; rewrite E. - assert (LE' := le_max_r p m). order. - apply le_max_l. -Qed. +Lemma max_le_compat_l n m p : n <= m -> max p n <= max p m. +Proof. intros. apply max_lub_iff. solve_max. Qed. -Lemma max_le_compat_r : forall n m p, n <= m -> max n p <= max m p. -Proof. - intros. rewrite (max_comm n p), (max_comm m p). - auto using max_le_compat_l. -Qed. +Lemma max_le_compat_r n m p : n <= m -> max n p <= max m p. +Proof. intros. apply max_lub_iff. solve_max. Qed. -Lemma max_le_compat : forall n m p q, n <= m -> p <= q -> - max n p <= max m q. +Lemma max_le_compat n m p q : n <= m -> p <= q -> max n p <= max m q. Proof. - intros n m p q Hnm Hpq. + intros Hnm Hpq. assert (LE := max_le_compat_l _ _ m Hpq). assert (LE' := max_le_compat_r _ _ p Hnm). order. Qed. -End MaxLogicalProperties. - - -(** ** Properties concernant [min], then both [min] and [max]. +(** Properties of [min] *) - To avoid too much code duplication, we exploit that [min] can be - seen as a [max] of the reversed order. -*) +Lemma min_spec n m : + (n < m /\ min n m == n) \/ (m <= n /\ min n m == m). +Proof. + destruct (lt_total n m); [left|right]. + - split; auto. apply min_l. rewrite le_lteq; auto. + - assert (m <= n) by (rewrite le_lteq; intuition). + split; auto. now apply min_r. +Qed. -Module MinMaxLogicalProperties (Import O:TotalOrder')(Import M:HasMinMax O). - Include MaxLogicalProperties O M. - Import Private_Tac. - - Module Import Private_Rev. - Module ORev := TotalOrderRev O. - Module MRev <: HasMax ORev. - Definition max x y := M.min y x. - Definition max_l x y := M.min_r y x. - Definition max_r x y := M.min_l y x. - End MRev. - Module MPRev := MaxLogicalProperties ORev MRev. - End Private_Rev. +Lemma min_spec_le n m : + (n <= m /\ min n m == n) \/ (m <= n /\ min n m == m). +Proof. + destruct (min_spec n m); [left|right]; intuition; order. +Qed. Instance min_compat : Proper (eq==>eq==>eq) min. -Proof. intros x x' Hx y y' Hy. apply MPRev.max_compat; assumption. Qed. +Proof. +intros x x' Hx y y' Hy. +assert (H1 := min_spec x y). assert (H2 := min_spec x' y'). +set (m := min x y) in *; set (m' := min x' y') in *; clearbody m m'. +rewrite <- Hx, <- Hy in *. +destruct (lt_total x y); intuition order. +Qed. -Lemma min_spec : forall n m, - (n < m /\ min n m == n) \/ (m <= n /\ min n m == m). -Proof. intros. exact (MPRev.max_spec m n). Qed. +Lemma min_unicity n m p : + ((n < m /\ p == n) \/ (m <= n /\ p == m)) -> p == min n m. +Proof. + assert (Hm := min_spec n m). + destruct (lt_total n m); intuition; order. +Qed. -Lemma min_spec_le : forall n m, - (n <= m /\ min n m == n) \/ (m <= n /\ min n m == m). -Proof. intros. exact (MPRev.max_spec_le m n). Qed. +Lemma min_unicity_ext f : + (forall n m, (n < m /\ f n m == n) \/ (m <= n /\ f n m == m)) -> + (forall n m, f n m == min n m). +Proof. + intros. apply min_unicity; auto. +Qed. -Lemma min_mono: forall f, +Lemma min_mono f : (Proper (eq ==> eq) f) -> (Proper (le ==> le) f) -> forall x y, min (f x) (f y) == f (min x y). Proof. - intros. apply MPRev.max_mono; auto. compute in *; eauto. + intros Eqf Lef x y. + destruct (min_spec x y) as [(H,E)|(H,E)]; rewrite E; + destruct (min_spec (f x) (f y)) as [(H',E')|(H',E')]; auto. + assert (f x <= f y) by (apply Lef; order). order. + assert (f y <= f x) by (apply Lef; order). order. Qed. -Lemma min_unicity : forall n m p, - ((n < m /\ p == n) \/ (m <= n /\ p == m)) -> p == min n m. -Proof. intros n m p. apply MPRev.max_unicity. Qed. - -Lemma min_unicity_ext : forall f, - (forall n m, (n < m /\ f n m == n) \/ (m <= n /\ f n m == m)) -> - (forall n m, f n m == min n m). -Proof. intros f H n m. apply MPRev.max_unicity, H; auto. Qed. - -Lemma min_id : forall n, min n n == n. -Proof. intros. exact (MPRev.max_id n). Qed. +Lemma min_id n : min n n == n. +Proof. + apply min_l; order. +Qed. Notation min_idempotent := min_id (only parsing). -Lemma min_assoc : forall m n p, min m (min n p) == min (min m n) p. -Proof. intros. symmetry; apply MPRev.max_assoc. Qed. +Lemma min_assoc m n p : min m (min n p) == min (min m n) p. +Proof. + destruct (min_spec n p) as [(H,E)|(H,E)]; rewrite E; + destruct (min_spec m n) as [(H',E')|(H',E')]; rewrite E', ?E; try easy. + - symmetry. apply min_l; order. + - apply min_r; order. +Qed. -Lemma min_comm : forall n m, min n m == min m n. -Proof. intros. exact (MPRev.max_comm m n). Qed. +Lemma min_comm n m : min n m == min m n. +Proof. + destruct (min_spec m n) as [(H,E)|(H,E)]; rewrite E; + (apply min_r || apply min_l); order. +Qed. -Lemma le_min_r : forall n m, min n m <= m. -Proof. intros. exact (MPRev.le_max_l m n). Qed. +Ltac solve_min := + match goal with |- context [min ?n ?m] => + destruct (min_spec n m); intuition; order + end. -Lemma le_min_l : forall n m, min n m <= n. -Proof. intros. exact (MPRev.le_max_r m n). Qed. +Lemma le_min_r n m : min n m <= m. +Proof. solve_min. Qed. -Lemma min_l_iff : forall n m, min n m == n <-> n <= m. -Proof. intros n m. exact (MPRev.max_r_iff m n). Qed. +Lemma le_min_l n m : min n m <= n. +Proof. solve_min. Qed. -Lemma min_r_iff : forall n m, min n m == m <-> m <= n. -Proof. intros n m. exact (MPRev.max_l_iff m n). Qed. +Lemma min_l_iff n m : min n m == n <-> n <= m. +Proof. solve_min. Qed. -Lemma min_le : forall n m p, min n m <= p -> n <= p \/ m <= p. -Proof. intros n m p H. destruct (MPRev.max_le _ _ _ H); auto. Qed. +Lemma min_r_iff n m : min n m == m <-> m <= n. +Proof. solve_min. Qed. -Lemma min_le_iff : forall n m p, min n m <= p <-> n <= p \/ m <= p. -Proof. intros n m p. rewrite (MPRev.max_le_iff m n p); intuition. Qed. +Lemma min_le n m p : min n m <= p -> n <= p \/ m <= p. +Proof. + destruct (min_spec n m); [left|right]; intuition; order. +Qed. + +Lemma min_le_iff n m p : min n m <= p <-> n <= p \/ m <= p. +Proof. split. apply min_le. solve_min. Qed. -Lemma min_lt_iff : forall n m p, min n m < p <-> n < p \/ m < p. -Proof. intros n m p. rewrite (MPRev.max_lt_iff m n p); intuition. Qed. +Lemma min_lt_iff n m p : min n m < p <-> n < p \/ m < p. +Proof. + destruct (min_spec n m); intuition; + order || (right; order) || (left; order). +Qed. -Lemma min_glb_l : forall n m p, p <= min n m -> p <= n. -Proof. intros n m. exact (MPRev.max_lub_r m n). Qed. +Lemma min_glb_l n m p : p <= min n m -> p <= n. +Proof. solve_min. Qed. -Lemma min_glb_r : forall n m p, p <= min n m -> p <= m. -Proof. intros n m. exact (MPRev.max_lub_l m n). Qed. +Lemma min_glb_r n m p : p <= min n m -> p <= m. +Proof. solve_min. Qed. -Lemma min_glb : forall n m p, p <= n -> p <= m -> p <= min n m. -Proof. intros. apply MPRev.max_lub; auto. Qed. +Lemma min_glb n m p : p <= n -> p <= m -> p <= min n m. +Proof. solve_min. Qed. -Lemma min_glb_iff : forall n m p, p <= min n m <-> p <= n /\ p <= m. -Proof. intros. rewrite (MPRev.max_lub_iff m n p); intuition. Qed. +Lemma min_glb_iff n m p : p <= min n m <-> p <= n /\ p <= m. +Proof. solve_min. Qed. -Lemma min_glb_lt : forall n m p, p < n -> p < m -> p < min n m. -Proof. intros. apply MPRev.max_lub_lt; auto. Qed. +Lemma min_glb_lt n m p : p < n -> p < m -> p < min n m. +Proof. solve_min. Qed. -Lemma min_glb_lt_iff : forall n m p, p < min n m <-> p < n /\ p < m. -Proof. intros. rewrite (MPRev.max_lub_lt_iff m n p); intuition. Qed. +Lemma min_glb_lt_iff n m p : p < min n m <-> p < n /\ p < m. +Proof. solve_min. Qed. -Lemma min_le_compat_l : forall n m p, n <= m -> min p n <= min p m. -Proof. intros n m. exact (MPRev.max_le_compat_r m n). Qed. +Lemma min_le_compat_l n m p : n <= m -> min p n <= min p m. +Proof. intros. apply min_glb_iff. solve_min. Qed. -Lemma min_le_compat_r : forall n m p, n <= m -> min n p <= min m p. -Proof. intros n m. exact (MPRev.max_le_compat_l m n). Qed. +Lemma min_le_compat_r n m p : n <= m -> min n p <= min m p. +Proof. intros. apply min_glb_iff. solve_min. Qed. -Lemma min_le_compat : forall n m p q, n <= m -> p <= q -> +Lemma min_le_compat n m p q : n <= m -> p <= q -> min n p <= min m q. -Proof. intros. apply MPRev.max_le_compat; auto. Qed. - +Proof. + intros Hnm Hpq. + assert (LE := min_le_compat_l _ _ m Hpq). + assert (LE' := min_le_compat_r _ _ p Hnm). + order. +Qed. (** *** Combined properties of min and max *) -Lemma min_max_absorption : forall n m, max n (min n m) == n. +Lemma min_max_absorption n m : max n (min n m) == n. Proof. intros. destruct (min_spec n m) as [(C,E)|(C,E)]; rewrite E. @@ -388,7 +379,7 @@ Proof. destruct (max_spec n m); intuition; order. Qed. -Lemma max_min_absorption : forall n m, min n (max n m) == n. +Lemma max_min_absorption n m : min n (max n m) == n. Proof. intros. destruct (max_spec n m) as [(C,E)|(C,E)]; rewrite E. @@ -398,35 +389,35 @@ Qed. (** Distributivity *) -Lemma max_min_distr : forall n m p, +Lemma max_min_distr n m p : max n (min m p) == min (max n m) (max n p). Proof. - intros. symmetry. apply min_mono. + symmetry. apply min_mono. eauto with *. repeat red; intros. apply max_le_compat_l; auto. Qed. -Lemma min_max_distr : forall n m p, +Lemma min_max_distr n m p : min n (max m p) == max (min n m) (min n p). Proof. - intros. symmetry. apply max_mono. + symmetry. apply max_mono. eauto with *. repeat red; intros. apply min_le_compat_l; auto. Qed. (** Modularity *) -Lemma max_min_modular : forall n m p, +Lemma max_min_modular n m p : max n (min m (max n p)) == min (max n m) (max n p). Proof. - intros. rewrite <- max_min_distr. + rewrite <- max_min_distr. destruct (max_spec n p) as [(C,E)|(C,E)]; rewrite E; auto with *. destruct (min_spec m n) as [(C',E')|(C',E')]; rewrite E'. rewrite 2 max_l; try order. rewrite min_le_iff; auto. rewrite 2 max_l; try order. rewrite min_le_iff; auto. Qed. -Lemma min_max_modular : forall n m p, +Lemma min_max_modular n m p : min n (max m (min n p)) == max (min n m) (min n p). Proof. intros. rewrite <- min_max_distr. @@ -438,7 +429,7 @@ Qed. (** Disassociativity *) -Lemma max_min_disassoc : forall n m p, +Lemma max_min_disassoc n m p : min n (max m p) <= max (min n m) p. Proof. intros. rewrite min_max_distr. @@ -447,24 +438,24 @@ Qed. (** Anti-monotonicity swaps the role of [min] and [max] *) -Lemma max_min_antimono : forall f, +Lemma max_min_antimono f : Proper (eq==>eq) f -> Proper (le==>inverse le) f -> forall x y, max (f x) (f y) == f (min x y). Proof. - intros f Eqf Lef x y. + intros Eqf Lef x y. destruct (min_spec x y) as [(H,E)|(H,E)]; rewrite E; destruct (max_spec (f x) (f y)) as [(H',E')|(H',E')]; auto. assert (f y <= f x) by (apply Lef; order). order. assert (f x <= f y) by (apply Lef; order). order. Qed. -Lemma min_max_antimono : forall f, +Lemma min_max_antimono f : Proper (eq==>eq) f -> Proper (le==>inverse le) f -> forall x y, min (f x) (f y) == f (max x y). Proof. - intros f Eqf Lef x y. + intros Eqf Lef x y. destruct (max_spec x y) as [(H,E)|(H,E)]; rewrite E; destruct (min_spec (f x) (f y)) as [(H',E')|(H',E')]; auto. assert (f y <= f x) by (apply Lef; order). order. @@ -480,11 +471,11 @@ Module MinMaxDecProperties (Import O:OrderedTypeFull')(Import M:HasMinMax O). (** Induction principles for [max]. *) -Lemma max_case_strong : forall n m (P:t -> Type), +Lemma max_case_strong n m (P:t -> Type) : (forall x y, x==y -> P x -> P y) -> (m<=n -> P n) -> (n<=m -> P m) -> P (max n m). Proof. -intros n m P Compat Hl Hr. +intros Compat Hl Hr. destruct (CompSpec2Type (compare_spec n m)) as [EQ|LT|GT]. assert (n<=m) by (rewrite le_lteq; auto). apply (Compat m), Hr; auto. symmetry; apply max_r; auto. @@ -494,26 +485,26 @@ assert (m<=n) by (rewrite le_lteq; auto). apply (Compat n), Hl; auto. symmetry; apply max_l; auto. Defined. -Lemma max_case : forall n m (P:t -> Type), +Lemma max_case n m (P:t -> Type) : (forall x y, x == y -> P x -> P y) -> P n -> P m -> P (max n m). Proof. intros. apply max_case_strong; auto. Defined. (** [max] returns one of its arguments. *) -Lemma max_dec : forall n m, {max n m == n} + {max n m == m}. +Lemma max_dec n m : {max n m == n} + {max n m == m}. Proof. - intros n m. apply max_case; auto with relations. + apply max_case; auto with relations. intros x y H [E|E]; [left|right]; rewrite <-H; auto. Defined. (** Idem for [min] *) -Lemma min_case_strong : forall n m (P:O.t -> Type), +Lemma min_case_strong n m (P:O.t -> Type) : (forall x y, x == y -> P x -> P y) -> (n<=m -> P n) -> (m<=n -> P m) -> P (min n m). Proof. -intros n m P Compat Hl Hr. +intros Compat Hl Hr. destruct (CompSpec2Type (compare_spec n m)) as [EQ|LT|GT]. assert (n<=m) by (rewrite le_lteq; auto). apply (Compat n), Hl; auto. symmetry; apply min_l; auto. @@ -523,12 +514,12 @@ assert (m<=n) by (rewrite le_lteq; auto). apply (Compat m), Hr; auto. symmetry; apply min_r; auto. Defined. -Lemma min_case : forall n m (P:O.t -> Type), +Lemma min_case n m (P:O.t -> Type) : (forall x y, x == y -> P x -> P y) -> P n -> P m -> P (min n m). Proof. intros. apply min_case_strong; auto. Defined. -Lemma min_dec : forall n m, {min n m == n} + {min n m == m}. +Lemma min_dec n m : {min n m == n} + {min n m == m}. Proof. intros. apply min_case; auto with relations. intros x y H [E|E]; [left|right]; rewrite <- E; auto with relations. @@ -558,19 +549,19 @@ Module UsualMinMaxLogicalProperties Include MinMaxLogicalProperties O M. - Lemma max_monotone : forall f, Proper (le ==> le) f -> + Lemma max_monotone f : Proper (le ==> le) f -> forall x y, max (f x) (f y) = f (max x y). Proof. intros; apply max_mono; auto. congruence. Qed. - Lemma min_monotone : forall f, Proper (le ==> le) f -> + Lemma min_monotone f : Proper (le ==> le) f -> forall x y, min (f x) (f y) = f (min x y). Proof. intros; apply min_mono; auto. congruence. Qed. - Lemma min_max_antimonotone : forall f, Proper (le ==> inverse le) f -> + Lemma min_max_antimonotone f : Proper (le ==> inverse le) f -> forall x y, min (f x) (f y) = f (max x y). Proof. intros; apply min_max_antimono; auto. congruence. Qed. - Lemma max_min_antimonotone : forall f, Proper (le ==> inverse le) f -> + Lemma max_min_antimonotone f : Proper (le ==> inverse le) f -> forall x y, max (f x) (f y) = f (min x y). Proof. intros; apply max_min_antimono; auto. congruence. Qed. diff --git a/theories/Structures/OrderedType.v b/theories/Structures/OrderedType.v index f84cdf32..75578195 100644 --- a/theories/Structures/OrderedType.v +++ b/theories/Structures/OrderedType.v @@ -108,19 +108,21 @@ Module OrderedTypeFacts (Import O: OrderedType). Lemma lt_total : forall x y, lt x y \/ eq x y \/ lt y x. Proof. intros; destruct (compare x y); auto. Qed. - Module OrderElts <: Orders.TotalOrder. - Definition t := t. - Definition eq := eq. - Definition lt := lt. - Definition le x y := lt x y \/ eq x y. - Definition eq_equiv := eq_equiv. - Definition lt_strorder := lt_strorder. - Definition lt_compat := lt_compat. - Definition lt_total := lt_total. - Lemma le_lteq : forall x y, le x y <-> lt x y \/ eq x y. - Proof. unfold le; intuition. Qed. - End OrderElts. - Module OrderTac := !MakeOrderTac OrderElts. + Module TO. + Definition t := t. + Definition eq := eq. + Definition lt := lt. + Definition le x y := lt x y \/ eq x y. + End TO. + Module IsTO. + Definition eq_equiv := eq_equiv. + Definition lt_strorder := lt_strorder. + Definition lt_compat := lt_compat. + Definition lt_total := lt_total. + Lemma le_lteq x y : TO.le x y <-> lt x y \/ eq x y. + Proof. reflexivity. Qed. + End IsTO. + Module OrderTac := !MakeOrderTac TO IsTO. Ltac order := OrderTac.order. Lemma le_eq x y z : ~lt x y -> eq y z -> ~lt x z. Proof. order. Qed. diff --git a/theories/Structures/OrdersTac.v b/theories/Structures/OrdersTac.v index 66a672c9..68ffc379 100644 --- a/theories/Structures/OrdersTac.v +++ b/theories/Structures/OrdersTac.v @@ -40,16 +40,26 @@ Definition trans_ord o o' := Local Infix "+" := trans_ord. -(** ** The requirements of the tactic : [TotalOrder]. +(** ** The tactic requirements : a total order - [TotalOrder] contains an equivalence [eq], - a strict order [lt] total and compatible with [eq], and - a larger order [le] synonym for [lt\/eq]. + We need : + - an equivalence [eq], + - a strict order [lt] total and compatible with [eq], + - a larger order [le] synonym for [lt\/eq]. + + This used to be provided here via a [TotalOrder], but + for technical reasons related to extraction, we now ask + for two sperate parts: relations in a [EqLtLe] + properties in + [IsTotalOrder]. Note that [TotalOrder = EqLtLe <+ IsTotalOrder] *) +Module Type IsTotalOrder (O:EqLtLe) := + IsEq O <+ IsStrOrder O <+ LeIsLtEq O <+ LtIsTotal O. + (** ** Properties that will be used by the [order] tactic *) -Module OrderFacts(Import O:TotalOrder'). +Module OrderFacts (Import O:EqLtLe)(P:IsTotalOrder O). +Include EqLtLeNotation O. (** Reflexivity rules *) @@ -57,7 +67,7 @@ Lemma eq_refl : forall x, x==x. Proof. reflexivity. Qed. Lemma le_refl : forall x, x<=x. -Proof. intros; rewrite le_lteq; right; reflexivity. Qed. +Proof. intros; rewrite P.le_lteq; right; reflexivity. Qed. Lemma lt_irrefl : forall x, ~ x y<=x -> x==y. Proof. - intros x y; rewrite 2 le_lteq. intuition. + intros x y; rewrite 2 P.le_lteq. intuition. elim (StrictOrder_Irreflexive x); transitivity y; auto. Qed. @@ -90,7 +100,7 @@ Local Notation "#" := interp_ord. Lemma trans : forall o o' x y z, #o x y -> #o' y z -> #(o+o') x z. Proof. -destruct o, o'; simpl; intros x y z; rewrite ?le_lteq; intuition; +destruct o, o'; simpl; intros x y z; rewrite ?P.le_lteq; intuition; subst_eqns; eauto using (StrictOrder_Transitive x y z) with *. Qed. @@ -114,19 +124,19 @@ Proof. eauto using eq_trans, eq_sym. Qed. Lemma not_neq_eq : forall x y, ~~x==y -> x==y. Proof. -intros x y H. destruct (lt_total x y) as [H'|[H'|H']]; auto; +intros x y H. destruct (P.lt_total x y) as [H'|[H'|H']]; auto; destruct H; intro H; rewrite H in H'; eapply lt_irrefl; eauto. Qed. Lemma not_ge_lt : forall x y, ~y<=x -> x x<=y. Proof. -intros x y H. rewrite le_lteq. generalize (lt_total x y); intuition. +intros x y H. rewrite P.le_lteq. generalize (P.lt_total x y); intuition. Qed. Lemma le_neq_lt : forall x y, x<=y -> ~x==y -> x
    \n\n
    \n
    Index" !index_name; - if !header_trailer then - if !footer_file_spec then + if !header_trailer && !footer_file_spec then let cin = Pervasives.open_in !footer_file in try while true do @@ -545,12 +538,14 @@ module Html = struct printf "%s\n" s done with End_of_file -> Pervasives.close_in cin - else - begin - printf "
    This page has been generated by "; - printf "coqdoc\n" Coq_config.wwwcoq; - printf "
    \n\n
    \n\n\n" - end + else + begin + if !index && (get_module false) <> "Index" then + printf "
    \n\n
    \n
    Index" !index_name; + printf "
    This page has been generated by "; + printf "coqdoc\n" Coq_config.wwwcoq; + printf "
    \n\n\n\n\n" + end let start_module () = let ln = !lib_name in @@ -620,15 +615,6 @@ module Html = struct | Some n -> n | None -> addr) - let module_ref m s = - match find_module m with - | Local -> - printf "%s" m s - | External m when !externals -> - printf "%s" m s - | External _ | Unknown -> - output_string s - let ident_ref m fid typ s = match find_module m with | Local -> @@ -645,12 +631,8 @@ module Html = struct | Def (fullid,ty) -> printf "" fullid; printf "%s" (type_name ty) s - | Mod (m,s') when s = s' -> - module_ref m s | Ref (m,fullid,ty) -> ident_ref m fullid (type_name ty) s - | Mod _ -> - printf "%s" s let output_sublexer_string doescape issymbchar tag s = let s = if doescape then escaped s else s in @@ -667,6 +649,7 @@ module Html = struct Tokens.output_tagged_symbol_char tag c let initialize () = + initialize_tex_html(); Tokens.token_tree := token_tree_html; Tokens.outfun := output_sublexer_string diff --git a/tools/fake_ide.ml b/tools/fake_ide.ml index 1e889639..22a36ede 100644 --- a/tools/fake_ide.ml +++ b/tools/fake_ide.ml @@ -21,7 +21,7 @@ let eval_call (call:'a Ide_intf.call) = Xml_utils.print_xml (snd !coqtop) xml_query; flush (snd !coqtop); let xml_answer = Xml_parser.parse p (Xml_parser.SChannel (fst !coqtop)) in - let res = Ide_intf.to_answer xml_answer in + let res = Ide_intf.to_answer xml_answer call in prerr_endline (Ide_intf.pr_full_value call res); match res with Interface.Fail _ -> exit 1 | _ -> () diff --git a/toplevel/ide_intf.ml b/toplevel/ide_intf.ml index 0df24c7a..28f97dc8 100644 --- a/toplevel/ide_intf.ml +++ b/toplevel/ide_intf.ml @@ -45,7 +45,7 @@ type handler = { evars : unit -> evar list option; hints : unit -> (hint list * hint) option; status : unit -> status; - search : search_flags -> search_answer list; + search : search_flags -> string coq_object list; get_options : unit -> (option_name * option_state) list; set_options : (option_name * option_value) list -> unit; inloadpath : string -> bool; @@ -63,7 +63,7 @@ let goals : goals option call = Goal let evars : evar list option call = Evars let hints : (hint list * hint) option call = Hints let status : status call = Status -let search flags : search_answer list call = Search flags +let search flags : string coq_object list call = Search flags let get_options : (option_name * option_state) list call = GetOptions let set_options l : unit call = SetOptions l let inloadpath s : bool call = InLoadPath s @@ -81,7 +81,7 @@ let abstract_eval_call handler c = | Evars -> Obj.magic (handler.evars () : evar list option) | Hints -> Obj.magic (handler.hints () : (hint list * hint) option) | Status -> Obj.magic (handler.status () : status) - | Search flags -> Obj.magic (handler.search flags : search_answer list) + | Search flags -> Obj.magic (handler.search flags : string coq_object list) | GetOptions -> Obj.magic (handler.get_options () : (option_name * option_state) list) | SetOptions opts -> Obj.magic (handler.set_options opts : unit) | InLoadPath s -> Obj.magic (handler.inloadpath s : bool) @@ -130,6 +130,12 @@ let bool_arg tag b = if b then [tag, ""] else [] (** Base types *) +let of_unit () = Element ("unit", [], []) + +let to_unit = function + | Element ("unit", [], []) -> () + | _ -> raise Marshal_error + let of_bool b = if b then constructor "bool" "true" [] else constructor "bool" "false" [] @@ -166,7 +172,8 @@ let to_string = function let of_int i = Element ("int", [], [PCData (string_of_int i)]) let to_int = function -| Element ("int", [], [PCData s]) -> int_of_string s +| Element ("int", [], [PCData s]) -> + (try int_of_string s with Failure _ -> raise Marshal_error) | _ -> raise Marshal_error let of_pair f g (x, y) = Element ("pair", [], [f x; g y]) @@ -232,20 +239,20 @@ let to_search_constraint xml = do_match xml "search_constraint" | "include_blacklist" -> Include_Blacklist | _ -> raise Marshal_error) -let of_search_answer ans = - let path = of_list of_string ans.search_answer_full_path in - let name = of_string ans.search_answer_base_name in - let tpe = of_string ans.search_answer_type in - Element ("search_answer", [], [path; name; tpe]) - -let to_search_answer = function -| Element ("search_answer", [], [path; name; tpe]) -> - let path = to_list to_string path in - let name = to_string name in - let tpe = to_string tpe in { - search_answer_full_path = path; - search_answer_base_name = name; - search_answer_type = tpe; +let of_coq_object f ans = + let prefix = of_list of_string ans.coq_object_prefix in + let qualid = of_list of_string ans.coq_object_qualid in + let obj = f ans.coq_object_object in + Element ("coq_object", [], [prefix; qualid; obj]) + +let to_coq_object f = function +| Element ("coq_object", [], [prefix; qualid; obj]) -> + let prefix = to_list to_string prefix in + let qualid = to_list to_string qualid in + let obj = f obj in { + coq_object_prefix = prefix; + coq_object_qualid = qualid; + coq_object_object = obj; } | _ -> raise Marshal_error @@ -412,51 +419,74 @@ let to_coq_info = function } | _ -> raise Marshal_error -let of_hints = - let of_hint = of_list (of_pair of_string of_string) in - of_option (of_pair (of_list of_hint) of_hint) - -let of_answer (q : 'a call) (r : 'a value) = - let convert = match q with - | Interp _ -> Obj.magic (of_string : string -> xml) - | Rewind _ -> Obj.magic (of_int : int -> xml) - | Goal -> Obj.magic (of_option of_goals : goals option -> xml) - | Evars -> Obj.magic (of_option (of_list of_evar) : evar list option -> xml) - | Hints -> Obj.magic (of_hints : (hint list * hint) option -> xml) - | Status -> Obj.magic (of_status : status -> xml) - | Search _ -> Obj.magic (of_list of_search_answer : search_answer list -> xml) - | GetOptions -> Obj.magic (of_list (of_pair (of_list of_string) of_option_state) : (option_name * option_state) list -> xml) - | SetOptions _ -> Obj.magic (fun _ -> Element ("unit", [], [])) - | InLoadPath _ -> Obj.magic (of_bool : bool -> xml) - | MkCases _ -> Obj.magic (of_list (of_list of_string) : string list list -> xml) - | Quit -> Obj.magic (fun _ -> Element ("unit", [], [])) - | About -> Obj.magic (of_coq_info : coq_info -> xml) +(** Conversions between ['a value] and xml answers + + When decoding an xml answer, we dynamically check that it is compatible + with the original call. For that we now rely on the fact that all + sub-fonctions [to_xxx : xml -> xxx] check that the current xml element + is "xxx", and raise [Marshal_error] if anything goes wrong. +*) + +type value_type = + | Unit | String | Int | Bool | Goals | Evar | State | Option_state | Coq_info + | Option of value_type + | List of value_type + | Coq_object of value_type + | Pair of value_type * value_type + +let hint = List (Pair (String, String)) +let option_name = List String + +let expected_answer_type = function + | Interp _ -> String + | Rewind _ -> Int + | Goal -> Option Goals + | Evars -> Option (List Evar) + | Hints -> Option (Pair (List hint, hint)) + | Status -> State + | Search _ -> List (Coq_object String) + | GetOptions -> List (Pair (option_name, Option_state)) + | SetOptions _ -> Unit + | InLoadPath _ -> Bool + | MkCases _ -> List (List String) + | Quit -> Unit + | About -> Coq_info + +let of_answer (q : 'a call) (r : 'a value) : xml = + let rec convert ty : 'a -> xml = match ty with + | Unit -> Obj.magic of_unit + | Bool -> Obj.magic of_bool + | String -> Obj.magic of_string + | Int -> Obj.magic of_int + | State -> Obj.magic of_status + | Option_state -> Obj.magic of_option_state + | Coq_info -> Obj.magic of_coq_info + | Goals -> Obj.magic of_goals + | Evar -> Obj.magic of_evar + | List t -> Obj.magic (of_list (convert t)) + | Option t -> Obj.magic (of_option (convert t)) + | Coq_object t -> Obj.magic (of_coq_object (convert t)) + | Pair (t1,t2) -> Obj.magic (of_pair (convert t1) (convert t2)) in - of_value convert r - -let to_answer xml = - let rec convert elt = match elt with - | Element (tpe, attrs, l) -> - begin match tpe with - | "unit" -> Obj.magic () - | "string" -> Obj.magic (to_string elt : string) - | "int" -> Obj.magic (to_int elt : int) - | "status" -> Obj.magic (to_status elt : status) - | "bool" -> Obj.magic (to_bool elt : bool) - | "list" -> Obj.magic (to_list convert elt : 'a list) - | "option" -> Obj.magic (to_option convert elt : 'a option) - | "pair" -> Obj.magic (to_pair convert convert elt : ('a * 'b)) - | "goals" -> Obj.magic (to_goals elt : goals) - | "evar" -> Obj.magic (to_evar elt : evar) - | "option_value" -> Obj.magic (to_option_value elt : option_value) - | "option_state" -> Obj.magic (to_option_state elt : option_state) - | "coq_info" -> Obj.magic (to_coq_info elt : coq_info) - | "search_answer" -> Obj.magic (to_search_answer elt : search_answer) - | _ -> raise Marshal_error - end - | _ -> raise Marshal_error + of_value (convert (expected_answer_type q)) r + +let to_answer xml (c : 'a call) : 'a value = + let rec convert ty : xml -> 'a = match ty with + | Unit -> Obj.magic to_unit + | Bool -> Obj.magic to_bool + | String -> Obj.magic to_string + | Int -> Obj.magic to_int + | State -> Obj.magic to_status + | Option_state -> Obj.magic to_option_state + | Coq_info -> Obj.magic to_coq_info + | Goals -> Obj.magic to_goals + | Evar -> Obj.magic to_evar + | List t -> Obj.magic (to_list (convert t)) + | Option t -> Obj.magic (to_option (convert t)) + | Coq_object t -> Obj.magic (to_coq_object (convert t)) + | Pair (t1,t2) -> Obj.magic (to_pair (convert t1) (convert t2)) in - to_value convert xml + to_value (convert (expected_answer_type c)) xml (** * Debug printing *) diff --git a/toplevel/ide_intf.mli b/toplevel/ide_intf.mli index 26c6b671..7d0685b1 100644 --- a/toplevel/ide_intf.mli +++ b/toplevel/ide_intf.mli @@ -77,7 +77,7 @@ type handler = { evars : unit -> evar list option; hints : unit -> (hint list * hint) option; status : unit -> status; - search : search_flags -> search_answer list; + search : search_flags -> string coq_object list; get_options : unit -> (option_name * option_state) list; set_options : (option_name * option_value) list -> unit; inloadpath : string -> bool; @@ -104,7 +104,7 @@ val of_call : 'a call -> xml val to_call : xml -> 'a call val of_answer : 'a call -> 'a value -> xml -val to_answer : xml -> 'a value +val to_answer : xml -> 'a call -> 'a value (** * Debug printing *) diff --git a/toplevel/ide_slave.ml b/toplevel/ide_slave.ml index 681eec0d..d67b272e 100644 --- a/toplevel/ide_slave.ml +++ b/toplevel/ide_slave.ml @@ -127,25 +127,25 @@ let hyp_next_tac sigma env (id,_,ast) = let id_s = Names.string_of_id id in let type_s = string_of_ppcmds (pr_ltype_env env ast) in [ - ("clear "^id_s),("clear "^id_s^".\n"); - ("apply "^id_s),("apply "^id_s^".\n"); - ("exact "^id_s),("exact "^id_s^".\n"); - ("generalize "^id_s),("generalize "^id_s^".\n"); - ("absurd <"^id_s^">"),("absurd "^type_s^".\n") + ("clear "^id_s),("clear "^id_s^"."); + ("apply "^id_s),("apply "^id_s^"."); + ("exact "^id_s),("exact "^id_s^"."); + ("generalize "^id_s),("generalize "^id_s^"."); + ("absurd <"^id_s^">"),("absurd "^type_s^".") ] @ [ - ("discriminate "^id_s),("discriminate "^id_s^".\n"); - ("injection "^id_s),("injection "^id_s^".\n") + ("discriminate "^id_s),("discriminate "^id_s^"."); + ("injection "^id_s),("injection "^id_s^".") ] @ [ - ("rewrite "^id_s),("rewrite "^id_s^".\n"); - ("rewrite <- "^id_s),("rewrite <- "^id_s^".\n") + ("rewrite "^id_s),("rewrite "^id_s^"."); + ("rewrite <- "^id_s),("rewrite <- "^id_s^".") ] @ [ - ("elim "^id_s), ("elim "^id_s^".\n"); - ("inversion "^id_s), ("inversion "^id_s^".\n"); - ("inversion clear "^id_s), ("inversion_clear "^id_s^".\n") + ("elim "^id_s), ("elim "^id_s^"."); + ("inversion "^id_s), ("inversion "^id_s^"."); + ("inversion clear "^id_s), ("inversion_clear "^id_s^".") ] let concl_next_tac sigma concl = - let expand s = (s,s^".\n") in + let expand s = (s,s^".") in List.map expand ([ "intro"; "intros"; @@ -312,16 +312,26 @@ let search flags = in let ans = ref [] in let print_function ref env constr = - let name = Names.string_of_id (Nametab.basename_of_global ref) in - let make_path = Names.string_of_id in - let path = - List.rev_map make_path (Names.repr_dirpath (Nametab.dirpath_of_global ref)) - in - let answer = { - Interface.search_answer_full_path = path; - Interface.search_answer_base_name = name; - Interface.search_answer_type = string_of_ppcmds (pr_lconstr_env env constr); - } in + let fullpath = repr_dirpath (Nametab.dirpath_of_global ref) in + let qualid = Nametab.shortest_qualid_of_global Idset.empty ref in + let (shortpath, basename) = Libnames.repr_qualid qualid in + let shortpath = repr_dirpath shortpath in + (* [shortpath] is a suffix of [fullpath] and we're looking for the missing + prefix *) + let rec prefix full short accu = match full, short with + | _, [] -> + let full = List.rev_map string_of_id full in + (full, accu) + | _ :: full, m :: short -> + prefix full short (string_of_id m :: accu) + | _ -> assert false + in + let (prefix, qualid) = prefix fullpath shortpath [string_of_id basename] in + let answer = { + Interface.coq_object_prefix = prefix; + Interface.coq_object_qualid = qualid; + Interface.coq_object_object = string_of_ppcmds (pr_lconstr_env env constr); + } in ans := answer :: !ans; in let () = Search.gen_filtered_search filter_function print_function in @@ -432,6 +442,9 @@ let loop () = let () = pr_debug ("--> " ^ Ide_intf.pr_full_value q r) in Ide_intf.of_answer q r with + | Xml_parser.Error (Xml_parser.Empty, _) -> + pr_debug ("End of input, exiting"); + exit 0 | Xml_parser.Error (err, loc) -> let msg = "Syntax error in query: " ^ Xml_parser.error_msg err in fail msg diff --git a/toplevel/interface.mli b/toplevel/interface.mli index 39fb2a0e..7b4312a3 100644 --- a/toplevel/interface.mli +++ b/toplevel/interface.mli @@ -86,10 +86,14 @@ type search_constraint = the flag should be negated. *) type search_flags = (search_constraint * bool) list -type search_answer = { - search_answer_full_path : string list; - search_answer_base_name : string; - search_answer_type : string; +(** A named object in Coq. [coq_object_qualid] is the shortest path defined for + the user. [coq_object_prefix] is the missing part to recover the fully + qualified name, i.e [fully_qualified = coq_object_prefix + coq_object_qualid]. + [coq_object_object] is the actual content of the object. *) +type 'a coq_object = { + coq_object_prefix : string list; + coq_object_qualid : string list; + coq_object_object : 'a; } type coq_info = { diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index fe6bf7db..6618b695 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -208,7 +208,7 @@ let show_match id = str "| " ++ hov 1 (prlist_with_sep spc str l) ++ str " =>" in msg (v 1 (str "match # with" ++ fnl () ++ - prlist_with_sep fnl pr_branch patterns ++ fnl ())) + prlist_with_sep fnl pr_branch patterns ++ fnl () ++ str "end" ++ fnl ())) (* "Print" commands *) -- cgit v1.2.3 From 499a11a45b5711d4eaabe84a80f0ad3ae539d500 Mon Sep 17 00:00:00 2001 From: Stephane Glondu Date: Wed, 8 May 2013 17:47:10 +0200 Subject: Imported Upstream version 8.4pl2dfsg --- CHANGES | 29 ++++++++++++ checker/check.ml | 6 +-- checker/checker.ml | 3 +- checker/mod_checking.ml | 7 ++- configure | 2 +- dev/base_include | 4 +- dev/top_printers.ml | 6 +-- ide/coqide.ml | 7 ++- ide/coqide_main.ml4 | 52 +++++++++------------ ide/gtk_parsing.ml | 1 + ide/ide_win32_stubs.c | 44 ++++++++--------- interp/constrextern.ml | 33 +++++++------ interp/constrextern.mli | 9 ++-- interp/constrintern.ml | 14 +++--- interp/implicit_quantifiers.ml | 4 +- interp/notation.ml | 2 +- kernel/csymtable.ml | 4 +- kernel/mod_subst.ml | 25 ++++++---- kernel/modops.ml | 2 +- kernel/modops.mli | 3 +- kernel/names.ml | 10 ++-- kernel/pre_env.ml | 2 +- kernel/safe_typing.ml | 5 +- kernel/subtyping.ml | 12 +++-- lib/envars.ml | 19 ++++---- lib/errors.ml | 13 +++++- lib/errors.mli | 8 ++++ lib/flags.ml | 4 +- lib/hashtbl_alt.ml | 2 +- lib/pp.ml4 | 2 +- lib/profile.ml | 30 ++++++------ lib/store.ml | 2 +- lib/system.ml | 24 ++++++---- lib/system.mli | 2 +- lib/xml_parser.ml | 6 +-- library/declaremods.ml | 4 +- library/heads.ml | 2 +- library/impargs.ml | 4 +- library/library.ml | 17 +++---- myocamlbuild.ml | 15 +++--- parsing/argextend.ml4 | 2 +- parsing/egrammar.ml | 2 +- parsing/g_tactic.ml4 | 2 +- parsing/g_xml.ml4 | 3 +- parsing/prettyp.ml | 8 ++-- parsing/printer.ml | 65 ++++++++++++++++++++++++-- parsing/printer.mli | 11 +++++ parsing/printmod.ml | 59 +++++++++++++++-------- parsing/tacextend.ml4 | 4 +- parsing/vernacextend.ml4 | 4 +- plugins/cc/ccalgo.ml | 7 ++- plugins/cc/cctac.ml | 4 +- plugins/decl_mode/decl_mode.ml | 4 +- plugins/decl_mode/decl_proof_instr.ml | 9 ++-- plugins/extraction/extract_env.ml | 18 ++++--- plugins/extraction/extraction.ml | 4 +- plugins/extraction/haskell.ml | 4 +- plugins/extraction/mlutil.ml | 4 +- plugins/extraction/ocaml.ml | 5 +- plugins/extraction/table.ml | 6 +-- plugins/firstorder/g_ground.ml4 | 2 +- plugins/firstorder/instances.ml | 2 +- plugins/fourier/fourier.ml | 2 +- plugins/fourier/fourierR.ml | 18 ++++--- plugins/funind/functional_principles_proofs.ml | 23 +++++---- plugins/funind/functional_principles_types.ml | 13 ++---- plugins/funind/g_indfun.ml4 | 4 +- plugins/funind/glob_term_to_relation.ml | 13 +++--- plugins/funind/glob_termops.ml | 6 ++- plugins/funind/indfun.ml | 14 +++--- plugins/funind/indfun_common.ml | 18 +++---- plugins/funind/invfun.ml | 17 ++++--- plugins/funind/merge.ml | 6 +-- plugins/funind/recdef.ml | 37 +++++++++------ plugins/micromega/certificate.ml | 7 +-- plugins/micromega/coq_micromega.ml | 24 ++++++---- plugins/micromega/csdpcert.ml | 6 +-- plugins/micromega/mfourier.ml | 3 +- plugins/micromega/mutils.ml | 12 +++-- plugins/micromega/persistent_cache.ml | 10 ++-- plugins/nsatz/ideal.ml | 5 +- plugins/nsatz/polynom.ml | 4 +- plugins/nsatz/utile.ml | 16 ++++--- plugins/omega/coq_omega.ml | 5 +- plugins/quote/quote.ml | 5 +- plugins/ring/ring.ml | 3 +- plugins/romega/const_omega.ml | 4 +- plugins/romega/refl_omega.ml | 30 +++++++----- plugins/subtac/g_subtac.ml4 | 3 +- plugins/subtac/subtac.ml | 4 +- plugins/subtac/subtac_cases.ml | 5 +- plugins/subtac/subtac_coercion.ml | 4 +- plugins/subtac/subtac_command.ml | 4 +- plugins/subtac/subtac_obligations.ml | 7 +-- plugins/subtac/subtac_pretyping_F.ml | 6 ++- plugins/subtac/subtac_utils.ml | 8 ++-- plugins/xml/cic2acic.ml | 2 +- plugins/xml/doubleTypeInference.ml | 3 +- plugins/xml/xmlcommand.ml | 2 +- pretyping/coercion.ml | 2 +- pretyping/detyping.ml | 6 +-- pretyping/evarconv.ml | 8 ++-- pretyping/evarutil.ml | 27 +++++++---- pretyping/evarutil.mli | 1 + pretyping/evd.ml | 5 +- pretyping/evd.mli | 1 + pretyping/inductiveops.ml | 1 + pretyping/pretyping.ml | 11 +++-- pretyping/recordops.ml | 8 ++-- pretyping/reductionops.ml | 10 +++- pretyping/retyping.ml | 12 ++--- pretyping/tacred.ml | 10 ++-- pretyping/typeclasses.ml | 10 ++-- pretyping/unification.ml | 13 ++++-- pretyping/vnorm.ml | 24 +++++++--- proofs/evar_refiner.ml | 2 +- proofs/goal.ml | 16 +++++-- proofs/goal.mli | 2 +- proofs/logic.ml | 2 +- proofs/pfedit.ml | 6 +-- proofs/proof.ml | 10 ++-- proofs/proofview.ml | 10 ++-- proofs/refiner.ml | 8 ++-- proofs/tactic_debug.ml | 8 ++-- scripts/coqmktop.ml | 13 +++--- tactics/auto.ml | 11 +++-- tactics/autorewrite.ml | 12 +++-- tactics/class_tactics.ml4 | 7 ++- tactics/eauto.ml4 | 3 +- tactics/equality.ml | 5 +- tactics/extratactics.ml4 | 2 +- tactics/hipattern.ml4 | 10 +++- tactics/inv.ml | 4 +- tactics/rewrite.ml4 | 25 ++++++---- tactics/tacinterp.ml | 64 +++++++++++++------------ tactics/tactics.ml | 15 ++++-- test-suite/bugs/closed/2955.v | 52 +++++++++++++++++++++ test-suite/bugs/closed/shouldsucceed/2629.v | 22 +++++++++ test-suite/bugs/closed/shouldsucceed/2668.v | 6 +++ test-suite/bugs/closed/shouldsucceed/2734.v | 15 ++++++ test-suite/bugs/closed/shouldsucceed/2750.v | 23 +++++++++ test-suite/bugs/closed/shouldsucceed/2928.v | 11 +++++ test-suite/bugs/closed/shouldsucceed/2983.v | 8 ++++ test-suite/bugs/closed/shouldsucceed/2995.v | 9 ++++ test-suite/bugs/closed/shouldsucceed/3000.v | 2 + test-suite/bugs/closed/shouldsucceed/3004.v | 7 +++ test-suite/bugs/closed/shouldsucceed/3008.v | 29 ++++++++++++ test-suite/output/inference.out | 4 ++ test-suite/output/inference.v | 12 +++++ test-suite/success/remember.v | 8 ++++ theories/Numbers/NatInt/NZOrder.v | 2 +- toplevel/auto_ind_decl.ml | 44 +++++++++-------- toplevel/autoinstance.ml | 3 +- toplevel/backtrack.ml | 4 +- toplevel/classes.ml | 11 +++-- toplevel/coqinit.ml | 4 +- toplevel/coqtop.ml | 9 ++-- toplevel/himsg.ml | 11 +++-- toplevel/ide_intf.ml | 6 +-- toplevel/ide_slave.ml | 11 +++-- toplevel/ind_tables.ml | 5 +- toplevel/indschemes.ml | 7 +-- toplevel/lemmas.ml | 27 +++++++---- toplevel/metasyntax.ml | 13 ++++-- toplevel/mltop.ml4 | 11 +++-- toplevel/search.ml | 2 +- toplevel/toplevel.ml | 12 ++--- toplevel/vernac.ml | 24 +++++----- toplevel/vernacentries.ml | 13 ++++-- toplevel/vernacinterp.ml | 4 +- 170 files changed, 1205 insertions(+), 632 deletions(-) create mode 100644 test-suite/bugs/closed/2955.v create mode 100644 test-suite/bugs/closed/shouldsucceed/2629.v create mode 100644 test-suite/bugs/closed/shouldsucceed/2668.v create mode 100644 test-suite/bugs/closed/shouldsucceed/2734.v create mode 100644 test-suite/bugs/closed/shouldsucceed/2750.v create mode 100644 test-suite/bugs/closed/shouldsucceed/2928.v create mode 100644 test-suite/bugs/closed/shouldsucceed/2983.v create mode 100644 test-suite/bugs/closed/shouldsucceed/2995.v create mode 100644 test-suite/bugs/closed/shouldsucceed/3000.v create mode 100644 test-suite/bugs/closed/shouldsucceed/3004.v create mode 100644 test-suite/bugs/closed/shouldsucceed/3008.v (limited to 'toplevel') diff --git a/CHANGES b/CHANGES index fa0cca0c..a696ad71 100644 --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,30 @@ +Changes from V8.4pl1 to V8.4pl2 +=============================== + +Bug fixes + +- Solved bugs : + #2466 #2629 #2668 #2750 #2839 #2869 #2954 #2955 #2959 #2962 #2966 #2967 + #2969 #2970 #2975 #2976 #2977 #2978 #2981 #2983 #2995 #3000 #3004 #3008 +- Partially fixed bugs : #2830 #2949 +- Coqtop should now react more reliably when receiving interrupt signals: + all the "try...with" constructs have been protected against undue + handling of the Sys.Break exception. + +Coqide + +- The Windows-specific code handling the interrupt button of Coqide + had to be reworked (cf. bug #2869). Now, in Win32 this button does + not target a specific coqtop client, but instead sends a Ctrl-C to + any process sharing its console with Coqide. To avoid awkward + effects, it is recommended to launch Coqide via its icon, its menu, + or in a dedicated console window. + +Extraction + +- The option Extraction AccessOpaque is now set by default, + restoring compatibility of older versions of Coq (cf bug #2952). + Changes from V8.4 to V8.4pl1 ============================ @@ -2438,3 +2465,5 @@ New user contributions - Correctness proof of Stalmarck tautology checker algorithm [Stalmarck] (Laurent Théry, Pierre Letouzey, Sophia-Antipolis) + + LocalWords: recommended diff --git a/checker/check.ml b/checker/check.ml index 237eb079..fb0dc12a 100644 --- a/checker/check.ml +++ b/checker/check.ml @@ -290,9 +290,9 @@ let intern_from_file (dir, f) = let (md,table,digest) = try let ch = with_magic_number_check raw_intern_library f in - let (md:library_disk) = System.marshal_in ch in - let digest = System.marshal_in ch in - let table = (System.marshal_in ch : Safe_typing.LightenLibrary.table) in + let (md:library_disk) = System.marshal_in f ch in + let digest = System.marshal_in f ch in + let table = (System.marshal_in f ch : Safe_typing.LightenLibrary.table) in close_in ch; if dir <> md.md_name then errorlabstrm "load_physical_library" diff --git a/checker/checker.ml b/checker/checker.ml index 945abde4..e5e20b1a 100644 --- a/checker/checker.ml +++ b/checker/checker.ml @@ -371,7 +371,8 @@ let run () = compile_files (); flush_all() with e -> - (Pp.ppnl(explain_exn e); + (flush_all(); + Pp.ppnl(explain_exn e); flush_all(); exit 1) diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml index e3431fec..dc3ed452 100644 --- a/checker/mod_checking.ml +++ b/checker/mod_checking.ml @@ -133,6 +133,11 @@ let lookup_modtype mp env = with Not_found -> failwith ("Unknown module type: "^string_of_mp mp) +let lookup_module mp env = + try Environ.lookup_module mp env + with Not_found -> + failwith ("Unknown module: "^string_of_mp mp) + let rec check_with env mtb with_decl mp= match with_decl with | With_definition_body (idl,c) -> @@ -199,7 +204,7 @@ and check_with_mod env mtb (idl,mp1) mp = SFBmodule msb -> msb | _ -> error_not_a_module l in - let (_:module_body) = (lookup_module mp1 env) in () + let (_:module_body) = (Environ.lookup_module mp1 env) in () else let old = match spec with SFBmodule msb -> msb diff --git a/configure b/configure index 589cba6e..f7bdf154 100755 --- a/configure +++ b/configure @@ -6,7 +6,7 @@ # ################################## -VERSION=8.4pl1 +VERSION=8.4pl2 VOMAGIC=08400 STATEMAGIC=58400 DATE=`LC_ALL=C LANG=C date +"%B %Y"` diff --git a/dev/base_include b/dev/base_include index ad2a3aec..9a788b7b 100644 --- a/dev/base_include +++ b/dev/base_include @@ -200,8 +200,8 @@ let pf_e gl s = (* Set usual printing since the global env is available from the tracer *) let _ = Constrextern.in_debugger := false -let _ = Constrextern.set_debug_global_reference_printer - (fun loc r -> Libnames.Qualid (loc,Nametab.shortest_qualid_of_global Idset.empty r));; +let _ = Constrextern.set_extern_reference + (fun loc _ r -> Libnames.Qualid (loc,Nametab.shortest_qualid_of_global Idset.empty r));; open Toplevel let go = loop diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 0038e78a..c55c4377 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -459,7 +459,7 @@ let encode_path loc prefix mpdir suffix id = Qualid (loc, make_qualid (make_dirpath (List.rev (id_of_string prefix::dir@suffix))) id) -let raw_string_of_ref loc = function +let raw_string_of_ref loc _ = function | ConstRef cst -> let (mp,dir,id) = repr_con cst in encode_path loc "CST" (Some (mp,dir)) [] (id_of_label id) @@ -475,7 +475,7 @@ let raw_string_of_ref loc = function | VarRef id -> encode_path loc "SECVAR" None [] id -let short_string_of_ref loc = function +let short_string_of_ref loc _ = function | VarRef id -> Ident (loc,id) | ConstRef cst -> Ident (loc,id_of_label (pi3 (repr_con cst))) | IndRef (kn,0) -> Ident (loc,id_of_label (pi3 (repr_mind kn))) @@ -491,5 +491,5 @@ let short_string_of_ref loc = function pretty-printer should not make calls to the global env since ocamldebug runs in a different process and does not have the proper env at hand *) let _ = Constrextern.in_debugger := true -let _ = Constrextern.set_debug_global_reference_printer +let _ = Constrextern.set_extern_reference (if !rawdebug then raw_string_of_ref else short_string_of_ref) diff --git a/ide/coqide.ml b/ide/coqide.ml index 07de4daf..94be8318 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -212,6 +212,9 @@ let ignore_break () = try Sys.set_signal i (Sys.Signal_handle crash_save) with _ -> prerr_endline "Signal ignored (normal if Win32)") signals_to_crash; + (* We ignore the Ctrl-C, this is required for the Stop button to work, + since we will actually send Ctrl-C to all processes sharing + our console (including us) *) Sys.set_signal Sys.sigint Sys.Signal_ignore @@ -902,7 +905,7 @@ object(self) if stop#compare start > 0 && is_sentence_end stop#backward_char then Some (start,stop) else None - with Not_found -> None + with StartError -> None method complete_at_offset (offset:int) = prerr_endline ("Completion at offset : " ^ string_of_int offset); @@ -2449,7 +2452,7 @@ let main files = try configure ~apply:update_notebook_pos () with _ -> flash_info "Cannot save preferences" end; - reset_revert_timer ()) ~accel:"," ~stock:`PREFERENCES; + reset_revert_timer ()) ~accel:"comma" ~stock:`PREFERENCES; (* GAction.add_action "Save preferences" ~label:"_Save preferences" ~callback:(fun _ -> save_pref ()); *) ]; GAction.add_actions view_actions [ GAction.add_action "View" ~label:"_View"; diff --git a/ide/coqide_main.ml4 b/ide/coqide_main.ml4 index ebcecc17..aaede465 100644 --- a/ide/coqide_main.ml4 +++ b/ide/coqide_main.ml4 @@ -38,6 +38,11 @@ let catch_gtk_messages () = let () = catch_gtk_messages () +(* We anticipate a bit the argument parsing and look for -debug *) + +let early_set_debug () = + Ideutils.debug := List.mem "-debug" (Array.to_list Sys.argv) + (* On win32, we add the directory of coqide to the PATH at launch-time (this used to be done in a .bat script). *) @@ -46,47 +51,32 @@ let set_win32_path () = (Filename.dirname Sys.executable_name ^ ";" ^ (try Sys.getenv "PATH" with _ -> "")) -(* On win32, since coqide is now console-free, we re-route stdout/stderr - to avoid Sys_error if someone writes to them. We write to a pipe which - is never read (by default) or to a temp log file (when in debug mode). -*) - -let reroute_stdout_stderr () = - (* We anticipate a bit the argument parsing and look for -debug *) - let debug = List.mem "-debug" (Array.to_list Sys.argv) in - Ideutils.debug := debug; - let out_descr = - if debug then - let (name,chan) = Filename.open_temp_file "coqide_" ".log" in - Coqide.logfile := Some name; - Unix.descr_of_out_channel chan - else - snd (Unix.pipe ()) - in +(* On win32, in debug mode we duplicate stdout/stderr in a log file. *) + +let log_stdout_stderr () = + let (name,chan) = Filename.open_temp_file "coqide_" ".log" in + Coqide.logfile := Some name; + let out_descr = Unix.descr_of_out_channel chan in Unix.set_close_on_exec out_descr; Unix.dup2 out_descr Unix.stdout; Unix.dup2 out_descr Unix.stderr (* We also provide specific kill and interrupt functions. *) -(* Since [win32_interrupt] involves some hack about the process console, - only one should run at the same time, we simply skip execution of - [win32_interrupt] if another instance is already running *) - -let ctrl_c_mtx = Mutex.create () - -let ctrl_c_protect f i = - if not (Mutex.try_lock ctrl_c_mtx) then () - else try f i; Mutex.unlock ctrl_c_mtx with _ -> Mutex.unlock ctrl_c_mtx - IFDEF WIN32 THEN external win32_kill : int -> unit = "win32_kill" -external win32_interrupt : int -> unit = "win32_interrupt" +external win32_interrupt_all : unit -> unit = "win32_interrupt_all" +external win32_hide_console : unit -> unit = "win32_hide_console" + let () = - Coq.killer := win32_kill; - Coq.interrupter := ctrl_c_protect win32_interrupt; set_win32_path (); - reroute_stdout_stderr () + Coq.killer := win32_kill; + Coq.interrupter := (fun pid -> win32_interrupt_all ()); + early_set_debug (); + if !Ideutils.debug then + log_stdout_stderr () + else + win32_hide_console () END IFDEF QUARTZ THEN diff --git a/ide/gtk_parsing.ml b/ide/gtk_parsing.ml index 67f7e649..47096e6f 100644 --- a/ide/gtk_parsing.ml +++ b/ide/gtk_parsing.ml @@ -6,6 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Ideutils let underscore = Glib.Utf8.to_unichar "_" ~pos:(ref 0) let arobase = Glib.Utf8.to_unichar "@" ~pos:(ref 0) diff --git a/ide/ide_win32_stubs.c b/ide/ide_win32_stubs.c index c09bf37d..c170b1a9 100644 --- a/ide/ide_win32_stubs.c +++ b/ide/ide_win32_stubs.c @@ -19,31 +19,33 @@ CAMLprim value win32_kill(value pseudopid) { CAMLreturn(Val_unit); } - /* Win32 emulation of a kill -2 (SIGINT) */ -/* This code rely of the fact that coqide is now without initial console. - Otherwise, no console creation in win32unix/createprocess.c, hence - the same console for coqide and all coqtop, and everybody will be - signaled at the same time by the code below. */ +/* For simplicity, we signal all processes sharing a console with coqide. + This shouldn't be an issue since currently at most one coqtop is busy + at a given time. Earlier, we tried to be more precise via + FreeConsole and AttachConsole before generating the Ctrl-C, but + that wasn't working so well (see #2869). + This code rely now on the fact that coqide is a console app, + and that coqide itself ignores Ctrl-C. +*/ + +CAMLprim value win32_interrupt_all(value unit) { + CAMLparam1(unit); + GenerateConsoleCtrlEvent(CTRL_C_EVENT,0); + CAMLreturn(Val_unit); +} -/* Moreover, AttachConsole exists only since WinXP, and GetProcessId - since WinXP SP1. For avoiding the GetProcessId, we could adapt code - from win32unix/createprocess.c to make it return both the pid and the - handle. For avoiding the AttachConsole, I don't know, maybe having - an intermediate process between coqide and coqtop ? */ +/* Get rid of the nasty console window (only if we created it) */ -CAMLprim value win32_interrupt(value pseudopid) { - CAMLparam1(pseudopid); - HANDLE h; +CAMLprim value win32_hide_console (value unit) { + CAMLparam1(unit); DWORD pid; - FreeConsole(); /* Normally unnecessary, just to be sure... */ - h = (HANDLE)(Long_val(pseudopid)); - pid = GetProcessId(h); - AttachConsole(pid); - /* We want to survive the Ctrl-C that will also concerns us */ - SetConsoleCtrlHandler(NULL,TRUE); /* NULL + TRUE means ignore */ - GenerateConsoleCtrlEvent(CTRL_C_EVENT,0); /* signal our co-console */ - FreeConsole(); + HWND hw = GetConsoleWindow(); + if (hw != NULL) { + GetWindowThreadProcessId(hw, &pid); + if (pid == GetCurrentProcessId()) + ShowWindow(hw, SW_HIDE); + } CAMLreturn(Val_unit); } diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 20b9c2a3..ee529fe0 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -137,20 +137,21 @@ let insert_pat_alias loc p = function let extern_evar loc n l = if !print_evar_arguments then CEvar (loc,n,l) else CEvar (loc,n,None) -let debug_global_reference_printer = - ref (fun _ -> failwith "Cannot print a global reference") +(** We allow customization of the global_reference printer. + For instance, in the debugger the tables of global references + may be inaccurate *) -let in_debugger = ref false +let default_extern_reference loc vars r = + Qualid (loc,shortest_qualid_of_global vars r) -let set_debug_global_reference_printer f = - debug_global_reference_printer := f +let my_extern_reference = ref default_extern_reference -let extern_reference loc vars r = - if !in_debugger then - (* Debugger does not have the tables of global reference at hand *) - !debug_global_reference_printer loc r - else - Qualid (loc,shortest_qualid_of_global vars r) +let set_extern_reference f = my_extern_reference := f +let get_extern_reference () = !my_extern_reference + +let extern_reference loc vars l = !my_extern_reference loc vars l + +let in_debugger = ref false (************************************************************************) @@ -303,10 +304,10 @@ let make_notation_gen loc ntn mknot mkprim destprim l = match decompose_notation_key ntn, l with | [Terminal "-"; Terminal x], [] -> (try mkprim (loc, Numeral (Bigint.neg (Bigint.of_string x))) - with _ -> mknot (loc,ntn,[])) + with e when Errors.noncritical e -> mknot (loc,ntn,[])) | [Terminal x], [] -> (try mkprim (loc, Numeral (Bigint.of_string x)) - with _ -> mknot (loc,ntn,[])) + with e when Errors.noncritical e -> mknot (loc,ntn,[])) | _ -> mknot (loc,ntn,l) @@ -816,12 +817,14 @@ and extern_symbol (tmp_scope,scopes as allscopes) vars t = function match f with | GRef (_,ref) -> let subscopes = - try list_skipn n (find_arguments_scope ref) with _ -> [] in + try list_skipn n (find_arguments_scope ref) + with e when Errors.noncritical e -> [] in let impls = let impls = select_impargs_size (List.length args) (implicits_of_global ref) in - try list_skipn n impls with _ -> [] in + try list_skipn n impls + with e when Errors.noncritical e -> [] in subscopes,impls | _ -> [], [] in diff --git a/interp/constrextern.mli b/interp/constrextern.mli index 1a1560e5..55fababd 100644 --- a/interp/constrextern.mli +++ b/interp/constrextern.mli @@ -50,9 +50,12 @@ val print_universes : bool ref val print_no_symbol : bool ref val print_projections : bool ref -(** Debug printing options *) -val set_debug_global_reference_printer : - (loc -> global_reference -> reference) -> unit +(** Customization of the global_reference printer *) +val set_extern_reference : + (loc -> Idset.t -> global_reference -> reference) -> unit +val get_extern_reference : + unit -> (loc -> Idset.t -> global_reference -> reference) + val in_debugger : bool ref (** This governs printing of implicit arguments. If [with_implicits] is diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 81e4501a..e806686a 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -650,7 +650,7 @@ let intern_var genv (ltacvars,ntnvars) namedctx loc id = let scopes = find_arguments_scope ref in Dumpglob.dump_reference loc "<>" (string_of_qualid (Decls.variable_secpath id)) "var"; GRef (loc, ref), impls, scopes, [] - with _ -> + with e when Errors.noncritical e -> (* [id] a goal variable *) GVar (loc,id), [], [], [] @@ -716,7 +716,7 @@ let intern_applied_reference intern env namedctx lvar args = function try let r,args2 = intern_non_secvar_qualid loc qid intern env lvar args in find_appl_head_data r, args2 - with e -> + with e when Errors.noncritical e -> (* Extra allowance for non globalizing functions *) if !interning_grammar || env.unb then (GVar (loc,id), [], [], []),args @@ -969,15 +969,15 @@ let sort_fields mode loc l completer = | [] -> anomaly "Number of projections mismatch" | (_, regular)::tm -> let boolean = not regular in - if ConstRef name = global_reference_of_reference refer - then + (match global_reference_of_reference refer with + | ConstRef name' when eq_constant name name' -> if boolean && mode then user_err_loc (loc, "", str"No local fields allowed in a record construction.") else build_patt b tm (i + 1) (i, snd acc) (* we found it *) - else + | _ -> build_patt b tm (if boolean&&mode then i else i + 1) (if boolean && mode then acc - else fst acc, (i, ConstRef name) :: snd acc)) + else fst acc, (i, ConstRef name) :: snd acc))) | None :: b-> (* we don't want anonymous fields *) if mode then user_err_loc (loc, "", str "This record contains anonymous fields.") @@ -1009,7 +1009,7 @@ let sort_fields mode loc l completer = (loc, "", str "This record contains fields of different records.") | (i, a) :: b-> - if glob_refer = a + if eq_gr glob_refer a then (i,List.rev_append acc l) else add_patt b ((i,a)::acc) in diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml index 9950178c..2c000258 100644 --- a/interp/implicit_quantifiers.ml +++ b/interp/implicit_quantifiers.ml @@ -88,8 +88,8 @@ let is_freevar ids env x = if Idset.mem x ids then false else try ignore(Environ.lookup_named x env) ; false - with _ -> not (is_global x) - with _ -> true + with e when Errors.noncritical e -> not (is_global x) + with e when Errors.noncritical e -> true (* Auxiliary functions for the inference of implicitly quantified variables. *) diff --git a/interp/notation.ml b/interp/notation.ml index e3fb5d5e..03fa23a3 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -838,4 +838,4 @@ let _ = let with_notation_protection f x = let fs = freeze () in try let a = f x in unfreeze fs; a - with e -> unfreeze fs; raise e + with reraise -> unfreeze fs; raise reraise diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml index 8d09cbd7..9c9f6a57 100644 --- a/kernel/csymtable.ml +++ b/kernel/csymtable.ml @@ -190,7 +190,9 @@ and eval_to_patch env (buff,pl,fv) = and val_of_constr env c = let (_,fun_code,_ as ccfv) = try compile env c - with e -> print_string "can not compile \n";Format.print_flush();raise e in + with reraise -> + print_string "can not compile \n";Format.print_flush();raise reraise + in eval_to_patch env (to_memory ccfv) let set_transparent_const kn = diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml index 15a48e1c..9aeaf110 100644 --- a/kernel/mod_subst.ml +++ b/kernel/mod_subst.ml @@ -83,13 +83,14 @@ let string_of_hint = function | Equiv kn -> string_of_kn kn let debug_string_of_delta resolve = - let kn_to_string kn hint s = - s^", "^(string_of_kn kn)^"=>"^(string_of_hint hint) + let kn_to_string kn hint l = + (string_of_kn kn ^ "=>" ^ string_of_hint hint) :: l in - let mp_to_string mp mp' s = - s^", "^(string_of_mp mp)^"=>"^(string_of_mp mp') + let mp_to_string mp mp' l = + (string_of_mp mp ^ "=>" ^ string_of_mp mp') :: l in - Deltamap.fold mp_to_string kn_to_string resolve "" + let l = Deltamap.fold mp_to_string kn_to_string resolve [] in + String.concat ", " (List.rev l) let list_contents sub = let one_pair (mp,reso) = (string_of_mp mp,debug_string_of_delta reso) in @@ -173,7 +174,7 @@ let solve_delta_kn resolve kn = let kn_of_delta resolve kn = try solve_delta_kn resolve kn - with _ -> kn + with e when Errors.noncritical e -> kn let constant_of_delta_kn resolve kn = constant_of_kn_equiv kn (kn_of_delta resolve kn) @@ -182,7 +183,7 @@ let gen_of_delta resolve x kn fix_can = try let new_kn = solve_delta_kn resolve kn in if kn == new_kn then x else fix_can new_kn - with _ -> x + with e when Errors.noncritical e -> x let constant_of_delta resolve con = let kn = user_con con in @@ -223,8 +224,10 @@ let constant_of_delta_with_inline resolve con = let kn1,kn2 = canonical_con con,user_con con in try find_inline_of_delta kn2 resolve with Not_found -> - try find_inline_of_delta kn1 resolve - with Not_found -> None + if kn1 == kn2 then None + else + try find_inline_of_delta kn1 resolve + with Not_found -> None let subst_mp0 sub mp = (* 's like subst *) let rec aux mp = @@ -272,7 +275,9 @@ type sideconstantsubst = | Canonical let gen_subst_mp f sub mp1 mp2 = - match subst_mp0 sub mp1, subst_mp0 sub mp2 with + let o1 = subst_mp0 sub mp1 in + let o2 = if mp1 == mp2 then o1 else subst_mp0 sub mp2 in + match o1, o2 with | None, None -> raise No_subst | Some (mp',resolve), None -> User, (f mp' mp2), resolve | None, Some (mp',resolve) -> Canonical, (f mp1 mp'), resolve diff --git a/kernel/modops.ml b/kernel/modops.ml index af32288c..a81f868e 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -33,7 +33,7 @@ type signature_mismatch_error = | NotConvertibleInductiveField of identifier | NotConvertibleConstructorField of identifier | NotConvertibleBodyField - | NotConvertibleTypeField + | NotConvertibleTypeField of env * types * types | NotSameConstructorNamesField | NotSameInductiveNameInBlockField | FiniteInductiveFieldExpected of bool diff --git a/kernel/modops.mli b/kernel/modops.mli index d03d61bd..daea3258 100644 --- a/kernel/modops.mli +++ b/kernel/modops.mli @@ -9,6 +9,7 @@ open Util open Names open Univ +open Term open Environ open Declarations open Entries @@ -60,7 +61,7 @@ type signature_mismatch_error = | NotConvertibleInductiveField of identifier | NotConvertibleConstructorField of identifier | NotConvertibleBodyField - | NotConvertibleTypeField + | NotConvertibleTypeField of env * types * types | NotSameConstructorNamesField | NotSameInductiveNameInBlockField | FiniteInductiveFieldExpected of bool diff --git a/kernel/names.ml b/kernel/names.ml index 17bda124..8c228404 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -205,7 +205,9 @@ type constant = kernel_name*kernel_name let constant_of_kn kn = (kn,kn) let constant_of_kn_equiv kn1 kn2 = (kn1,kn2) let make_con mp dir l = constant_of_kn (mp,dir,l) -let make_con_equiv mp1 mp2 dir l = ((mp1,dir,l),(mp2,dir,l)) +let make_con_equiv mp1 mp2 dir l = + if mp1 == mp2 then make_con mp1 dir l + else ((mp1,dir,l),(mp2,dir,l)) let canonical_con con = snd con let user_con con = fst con let repr_con con = fst con @@ -263,8 +265,10 @@ let constr_modpath c = ind_modpath (fst c) let mind_of_kn kn = (kn,kn) let mind_of_kn_equiv kn1 kn2 = (kn1,kn2) -let make_mind mp dir l = ((mp,dir,l),(mp,dir,l)) -let make_mind_equiv mp1 mp2 dir l = ((mp1,dir,l),(mp2,dir,l)) +let make_mind mp dir l = mind_of_kn (mp,dir,l) +let make_mind_equiv mp1 mp2 dir l = + if mp1 == mp2 then make_mind mp1 dir l + else ((mp1,dir,l),(mp2,dir,l)) let canonical_mind mind = snd mind let user_mind mind = fst mind let repr_mind mind = fst mind diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml index 6c08c34c..f0a3292c 100644 --- a/kernel/pre_env.ml +++ b/kernel/pre_env.ml @@ -90,7 +90,7 @@ let push_rel d env = let lookup_rel_val n env = try List.nth env.env_rel_val (n - 1) - with _ -> raise Not_found + with e when Errors.noncritical e -> raise Not_found let env_of_rel n env = { env with diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 1d606782..ec891e13 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -477,7 +477,7 @@ let end_module l restype senv = in let str = match sign with | SEBstruct(str_l) -> str_l - | _ -> error ("You cannot Include a high-order structure.") + | _ -> error ("You cannot Include a higher-order structure.") in let senv = update_resolver (add_delta_resolver resolver) senv in @@ -873,7 +873,8 @@ end = struct let k = key_of_lazy_constr k in let access key = try (Lazy.force table).(key) - with _ -> error "Error while retrieving an opaque body" + with e when Errors.noncritical e -> + error "Error while retrieving an opaque body" in match load_proof with | Flags.Force -> diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index e2c5f48c..c809572a 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -219,6 +219,8 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = let check_conv cst f = check_conv_error error cst f in let check_type cst env t1 t2 = + let err = NotConvertibleTypeField (env, t1, t2) in + (* If the type of a constant is generated, it may mention non-variable algebraic universes that the general conversion algorithm is not ready to handle. Anyway, generated types of @@ -257,12 +259,12 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = (the user has to use an explicit type in the interface *) error NoTypeConstraintExpected with NotArity -> - error NotConvertibleTypeField end + error err end | _ -> t1,t2 else (t1,t2) in - check_conv NotConvertibleTypeField cst conv_leq env t1 t2 + check_conv err cst conv_leq env t1 t2 in match info1 with @@ -301,7 +303,8 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = if constant_has_body cb2 then error DefinitionFieldExpected; let arity1 = type_of_inductive env (mind1,mind1.mind_packets.(i)) in let typ2 = Typeops.type_of_constant_type env cb2.const_type in - check_conv NotConvertibleTypeField cst conv_leq env arity1 typ2 + let error = NotConvertibleTypeField (env, arity1, typ2) in + check_conv error cst conv_leq env arity1 typ2 | IndConstr (((kn,i),j) as cstr,mind1) -> ignore (Util.error ( "The kernel does not recognize yet that a parameter can be " ^ @@ -312,7 +315,8 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = if constant_has_body cb2 then error DefinitionFieldExpected; let ty1 = type_of_constructor cstr (mind1,mind1.mind_packets.(i)) in let ty2 = Typeops.type_of_constant_type env cb2.const_type in - check_conv NotConvertibleTypeField cst conv env ty1 ty2 + let error = NotConvertibleTypeField (env, ty1, ty2) in + check_conv error cst conv env ty1 ty2 let rec check_modules cst env msb1 msb2 subst1 subst2 = let mty1 = module_type_of_module None msb1 in diff --git a/lib/envars.ml b/lib/envars.ml index 4ec68a27..c672d30c 100644 --- a/lib/envars.ml +++ b/lib/envars.ml @@ -23,6 +23,8 @@ let _ = if Coq_config.arch = "win32" then Unix.putenv "PATH" (coqbin ^ ";" ^ System.getenv_else "PATH" "") +let exe s = s ^ Coq_config.exec_extension + let reldir instdir testfile oth = let rpath = if Coq_config.local then [] else instdir in let out = List.fold_left Filename.concat coqroot rpath in @@ -87,19 +89,19 @@ let rec which l f = else which tl f let guess_camlbin () = - let path = try Sys.getenv "PATH" with _ -> raise Not_found in + let path = Sys.getenv "PATH" in (* may raise Not_found *) let lpath = path_to_list path in - which lpath "ocamlc" + which lpath (exe "ocamlc") let guess_camlp4bin () = - let path = try Sys.getenv "PATH" with _ -> raise Not_found in + let path = Sys.getenv "PATH" in (* may raise Not_found *) let lpath = path_to_list path in - which lpath Coq_config.camlp4 + which lpath (exe Coq_config.camlp4) let camlbin () = if !Flags.camlbin_spec then !Flags.camlbin else if !Flags.boot then Coq_config.camlbin else - try guess_camlbin () with _ -> Coq_config.camlbin + try guess_camlbin () with e when e <> Sys.Break -> Coq_config.camlbin let camllib () = if !Flags.boot @@ -113,9 +115,10 @@ let camllib () = let camlp4bin () = if !Flags.camlp4bin_spec then !Flags.camlp4bin else if !Flags.boot then Coq_config.camlp4bin else - try guess_camlp4bin () with _ -> let cb = camlbin () in - if Sys.file_exists (Filename.concat cb Coq_config.camlp4) then cb - else Coq_config.camlp4bin + try guess_camlp4bin () with e when e <> Sys.Break -> + let cb = camlbin () in + if Sys.file_exists (Filename.concat cb (exe Coq_config.camlp4)) then cb + else Coq_config.camlp4bin let camlp4lib () = if !Flags.boot diff --git a/lib/errors.ml b/lib/errors.ml index 3b5e6770..6affea23 100644 --- a/lib/errors.ml +++ b/lib/errors.ml @@ -28,7 +28,7 @@ let rec print_gen bottom stk e = try h e with | Unhandled -> print_gen bottom stk' e - | e' -> print_gen bottom stk' e' + | any -> print_gen bottom stk' any (** Only anomalies should reach the bottom of the handler stack. In usual situation, the [handle_stack] is treated as it if was always @@ -66,3 +66,14 @@ let _ = register_handler begin function | _ -> raise Unhandled end +(** Critical exceptions shouldn't be catched and ignored by mistake + by inner functions during a [vernacinterp]. They should be handled + only at the very end of interp, to be displayed to the user. *) + +(** NB: in the 8.4 branch, for maximal compatibility, anomalies + are considered non-critical *) + +let noncritical = function + | Sys.Break | Out_of_memory | Stack_overflow -> false + | _ -> true + diff --git a/lib/errors.mli b/lib/errors.mli index eb7fde8e..ae4d0b85 100644 --- a/lib/errors.mli +++ b/lib/errors.mli @@ -39,3 +39,11 @@ val print_no_report : exn -> Pp.std_ppcmds (** Same as [print], except that anomalies are not printed but re-raised (used for the Fail command) *) val print_no_anomaly : exn -> Pp.std_ppcmds + +(** Critical exceptions shouldn't be catched and ignored by mistake + by inner functions during a [vernacinterp]. They should be handled + only in [Toplevel.do_vernac] (or Ideslave), to be displayed to the user. + Typical example: [Sys.Break]. In the 8.4 branch, for maximal + compatibility, anomalies are not considered as critical... +*) +val noncritical : exn -> bool diff --git a/lib/flags.ml b/lib/flags.ml index 3474573e..32c68b25 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -9,12 +9,12 @@ let with_option o f x = let old = !o in o:=true; try let r = f x in o := old; r - with e -> o := old; raise e + with reraise -> o := old; raise reraise let without_option o f x = let old = !o in o:=false; try let r = f x in o := old; r - with e -> o := old; raise e + with reraise -> o := old; raise reraise let boot = ref false diff --git a/lib/hashtbl_alt.ml b/lib/hashtbl_alt.ml index 2780afe8..bb2252da 100644 --- a/lib/hashtbl_alt.ml +++ b/lib/hashtbl_alt.ml @@ -89,7 +89,7 @@ module Make (E : Hashtype) = match rest2 with | Empty -> add hash key; key | Cons (k3, h3, rest3) -> - if hash == h2 && E.equals key k3 then k3 + if hash == h3 && E.equals key k3 then k3 else find_rec hash key rest3 end diff --git a/lib/pp.ml4 b/lib/pp.ml4 index 7777d091..569a028f 100644 --- a/lib/pp.ml4 +++ b/lib/pp.ml4 @@ -279,7 +279,7 @@ let pp_dirs ft = try Stream.iter pp_dir dirstream; com_brk ft with - | e -> Format.pp_print_flush ft () ; raise e + | reraise -> Format.pp_print_flush ft () ; raise reraise (* pretty print on stdout and stderr *) diff --git a/lib/profile.ml b/lib/profile.ml index 2472d75d..39e08721 100644 --- a/lib/profile.ml +++ b/lib/profile.ml @@ -260,7 +260,7 @@ let time_overhead_B_C () = let _dw = dummy_spent_alloc () in let _dt = get_time () in () - with _ -> assert false + with e when e <> Sys.Break -> assert false done; let after = get_time () in let beforeloop = get_time () in @@ -390,7 +390,7 @@ let profile1 e f a = (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); r - with exn -> + with reraise -> let dw = spent_alloc () in let dt = get_time () - t in e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt; @@ -403,7 +403,7 @@ let profile1 e f a = if not (p==e) then (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); - raise exn + raise reraise let profile2 e f a b = let dw = spent_alloc () in @@ -432,7 +432,7 @@ let profile2 e f a b = (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); r - with exn -> + with reraise -> let dw = spent_alloc () in let dt = get_time () - t in e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt; @@ -445,7 +445,7 @@ let profile2 e f a b = if not (p==e) then (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); - raise exn + raise reraise let profile3 e f a b c = let dw = spent_alloc () in @@ -474,7 +474,7 @@ let profile3 e f a b c = (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); r - with exn -> + with reraise -> let dw = spent_alloc () in let dt = get_time () - t in e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt; @@ -487,7 +487,7 @@ let profile3 e f a b c = if not (p==e) then (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); - raise exn + raise reraise let profile4 e f a b c d = let dw = spent_alloc () in @@ -516,7 +516,7 @@ let profile4 e f a b c d = (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); r - with exn -> + with reraise -> let dw = spent_alloc () in let dt = get_time () - t in e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt; @@ -529,7 +529,7 @@ let profile4 e f a b c d = if not (p==e) then (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); - raise exn + raise reraise let profile5 e f a b c d g = let dw = spent_alloc () in @@ -558,7 +558,7 @@ let profile5 e f a b c d g = (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); r - with exn -> + with reraise -> let dw = spent_alloc () in let dt = get_time () - t in e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt; @@ -571,7 +571,7 @@ let profile5 e f a b c d g = if not (p==e) then (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); - raise exn + raise reraise let profile6 e f a b c d g h = let dw = spent_alloc () in @@ -600,7 +600,7 @@ let profile6 e f a b c d g h = (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); r - with exn -> + with reraise -> let dw = spent_alloc () in let dt = get_time () - t in e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt; @@ -613,7 +613,7 @@ let profile6 e f a b c d g h = if not (p==e) then (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); - raise exn + raise reraise let profile7 e f a b c d g h i = let dw = spent_alloc () in @@ -642,7 +642,7 @@ let profile7 e f a b c d g h i = (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); r - with exn -> + with reraise -> let dw = spent_alloc () in let dt = get_time () - t in e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt; @@ -655,7 +655,7 @@ let profile7 e f a b c d g h i = if not (p==e) then (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); - raise exn + raise reraise (* Some utilities to compute the logical and physical sizes and depth of ML objects *) diff --git a/lib/store.ml b/lib/store.ml index bc1b335f..28eb65c8 100644 --- a/lib/store.ml +++ b/lib/store.ml @@ -53,7 +53,7 @@ let field () = in let get s = try Some (Obj.obj (Util.Intmap.find fid s)) - with _ -> None + with Not_found -> None in let remove s = Util.Intmap.remove fid s diff --git a/lib/system.ml b/lib/system.ml index a99c29f2..ae637708 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -140,7 +140,8 @@ let exclude_search_in_dirname f = skipped_dirnames := f :: !skipped_dirnames let ok_dirname f = f <> "" && f.[0] <> '.' && not (List.mem f !skipped_dirnames) && - try ignore (check_ident f); true with _ -> false + try ignore (check_ident f); true + with e when e <> Sys.Break -> false let all_subdirs ~unix_path:root = let l = ref [] in @@ -223,17 +224,22 @@ let file_readable_p name = try access name [R_OK];true with Unix_error (_, _, _) -> false let open_trapping_failure name = - try open_out_bin name with _ -> error ("Can't open " ^ name) + try open_out_bin name + with e when e <> Sys.Break -> error ("Can't open " ^ name) let try_remove filename = try Sys.remove filename - with _ -> msgnl (str"Warning: " ++ str"Could not remove file " ++ - str filename ++ str" which is corrupted!" ) + with e when e <> Sys.Break -> + msgnl (str"Warning: " ++ str"Could not remove file " ++ + str filename ++ str" which is corrupted!" ) let marshal_out ch v = Marshal.to_channel ch v [] -let marshal_in ch = +let marshal_in filename ch = try Marshal.from_channel ch - with End_of_file -> error "corrupted file: reached end of file" + with + | End_of_file -> error "corrupted file: reached end of file" + | Failure _ (* e.g. "truncated object" *) -> + error (filename ^ " is corrupted, try to rebuild it.") exception Bad_magic_number of string @@ -259,14 +265,14 @@ let extern_intern ?(warn=true) magic suffix = try marshal_out channel val_0; close_out channel - with e -> - begin try_remove filename; raise e end + with reraise -> + begin try_remove filename; raise reraise end with Sys_error s -> error ("System error: " ^ s) and intern_state paths name = try let _,filename = find_file_in_path ~warn paths (make_suffix name suffix) in let channel = raw_intern filename in - let v = marshal_in channel in + let v = marshal_in filename channel in close_in channel; v with Sys_error s -> diff --git a/lib/system.mli b/lib/system.mli index 4a79b874..d8420e7d 100644 --- a/lib/system.mli +++ b/lib/system.mli @@ -47,7 +47,7 @@ val find_file_in_path : when the check fails, with the full file name. *) val marshal_out : out_channel -> 'a -> unit -val marshal_in : in_channel -> 'a +val marshal_in : string -> in_channel -> 'a exception Bad_magic_number of string diff --git a/lib/xml_parser.ml b/lib/xml_parser.ml index 19bab4f6..600796f7 100644 --- a/lib/xml_parser.ml +++ b/lib/xml_parser.ml @@ -175,7 +175,7 @@ let do_parse xparser source = if xparser.check_eof && pop s <> Xml_lexer.Eof then raise (Internal_error EOFExpected); Xml_lexer.close source; x - with e -> + with e when e <> Sys.Break -> Xml_lexer.close source; raise (!xml_error (error_of_exn stk e) source) @@ -190,9 +190,9 @@ let parse p = function close_in ch; x with - e -> + reraise -> close_in ch; - raise e + raise reraise let error_msg = function diff --git a/library/declaremods.ml b/library/declaremods.ml index 80da9e73..db7b8915 100644 --- a/library/declaremods.ml +++ b/library/declaremods.ml @@ -990,9 +990,9 @@ let declare_include_ interp_struct me_asts = let protect_summaries f = let fs = Summary.freeze_summaries () in try f fs - with e -> + with reraise -> (* Something wrong: undo the whole process *) - Summary.unfreeze_summaries fs; raise e + Summary.unfreeze_summaries fs; raise reraise let declare_include interp_struct me_asts = protect_summaries diff --git a/library/heads.ml b/library/heads.ml index b860dc2a..c33ea9b1 100644 --- a/library/heads.ml +++ b/library/heads.ml @@ -88,7 +88,7 @@ let kind_of_head env t = | Sort _ | Ind _ | Prod _ -> RigidHead RigidType | Cast (c,_,_) -> aux k l c b | Lambda (_,_,c) when l = [] -> assert (not b); aux (k+1) [] c b - | Lambda (_,_,c) -> aux (k+1) (List.tl l) (subst1 (List.hd l) c) b + | Lambda (_,_,c) -> aux k (List.tl l) (subst1 (List.hd l) c) b | LetIn _ -> assert false | Meta _ | Evar _ -> NotImmediatelyComputableHead | App (c,al) -> aux k (Array.to_list al @ l) c b diff --git a/library/impargs.ml b/library/impargs.ml index c79edb99..930b8f09 100644 --- a/library/impargs.ml +++ b/library/impargs.ml @@ -74,9 +74,9 @@ let with_implicits flags f x = let rslt = f x in implicit_args := oflags; rslt - with e -> begin + with reraise -> begin implicit_args := oflags; - raise e + raise reraise end let set_maximality imps b = diff --git a/library/library.ml b/library/library.ml index 30e7b675..c857fc86 100644 --- a/library/library.ml +++ b/library/library.ml @@ -368,14 +368,14 @@ let explain_locate_library_error qid = function let try_locate_absolute_library dir = try locate_absolute_library dir - with e -> + with e when Errors.noncritical e -> explain_locate_library_error (qualid_of_dirpath dir) e let try_locate_qualified_library (loc,qid) = try let (_,dir,f) = locate_qualified_library (Flags.is_verbose()) qid in dir,f - with e -> + with e when Errors.noncritical e -> explain_locate_library_error qid e @@ -398,20 +398,20 @@ let fetch_opaque_table (f,pos,digest) = try let ch = System.with_magic_number_check raw_intern_library f in seek_in ch pos; - if System.marshal_in ch <> digest then failwith "File changed!"; - let table = (System.marshal_in ch : LightenLibrary.table) in + if System.marshal_in f ch <> digest then failwith "File changed!"; + let table = (System.marshal_in f ch : LightenLibrary.table) in close_in ch; table - with _ -> + with e when Errors.noncritical e -> error ("The file "^f^" is inaccessible or has changed,\n" ^ "cannot load some opaque constant bodies in it.\n") let intern_from_file f = let ch = System.with_magic_number_check raw_intern_library f in - let lmd = System.marshal_in ch in + let lmd = System.marshal_in f ch in let pos = pos_in ch in - let digest = System.marshal_in ch in + let digest = System.marshal_in f ch in let table = lazy (fetch_opaque_table (f,pos,digest)) in register_library_filename lmd.md_name f; let library = mk_library lmd table digest in @@ -655,7 +655,8 @@ let save_library_to dir f = System.marshal_out ch di; System.marshal_out ch table; close_out ch - with e -> warning ("Removed file "^f'); close_out ch; Sys.remove f'; raise e + with reraise -> + warning ("Removed file "^f'); close_out ch; Sys.remove f'; raise reraise (************************************************************************) (*s Display the memory use of a library. *) diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 184985b5..7a214bcd 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -393,14 +393,17 @@ let extra_rules () = begin Cmd (S [P w32res;A "--input-format";A "rc";A "--input";P rc; A "--output-format";A "coff";A "--output"; Px o])); -(** The windows version of Coqide is now a console-free win32 app, - which moreover contains the Coq icon. If necessary, the mkwinapp - tool can be used later to restore or suppress the console of Coqide. *) +(** Embed the Coq icon inside the windows version of Coqide *) if w32 then dep ["link"; "ocaml"; "program"; "ide"] [w32ico]; - - if w32 then flag ["link"; "ocaml"; "program"; "ide"] - (S [A "-ccopt"; A "-link -Wl,-subsystem,windows"; P w32ico]); + if w32 then flag ["link"; "ocaml"; "program"; "ide"] (P w32ico); + +(** Ealier we tried to make Coqide a console-free win32 app, + but that was troublesome (unavailable stdout/stderr, issues + with the stop button,...). If somebody really want to try again, + the extra args to add are : + [A "-ccopt"; A "-link -Wl,-subsystem,windows"] + Other solution: use the mkwinapp tool. *) (** The mingw32-ocaml cross-compiler currently uses Filename.dir_sep="/". Let's tweak that... *) diff --git a/parsing/argextend.ml4 b/parsing/argextend.ml4 index 1888ef17..214a6b98 100644 --- a/parsing/argextend.ml4 +++ b/parsing/argextend.ml4 @@ -146,7 +146,7 @@ let possibly_empty_subentries loc (prods,act) = (* an exception rather than returning a value; *) (* declares loc because some code can refer to it; *) (* ensures loc is used to avoid "unused variable" warning *) - (true, <:expr< try Some $aux prods$ with [ _ -> None ] >>) + (true, <:expr< try Some $aux prods$ with [ e when Errors.noncritical e -> None ] >>) else (* Static optimisation *) (false, aux prods) diff --git a/parsing/egrammar.ml b/parsing/egrammar.ml index c68ba137..12359776 100644 --- a/parsing/egrammar.ml +++ b/parsing/egrammar.ml @@ -365,4 +365,4 @@ let _ = let with_grammar_rule_protection f x = let fs = freeze () in try let a = f x in unfreeze fs; a - with e -> unfreeze fs; raise e + with reraise -> unfreeze fs; raise reraise diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index d265729a..1609e541 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -126,7 +126,7 @@ let mk_cofix_tac (loc,id,bl,ann,ty) = let induction_arg_of_constr (c,lbind as clbind) = if lbind = NoBindings then try ElimOnIdent (constr_loc c,snd(coerce_to_id c)) - with _ -> ElimOnConstr clbind + with e when Errors.noncritical e -> ElimOnConstr clbind else ElimOnConstr clbind let mkTacCase with_evar = function diff --git a/parsing/g_xml.ml4 b/parsing/g_xml.ml4 index 9dd0e369..869674f4 100644 --- a/parsing/g_xml.ml4 +++ b/parsing/g_xml.ml4 @@ -104,7 +104,8 @@ let get_xml_sort al = sort_of_cdata (get_xml_attr "value" al) let get_xml_inductive_kn al = inductive_of_cdata (* uriType apparent synonym of uri *) - (try get_xml_attr "uri" al with _ -> get_xml_attr "uriType" al) + (try get_xml_attr "uri" al + with e when Errors.noncritical e -> get_xml_attr "uriType" al) let get_xml_constant al = constant_of_cdata (get_xml_attr "uri" al) diff --git a/parsing/prettyp.ml b/parsing/prettyp.ml index d3eb40d0..99e10908 100644 --- a/parsing/prettyp.ml +++ b/parsing/prettyp.ml @@ -273,7 +273,9 @@ let print_inductive_implicit_args = let print_inductive_renames = print_args_data_of_inductive_ids - (fun r -> try List.hd (Arguments_renaming.arguments_names r) with _ -> []) + (fun r -> + try List.hd (Arguments_renaming.arguments_names r) + with e when Errors.noncritical e -> []) ((<>) Anonymous) print_renames_list @@ -737,7 +739,7 @@ let print_coercions () = let index_of_class cl = try fst (class_info cl) - with _ -> + with e when Errors.noncritical e -> errorlabstrm "index_of_class" (pr_class cl ++ spc() ++ str "not a defined class.") @@ -747,7 +749,7 @@ let print_path_between cls clt = let p = try lookup_path_between_class (i,j) - with _ -> + with e when Errors.noncritical e -> errorlabstrm "index_cl_of_id" (str"No path between " ++ pr_class cls ++ str" and " ++ pr_class clt ++ str ".") diff --git a/parsing/printer.ml b/parsing/printer.ml index 9f0cb00d..29ebe4fa 100644 --- a/parsing/printer.ml +++ b/parsing/printer.ml @@ -24,6 +24,7 @@ open Pfedit open Ppconstr open Constrextern open Tacexpr +open Declarations open Store.Field @@ -118,6 +119,63 @@ let pr_sort s = pr_glob_sort (extern_sort s) let _ = Termops.set_print_constr pr_lconstr_env + +(** Term printers resilient to [Nametab] errors *) + +(** When the nametab isn't up-to-date, the term printers above + could raise [Not_found] during [Nametab.shortest_qualid_of_global]. + In this case, we build here a fully-qualified name based upon + the kernel modpath and label of constants, and the idents in + the [mutual_inductive_body] for the inductives and constructors + (needs an environment for this). *) + +let id_of_global env = function + | ConstRef kn -> id_of_label (con_label kn) + | IndRef (kn,0) -> id_of_label (mind_label kn) + | IndRef (kn,i) -> + (Environ.lookup_mind kn env).mind_packets.(i).mind_typename + | ConstructRef ((kn,i),j) -> + (Environ.lookup_mind kn env).mind_packets.(i).mind_consnames.(j-1) + | VarRef v -> v + +let cons_dirpath id dp = make_dirpath (id :: repr_dirpath dp) + +let rec dirpath_of_mp = function + | MPfile sl -> sl + | MPbound uid -> make_dirpath [id_of_mbid uid] + | MPdot (mp,l) -> cons_dirpath (id_of_label l) (dirpath_of_mp mp) + +let dirpath_of_global = function + | ConstRef kn -> dirpath_of_mp (con_modpath kn) + | IndRef (kn,_) | ConstructRef ((kn,_),_) -> + dirpath_of_mp (mind_modpath kn) + | VarRef _ -> empty_dirpath + +let qualid_of_global env r = + Libnames.make_qualid (dirpath_of_global r) (id_of_global env r) + +let safe_gen f env c = + let orig_extern_ref = Constrextern.get_extern_reference () in + let extern_ref loc vars r = + try orig_extern_ref loc vars r + with e when Errors.noncritical e -> + Libnames.Qualid (loc, qualid_of_global env r) + in + Constrextern.set_extern_reference extern_ref; + try + let p = f env c in + Constrextern.set_extern_reference orig_extern_ref; + p + with e when Errors.noncritical e -> + Constrextern.set_extern_reference orig_extern_ref; + str "??" + +let safe_pr_lconstr_env = safe_gen pr_lconstr_env +let safe_pr_constr_env = safe_gen pr_constr_env +let safe_pr_lconstr t = safe_pr_lconstr_env (Global.env()) t +let safe_pr_constr t = safe_pr_constr_env (Global.env()) t + + (**********************************************************************) (* Global references *) @@ -389,7 +447,7 @@ let default_pr_subgoals ?(pr_first=true) close_cmd sigma seeds stack goals = | None -> let exl = Evarutil.non_instantiated sigma in if exl = [] then - (str"No more subgoals." + (str"No more subgoals." ++ fnl () ++ emacs_print_dependent_evars sigma seeds) else let pei = pr_evars_int 1 exl in @@ -415,7 +473,7 @@ let default_pr_subgoals ?(pr_first=true) close_cmd sigma seeds stack goals = v 0 ( int(List.length rest+1) ++ str" subgoals" ++ str (emacs_str ", subgoal 1") ++ pr_goal_tag g1 ++ cut () - ++ goals + ++ goals ++ fnl () ++ emacs_print_dependent_evars sigma seeds ) | g1::rest,a::l -> @@ -589,7 +647,7 @@ let pr_assumptionset env s = str (string_of_mp mp ^ "." ^ string_of_label lab) in let safe_pr_ltype typ = - try str " : " ++ pr_ltype typ with _ -> mt () + try str " : " ++ pr_ltype typ with e when Errors.noncritical e -> mt () in let (vars,axioms,opaque) = ContextObjectMap.fold (fun t typ r -> @@ -647,7 +705,6 @@ let pr_instance_gmap insts = (** Inductive declarations *) -open Declarations open Termops open Reduction open Inductive diff --git a/parsing/printer.mli b/parsing/printer.mli index a034f0ed..3abe90e7 100644 --- a/parsing/printer.mli +++ b/parsing/printer.mli @@ -31,6 +31,17 @@ val pr_lconstr : constr -> std_ppcmds val pr_constr_env : env -> constr -> std_ppcmds val pr_constr : constr -> std_ppcmds +(** Same, but resilient to [Nametab] errors. Prints fully-qualified + names when [shortest_qualid_of_global] has failed. Prints "??" + in case of remaining issues (such as reference not in env). *) + +val safe_pr_lconstr_env : env -> constr -> std_ppcmds +val safe_pr_lconstr : constr -> std_ppcmds + +val safe_pr_constr_env : env -> constr -> std_ppcmds +val safe_pr_constr : constr -> std_ppcmds + + val pr_open_constr_env : env -> open_constr -> std_ppcmds val pr_open_constr : open_constr -> std_ppcmds diff --git a/parsing/printmod.ml b/parsing/printmod.ml index b4a8fdfd..b46cf42d 100644 --- a/parsing/printmod.ml +++ b/parsing/printmod.ml @@ -68,12 +68,17 @@ let print_kn locals kn = with Not_found -> print_modpath locals kn +(** Each time we have to print a non-globally visible structure, + we place its elements in a fake fresh namespace. *) + +let mk_fake_top = + let r = ref 0 in + fun () -> incr r; id_of_string ("FAKETOP"^(string_of_int !r)) + let nametab_register_dir mp = - let id = id_of_string "FAKETOP" in - let fp = Libnames.make_path empty_dirpath id in + let id = mk_fake_top () in let dir = make_dirpath [id] in - Nametab.push_dir (Nametab.Until 1) dir (DirModule (dir,(mp,empty_dirpath))); - fp + Nametab.push_dir (Nametab.Until 1) dir (DirModule (dir,(mp,empty_dirpath))) (** Nota: the [global_reference] we register in the nametab below might differ from internal ones, since we cannot recreate here @@ -81,9 +86,10 @@ let nametab_register_dir mp = the user names. This works nonetheless since we search now [Nametab.the_globrevtab] modulo user name. *) -let nametab_register_body mp fp (l,body) = +let nametab_register_body mp dir (l,body) = let push id ref = - Nametab.push (Nametab.Until 1) (make_path (dirpath fp) id) ref + Nametab.push (Nametab.Until (1+List.length (repr_dirpath dir))) + (make_path dir id) ref in match body with | SFBmodule _ -> () (* TODO *) @@ -99,6 +105,27 @@ let nametab_register_body mp fp (l,body) = mip.mind_consnames) mib.mind_packets +let nametab_register_module_body mp struc = + (* If [mp] is a globally visible module, we simply import it *) + try Declaremods.really_import_module mp + with Not_found -> + (* Otherwise we try to emulate an import by playing with nametab *) + nametab_register_dir mp; + List.iter (nametab_register_body mp empty_dirpath) struc + +let nametab_register_module_param mbid seb = + (* For algebraic seb, we use a Declaremods function that converts into mse *) + try Declaremods.process_module_seb_binding mbid seb + with e when Errors.noncritical e -> + (* Otherwise, for expanded structure, we try to play with the nametab *) + match seb with + | SEBstruct struc -> + let mp = MPbound mbid in + let dir = make_dirpath [id_of_mbid mbid] in + nametab_register_dir mp; + List.iter (nametab_register_body mp dir) struc + | _ -> () + let print_body is_impl env mp (l,body) = let name = str (string_of_label l) in hov 2 (match body with @@ -126,19 +153,11 @@ let print_body is_impl env mp (l,body) = try let env = Option.get env in Printer.pr_mutual_inductive_body env (make_mind mp empty_dirpath l) mib - with _ -> + with e when Errors.noncritical e -> (if mib.mind_finite then str "Inductive " else str "CoInductive") ++ name) let print_struct is_impl env mp struc = - begin - (* If [mp] is a globally visible module, we simply import it *) - try Declaremods.really_import_module mp - with _ -> - (* Otherwise we try to emulate an import by playing with nametab *) - let fp = nametab_register_dir mp in - List.iter (nametab_register_body mp fp) struc - end; prlist_with_sep spc (print_body is_impl env mp) struc let rec flatten_app mexpr l = match mexpr with @@ -156,7 +175,7 @@ let rec print_modtype env mp locals mty = let seb1 = Option.default mtb1.typ_expr mtb1.typ_expr_alg in let locals' = (mbid, get_new_id locals (id_of_mbid mbid))::locals in - (try Declaremods.process_module_seb_binding mbid seb1 with _ -> ()); + nametab_register_module_param mbid seb1; hov 2 (str "Funsig" ++ spc () ++ str "(" ++ pr_id (id_of_mbid mbid) ++ str ":" ++ print_modtype env mp1 locals seb1 ++ @@ -164,6 +183,7 @@ let rec print_modtype env mp locals mty = | SEBstruct (sign) -> let env' = Option.map (Modops.add_signature mp sign Mod_subst.empty_delta_resolver) env in + nametab_register_module_body mp sign; hv 2 (str "Sig" ++ spc () ++ print_struct false env' mp sign ++ brk (1,-2) ++ str "End") | SEBapply _ -> @@ -190,13 +210,14 @@ let rec print_modexpr env mp locals mexpr = match mexpr with (Modops.add_module (Modops.module_body_of_type mp' mty)) env in let typ = Option.default mty.typ_expr mty.typ_expr_alg in let locals' = (mbid, get_new_id locals (id_of_mbid mbid))::locals in - (try Declaremods.process_module_seb_binding mbid typ with _ -> ()); + nametab_register_module_param mbid typ; hov 2 (str "Functor" ++ spc() ++ str"(" ++ pr_id(id_of_mbid mbid) ++ str ":" ++ print_modtype env mp' locals typ ++ str ")" ++ spc () ++ print_modexpr env' mp locals' mexpr) | SEBstruct struc -> let env' = Option.map (Modops.add_signature mp struc Mod_subst.empty_delta_resolver) env in + nametab_register_module_body mp struc; hv 2 (str "Struct" ++ spc () ++ print_struct true env' mp struc ++ brk (1,-2) ++ str "End") | SEBapply _ -> @@ -243,7 +264,7 @@ let print_module with_body mp = try if !short then raise ShortPrinting; print_module' (Some (Global.env ())) mp with_body me ++ fnl () - with _ -> + with e when Errors.noncritical e -> print_module' None mp with_body me ++ fnl () let print_modtype kn = @@ -254,5 +275,5 @@ let print_modtype kn = (try if !short then raise ShortPrinting; print_modtype' (Some (Global.env ())) kn mtb.typ_expr - with _ -> + with e when Errors.noncritical e -> print_modtype' None kn mtb.typ_expr)) diff --git a/parsing/tacextend.ml4 b/parsing/tacextend.ml4 index dbc06856..77364180 100644 --- a/parsing/tacextend.ml4 +++ b/parsing/tacextend.ml4 @@ -188,11 +188,11 @@ let declare_tactic loc s cl = Tacexpr.TacExtend($default_loc$,$se$,l))) | None -> () ]) $atomic_tactics$ - with e -> + with [ e when Errors.noncritical e -> Pp.msg_warning (Stream.iapp (Pp.str ("Exception in tactic extend " ^ $se$ ^": ")) - (Errors.print e)); + (Errors.print e)) ]; Egrammar.extend_tactic_grammar $se$ $gl$; List.iter Pptactic.declare_extra_tactic_pprule $pp$; } >> ]) diff --git a/parsing/vernacextend.ml4 b/parsing/vernacextend.ml4 index 4f39019f..bcdf7cff 100644 --- a/parsing/vernacextend.ml4 +++ b/parsing/vernacextend.ml4 @@ -55,11 +55,11 @@ let declare_command loc s nt cl = declare_str_items loc [ <:str_item< do { try Vernacinterp.vinterp_add $se$ $funcl$ - with e -> + with [ e when Errors.noncritical e -> Pp.msg_warning (Stream.iapp (Pp.str ("Exception in vernac extend " ^ $se$ ^": ")) - (Errors.print e)); + (Errors.print e)) ]; Egrammar.extend_vernac_command_grammar $se$ $nt$ $gl$ } >> ] diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index d0f81dad..1c021eee 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -404,7 +404,8 @@ let rec canonize_name c = let build_subst uf subst = Array.map (fun i -> try term uf i - with _ -> anomaly "incomplete matching") subst + with e when Errors.noncritical e -> + anomaly "incomplete matching") subst let rec inst_pattern subst = function PVar i -> @@ -730,9 +731,7 @@ let __eps__ = id_of_string "_eps_" let new_state_var typ state = let id = pf_get_new_id __eps__ state.gls in let {it=gl ; sigma=sigma} = state.gls in - let new_hyps = - Environ.push_named_context_val (id,None,typ) (Goal.V82.hyps sigma gl) in - let gls = Goal.V82.new_goal_with sigma gl new_hyps in + let gls = Goal.V82.new_goal_with sigma gl [id,None,typ] in state.gls<- gls; id diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 95ff4d34..764e36b0 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -129,7 +129,9 @@ let non_trivial = function let patterns_of_constr env sigma nrels term= let f,args= - try destApp (whd_delta env term) with _ -> raise Not_found in + try destApp (whd_delta env term) + with e when Errors.noncritical e -> raise Not_found + in if eq_constr f (Lazy.force _eq) && (Array.length args)=3 then let patt1,rels1 = pattern_of_constr env sigma args.(1) diff --git a/plugins/decl_mode/decl_mode.ml b/plugins/decl_mode/decl_mode.ml index 730051c1..da88d48d 100644 --- a/plugins/decl_mode/decl_mode.ml +++ b/plugins/decl_mode/decl_mode.ml @@ -75,9 +75,9 @@ let mode_of_pftreestate pts = Mode_proof let get_current_mode () = - try + try mode_of_pftreestate (Pfedit.get_pftreestate ()) - with _ -> Mode_none + with e when Errors.noncritical e -> Mode_none let check_not_proof_mode str = if get_current_mode () = Mode_proof then diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml index 72caeaed..ab161b35 100644 --- a/plugins/decl_mode/decl_proof_instr.ml +++ b/plugins/decl_mode/decl_proof_instr.ml @@ -381,7 +381,7 @@ let find_subsubgoal c ctyp skip submetas gls = se.se_meta submetas se.se_meta_list} else dfs (pred n) - with _ -> + with e when Errors.noncritical e -> begin enstack_subsubgoals env se stack gls; dfs n @@ -519,7 +519,10 @@ let decompose_eq id gls = let instr_rew _thus rew_side cut gls0 = let last_id = - try get_last (pf_env gls0) with _ -> error "No previous equality." in + try get_last (pf_env gls0) + with e when Errors.noncritical e -> + error "No previous equality." + in let typ,lhs,rhs = decompose_eq last_id gls0 in let items_tac gls = match cut.cut_by with @@ -849,7 +852,7 @@ let build_per_info etype casee gls = let ind = try destInd hd - with _ -> + with e when Errors.noncritical e -> error "Case analysis must be done on an inductive object." in let mind,oind = Global.lookup_inductive ind in let nparams,index = diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index 6aa47eff..b7ee3c1a 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -397,8 +397,10 @@ let mono_filename f = in let id = if lang () <> Haskell then default_id - else try id_of_string (Filename.basename f) - with _ -> error "Extraction: provided filename is not a valid identifier" + else + try id_of_string (Filename.basename f) + with e when Errors.noncritical e -> + error "Extraction: provided filename is not a valid identifier" in Some (f^d.file_suffix), Option.map ((^) f) d.sig_suffix, id @@ -473,8 +475,8 @@ let print_structure_to_file (fn,si,mo) dry struc = msg_with ft (d.preamble mo opened unsafe_needs); msg_with ft (d.pp_struct struc); Option.iter close_out cout; - with e -> - Option.iter close_out cout; raise e + with reraise -> + Option.iter close_out cout; raise reraise end; if not dry then Option.iter info_file fn; (* Now, let's print the signature *) @@ -487,8 +489,8 @@ let print_structure_to_file (fn,si,mo) dry struc = msg_with ft (d.sig_preamble mo opened unsafe_needs); msg_with ft (d.pp_sig (signature_of_structure struc)); close_out cout; - with e -> - close_out cout; raise e + with reraise -> + close_out cout; raise reraise end; info_file si) (if dry then None else si); @@ -527,7 +529,9 @@ let rec locate_ref = function | r::l -> let q = snd (qualid_of_reference r) in let mpo = try Some (Nametab.locate_module q) with Not_found -> None - and ro = try Some (Smartlocate.global_with_alias r) with _ -> None + and ro = + try Some (Smartlocate.global_with_alias r) + with e when Errors.noncritical e -> None in match mpo, ro with | None, None -> Nametab.error_global_not_found q diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index 0a17453c..e5357336 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -149,7 +149,7 @@ let rec handle_exn r n fn_name = function (fun i -> assert ((0 < i) && (i <= n)); MLexn ("IMPLICIT "^ msg_non_implicit r (n+1-i) (fn_name i))) - with _ -> MLexn s) + with e when Errors.noncritical e -> MLexn s) | a -> ast_map (handle_exn r n fn_name) a (*S Management of type variable contexts. *) @@ -683,7 +683,7 @@ and extract_cst_app env mle mlt kn args = let l,l' = list_chop (projection_arity (ConstRef kn)) mla in if l' <> [] then (List.map (fun _ -> MLexn "Proj Args") l) @ l' else mla - with _ -> mla + with e when Errors.noncritical e -> mla in (* For strict languages, purely logical signatures with at least one [Kill Kother] lead to a dummy lam. So a [MLdummy] is left diff --git a/plugins/extraction/haskell.ml b/plugins/extraction/haskell.ml index 6c78b533..b6fc5ac8 100644 --- a/plugins/extraction/haskell.ml +++ b/plugins/extraction/haskell.ml @@ -81,7 +81,9 @@ let kn_sig = let rec pp_type par vl t = let rec pp_rec par = function | Tmeta _ | Tvar' _ -> assert false - | Tvar i -> (try pr_id (List.nth vl (pred i)) with _ -> (str "a" ++ int i)) + | Tvar i -> + (try pr_id (List.nth vl (pred i)) + with e when Errors.noncritical e -> (str "a" ++ int i)) | Tglob (r,[]) -> pp_global Type r | Tglob (IndRef(kn,0),l) when not (keep_singleton ()) && kn = mk_ind "Coq.Init.Specif" "sig" -> diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index a38b303f..d0bf387a 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -879,7 +879,7 @@ let is_program_branch = function (try ignore (int_of_string (String.sub s n (String.length s - n))); String.sub s 0 n = br - with _ -> false) + with e when Errors.noncritical e -> false) | Tmp _ | Dummy -> false let expand_linear_let o id e = @@ -1312,7 +1312,7 @@ let inline_test r t = let c = match r with ConstRef c -> c | _ -> assert false in let has_body = try constant_has_body (Global.lookup_constant c) - with _ -> false + with e when Errors.noncritical e -> false in has_body && (let t1 = eta_red t in diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml index 289b2a1d..4e8d8145 100644 --- a/plugins/extraction/ocaml.ml +++ b/plugins/extraction/ocaml.ml @@ -119,7 +119,8 @@ let rec pp_type par vl t = let rec pp_rec par = function | Tmeta _ | Tvar' _ | Taxiom -> assert false | Tvar i -> (try pp_tvar (List.nth vl (pred i)) - with _ -> (str "'a" ++ int i)) + with e when Errors.noncritical e -> + (str "'a" ++ int i)) | Tglob (r,[a1;a2]) when is_infix r -> pp_par par (pp_rec true a1 ++ str (get_infix r) ++ pp_rec true a2) | Tglob (r,[]) -> pp_global Type r @@ -188,7 +189,7 @@ let rec pp_expr par env args = let args = list_skipn (projection_arity r) args in let record = List.hd args in pp_apply (record ++ str "." ++ pp_global Term r) par (List.tl args) - with _ -> apply (pp_global Term r)) + with e when Errors.noncritical e -> apply (pp_global Term r)) | MLfix (i,ids,defs) -> let ids',env' = push_vars (List.rev (Array.to_list ids)) env in pp_fix par env' i (Array.of_list (List.rev ids'),defs) args diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index e0a6e843..497ddf03 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -255,7 +255,7 @@ let safe_basename_of_global r = let string_of_global r = try string_of_qualid (Nametab.shortest_qualid_of_global Idset.empty r) - with _ -> string_of_id (safe_basename_of_global r) + with e when Errors.noncritical e -> string_of_id (safe_basename_of_global r) let safe_pr_global r = str (string_of_global r) @@ -263,7 +263,7 @@ let safe_pr_global r = str (string_of_global r) let safe_pr_long_global r = try Printer.pr_global r - with _ -> match r with + with e when Errors.noncritical e -> match r with | ConstRef kn -> let mp,_,l = repr_con kn in str ((string_of_mp mp)^"."^(string_of_label l)) @@ -452,7 +452,7 @@ let my_bool_option name initval = (*s Extraction AccessOpaque *) -let access_opaque = my_bool_option "AccessOpaque" false +let access_opaque = my_bool_option "AccessOpaque" true (*s Extraction AutoInline *) diff --git a/plugins/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.ml4 index 9d3d8c99..29d41b81 100644 --- a/plugins/firstorder/g_ground.ml4 +++ b/plugins/firstorder/g_ground.ml4 @@ -85,7 +85,7 @@ let gen_ground_tac flag taco ids bases gl= extend_with_auto_hints bases (extend_with_ref_list ids seq gl) gl in let result=ground_tac solver startseq gl in qflag:=backup;result - with e ->qflag:=backup;raise e + with reraise ->qflag:=backup;raise reraise (* special for compatibility with Intuition diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index 68f112d6..4b07c609 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -129,7 +129,7 @@ let mk_open_instance id gl m t= | _-> anomaly "can't happen" in let ntt=try Pretyping.Default.understand evmap env (raux m rawt) - with _ -> + with e when Errors.noncritical e -> error "Untypable instance, maybe higher-order non-prenex quantification" in decompose_lam_n_assum m ntt diff --git a/plugins/fourier/fourier.ml b/plugins/fourier/fourier.ml index 043c9e51..1574e21e 100644 --- a/plugins/fourier/fourier.ml +++ b/plugins/fourier/fourier.ml @@ -175,7 +175,7 @@ let unsolvable lie = raise (Failure "contradiction found")) |_->assert false) lr) - with _ -> ()); + with e when Errors.noncritical e -> ()); !res ;; diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml index cdd10d70..e0e4f7d6 100644 --- a/plugins/fourier/fourierR.ml +++ b/plugins/fourier/fourierR.ml @@ -40,7 +40,7 @@ type flin = {fhom: rational Constrhash.t; let flin_zero () = {fhom=Constrhash.create 50;fcste=r0};; -let flin_coef f x = try (Constrhash.find f.fhom x) with _-> r0;; +let flin_coef f x = try (Constrhash.find f.fhom x) with Not_found -> r0;; let flin_add f x c = let cx = flin_coef f x in @@ -141,10 +141,12 @@ let rec flin_of_constr c = (try (let a=(rational_of_constr args.(0)) in try (let b = (rational_of_constr args.(1)) in (flin_add_cste (flin_zero()) (rmult a b))) - with _-> (flin_add (flin_zero()) + with e when Errors.noncritical e -> + (flin_add (flin_zero()) args.(1) a)) - with _-> (flin_add (flin_zero()) + with e when Errors.noncritical e -> + (flin_add (flin_zero()) args.(0) (rational_of_constr args.(1)))) | "Rinv"-> @@ -154,7 +156,8 @@ let rec flin_of_constr c = (let b=(rational_of_constr args.(1)) in try (let a = (rational_of_constr args.(0)) in (flin_add_cste (flin_zero()) (rdiv a b))) - with _-> (flin_add (flin_zero()) + with e when Errors.noncritical e -> + (flin_add (flin_zero()) args.(0) (rinv b))) |_->assert false) @@ -164,7 +167,8 @@ let rec flin_of_constr c = |"R0" -> flin_zero () |_-> assert false) |_-> assert false) - with _ -> flin_add (flin_zero()) + with e when Errors.noncritical e -> + flin_add (flin_zero()) c r1 ;; @@ -494,13 +498,13 @@ let rec fourier gl= |_->assert false) |_->assert false in tac gl) - with _ -> + with e when Errors.noncritical e -> (* les hypothèses *) let hyps = List.map (fun (h,t)-> (mkVar h,t)) (list_of_sign (pf_hyps gl)) in let lineq =ref [] in List.iter (fun h -> try (lineq:=(ineq1_of_constr h)@(!lineq)) - with _ -> ()) + with e when Errors.noncritical e -> ()) hyps; (* lineq = les inéquations découlant des hypothèses *) if !lineq=[] then Util.error "No inequalities"; diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 33d77568..48205019 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -33,9 +33,12 @@ let observennl strm = 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 e = Cerrors.process_vernac_interp_error e in - let goal = begin try (Printer.pr_goal g) with _ -> assert false end in + with reraise -> + let e = Cerrors.process_vernac_interp_error reraise in + let goal = + try (Printer.pr_goal g) + with e when Errors.noncritical e -> assert false + in msgnl (str "observation "++ s++str " raised exception " ++ Errors.print e ++ str " on goal " ++ goal ); raise e;; @@ -119,7 +122,7 @@ let is_trivial_eq t = eq_constr t1 t2 && eq_constr a1 a2 | _ -> false end - with _ -> false + with e when Errors.noncritical e -> false in (* observe (str "is_trivial_eq " ++ Printer.pr_lconstr t ++ (if res then str " true" else str " false")); *) res @@ -145,7 +148,7 @@ let is_incompatible_eq t = (eq_constr u1 u2 && incompatible_constructor_terms t1 t2) | _ -> false - with _ -> false + with e when Errors.noncritical e -> false in if res then observe (str "is_incompatible_eq " ++ Printer.pr_lconstr t); res @@ -232,7 +235,7 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = then (jmeq_refl (),(args.(1),args.(0)),(args.(3),args.(2)),args.(0)) else nochange "not an equality" - with _ -> nochange "not an equality" + with e when Errors.noncritical e -> nochange "not an equality" in if not ((closed0 (fst t1)) && (closed0 (snd t1)))then nochange "not a closed lhs"; let rec compute_substitution sub t1 t2 = @@ -608,7 +611,7 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = let my_orelse tac1 tac2 g = try tac1 g - with e -> + with e when Errors.noncritical e -> (* observe (str "using snd tac since : " ++ Errors.print e); *) tac2 g @@ -1212,7 +1215,11 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : let ctxt,pte_app = (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 pte = + try destVar pte + with e when Errors.noncritical e -> + 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 diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 00e966fb..04fcc8d4 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -302,11 +302,8 @@ let defined () = "defined" ((try str "On goal : " ++ fnl () ++ pr_open_subgoals () ++ fnl () - with _ -> mt () + with e when Errors.noncritical e -> mt () ) ++msg) - | e -> raise e - - let build_functional_principle interactive_proof old_princ_type sorts funs i proof_tac hook = (* First we get the type of the old graph principle *) @@ -401,7 +398,7 @@ let generate_functional_principle Don't forget to close the goal if an error is raised !!!! *) save false new_princ_name entry g_kind hook - with e -> + with e when Errors.noncritical e -> begin begin try @@ -413,7 +410,7 @@ let generate_functional_principle then Pfedit.delete_current_proof () else () else () - with _ -> () + with e when Errors.noncritical e -> () end; raise (Defining_principle e) end @@ -554,7 +551,7 @@ let make_scheme (fas : (constant*Glob_term.glob_sort) list) : Entries.definition 0 (prove_princ_for_struct false 0 (Array.of_list funs)) (fun _ _ _ -> ()) - with e -> + with e when Errors.noncritical e -> begin begin try @@ -566,7 +563,7 @@ let make_scheme (fas : (constant*Glob_term.glob_sort) list) : Entries.definition then Pfedit.delete_current_proof () else () else () - with _ -> () + with e when Errors.noncritical e -> () end; raise (Defining_principle e) end diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index 85d79214..6b6e4838 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -208,14 +208,14 @@ VERNAC COMMAND EXTEND NewFunctionalScheme try Functional_principles_types.build_scheme fas with Functional_principles_types.No_graph_found -> Util.error ("Cannot generate induction principle(s)") - | e -> + | e when Errors.noncritical e -> let names = List.map (fun (_,na,_) -> na) fas in warning_error names e end | _ -> assert false (* we can only have non empty list *) end - | e -> + | e when Errors.noncritical e -> let names = List.map (fun (_,na,_) -> na) fas in warning_error names e end diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 43b08840..b9e0e62a 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -948,7 +948,8 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = try observe (str "computing new type for eq : " ++ pr_glob_constr rt); let t' = - try Pretyping.Default.understand Evd.empty env t with _ -> raise Continue + try Pretyping.Default.understand Evd.empty env t + with e when Errors.noncritical e -> raise Continue in let is_in_b = is_free_in id b in let _keep_eq = @@ -1247,7 +1248,7 @@ let compute_params_name relnames (args : (Names.name * Glob_term.glob_constr * b l := param::!l ) rels_params.(0) - with _ -> + with e when Errors.noncritical e -> () in List.rev !l @@ -1453,7 +1454,7 @@ let do_build_inductive in observe (msg); raise e - | e -> + | reraise -> let _time3 = System.get_time () in (* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) let repacked_rel_inds = @@ -1464,16 +1465,16 @@ let do_build_inductive str "while trying to define"++ spc () ++ Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,false,repacked_rel_inds)) ++ fnl () ++ - Errors.print e + Errors.print reraise in observe msg; - raise e + raise reraise let build_inductive funnames funsargs returned_types rtl = try do_build_inductive funnames funsargs returned_types rtl - with e -> raise (Building_graph e) + with e when Errors.noncritical e -> raise (Building_graph e) diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index cdd0eaf7..6cc932b1 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -534,7 +534,8 @@ let rec are_unifiable_aux = function else let eqs' = try ((List.combine cpl1 cpl2)@eqs) - with _ -> anomaly "are_unifiable_aux" + with e when Errors.noncritical e -> + anomaly "are_unifiable_aux" in are_unifiable_aux eqs' @@ -556,7 +557,8 @@ let rec eq_cases_pattern_aux = function else let eqs' = try ((List.combine cpl1 cpl2)@eqs) - with _ -> anomaly "eq_cases_pattern_aux" + with e when Errors.noncritical e -> + anomaly "eq_cases_pattern_aux" in eq_cases_pattern_aux eqs' | _ -> raise NotUnifiable diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 8caeca57..d2c065a0 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -82,7 +82,7 @@ let functional_induction with_clean c princl pat = List.fold_right (fun a acc -> try Idset.add (destVar a) acc - with _ -> acc + with e when Errors.noncritical e -> acc ) args Idset.empty @@ -166,8 +166,8 @@ let build_newrecursive sigma rec_sign rec_impls def ) lnameargsardef - with e -> - States.unfreeze fs; raise e in + with reraise -> + States.unfreeze fs; raise reraise in States.unfreeze fs; def in recdef,rec_impls @@ -251,12 +251,12 @@ let derive_inversion fix_names = (fun id -> destInd (Constrintern.global_reference (mk_rel_id id))) fix_names ) - with e -> + with e when Errors.noncritical e -> let e' = Cerrors.process_vernac_interp_error e in msg_warning (str "Cannot build inversion information" ++ if do_observe () then (fnl() ++ Errors.print e') else mt ()) - with _ -> () + with e when Errors.noncritical e -> () let warning_error names e = let e = Cerrors.process_vernac_interp_error e in @@ -346,7 +346,7 @@ let generate_principle on_error Array.iter (add_Function is_general) funs_kn; () end - with e -> + with e when Errors.noncritical e -> on_error names e let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = @@ -413,7 +413,7 @@ let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation ); derive_inversion [fname] - with e -> + with e when Errors.noncritical e -> (* No proof done *) () in diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index dd475315..827191b1 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -55,7 +55,6 @@ let locate_with_msg msg f x = f x with | Not_found -> raise (Util.UserError("", msg)) - | e -> raise e let filter_map filter f = @@ -123,7 +122,7 @@ let def_of_const t = (try (match Declarations.body_of_constant (Global.lookup_constant sp) with | Some c -> Declarations.force c | _ -> assert false) - with _ -> assert false) + with e when Errors.noncritical e -> assert false) |_ -> assert false let coq_constant s = @@ -215,13 +214,13 @@ let with_full_print f a = Dumpglob.continue (); res with - | e -> + | reraise -> 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; Flags.raw_print := old_rawprint; Dumpglob.continue (); - raise e + raise reraise @@ -350,7 +349,8 @@ open Term let pr_info f_info = str "function_constant := " ++ Printer.pr_lconstr (mkConst f_info.function_constant)++ fnl () ++ str "function_constant_type := " ++ - (try Printer.pr_lconstr (Global.type_of_global (ConstRef f_info.function_constant)) with _ -> mt ()) ++ fnl () ++ + (try Printer.pr_lconstr (Global.type_of_global (ConstRef f_info.function_constant)) + with e when Errors.noncritical e -> mt ()) ++ fnl () ++ str "equation_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.equation_lemma (mt ()) ) ++ fnl () ++ str "completeness_lemma :=" ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.completeness_lemma (mt ()) ) ++ fnl () ++ str "correctness_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.correctness_lemma (mt ()) ) ++ fnl () ++ @@ -502,22 +502,22 @@ exception ToShow of exn let init_constant dir s = try Coqlib.gen_constant "Function" dir s - with e -> raise (ToShow e) + with e when Errors.noncritical e -> raise (ToShow e) let jmeq () = try (Coqlib.check_required_library ["Coq";"Logic";"JMeq"]; init_constant ["Logic";"JMeq"] "JMeq") - with e -> raise (ToShow e) + with e when Errors.noncritical e -> raise (ToShow e) let jmeq_rec () = try Coqlib.check_required_library ["Coq";"Logic";"JMeq"]; init_constant ["Logic";"JMeq"] "JMeq_rec" - with e -> raise (ToShow e) + with e when Errors.noncritical e -> raise (ToShow e) let jmeq_refl () = try Coqlib.check_required_library ["Coq";"Logic";"JMeq"]; init_constant ["Logic";"JMeq"] "JMeq_refl" - with e -> raise (ToShow e) + with e when Errors.noncritical e -> raise (ToShow e) diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 55451a9f..7b5dd763 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -59,14 +59,17 @@ let observennl strm = let do_observe_tac s tac g = - let goal = begin try (Printer.pr_goal g) with _ -> assert false end in + let goal = + try Printer.pr_goal g + with e when Errors.noncritical e -> assert false + in try let v = tac g in msgnl (goal ++ fnl () ++ s ++(str " ")++(str "finished")); v - with e -> - let e' = Cerrors.process_vernac_interp_error e in + with reraise -> + let e' = Cerrors.process_vernac_interp_error reraise in msgnl (str "observation "++ s++str " raised exception " ++ Errors.print e' ++ str " on goal " ++ goal ); - raise e;; + raise reraise;; let observe_tac s tac g = @@ -568,7 +571,7 @@ let rec reflexivity_with_destruct_cases g = observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases ] | _ -> reflexivity - with _ -> reflexivity + with e when Errors.noncritical e -> reflexivity in let eq_ind = Coqlib.build_coq_eq () in let discr_inject = @@ -862,11 +865,11 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g update_Function {finfo with completeness_lemma = Some lem_cst} ) funs; - with e -> + with reraise -> (* In case of problem, we reset all the lemmas *) Pfedit.delete_all_proofs (); States.unfreeze previous_state; - raise e + raise reraise diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml index 6ee2f352..bd1a1710 100644 --- a/plugins/funind/merge.ml +++ b/plugins/funind/merge.ml @@ -70,7 +70,7 @@ let ident_global_exist id = let ans = CRef (Libnames.Ident (dummy_loc,id)) in let _ = ignore (Constrintern.intern_constr Evd.empty (Global.env()) ans) in true - with _ -> false + with e when Errors.noncritical e -> false (** [next_ident_fresh id] returns a fresh identifier (ie not linked in global env) with base [id]. *) @@ -793,10 +793,10 @@ let rec merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body) let params1 = try fst (glob_decompose_prod_n shift.nrecprms1 (List.hd lcstr1)) - with _ -> [] in + with e when Errors.noncritical e -> [] in let params2 = try fst (glob_decompose_prod_n shift.nrecprms2 (List.hd lcstr2)) - with _ -> [] in + with e when Errors.noncritical e -> [] in let lcstr1 = List.combine (Array.to_list oib1.mind_consnames) lcstr1 in let lcstr2 = List.combine (Array.to_list oib2.mind_consnames) lcstr2 in diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 892c1a77..9853fd73 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -94,11 +94,11 @@ let do_observe_tac s tac g = let v = tac g in ignore(Stack.pop debug_queue); v - with e -> + with reraise -> if not (Stack.is_empty debug_queue) then - print_debug_queue true e; - raise e + print_debug_queue true reraise; + raise reraise let observe_tac s tac g = if Tacinterp.get_debug () <> Tactic_debug.DebugOff @@ -140,7 +140,7 @@ let def_of_const t = (try (match body_of_constant (Global.lookup_constant sp) with | Some c -> Declarations.force c | _ -> assert false) - with _ -> + with e when Errors.noncritical e -> anomaly ("Cannot find definition of constant "^ (string_of_id (id_of_label (con_label sp)))) ) @@ -380,7 +380,11 @@ let rec mk_intros_and_continue thin_intros (extra_eqn:bool) (fun g1 -> let ty_teq = pf_type_of g1 (mkVar teq) in let teq_lhs,teq_rhs = - let _,args = try destApp ty_teq with _ -> Pp.msgnl (Printer.pr_goal g1 ++ fnl () ++ pr_id teq ++ str ":" ++ Printer.pr_lconstr ty_teq); assert false in + let _,args = + try destApp ty_teq + with e when Errors.noncritical e -> + Pp.msgnl (Printer.pr_goal g1 ++ fnl () ++ pr_id teq ++ str ":" ++ Printer.pr_lconstr ty_teq); assert false + in args.(1),args.(2) in cont_function (mkVar teq::eqs) (Termops.replace_term teq_lhs teq_rhs expr) g1 @@ -701,12 +705,17 @@ let proveterminate nb_arg rec_arg_id is_mes acc_inv (hrec:identifier) (match find_call_occs nb_arg 0 f_constr expr with _,[] -> (try observe_tac "base_leaf" (base_leaf func eqs expr) - with e -> (msgerrnl (str "failure in base case");raise e )) + with reraise -> + (msgerrnl (str "failure in base case");raise reraise )) | _, _::_ -> observe_tac "rec_leaf" (rec_leaf is_mes acc_inv hrec func eqs expr)) in v - with e -> begin msgerrnl(str "failure in proveterminate"); raise e end + with reraise -> + begin + msgerrnl(str "failure in proveterminate"); + raise reraise + end in proveterminate @@ -931,7 +940,7 @@ let is_rec_res id = let id_name = string_of_id id in try String.sub id_name 0 (String.length rec_res_name) = rec_res_name - with _ -> false + with e when Errors.noncritical e -> false let clear_goals = let rec clear_goal t = @@ -969,7 +978,8 @@ let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_ | Some s -> s | None -> try (add_suffix current_proof_name "_subproof") - with _ -> anomaly "open_new_goal with an unamed theorem" + with e when Errors.noncritical e -> + anomaly "open_new_goal with an unamed theorem" in let sign = initialize_named_context_for_proof () in let na = next_global_ident_away name [] in @@ -1439,7 +1449,7 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let stop = ref false in begin try com_eqn (List.length res_vars) equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type) - with e -> + with e when Errors.noncritical e -> begin if Tacinterp.get_debug () <> Tactic_debug.DebugOff then pperrnl (str "Cannot create equation Lemma " ++ Errors.print e) @@ -1474,9 +1484,10 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num using_lemmas (List.length res_vars) hook - with e -> + with reraise -> begin - (try ignore (Backtrack.backto previous_label) with _ -> ()); + (try ignore (Backtrack.backto previous_label) + with e when Errors.noncritical e -> ()); (* anomaly "Cannot create termination Lemma" *) - raise e + raise reraise end diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml index 25579a87..a5b0da9c 100644 --- a/plugins/micromega/certificate.ml +++ b/plugins/micromega/certificate.ml @@ -331,7 +331,7 @@ let dual_raw_certificate (l: (Poly.t * Mc.op1) list) = | Inr _ -> None | Inl cert -> Some (rats_to_ints (Vect.to_list cert)) (* should not use rats_to_ints *) - with x -> + with x when Errors.noncritical x -> if debug then (Printf.printf "raw certificate %s" (Printexc.to_string x); flush stdout) ; @@ -377,8 +377,9 @@ let linear_prover n_spec l = let linear_prover n_spec l = - try linear_prover n_spec l with - x -> (print_string (Printexc.to_string x); None) + try linear_prover n_spec l + with x when x <> Sys.Break -> + (print_string (Printexc.to_string x); None) let linear_prover_with_cert spec l = match linear_prover spec l with diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 2020447f..ff08aeb3 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -937,7 +937,8 @@ struct let (expr,env) = parse_expr env args.(0) in let power = (parse_exp expr args.(1)) in (power , env) - with _ -> (* if the exponent is a variable *) + with e when e <> Sys.Break -> + (* if the exponent is a variable *) let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env) end | Ukn s -> @@ -1112,8 +1113,12 @@ struct let parse_formula parse_atom env tg term = - let parse_atom env tg t = try let (at,env) = parse_atom env t in - (A(at,tg,t), env,Tag.next tg) with _ -> (X(t),env,tg) in + let parse_atom env tg t = + try + let (at,env) = parse_atom env t in + (A(at,tg,t), env,Tag.next tg) + with e when e <> Sys.Break -> (X(t),env,tg) + in let rec xparse_formula env tg term = match kind_of_term term with @@ -1189,7 +1194,8 @@ let same_proof sg cl1 cl2 = let rec xsame_proof sg = match sg with | [] -> true - | n::sg -> (try List.nth cl1 n = List.nth cl2 n with _ -> false) + | n::sg -> + (try List.nth cl1 n = List.nth cl2 n with e when e <> Sys.Break -> false) && (xsame_proof sg ) in xsame_proof sg @@ -1253,7 +1259,7 @@ let btree_of_array typ a = let btree_of_array typ a = try btree_of_array typ a - with x -> + with x when x <> Sys.Break -> failwith (Printf.sprintf "btree of array : %s" (Printexc.to_string x)) let dump_varmap typ env = @@ -1322,7 +1328,7 @@ let rec parse_hyps parse_arith env tg hyps = try let (c,env,tg) = parse_formula parse_arith env tg t in ((i,c)::lhyps, env,tg) - with _ -> (lhyps,env,tg) + with e when e <> Sys.Break -> (lhyps,env,tg) (*(if debug then Printf.printf "parse_arith : %s\n" x);*) @@ -1466,7 +1472,7 @@ let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) = (pp_ml_list prover.pp_f) (List.map fst new_cl) ; flush stdout end ; *) - let res = try prover.compact prf remap with x -> + let res = try prover.compact prf remap with x when x <> Sys.Break -> if debug then Printf.fprintf stdout "Proof compaction %s" (Printexc.to_string x) ; (* This should not happen -- this is the recovery plan... *) match prover.prover (List.map fst new_cl) with @@ -2031,13 +2037,13 @@ let xlia gl = try micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec [ linear_Z ] gl - with z -> (*Printexc.print_backtrace stdout ;*) raise z + with reraise -> (*Printexc.print_backtrace stdout ;*) raise reraise let xnlia gl = try micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec [ nlinear_Z ] gl - with z -> (*Printexc.print_backtrace stdout ;*) raise z + with reraise -> (*Printexc.print_backtrace stdout ;*) raise reraise diff --git a/plugins/micromega/csdpcert.ml b/plugins/micromega/csdpcert.ml index dfda5984..0f26575c 100644 --- a/plugins/micromega/csdpcert.ml +++ b/plugins/micromega/csdpcert.ml @@ -150,7 +150,7 @@ let real_nonlinear_prover d l = S (Some proof) with | Sos_lib.TooDeep -> S None - | x -> F (Printexc.to_string x) + | x when x <> Sys.Break -> F (Printexc.to_string x) (* This is somewhat buggy, over Z, strict inequality vanish... *) let pure_sos l = @@ -174,7 +174,7 @@ let pure_sos l = S (Some proof) with (* | Sos.CsdpNotFound -> F "Sos.CsdpNotFound" *) - | x -> (* May be that could be refined *) S None + | x when x <> Sys.Break -> (* May be that could be refined *) S None @@ -203,7 +203,7 @@ let main () = Marshal.to_channel chan (cert:csdp_certificate) [] ; flush chan ; exit 0 - with x -> (Printf.fprintf chan "error %s" (Printexc.to_string x) ; exit 1) + with any -> (Printf.fprintf chan "error %s" (Printexc.to_string any) ; exit 1) ;; diff --git a/plugins/micromega/mfourier.ml b/plugins/micromega/mfourier.ml index d9201722..6effa4c4 100644 --- a/plugins/micromega/mfourier.ml +++ b/plugins/micromega/mfourier.ml @@ -728,7 +728,8 @@ struct try Some (bound_of_variable IMap.empty fresh s.sys) with - x -> Printf.printf "optimise Exception : %s" (Printexc.to_string x) ; None + x when x <> Sys.Break -> + Printf.printf "optimise Exception : %s" (Printexc.to_string x) ; None let find_point cstrs = diff --git a/plugins/micromega/mutils.ml b/plugins/micromega/mutils.ml index ccbf0406..3129e54d 100644 --- a/plugins/micromega/mutils.ml +++ b/plugins/micromega/mutils.ml @@ -29,10 +29,10 @@ let finally f rst = try let res = f () in rst () ; res - with x -> + with reraise -> (try rst () - with _ -> raise x - ); raise x + with any -> raise reraise + ); raise reraise let map_option f x = match x with @@ -431,14 +431,16 @@ let command exe_path args vl = | Unix.WEXITED 0 -> let inch = Unix.in_channel_of_descr stdout_read in begin try Marshal.from_channel inch - with x -> failwith (Printf.sprintf "command \"%s\" exited %s" exe_path (Printexc.to_string x)) + with x when x <> Sys.Break -> + failwith (Printf.sprintf "command \"%s\" exited %s" exe_path (Printexc.to_string x)) end | Unix.WEXITED i -> failwith (Printf.sprintf "command \"%s\" exited %i" exe_path i) | Unix.WSIGNALED i -> failwith (Printf.sprintf "command \"%s\" killed %i" exe_path i) | Unix.WSTOPPED i -> failwith (Printf.sprintf "command \"%s\" stopped %i" exe_path i)) (* Cleanup *) (fun () -> - List.iter (fun x -> try Unix.close x with _ -> ()) [stdin_read; stdin_write; stdout_read; stdout_write; stderr_read; stderr_write]) + List.iter (fun x -> try Unix.close x with e when e <> Sys.Break -> ()) + [stdin_read; stdin_write; stdout_read; stdout_write; stderr_read; stderr_write]) (* Local Variables: *) (* coding: utf-8 *) diff --git a/plugins/micromega/persistent_cache.ml b/plugins/micromega/persistent_cache.ml index cb7a9280..6d1a2927 100644 --- a/plugins/micromega/persistent_cache.ml +++ b/plugins/micromega/persistent_cache.ml @@ -82,10 +82,10 @@ let finally f rst = try let res = f () in rst () ; res - with x -> + with reraise -> (try rst () - with _ -> raise x - ); raise x + with any -> raise reraise + ); raise reraise let read_key_elem inch = @@ -93,7 +93,7 @@ let read_key_elem inch = Some (Marshal.from_channel inch) with | End_of_file -> None - | _ -> raise InvalidTableFormat + | e when e <> Sys.Break -> raise InvalidTableFormat (** In win32, it seems that we should unlock the exact zone that has been locked, and not the whole file *) @@ -151,7 +151,7 @@ let open_in f = Table.iter (fun k e -> Marshal.to_channel outch (k,e) [Marshal.No_sharing]) htbl; flush outch ; - with _ -> () ) + with e when e <> Sys.Break -> () ) ; unlock out ; { outch = outch ; diff --git a/plugins/nsatz/ideal.ml b/plugins/nsatz/ideal.ml index 996dbadd..68fb2626 100644 --- a/plugins/nsatz/ideal.ml +++ b/plugins/nsatz/ideal.ml @@ -237,7 +237,8 @@ open Format let getvar lv i = try (nth lv i) - with _ -> (fold_left (fun r x -> r^" "^x) "lv= " lv) + with e when Errors.noncritical e -> + (fold_left (fun r x -> r^" "^x) "lv= " lv) ^" i="^(string_of_int i) let string_of_pol zeroP hdP tlP coefterm monterm string_of_coef @@ -590,7 +591,7 @@ let coefpoldep = Hashtbl.create 51 (* coef of q in p = sum_i c_i*q_i *) let coefpoldep_find p q = try (Hashtbl.find coefpoldep (p.num,q.num)) - with _ -> [] + with Not_found -> [] let coefpoldep_remove p q = Hashtbl.remove coefpoldep (p.num,q.num) diff --git a/plugins/nsatz/polynom.ml b/plugins/nsatz/polynom.ml index 0eea961d..fdc8e865 100644 --- a/plugins/nsatz/polynom.ml +++ b/plugins/nsatz/polynom.ml @@ -173,7 +173,7 @@ let rec equal p q = then failwith "raté") p1; true) - with _ -> false) + with e when Errors.noncritical e -> false) | (_,_) -> false (* normalize polynomial: remove head zeros, coefficients are normalized @@ -524,7 +524,7 @@ let div_pol_rat p q= q x in (* degueulasse, mais c 'est pour enlever un warning *) if s==s then true else true) - with _ -> false + with e when Errors.noncritical e -> false (*********************************************************************** 5. Pseudo-division and gcd with subresultants. diff --git a/plugins/nsatz/utile.ml b/plugins/nsatz/utile.ml index c16bd425..17c8654b 100644 --- a/plugins/nsatz/utile.ml +++ b/plugins/nsatz/utile.ml @@ -33,10 +33,11 @@ let set_of_list_eq eq l = let memos s memoire nf f x = try (let v = Hashtbl.find memoire (nf x) in pr s;v) - with _ -> (pr "#"; - let v = f x in - Hashtbl.add memoire (nf x) v; - v) + with e when Errors.noncritical e -> + (pr "#"; + let v = f x in + Hashtbl.add memoire (nf x) v; + v) (********************************************************************** @@ -64,7 +65,7 @@ let facteurs_liste div constant lp = if not (constant r) then l1:=r::(!l1) else p_dans_lmin:=true) - with _ -> ()) + with e when Errors.noncritical e -> ()) lmin; if !p_dans_lmin then factor lmin lp1 @@ -75,7 +76,8 @@ let facteurs_liste div constant lp = List.iter (fun q -> try (let r = div q p in if not (constant r) then l1:=r::(!l1)) - with _ -> lmin1:=q::(!lmin1)) + with e when Errors.noncritical e -> + lmin1:=q::(!lmin1)) lmin; factor (List.rev (p::(!lmin1))) !l1) (* au moins un q de lmin divise p non trivialement *) @@ -105,7 +107,7 @@ let factorise_tableau div zero c f l1 = li:=j::(!li); r:=rr; done) - with _ -> ()) + with e when Errors.noncritical e -> ()) l1; res.(i)<-(!r,!li)) f; diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 028ef95d..ffa99fc7 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -885,7 +885,7 @@ let rec transform p t = try let v,th,_ = find_constr t' in [clever_rewrite_base p (mkVar v) (mkVar th)], Oatom v - with _ -> + with e when Errors.noncritical e -> let v = new_identifier_var () and th = new_identifier () in hide_constr t' v th isnat; @@ -924,7 +924,8 @@ let rec transform p t = | _ -> default false t end | Kapp((Zpos|Zneg|Z0),_) -> - (try ([],Oz(recognize_number t)) with _ -> default false t) + (try ([],Oz(recognize_number t)) + with e when Errors.noncritical e -> default false t) | Kvar s -> [],Oatom s | Kapp(Zopp,[t]) -> let tac,t' = transform (P_APP 1 :: p) t in diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml index f0ca3bb9..216a719d 100644 --- a/plugins/quote/quote.ml +++ b/plugins/quote/quote.ml @@ -221,7 +221,10 @@ let compute_rhs bodyi index_of_f = (*s Now the function [compute_ivs] itself *) let compute_ivs gl f cs = - let cst = try destConst f with _ -> i_can't_do_that () in + let cst = + try destConst f + with e when Errors.noncritical e -> i_can't_do_that () + in let body = Environ.constant_value (Global.env()) cst in match decomp_term body with | Fix(([| len |], 0), ([| name |], [| typ |], [| body2 |])) -> diff --git a/plugins/ring/ring.ml b/plugins/ring/ring.ml index ae73069d..7b0d96bb 100644 --- a/plugins/ring/ring.ml +++ b/plugins/ring/ring.ml @@ -292,7 +292,8 @@ let unbox = function (* Protects the convertibility test against undue exceptions when using it with untyped terms *) -let safe_pf_conv_x gl c1 c2 = try pf_conv_x gl c1 c2 with _ -> false +let safe_pf_conv_x gl c1 c2 = + try pf_conv_x gl c1 c2 with e when Errors.noncritical e -> false (* Add a Ring or a Semi-Ring to the database after a type verification *) diff --git a/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml index e810e15c..fb45e816 100644 --- a/plugins/romega/const_omega.ml +++ b/plugins/romega/const_omega.ml @@ -335,7 +335,7 @@ let parse_term t = | Kapp("Z.succ",[t]) -> Tsucc t | Kapp("Z.pred",[t]) -> Tplus(t, mk_Z (Bigint.neg Bigint.one)) | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> - (try Tnum (recognize t) with _ -> Tother) + (try Tnum (recognize t) with e when Errors.noncritical e -> Tother) | _ -> Tother with e when Logic.catchable_exception e -> Tother @@ -357,6 +357,6 @@ let is_scalar t = | Kapp(("Z.opp"|"Z.succ"|"Z.pred"),[t]) -> aux t | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> let _ = recognize t in true | _ -> false in - try aux t with _ -> false + try aux t with e when Errors.noncritical e -> false end diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index 4a6d462e..e57230cb 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -225,7 +225,8 @@ let add_reified_atom t env = env.terms <- env.terms @ [t]; i let get_reified_atom env = - try List.nth env.terms with _ -> failwith "get_reified_atom" + try List.nth env.terms + with e when Errors.noncritical e -> failwith "get_reified_atom" (* \subsection{Gestion de l'environnement de proposition pour Omega} *) (* ajout d'une proposition *) @@ -235,7 +236,9 @@ let add_prop env t = let i = List.length env.props in env.props <- env.props @ [t]; i (* accès a une proposition *) -let get_prop v env = try List.nth v env with _ -> failwith "get_prop" +let get_prop v env = + try List.nth v env + with e when Errors.noncritical e -> failwith "get_prop" (* \subsection{Gestion du nommage des équations} *) (* Ajout d'une equation dans l'environnement de reification *) @@ -247,7 +250,8 @@ let add_equation env e = (* accès a une equation *) let get_equation env id = try Hashtbl.find env.equations id - with e -> Printf.printf "Omega Equation %d non trouvée\n" id; raise e + with Not_found as e -> + Printf.printf "Omega Equation %d non trouvée\n" id; raise e (* Affichage des termes réifiés *) let rec oprint ch = function @@ -349,7 +353,8 @@ let rec reified_of_formula env = function app coq_t_minus [| reified_of_formula env t1; reified_of_formula env t2 |] let reified_of_formula env f = - begin try reified_of_formula env f with e -> oprint stderr f; raise e end + try reified_of_formula env f + with reraise -> oprint stderr f; raise reraise let rec reified_of_proposition env = function Pequa (_,{ e_comp=Eq; e_left=t1; e_right=t2 }) -> @@ -380,8 +385,8 @@ let rec reified_of_proposition env = function | Pprop t -> app coq_p_prop [| mk_nat (add_prop env t) |] let reified_of_proposition env f = - begin try reified_of_proposition env f - with e -> pprint stderr f; raise e end + try reified_of_proposition env f + with reraise -> pprint stderr f; raise reraise (* \subsection{Omega vers COQ réifié} *) @@ -397,11 +402,11 @@ let reified_of_omega env body constant = List.fold_right mk_coeff body coeff_constant let reified_of_omega env body c = - begin try + try reified_of_omega env body c - with e -> - display_eq display_omega_var (body,c); raise e - end + with reraise -> + display_eq display_omega_var (body,c); raise reraise + (* \section{Opérations sur les équations} Ces fonctions préparent les traces utilisées par la tactique réfléchie @@ -1000,10 +1005,11 @@ let rec solve_with_constraints all_solutions path = let weighted = filter_compatible_systems path all_solutions in let (winner_sol,winner_deps) = try select_smaller weighted - with e -> + with reraise -> Printf.printf "%d - %d\n" (List.length weighted) (List.length all_solutions); - List.iter display_depend path; raise e in + List.iter display_depend path; raise reraise + in build_tree winner_sol (List.rev path) winner_deps let find_path {o_hyp=id;o_path=p} env = diff --git a/plugins/subtac/g_subtac.ml4 b/plugins/subtac/g_subtac.ml4 index 956ccf09..6e7a8d32 100644 --- a/plugins/subtac/g_subtac.ml4 +++ b/plugins/subtac/g_subtac.ml4 @@ -90,7 +90,8 @@ VERNAC COMMAND EXTEND Subtac let try_catch_exn f e = try f e - with exn -> errorlabstrm "Program" (Errors.print exn) + with exn when Errors.noncritical exn -> + errorlabstrm "Program" (Errors.print exn) let subtac_obligation e = try_catch_exn Subtac_obligations.subtac_obligation e let next_obligation e = try_catch_exn Subtac_obligations.next_obligation e diff --git a/plugins/subtac/subtac.ml b/plugins/subtac/subtac.ml index 281e981b..ad248bfb 100644 --- a/plugins/subtac/subtac.ml +++ b/plugins/subtac/subtac.ml @@ -221,6 +221,6 @@ let subtac (loc, command) = | (Loc.Exc_located (loc, Proof_type.LtacLocated (_,e')) | Loc.Exc_located (loc, e') as e) -> raise e - | e -> + | reraise -> (* msg_warning (str "Uncaught exception: " ++ Errors.print e); *) - raise e + raise reraise diff --git a/plugins/subtac/subtac_cases.ml b/plugins/subtac/subtac_cases.ml index 221b57ee..0b1ed9bb 100644 --- a/plugins/subtac/subtac_cases.ml +++ b/plugins/subtac/subtac_cases.ml @@ -342,7 +342,7 @@ let prepare_predicate_from_arsign_tycon loc env evm tomatchs arsign c = let pred = predicate 0 c in let env' = push_rel_context (context_of_arsign arsign) env in ignore(Typing.sort_of env' evm pred); pred - with _ -> lift nar c + with e when Errors.noncritical e -> lift nar c module Cases_F(Coercion : Coercion.S) : S = struct @@ -1465,7 +1465,8 @@ let extract_arity_signatures env0 tomatchl tmsign = | None -> list_tabulate (fun _ -> Anonymous) nrealargs in let arsign = fst (get_arity env0 indf) in (na,None,build_dependent_inductive env0 indf) - ::(try List.map2 (fun x (_,c,t) ->(x,c,t)) realnal arsign with _ -> assert false) in + ::(try List.map2 (fun x (_,c,t) ->(x,c,t)) realnal arsign + with e when Errors.noncritical e -> assert false) in let rec buildrec = function | [],[] -> [] | (_,tm)::ltm, x::tmsign -> diff --git a/plugins/subtac/subtac_coercion.ml b/plugins/subtac/subtac_coercion.ml index 168a799d..0c03fb4c 100644 --- a/plugins/subtac/subtac_coercion.ml +++ b/plugins/subtac/subtac_coercion.ml @@ -356,7 +356,7 @@ module Coercion = struct jres), jres.uj_type) (hj,typ_cl) p) - with _ -> anomaly "apply_coercion" + with e when Errors.noncritical e -> anomaly "apply_coercion" let inh_app_fun env isevars j = let isevars = ref isevars in @@ -506,5 +506,5 @@ module Coercion = struct with NoSubtacCoercion -> error_cannot_coerce env' isevars (t, t')) else isevars - with _ -> isevars + with e when Errors.noncritical e -> isevars end diff --git a/plugins/subtac/subtac_command.ml b/plugins/subtac/subtac_command.ml index 14a09032..537a8301 100644 --- a/plugins/subtac/subtac_command.ml +++ b/plugins/subtac/subtac_command.ml @@ -248,7 +248,7 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation = | [(_, None, t); (_, None, u)], Sort (Prop Null) when Reductionops.is_conv env !isevars t u -> t | _, _ -> error () - with _ -> error () + with e when Errors.noncritical e -> error () in let measure = interp_casted_constr isevars binders_env measure relargty in let wf_rel, wf_rel_fun, measure_fn = @@ -440,7 +440,7 @@ let interp_recursive fixkind l = let sort = Retyping.get_type_of env !evdref t in let fixprot = try mkApp (delayed_force Subtac_utils.fix_proto, [|sort; t|]) - with e -> t + with e when Errors.noncritical e -> t in (id,None,fixprot) :: env') [] fixnames fixtypes diff --git a/plugins/subtac/subtac_obligations.ml b/plugins/subtac/subtac_obligations.ml index dfcc8526..d8f46098 100644 --- a/plugins/subtac/subtac_obligations.ml +++ b/plugins/subtac/subtac_obligations.ml @@ -121,7 +121,7 @@ let obl_substitution expand obls deps = let xobl = obls.(x) in let oblb = try get_obligation_body expand xobl - with _ -> assert(false) + with e when Errors.noncritical e -> assert(false) in (xobl.obl_name, (xobl.obl_type, oblb)) :: acc) deps [] @@ -498,7 +498,8 @@ let rec solve_obligation prg num tac = let obls = Array.copy obls in let _ = obls.(num) <- obl in let res = try update_obls prg obls (pred rem) - with e -> pperror (Errors.print (Cerrors.process_vernac_interp_error e)) + with e when Errors.noncritical e -> + pperror (Errors.print (Cerrors.process_vernac_interp_error e)) in match res with | Remain n when n > 0 -> @@ -552,7 +553,7 @@ and solve_obligation_by_tac prg obls i tac = | Refiner.FailError (_, s) -> user_err_loc (fst obl.obl_location, "solve_obligation", Lazy.force s) | Util.Anomaly _ as e -> raise e - | e -> false + | e when Errors.noncritical e -> false and solve_prg_obligations prg ?oblset tac = let obls, rem = prg.prg_obligations in diff --git a/plugins/subtac/subtac_pretyping_F.ml b/plugins/subtac/subtac_pretyping_F.ml index 95e756ab..f0579711 100644 --- a/plugins/subtac/subtac_pretyping_F.ml +++ b/plugins/subtac/subtac_pretyping_F.ml @@ -302,7 +302,8 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct make_judge (mkFix ((indexes,i),fixdecls)) ftys.(i) | GCoFix i -> let cofix = (i,(names,ftys,fdefs)) in - (try check_cofix env cofix with e -> Loc.raise loc e); + (try check_cofix env cofix + with e when Errors.noncritical e -> Loc.raise loc e); make_judge (mkCoFix cofix) ftys.(i) in inh_conv_coerce_to_tycon loc env evdref fixj tycon @@ -601,7 +602,8 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct ~split:true ~fail:true env !evdref; evdref := Typeclasses.resolve_typeclasses ~filter:Typeclasses.all_evars ~split:true ~fail:false env !evdref - with e -> if fail_evar then raise e else ()); + with e when Errors.noncritical e -> + if fail_evar then raise e else ()); evdref := consider_remaining_unif_problems env !evdref; let c = if expand_evar then nf_evar !evdref c' else c' in if fail_evar then check_evars env Evd.empty !evdref c; diff --git a/plugins/subtac/subtac_utils.ml b/plugins/subtac/subtac_utils.ml index fbb44811..e32bb9e0 100644 --- a/plugins/subtac/subtac_utils.ml +++ b/plugins/subtac/subtac_utils.ml @@ -232,7 +232,7 @@ let build_dependent_sum l = let hyptype = substl names t in trace (spc () ++ str ("treating evar " ^ string_of_id n)); (try trace (str " assert: " ++ my_print_constr (Global.env ()) hyptype) - with _ -> ()); + with e when Errors.noncritical e -> ()); let tac = assert_tac (Name n) hyptype in let conttac = (fun cont -> @@ -331,7 +331,7 @@ let destruct_ex ext ex = Ind i when i = Term.destInd (delayed_force ex_ind) && Array.length args = 2 -> let (dom, rng) = try (args.(0), args.(1)) - with _ -> assert(false) + with e when Errors.noncritical e -> assert(false) in let pi1 = (mk_ex_pi1 dom rng acc) in let rng_body = @@ -375,9 +375,9 @@ let solve_by_tac evi t = Inductiveops.control_only_guard (Global.env ()) const.Entries.const_entry_body; const.Entries.const_entry_body - with e -> + with reraise -> Pfedit.delete_current_proof(); - raise e + raise reraise (* let apply_tac t goal = t goal *) diff --git a/plugins/xml/cic2acic.ml b/plugins/xml/cic2acic.ml index da0a65ff..a14eda60 100644 --- a/plugins/xml/cic2acic.ml +++ b/plugins/xml/cic2acic.ml @@ -349,7 +349,7 @@ let acic_of_cic_context' computeinnertypes seed ids_to_terms constr_to_ids if computeinnertypes then try Acic.CicHash.find terms_to_types tt -with _ -> +with e when e <> Sys.Break -> (*CSC: Warning: it really happens, for example in Ring_theory!!! *) Pp.ppnl (Pp.(++) (Pp.str "BUG: this subterm was not visited during the double-type-inference: ") (Printer.pr_lconstr tt)) ; assert false else diff --git a/plugins/xml/doubleTypeInference.ml b/plugins/xml/doubleTypeInference.ml index a21a919a..c22c16f0 100644 --- a/plugins/xml/doubleTypeInference.ml +++ b/plugins/xml/doubleTypeInference.ml @@ -147,7 +147,8 @@ let double_type_of env sigma cstr expectedty subterms_to_types = (*CSC: universes. *) (try Typeops.judge_of_type u - with _ -> (* Successor of a non universe-variable universe anomaly *) + with e when e <> Sys.Break -> + (* Successor of a non universe-variable universe anomaly *) (Pp.ppnl (Pp.str "Warning: universe refresh performed!!!") ; flush stdout ) ; Typeops.judge_of_type (Termops.new_univ ()) ) diff --git a/plugins/xml/xmlcommand.ml b/plugins/xml/xmlcommand.ml index 1037bbf0..867aac71 100644 --- a/plugins/xml/xmlcommand.ml +++ b/plugins/xml/xmlcommand.ml @@ -143,7 +143,7 @@ let rec join_dirs cwd = | he::tail -> (try Unix.mkdir cwd 0o775 - with _ -> () (* Let's ignore the errors on mkdir *) + with e when e <> Sys.Break -> () (* Let's ignore the errors on mkdir *) ) ; let newcwd = cwd ^ "/" ^ he in join_dirs newcwd tail diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index bdf94e0d..86f96c7c 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -126,7 +126,7 @@ module Default = struct jres), jres.uj_type) (hj,typ_cl) p) - with _ -> anomaly "apply_coercion" + with e when Errors.noncritical e -> anomaly "apply_coercion" let inh_app_fun env evd j = let t = whd_betadeltaiota env evd j.uj_type in diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index a74e4cb4..0166b64c 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -272,7 +272,7 @@ let is_nondep_branch c n = try let sign,ccl = decompose_lam_n_assum n c in noccur_between 1 (rel_context_length sign) ccl - with _ -> (* Not eta-expanded or not reduced *) + with e when Errors.noncritical e -> (* Not eta-expanded or not reduced *) false let extract_nondep_branches test c b n = @@ -386,7 +386,7 @@ let rec detype (isgoal:bool) avoid env t = | Var id -> (try let _ = Global.lookup_named id in GRef (dl, VarRef id) - with _ -> + with e when Errors.noncritical e -> GVar (dl, id)) | Sort s -> GSort (dl,detype_sort s) | Cast (c1,REVERTcast,c2) when not !Flags.raw_print -> @@ -492,7 +492,7 @@ and detype_eqns isgoal avoid env ci computable constructs consnargsl bl = let mat = build_tree Anonymous isgoal (avoid,env) ci bl in List.map (fun (pat,((avoid,env),c)) -> (dl,[],[pat],detype isgoal avoid env c)) mat - with _ -> + with e when Errors.noncritical e -> Array.to_list (array_map3 (detype_eqn isgoal avoid env) constructs consnargsl bl) diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 14f35941..0eed1949 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -454,7 +454,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) else Evd.set_leq_sort evd s1 s2 in (evd', true) with Univ.UniverseInconsistency _ -> (evd, false) - | _ -> (evd, false)) + | e when Errors.noncritical e -> (evd, false)) | Prod (n,c1,c'1), Prod (_,c2,c'2) when l1=[] & l2=[] -> ise_and evd @@ -730,12 +730,14 @@ let apply_conversion_problem_heuristic ts env evd pbty t1 t2 = let (term2,l2 as appr2) = decompose_app t2 in match kind_of_term term1, kind_of_term term2 with | Evar (evk1,args1), (Rel _|Var _) when l1 = [] & l2 = [] - & array_for_all (fun a -> eq_constr a term2 or isEvar a) args1 -> + & List.for_all (fun a -> eq_constr a term2 or isEvar a) + (remove_instance_local_defs evd evk1 (Array.to_list args1)) -> (* The typical kind of constraint coming from pattern-matching return type inference *) choose_less_dependent_instance evk1 evd term2 args1 | (Rel _|Var _), Evar (evk2,args2) when l1 = [] & l2 = [] - & array_for_all (fun a -> eq_constr a term1 or isEvar a) args2 -> + & List.for_all (fun a -> eq_constr a term1 or isEvar a) + (remove_instance_local_defs evd evk2 (Array.to_list args2)) -> (* The typical kind of constraint coming from pattern-matching return type inference *) choose_less_dependent_instance evk2 evd term1 args2 diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml index b0248a84..fc29ba6c 100644 --- a/pretyping/evarutil.ml +++ b/pretyping/evarutil.ml @@ -1194,10 +1194,9 @@ let filter_candidates evd evk filter candidates = let closure_of_filter evd evk filter = let evi = Evd.find_undefined evd evk in - let vars = collect_vars (evar_concl evi) in - let ids = List.map pi1 (evar_context evi) in - let test id b = b || Idset.mem id vars in - let newfilter = List.map2 test ids filter in + let vars = collect_vars (nf_evar evd (evar_concl evi)) in + let test (id,c,_) b = b || Idset.mem id vars || c <> None in + let newfilter = List.map2 test (evar_context evi) filter in if newfilter = evar_filter evi then None else Some newfilter let restrict_hyps evd evk filter candidates = @@ -1352,9 +1351,14 @@ let rec is_constrainable_in k (ev,(fv_rels,fv_ids) as g) t = let f,args = decompose_app_vect t in match kind_of_term f with | Construct (ind,_) -> - let nparams = (fst (Global.lookup_inductive ind)).Declarations.mind_nparams in - let params,_ = array_chop nparams args in - array_for_all (is_constrainable_in k g) params + let nparams = + (fst (Global.lookup_inductive ind)).Declarations.mind_nparams + in + if nparams > Array.length args + then true (* We don't try to be more clever *) + else + let params,_ = array_chop nparams args in + array_for_all (is_constrainable_in k g) params | Ind _ -> array_for_all (is_constrainable_in k g) args | Prod (_,t1,t2) -> is_constrainable_in k g t1 && is_constrainable_in k g t2 | Evar (ev',_) -> ev' <> ev (*If ev' needed, one may also try to restrict it*) @@ -1442,7 +1446,7 @@ let check_evar_instance evd evk1 body conv_algo = (* FIXME: The body might be ill-typed when this is called from w_merge *) let ty = try Retyping.get_type_of evenv evd body - with _ -> error "Ill-typed evar instance" + with e when Errors.noncritical e -> error "Ill-typed evar instance" in let evd,b = conv_algo evenv evd Reduction.CUMUL ty evi.evar_concl in if b then evd else @@ -1492,7 +1496,10 @@ let solve_candidates conv_algo env evd (evk,argsv as ev) rhs = (filter_compatible_candidates conv_algo env evd evi args rhs) l in match l' with | [] -> error_cannot_unify env evd (mkEvar ev, rhs) - | [c,evd] -> Evd.define evk c evd + | [c,evd] -> + (* solve_candidates might have been called recursively in the mean *) + (* time and the evar been solved by the filtering process *) + if Evd.is_undefined evd evk then Evd.define evk c evd else evd | l when List.length l < List.length l' -> let candidates = List.map fst l in restrict_evar evd evk None (Some candidates) @@ -1643,7 +1650,7 @@ let rec invert_definition conv_algo choose env evd (evk,argsv as ev) rhs = map_constr_with_full_binders (fun d (env,k) -> push_rel d env, k+1) imitate envk t in t::l - with _ -> l in + with e when Errors.noncritical e -> l in (match candidates with | [x] -> x | _ -> diff --git a/pretyping/evarutil.mli b/pretyping/evarutil.mli index 2b326fd1..591a008c 100644 --- a/pretyping/evarutil.mli +++ b/pretyping/evarutil.mli @@ -230,3 +230,4 @@ val generalize_evar_over_rels : evar_map -> existential -> types * constr list val check_evar_instance : evar_map -> existential_key -> constr -> conv_fun -> evar_map +val remove_instance_local_defs : evar_map -> existential_key -> constr list -> constr list diff --git a/pretyping/evd.ml b/pretyping/evd.ml index 6d5c98ce..4d9eb897 100644 --- a/pretyping/evd.ml +++ b/pretyping/evd.ml @@ -67,9 +67,12 @@ let evar_hyps evi = evi.evar_hyps let evar_context evi = named_context_of_val evi.evar_hyps let evar_body evi = evi.evar_body let evar_filter evi = evi.evar_filter -let evar_unfiltered_env evi = Global.env_of_context evi.evar_hyps let evar_filtered_context evi = snd (list_filter2 (fun b c -> b) (evar_filter evi,evar_context evi)) +let evar_filtered_hyps evi = + List.fold_right push_named_context_val (evar_filtered_context evi) + empty_named_context_val +let evar_unfiltered_env evi = Global.env_of_context evi.evar_hyps let evar_env evi = List.fold_right push_named (evar_filtered_context evi) (reset_context (Global.env())) diff --git a/pretyping/evd.mli b/pretyping/evd.mli index 4813d3b9..dbaf803b 100644 --- a/pretyping/evd.mli +++ b/pretyping/evd.mli @@ -127,6 +127,7 @@ val evar_concl : evar_info -> constr val evar_context : evar_info -> named_context val evar_filtered_context : evar_info -> named_context val evar_hyps : evar_info -> named_context_val +val evar_filtered_hyps : evar_info -> named_context_val val evar_body : evar_info -> evar_body val evar_filter : evar_info -> bool list val evar_unfiltered_env : evar_info -> env diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index bb0a0e92..bdccc57b 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -290,6 +290,7 @@ let find_rectype env sigma c = match kind_of_term t with | Ind ind -> let (mib,mip) = Inductive.lookup_mind_specif env ind in + if mib.mind_nparams > List.length l then raise Not_found; let (par,rargs) = list_chop mib.mind_nparams l in IndType((ind, par),rargs) | _ -> raise Not_found diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index d8678371..1dd71fab 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -69,8 +69,9 @@ let search_guard loc env possible_indexes fixdefs = if List.for_all (fun l->1=List.length l) possible_indexes then let indexes = Array.of_list (List.map List.hd possible_indexes) in let fix = ((indexes, 0),fixdefs) in - (try check_fix env fix with - | e -> if loc = dummy_loc then raise e else Loc.raise loc e); + (try check_fix env fix + with e when Errors.noncritical e -> + if loc = dummy_loc then raise e else Loc.raise loc e); indexes else (* we now search recursively amoungst all combinations *) @@ -109,7 +110,8 @@ let resolve_evars env evdref fail_evar resolve_classes = (* Resolve eagerly, potentially making wrong choices *) evdref := (try consider_remaining_unif_problems ~ts:(Typeclasses.classes_transparent_state ()) env !evdref - with e -> if fail_evar then raise e else !evdref) + with e when Errors.noncritical e -> + if fail_evar then raise e else !evdref) let solve_remaining_evars fail_evar use_classes hook env initial_sigma (evd,c) = let evdref = ref evd in @@ -441,7 +443,8 @@ module Pretyping_F (Coercion : Coercion.S) = struct make_judge (mkFix ((indexes,i),fixdecls)) ftys.(i) | GCoFix i -> let cofix = (i,(names,ftys,fdefs)) in - (try check_cofix env cofix with e -> Loc.raise loc e); + (try check_cofix env cofix + with e when Errors.noncritical e -> Loc.raise loc e); make_judge (mkCoFix cofix) ftys.(i) in inh_conv_coerce_to_tycon loc env evdref fixj tycon diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index 0f04549f..434fe80c 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -207,16 +207,16 @@ let cs_pattern_of_constr t = match kind_of_term t with App (f,vargs) -> begin - try Const_cs (global_of_constr f) , -1, Array.to_list vargs with - _ -> raise Not_found + try Const_cs (global_of_constr f) , -1, Array.to_list vargs + with e when Errors.noncritical e -> raise Not_found end | Rel n -> Default_cs, pred n, [] | Prod (_,a,b) when not (Termops.dependent (mkRel 1) b) -> Prod_cs, -1, [a; Termops.pop b] | Sort s -> Sort_cs (family_of_sort s), -1, [] | _ -> begin - try Const_cs (global_of_constr t) , -1, [] with - _ -> raise Not_found + try Const_cs (global_of_constr t) , -1, [] + with e when Errors.noncritical e -> raise Not_found end (* Intended to always succeed *) diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index fddc7fc7..993ad46b 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -924,7 +924,10 @@ let meta_reducible_instance evd b = let u = whd_betaiota Evd.empty u in match kind_of_term u with | Case (ci,p,c,bl) when isMeta c or isCast c & isMeta (pi1 (destCast c)) -> - let m = try destMeta c with _ -> destMeta (pi1 (destCast c)) in + let m = + try destMeta c + with e when Errors.noncritical e -> destMeta (pi1 (destCast c)) + in (match try let g,s = List.assoc m metas in @@ -934,7 +937,10 @@ let meta_reducible_instance evd b = | Some g -> irec (mkCase (ci,p,g,bl)) | None -> mkCase (ci,irec p,c,Array.map irec bl)) | App (f,l) when isMeta f or isCast f & isMeta (pi1 (destCast f)) -> - let m = try destMeta f with _ -> destMeta (pi1 (destCast f)) in + let m = + try destMeta f + with e when Errors.noncritical e -> destMeta (pi1 (destCast f)) + in (match try let g,s = List.assoc m metas in diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index f16eed6c..3b679fce 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -30,12 +30,12 @@ let rec subst_type env sigma typ = function (* et sinon on substitue *) let sort_of_atomic_type env sigma ft args = - let rec concl_of_arity env ar = - match kind_of_term (whd_betadeltaiota env sigma ar) with - | Prod (na, t, b) -> concl_of_arity (push_rel (na,None,t) env) b - | Sort s -> s - | _ -> decomp_sort env sigma (subst_type env sigma ft (Array.to_list args)) - in concl_of_arity env ft + let rec concl_of_arity env ar args = + match kind_of_term (whd_betadeltaiota env sigma ar), args with + | Prod (na, t, b), h::l -> concl_of_arity (push_rel (na,Some h,t) env) b l + | Sort s, [] -> s + | _ -> anomaly "Not a sort" + in concl_of_arity env ft (Array.to_list args) let type_of_var env id = try let (_,_,ty) = lookup_named id env in ty diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index b43b9adb..78b239c0 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -125,12 +125,12 @@ type constant_evaluation = (* We use a cache registered as a global table *) -let eval_table = ref Cmap.empty +let eval_table = ref Cmap_env.empty -type frozen = (int * constant_evaluation) Cmap.t +type frozen = (int * constant_evaluation) Cmap_env.t let init () = - eval_table := Cmap.empty + eval_table := Cmap_env.empty let freeze () = !eval_table @@ -291,10 +291,10 @@ let compute_consteval sigma env ref = let reference_eval sigma env = function | EvalConst cst as ref -> (try - Cmap.find cst !eval_table + Cmap_env.find cst !eval_table with Not_found -> begin let v = compute_consteval sigma env ref in - eval_table := Cmap.add cst v !eval_table; + eval_table := Cmap_env.add cst v !eval_table; v end) | ref -> compute_consteval sigma env ref diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index b78850d3..0344ebcc 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -118,7 +118,7 @@ let _ = let class_info c = try Gmap.find c !classes - with _ -> not_a_class (Global.env()) (constr_of_global c) + with Not_found -> not_a_class (Global.env()) (constr_of_global c) let global_class_of_constr env c = try class_info (global_of_constr c) @@ -132,7 +132,9 @@ let dest_class_arity env c = let rels, c = Term.decompose_prod_assum c in rels, dest_class_app env c -let class_of_constr c = try Some (dest_class_arity (Global.env ()) c) with _ -> None +let class_of_constr c = + try Some (dest_class_arity (Global.env ()) c) + with e when Errors.noncritical e -> None let rec is_class_type evd c = match kind_of_term c with @@ -215,7 +217,7 @@ let rebuild_class cl = try let cst = Tacred.evaluable_of_global_reference (Global.env ()) cl.cl_impl in set_typeclass_transparency cst false false; cl - with _ -> cl + with e when Errors.noncritical e -> cl let class_input : typeclass -> obj = declare_object @@ -238,7 +240,7 @@ let check_instance env sigma c = let (evd, c) = resolve_one_typeclass env sigma (Retyping.get_type_of env sigma c) in Evd.is_empty (Evd.undefined_evars evd) - with _ -> false + with e when Errors.noncritical e -> false let build_subclasses ~check env sigma glob pri = let rec aux pri c = diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 63cdb378..df5eff6a 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -430,8 +430,9 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag then Evd.set_leq_sort sigma s1 s2 else Evd.set_eq_sort sigma s1 s2 in (sigma', metasubst, evarsubst) - with _ -> error_cannot_unify curenv sigma (m,n)) - + with e when Errors.noncritical e -> + error_cannot_unify curenv sigma (m,n)) + | Lambda (na,t1,c1), Lambda (_,t2,c2) -> unirec_rec (push (na,t1) curenvnb) CONV true wt (unirec_rec curenvnb CONV true false substn t1 t2) c1 c2 @@ -708,10 +709,12 @@ let merge_instances env sigma flags st1 st2 c1 c2 = else (right, st2, res) | (IsSuperType,IsSubType) -> (try (left, IsSubType, unify_0 env sigma CUMUL flags c2 c1) - with _ -> (right, IsSubType, unify_0 env sigma CUMUL flags c1 c2)) + with e when Errors.noncritical e -> + (right, IsSubType, unify_0 env sigma CUMUL flags c1 c2)) | (IsSubType,IsSuperType) -> (try (left, IsSuperType, unify_0 env sigma CUMUL flags c1 c2) - with _ -> (right, IsSuperType, unify_0 env sigma CUMUL flags c2 c1)) + with e when Errors.noncritical e -> + (right, IsSuperType, unify_0 env sigma CUMUL flags c2 c1)) (* Unification * @@ -913,7 +916,7 @@ let w_merge env with_types flags (evd,metas,evars) = let rec process_eqns failures = function | (mv,status,c)::eqns -> (match (try Inl (unify_type env evd flags mv status c) - with e -> Inr e) + with e when Errors.noncritical e -> Inr e) with | Inr e -> process_eqns (((mv,status,c),e)::failures) eqns | Inl (evd,metas,evars) -> diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index 00efa981..3966146d 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -44,7 +44,7 @@ let invert_tag cst tag reloc_tbl = let find_rectype_a env c = let (t, l) = let t = whd_betadeltaiota env c in - try destApp t with _ -> (t,[||]) in + try destApp t with e when Errors.noncritical e -> (t,[||]) in match kind_of_term t with | Ind ind -> (ind, l) | _ -> raise Not_found @@ -176,7 +176,10 @@ and nf_stk env c t stk = nf_stk env (mkApp(c,args)) t stk | Zfix (f,vargs) :: stk -> let fa, typ = nf_fix_app env f vargs in - let _,_,codom = try decompose_prod env typ with _ -> exit 120 in + let _,_,codom = + try decompose_prod env typ + with e when Errors.noncritical e -> exit 120 + in nf_stk env (mkApp(fa,[|c|])) (subst1 c codom) stk | Zswitch sw :: stk -> let (mind,_ as ind),allargs = find_rectype_a env t in @@ -206,7 +209,10 @@ and nf_predicate env ind mip params v pT = | Vfun f, Prod _ -> let k = nb_rel env in let vb = body_of_vfun k f in - let name,dom,codom = try decompose_prod env pT with _ -> exit 121 in + let name,dom,codom = + try decompose_prod env pT + with e when Errors.noncritical e -> exit 121 + in let dep,body = nf_predicate (push_rel (name,None,dom) env) ind mip params vb codom in dep, mkLambda(name,dom,body) @@ -228,7 +234,10 @@ and nf_args env vargs t = let args = Array.init len (fun i -> - let _,dom,codom = try decompose_prod env !t with _ -> exit 123 in + let _,dom,codom = + try decompose_prod env !t + with e when Errors.noncritical e -> exit 123 + in let c = nf_val env (arg vargs i) dom in t := subst1 c codom; c) in !t,args @@ -239,7 +248,10 @@ and nf_bargs env b t = let args = Array.init len (fun i -> - let _,dom,codom = try decompose_prod env !t with _ -> exit 124 in + let _,dom,codom = + try decompose_prod env !t + with e when Errors.noncritical e -> exit 124 + in let c = nf_val env (bfield b i) dom in t := subst1 c codom; c) in args @@ -249,7 +261,7 @@ and nf_fun env f typ = let vb = body_of_vfun k f in let name,dom,codom = try decompose_prod env typ - with _ -> + with e when Errors.noncritical e -> raise (Type_errors.TypeError(env,Type_errors.ReferenceVariables typ)) in let body = nf_val (push_rel (name,None,dom) env) vb codom in diff --git a/proofs/evar_refiner.ml b/proofs/evar_refiner.ml index 4462062c..f271a6bd 100644 --- a/proofs/evar_refiner.ml +++ b/proofs/evar_refiner.ml @@ -42,7 +42,7 @@ let w_refine (evk,evi) (ltac_var,rawc) sigma = let sigma',typed_c = try Pretyping.Default.understand_ltac ~resolve_classes:true true sigma env ltac_var (Pretyping.OfType (Some evi.evar_concl)) rawc - with _ -> + with e when Errors.noncritical e -> let loc = Glob_term.loc_of_glob_constr rawc in user_err_loc (loc,"",Pp.str ("Instance is not well-typed in the environment of " ^ diff --git a/proofs/goal.ml b/proofs/goal.ml index dc1ac5dd..37ebce67 100644 --- a/proofs/goal.ml +++ b/proofs/goal.ml @@ -276,7 +276,7 @@ let check_typability env sigma c = let recheck_typability (what,id) env sigma t = try check_typability env sigma t - with _ -> + with e when Errors.noncritical e -> let s = match what with | None -> "the conclusion" | Some id -> "hypothesis "^(Names.string_of_id id) in @@ -474,7 +474,7 @@ module V82 = struct (* Old style hyps primitive *) let hyps evars gl = let evi = content evars gl in - evi.Evd.evar_hyps + Evd.evar_filtered_hyps evi (* Access to ".evar_concl" *) let concl evars gl = @@ -554,10 +554,16 @@ module V82 = struct with a good implementation of them. *) - (* Used for congruence closure *) - let new_goal_with sigma gl new_hyps = + (* Used for congruence closure and change *) + let new_goal_with sigma gl extra_hyps = let evi = content sigma gl in - let new_evi = { evi with Evd.evar_hyps = new_hyps } in + let hyps = evi.Evd.evar_hyps in + let new_hyps = + List.fold_right Environ.push_named_context_val extra_hyps hyps in + let extra_filter = List.map (fun _ -> true) extra_hyps in + let new_filter = extra_filter @ evi.Evd.evar_filter in + let new_evi = + { evi with Evd.evar_hyps = new_hyps; Evd.evar_filter = new_filter } in let new_evi = Typeclasses.mark_unresolvable new_evi in let evk = Evarutil.new_untyped_evar () in let new_sigma = Evd.add Evd.empty evk new_evi in diff --git a/proofs/goal.mli b/proofs/goal.mli index 9cd439ab..c0a094d3 100644 --- a/proofs/goal.mli +++ b/proofs/goal.mli @@ -232,7 +232,7 @@ module V82 : sig val same_goal : Evd.evar_map -> goal -> Evd.evar_map -> goal -> bool (* Used for congruence closure *) - val new_goal_with : Evd.evar_map -> goal -> Environ.named_context_val -> goal Evd.sigma + val new_goal_with : Evd.evar_map -> goal -> Sign.named_context -> goal Evd.sigma (* Used by the compatibility layer and typeclasses *) val nf_evar : Evd.evar_map -> goal -> goal * Evd.evar_map diff --git a/proofs/logic.ml b/proofs/logic.ml index d240c1e1..497ab1fa 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -105,7 +105,7 @@ let clear_hyps sigma ids sign cl = let recheck_typability (what,id) env sigma t = try check_typability env sigma t - with _ -> + with e when Errors.noncritical e -> let s = match what with | None -> "the conclusion" | Some id -> "hypothesis "^(string_of_id id) in diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 45e4a84e..7bac87d2 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -68,7 +68,7 @@ let start_proof id str hyps c ?init_tac ?compute_guard hook = | None -> Proofview.tclUNIT () in try Proof_global.run_tactic tac - with e -> Proof_global.discard_current (); raise e + with reraise -> Proof_global.discard_current (); raise reraise let restart_proof () = undo_todepth 1 @@ -164,9 +164,9 @@ let build_constant_by_tactic id sign typ tac = let _,(const,_,_,_) = cook_proof (fun _ -> ()) in delete_current_proof (); const - with e -> + with reraise -> delete_current_proof (); - raise e + raise reraise let build_by_tactic env typ tac = let id = id_of_string ("temporary_proof"^string_of_int (next())) in diff --git a/proofs/proof.ml b/proofs/proof.ml index a4e556c5..012a4dc1 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -323,7 +323,7 @@ let rec rollback pr = let transaction pr t = init_transaction pr; try t (); commit pr - with e -> rollback pr; raise e + with reraise -> rollback pr; raise reraise (* Focus command (focuses on the [i]th subgoal) *) @@ -429,9 +429,9 @@ let run_tactic env tac pr = let tacticced_proofview = Proofview.apply env tac sp in pr.state <- { pr.state with proofview = tacticced_proofview }; push_undo starting_point pr - with e -> + with reraise -> restore_state starting_point pr; - raise e + raise reraise (*** Commands ***) @@ -476,7 +476,7 @@ module V82 = struct let new_proofview = Proofview.V82.instantiate_evar n com sp in pr.state <- { pr.state with proofview = new_proofview }; push_undo starting_point pr - with e -> + with reraise -> restore_state starting_point pr; - raise e + raise reraise end diff --git a/proofs/proofview.ml b/proofs/proofview.ml index 74e40e3b..d299a520 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -320,10 +320,12 @@ let rec tclDISPATCHGEN null join tacs env = { go = fun sk fk step -> (* takes a tactic which can raise exception and makes it pure by *failing* on with these exceptions. Does not catch anomalies. *) let purify t = - let t' env = { go = fun sk fk step -> try (t env).go (fun x -> sk (Util.Inl x)) fk step - with Util.Anomaly _ as e -> raise e - | e -> sk (Util.Inr e) fk step - } + let t' env = + { go = fun sk fk step -> + try (t env).go (fun x -> sk (Util.Inl x)) fk step + with Util.Anomaly _ as e -> raise e + | e when Errors.noncritical e -> sk (Util.Inr e) fk step + } in tclBIND t' begin function | Util.Inl x -> tclUNIT x diff --git a/proofs/refiner.ml b/proofs/refiner.ml index 37c63644..21b43212 100644 --- a/proofs/refiner.ml +++ b/proofs/refiner.ml @@ -255,7 +255,7 @@ let tclORELSE0 t1 t2 g = try t1 g with (* Breakpoint *) - | e -> catch_failerror e; t2 g + | e when Errors.noncritical e -> catch_failerror e; t2 g (* ORELSE t1 t2 tries to apply t1 and if it fails or does not progress, then applies t2 *) @@ -267,7 +267,7 @@ let tclORELSE t1 t2 = tclORELSE0 (tclPROGRESS t1) t2 let tclORELSE_THEN t1 t2then t2else gls = match try Some(tclPROGRESS t1 gls) - with e -> catch_failerror e; None + with e when Errors.noncritical e -> catch_failerror e; None with | None -> t2else gls | Some sgl -> @@ -298,7 +298,7 @@ let ite_gen tcal tac_if continue tac_else gl= try tcal tac_if0 continue gl with (* Breakpoint *) - | e -> catch_failerror e; tac_else0 e gl + | e when Errors.noncritical e -> catch_failerror e; tac_else0 e gl (* Try the first tactic and, if it succeeds, continue with the second one, and if it fails, use the third one *) @@ -352,7 +352,7 @@ let tclTIMEOUT n t g = | TacTimeout | Loc.Exc_located(_,TacTimeout) -> restore_timeout (); errorlabstrm "Refiner.tclTIMEOUT" (str"Timeout!") - | e -> restore_timeout (); raise e + | reraise -> restore_timeout (); raise reraise (* Beware: call by need of CAML, g is needed *) let rec tclREPEAT t g = diff --git a/proofs/tactic_debug.ml b/proofs/tactic_debug.ml index b56cb844..27ab990c 100644 --- a/proofs/tactic_debug.ml +++ b/proofs/tactic_debug.ml @@ -140,11 +140,11 @@ let debug_prompt lev g tac f = else (decr skip; run false; if !skip=0 then skipped:=0; DebugOn (lev+1)) in (* What to execute *) try f newlevel - with e -> + with reraise -> skip:=0; skipped:=0; - if Logic.catchable_exception e then - ppnl (str "Level " ++ int lev ++ str ": " ++ !explain_logic_error e); - raise e + if Logic.catchable_exception reraise then + ppnl (str "Level " ++ int lev ++ str ": " ++ !explain_logic_error reraise); + raise reraise (* Prints a constr *) let db_constr debug env c = diff --git a/scripts/coqmktop.ml b/scripts/coqmktop.ml index 5bc77457..b75984e3 100644 --- a/scripts/coqmktop.ml +++ b/scripts/coqmktop.ml @@ -45,8 +45,7 @@ let camlp4topobjs = [ "Camlp4Top.cmo"; "Camlp4Parsers/Camlp4OCamlRevisedParser.cmo"; "Camlp4Parsers/Camlp4OCamlParser.cmo"; - "Camlp4Parsers/Camlp4GrammarParser.cmo"; - "q_util.cmo"; "q_coqast.cmo" ] + "Camlp4Parsers/Camlp4GrammarParser.cmo" ] let topobjs = camlp4topobjs let gramobjs = [] @@ -257,8 +256,8 @@ let create_tmp_main_file modules = output_string oc "Coqtop.start();;\n"; close_out oc; main_name - with e -> - clean main_name; raise e + with reraise -> + clean main_name; raise reraise (* main part *) let main () = @@ -311,10 +310,10 @@ let main () = clean main_file; (* command gives the exit code in HSB, and signal in LSB !!! *) if retcode > 255 then retcode lsr 8 else retcode - with e -> - clean main_file; raise e + with reraise -> + clean main_file; raise reraise let retcode = - try Printexc.print main () with _ -> 1 + try Printexc.print main () with any -> 1 let _ = exit retcode diff --git a/tactics/auto.ml b/tactics/auto.ml index f7d63dcd..44fea151 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -829,7 +829,8 @@ let prepare_hint env (sigma,c) = let path_of_constr_expr c = match c with - | Topconstr.CRef r -> (try PathHints [global r] with _ -> PathAny) + | Topconstr.CRef r -> + (try PathHints [global r] with e when Errors.noncritical e -> PathAny) | _ -> PathAny let interp_hints h = @@ -1170,9 +1171,9 @@ let tclLOG (dbg,depth,trace) pp tac = let out = tac gl in msg_debug (str s ++ spc () ++ pp () ++ str ". (*success*)"); out - with e -> + with reraise -> msg_debug (str s ++ spc () ++ pp () ++ str ". (*fail*)"); - raise e + raise reraise end | Info -> (* For "info (trivial/auto)", we store a log trace *) @@ -1181,9 +1182,9 @@ let tclLOG (dbg,depth,trace) pp tac = let out = tac gl in trace := (depth, Some pp) :: !trace; out - with e -> + with reraise -> trace := (depth, None) :: !trace; - raise e + raise reraise end (** For info, from the linear trace information, we reconstitute the part diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index 039f022d..8e1d7cbf 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -208,8 +208,14 @@ let auto_multi_rewrite_with ?(conds=Naive) tac_main lbas cl gl = (* Functions necessary to the library object declaration *) let cache_hintrewrite (_,(rbase,lrl)) = - let base = try find_base rbase with _ -> HintDN.empty in - let max = try fst (Util.list_last (HintDN.find_all base)) with _ -> 0 in + let base = + try find_base rbase + with e when Errors.noncritical e -> HintDN.empty + in + let max = + try fst (Util.list_last (HintDN.find_all base)) + with e when Errors.noncritical e -> 0 + in let lrl = HintDN.map (fun (i,h) -> (i + max, h)) lrl in rewtab:=Stringmap.add rbase (HintDN.union lrl base) !rewtab @@ -248,7 +254,7 @@ let evd_convertible env evd x y = try ignore(Unification.w_unify ~flags:Unification.elim_flags env evd Reduction.CONV x y); true (* try ignore(Evarconv.the_conv_x env x y evd); true *) - with _ -> false + with e when Errors.noncritical e -> false let decompose_applied_relation metas env sigma c ctype left2right = let find_rel ty = diff --git a/tactics/class_tactics.ml4 b/tactics/class_tactics.ml4 index cf4a267f..d05ae680 100644 --- a/tactics/class_tactics.ml4 +++ b/tactics/class_tactics.ml4 @@ -685,7 +685,7 @@ let resolve_typeclass_evars debug m env evd filter split fail = let evd = try Evarconv.consider_remaining_unif_problems ~ts:(Typeclasses.classes_transparent_state ()) env evd - with _ -> evd + with e when Errors.noncritical e -> evd in resolve_all_evars debug m env (initial_select_evars filter) evd split fail @@ -776,7 +776,10 @@ END let typeclasses_eauto ?(only_classes=false) ?(st=full_transparent_state) dbs gl = try - let dbs = list_map_filter (fun db -> try Some (Auto.searchtable_map db) with _ -> None) dbs in + let dbs = list_map_filter + (fun db -> try Some (Auto.searchtable_map db) + with e when Errors.noncritical e -> None) dbs + in let st = match dbs with x :: _ -> Hint_db.transparent_state x | _ -> st in eauto ?limit:!typeclasses_depth ~only_classes ~st dbs gl with Not_found -> tclFAIL 0 (str" typeclasses eauto failed on: " ++ Printer.pr_goal gl) gl diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4 index 68dd5dba..6981a733 100644 --- a/tactics/eauto.ml4 +++ b/tactics/eauto.ml4 @@ -205,7 +205,8 @@ module SearchProblem = struct (* let gl = Proof_trees.db_pr_goal (List.hd (sig_it glls)) in *) (* msg (hov 1 (pptac ++ str" gives: \n" ++ pr_goals lgls ++ str"\n")); *) (lgls,pptac) :: aux tacl - with e -> Refiner.catch_failerror e; aux tacl + with e when Errors.noncritical e -> + Refiner.catch_failerror e; aux tacl in aux l (* Ordering of states is lexicographic on depth (greatest first) then diff --git a/tactics/equality.ml b/tactics/equality.ml index a352355b..1c5e4b2f 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -334,7 +334,8 @@ let general_rewrite_ebindings_clause cls lft2rgt occs frzevars dep_proof_ok ?tac try rewrite_side_tac (!general_rewrite_clause cls lft2rgt occs (c,l) ~new_goals:[]) tac gl - with e -> (* Try to see if there's an equality hidden *) + with e when Errors.noncritical e -> + (* Try to see if there's an equality hidden *) let env' = push_rel_context rels env in let rels',t' = splay_prod_assum env' sigma t in (* Search for underlying eq *) match match_with_equality_type t' with @@ -1156,7 +1157,7 @@ let injEq ipats (eq,_,(t,t1,t2) as u) eq_clause = ] (* not a dep eq or no decidable type found *) ) else (raise Not_dep_pair) - ) with _ -> + ) with e when Errors.noncritical e -> inject_at_positions env sigma u eq_clause posns (fun _ -> intros_pattern no_move ipats) diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index f5fcb736..f6ecb47c 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -606,7 +606,7 @@ let hResolve_auto id c t gl = hResolve id c n t gl with | UserError _ as e -> raise e - | _ -> resolve_auto (n+1) + | e when Errors.noncritical e -> resolve_auto (n+1) in resolve_auto 1 diff --git a/tactics/hipattern.ml4 b/tactics/hipattern.ml4 index 47e3b7ca..c6f32ce2 100644 --- a/tactics/hipattern.ml4 +++ b/tactics/hipattern.ml4 @@ -64,9 +64,12 @@ let is_non_recursive_type t = op2bool (match_with_non_recursive_type t) (* Test dependencies *) +(* NB: we consider also the let-in case in the following function, + since they may appear in types of inductive constructors (see #2629) *) + let rec has_nodep_prod_after n c = match kind_of_term c with - | Prod (_,_,b) -> + | Prod (_,_,b) | LetIn (_,_,_,b) -> ( n>0 || not (dependent (mkRel 1) b)) && (has_nodep_prod_after (n-1) b) | _ -> true @@ -355,7 +358,10 @@ let coq_jmeq_pattern = lazy PATTERN [ %coq_jmeq_ref ?X1 ?X2 ?X3 ?X4 ] let coq_eq_true_pattern = lazy PATTERN [ %coq_eq_true_ref ?X1 ] let match_eq eqn eq_pat = - let pat = try Lazy.force eq_pat with _ -> raise PatternMatchingFailure in + let pat = + try Lazy.force eq_pat + with e when Errors.noncritical e -> raise PatternMatchingFailure + in match matches pat eqn with | [(m1,t);(m2,x);(m3,y)] -> assert (m1 = meta1 & m2 = meta2 & m3 = meta3); diff --git a/tactics/inv.ml b/tactics/inv.ml index b7f6addc..e4b3bdb1 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -497,7 +497,7 @@ let wrap_inv_error id = function (* The most general inversion tactic *) let inversion inv_kind status names id gls = try (raw_inversion inv_kind id status names) gls - with e -> wrap_inv_error id e + with e when Errors.noncritical e -> wrap_inv_error id e (* Specializing it... *) @@ -540,7 +540,7 @@ let invIn k names ids id gls = inversion (false,k) NoDep names id; intros_replace_ids]) gls - with e -> wrap_inv_error id e + with e when Errors.noncritical e -> wrap_inv_error id e let invIn_gen k names idl = try_intros_until (invIn k names idl) diff --git a/tactics/rewrite.ml4 b/tactics/rewrite.ml4 index b90a911a..98885af8 100644 --- a/tactics/rewrite.ml4 +++ b/tactics/rewrite.ml4 @@ -121,7 +121,7 @@ let is_applied_rewrite_relation env sigma rels t = let inst = mkApp (Lazy.force rewrite_relation_class, [| evar; mkApp (c, params) |]) in let _ = Typeclasses.resolve_one_typeclass env' evd inst in Some (it_mkProd_or_LetIn t rels) - with _ -> None) + with e when Errors.noncritical e -> None) | _ -> None let _ = @@ -145,11 +145,14 @@ let build_signature evars env m (cstrs : (types * types option) option list) new_cstr_evar evars env (* ~src:(dummy_loc, ImplicitArg (ConstRef (Lazy.force respectful), (n, Some na))) *) t in - let mk_relty evars env ty obj = + let mk_relty evars newenv ty obj = match obj with | None | Some (_, None) -> let relty = mk_relation ty in - new_evar evars env relty + if closed0 ty then + let env' = Environ.reset_with_named_context (Environ.named_context_val env) env in + new_evar evars env' relty + else new_evar evars newenv relty | Some (x, Some rel) -> evars, rel in let rec aux env evars ty l = @@ -227,7 +230,7 @@ let cstrevars evars = snd evars let evd_convertible env evd x y = try ignore(Evarconv.the_conv_x env x y evd); true - with _ -> false + with e when Errors.noncritical e -> false let rec decompose_app_rel env evd t = match kind_of_term t with @@ -493,7 +496,7 @@ let rec apply_pointwise rel = function | [] -> rel let pointwise_or_dep_relation n t car rel = - if noccurn 1 car then + if noccurn 1 car && noccurn 1 rel then mkApp (Lazy.force pointwise_relation, [| t; lift (-1) car; lift (-1) rel |]) else mkApp (Lazy.force forall_relation, @@ -1048,7 +1051,8 @@ module Strategies = let sigma, c = Constrintern.interp_open_constr (goalevars evars) env c in let unfolded = try Tacred.try_red_product env sigma c - with _ -> error "fold: the term is not unfoldable !" + with e when Errors.noncritical e -> + error "fold: the term is not unfoldable !" in try let sigma = Unification.w_unify env sigma CONV ~flags:Unification.elim_flags unfolded t in @@ -1056,7 +1060,7 @@ module Strategies = Some (Some { rew_car = ty; rew_from = t; rew_to = c'; rew_prf = RewCast DEFAULTcast; rew_evars = sigma, cstrevars evars }) - with _ -> None + with e when Errors.noncritical e -> None let fold_glob c : strategy = fun env avoid t ty cstr evars -> @@ -1064,7 +1068,8 @@ module Strategies = let sigma, c = Pretyping.Default.understand_tcc (goalevars evars) env c in let unfolded = try Tacred.try_red_product env sigma c - with _ -> error "fold: the term is not unfoldable !" + with e when Errors.noncritical e -> + error "fold: the term is not unfoldable !" in try let sigma = Unification.w_unify env sigma CONV ~flags:Unification.elim_flags unfolded t in @@ -1072,7 +1077,7 @@ module Strategies = Some (Some { rew_car = ty; rew_from = t; rew_to = c'; rew_prf = RewCast DEFAULTcast; rew_evars = sigma, cstrevars evars }) - with _ -> None + with e when Errors.noncritical e -> None end @@ -1977,7 +1982,7 @@ let setoid_proof gl ty fn fallback = let evm = project gl in let car = pi3 (List.hd (fst (Reduction.dest_prod env (Typing.type_of env evm rel)))) in fn env evm car rel gl - with e -> + with e when Errors.noncritical e -> try fallback gl with Hipattern.NoEquationFound -> match e with diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 3ff0cf93..7479ee9a 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -50,7 +50,7 @@ open Compat open Evd let safe_msgnl s = - try msgnl s with e -> + try msgnl s with e when Errors.noncritical e -> msgnl (str "bug in the debugger: " ++ str "an exception is raised while printing debug information") @@ -92,7 +92,7 @@ let catch_error call_trace tac g = if call_trace = [] then tac g else try tac g with | LtacLocated _ as e -> raise e | Loc.Exc_located (_,LtacLocated _) as e -> raise e - | e -> + | e when Errors.noncritical e -> let (nrep,loc',c),tail = list_sep_last call_trace in let loc,e' = match e with Loc.Exc_located(loc,e) -> loc,e | _ ->dloc,e in if tail = [] then @@ -569,13 +569,13 @@ let dump_glob_red_expr = function try Dumpglob.add_glob (loc_of_or_by_notation Libnames.loc_of_reference r) (Smartlocate.smart_global r) - with _ -> ()) occs + with e when Errors.noncritical e -> ()) occs | Cbv grf | Lazy grf -> List.iter (fun r -> try Dumpglob.add_glob (loc_of_or_by_notation Libnames.loc_of_reference r) (Smartlocate.smart_global r) - with _ -> ()) grf.rConst + with e when Errors.noncritical e -> ()) grf.rConst | _ -> () let intern_red_expr ist = function @@ -1412,19 +1412,20 @@ let interp_may_eval f ist gl = function | ConstrTerm c -> try f ist gl c - with e -> - debugging_exception_step ist false e (fun () -> + with reraise -> + debugging_exception_step ist false reraise (fun () -> str"interpretation of term " ++ pr_glob_constr_env (pf_env gl) (fst c)); - raise e + raise reraise (* Interprets a constr expression possibly to first evaluate *) let interp_constr_may_eval ist gl c = let (sigma,csr) = try interp_may_eval pf_interp_constr ist gl c - with e -> - debugging_exception_step ist false e (fun () -> str"evaluation of term"); - raise e + with reraise -> + debugging_exception_step ist false reraise (fun () -> + str"evaluation of term"); + raise reraise in begin db_constr ist.debug (pf_env gl) csr; @@ -1762,10 +1763,7 @@ let mk_int_or_var_value ist c = VInteger (interp_int_or_var ist c) let pack_sigma (sigma,c) = {it=c;sigma=sigma} let extend_gl_hyps { it=gl ; sigma=sigma } sign = - let hyps = Goal.V82.hyps sigma gl in - let new_hyps = List.fold_right Environ.push_named_context_val sign hyps in - (* spiwack: (2010/01/13) if a bug was reintroduced in [change] in is probably here *) - Goal.V82.new_goal_with sigma gl new_hyps + Goal.V82.new_goal_with sigma gl sign (* Interprets an l-tac expression into a value *) let rec val_interp ist gl (tac:glob_tactic_expr) = @@ -1925,9 +1923,11 @@ and interp_app loc ist gl fv largs = try catch_error trace (val_interp {ist with lfun=newlfun@olfun; trace=trace} gl) body - with e -> - debugging_exception_step ist false e (fun () -> str "evaluation"); - raise e in + with reraise -> + debugging_exception_step ist false reraise + (fun () -> str "evaluation"); + raise reraise + in let gl = { gl with sigma=sigma } in debugging_step ist (fun () -> @@ -2212,19 +2212,20 @@ and interp_match ist g lz constr lmr = (try let lmatch = try extended_matches c csr - with e -> - debugging_exception_step ist false e (fun () -> + with reraise -> + debugging_exception_step ist false reraise (fun () -> str "matching with pattern" ++ fnl () ++ pr_constr_pattern_env (pf_env g) c); - raise e in + raise reraise + in try let lfun = extend_values_with_bindings lmatch ist.lfun in eval_with_fail { ist with lfun=lfun } lz g mt - with e -> - debugging_exception_step ist false e (fun () -> + with reraise -> + debugging_exception_step ist false reraise (fun () -> str "rule body for pattern" ++ pr_constr_pattern_env (pf_env g) c); - raise e + raise reraise with e when is_match_catchable e -> debugging_step ist (fun () -> str "switching to the next rule"); apply_match ist sigma csr tl) @@ -2236,15 +2237,16 @@ and interp_match ist g lz constr lmr = errorlabstrm "Tacinterp.apply_match" (str "No matching clauses for match.") in let (sigma,csr) = - try interp_ltac_constr ist g constr with e -> - debugging_exception_step ist true e + try interp_ltac_constr ist g constr with reraise -> + debugging_exception_step ist true reraise (fun () -> str "evaluation of the matched expression"); - raise e in + raise reraise in let ilr = read_match_rule (fst (extract_ltac_constr_values ist (pf_env g))) ist (pf_env g) sigma lmr in let res = - try apply_match ist sigma csr ilr with e -> - debugging_exception_step ist true e (fun () -> str "match expression"); - raise e in + try apply_match ist sigma csr ilr with reraise -> + debugging_exception_step ist true reraise + (fun () -> str "match expression"); + raise reraise in debugging_step ist (fun () -> str "match expression returns " ++ pr_value (Some (pf_env g)) (snd res)); res @@ -2404,6 +2406,7 @@ and interp_atomic ist gl tac = (h_generalize_dep c_interp) | TacLetTac (na,c,clp,b,eqpat) -> let clp = interp_clause ist gl clp in + let eqpat = Option.map (interp_intro_pattern ist gl) eqpat in if clp = nowhere then (* We try to fully-typecheck the term *) let (sigma,c_interp) = pf_interp_constr ist gl c in @@ -3180,7 +3183,8 @@ let globTacticIn t = TacArg (dloc,TacDynamic (dloc,tactic_in t)) let tacticIn t = globTacticIn (fun ist -> try glob_tactic (t ist) - with e -> anomalylabstrm "tacticIn" + with e when Errors.noncritical e -> + anomalylabstrm "tacticIn" (str "Incorrect tactic expression. Received exception is:" ++ Errors.print e)) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 12292196..ac00a73d 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1018,7 +1018,7 @@ let apply_in_once_main flags innerclause (d,lbind) gl = let thm = nf_betaiota gl.sigma (pf_type_of gl d) in let rec aux clause = try progress_with_clause flags innerclause clause - with err -> + with err when Errors.noncritical err -> try aux (clenv_push_prod clause) with NotExtensibleClause -> raise err in aux (make_clenv_binding gl (d,thm) lbind) @@ -1708,7 +1708,7 @@ let make_pattern_test env sigma0 (sigma,c) = let flags = default_matching_flags sigma0 in let matching_fun t = try let sigma = w_unify env sigma Reduction.CONV ~flags c t in Some(sigma,t) - with _ -> raise NotUnifiable in + with e when Errors.noncritical e -> raise NotUnifiable in let merge_fun c1 c2 = match c1, c2 with | Some (_,c1), Some (_,c2) when not (is_fconv Reduction.CONV env sigma0 c1 c2) -> @@ -2554,7 +2554,10 @@ let specialize_eqs id gl = let specialize_eqs id gl = - if try ignore(clear [id] gl); false with _ -> true then + if + (try ignore(clear [id] gl); false + with e when Errors.noncritical e -> true) + then tclFAIL 0 (str "Specialization not allowed on dependent hypotheses") gl else specialize_eqs id gl @@ -2716,7 +2719,8 @@ let compute_elim_sig ?elimc elimt = | Some ( _,None,ind) -> let indhd,indargs = decompose_app ind in try {!res with indref = Some (global_of_constr indhd) } - with _ -> error "Cannot find the inductive type of the inductive scheme.";; + with e when Errors.noncritical e -> + error "Cannot find the inductive type of the inductive scheme.";; let compute_scheme_signature scheme names_info ind_type_guess = let f,l = decompose_app scheme.concl in @@ -3551,4 +3555,5 @@ let unify ?(state=full_transparent_state) x y gl = in let evd = w_unify (pf_env gl) (project gl) Reduction.CONV ~flags x y in tclEVARS evd gl - with _ -> tclFAIL 0 (str"Not unifiable") gl + with e when Errors.noncritical e -> + tclFAIL 0 (str"Not unifiable") gl diff --git a/test-suite/bugs/closed/2955.v b/test-suite/bugs/closed/2955.v new file mode 100644 index 00000000..45e24b5f --- /dev/null +++ b/test-suite/bugs/closed/2955.v @@ -0,0 +1,52 @@ +Require Import Coq.Arith.Arith. + +Module A. + + Fixpoint foo (n:nat) := + match n with + | 0 => 0 + | S n => bar n + end + + with bar (n:nat) := + match n with + | 0 => 0 + | S n => foo n + end. + + Lemma using_foo: + forall (n:nat), foo n = 0 /\ bar n = 0. + Proof. + induction n ; split ; auto ; + destruct IHn ; auto. + Qed. + +End A. + + +Module B. + + Module A := A. + Import A. + +End B. + +Module E. + + Module B := B. + Import B.A. + + (* Bug 1 *) + Lemma test_1: + forall (n:nat), foo n = 0. + Proof. + intros ; destruct n. + reflexivity. + specialize (A.using_foo (S n)) ; intros. + simpl in H. + simpl. + destruct H. + assumption. + Qed. + +End E. \ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/2629.v b/test-suite/bugs/closed/shouldsucceed/2629.v new file mode 100644 index 00000000..759cd3dd --- /dev/null +++ b/test-suite/bugs/closed/shouldsucceed/2629.v @@ -0,0 +1,22 @@ +Class Join (t: Type) : Type := mkJoin {join: t -> t -> t -> Prop}. + +Class sepalg (t: Type) {JOIN: Join t} : Type := + SepAlg { + join_eq: forall {x y z z'}, join x y z -> join x y z' -> z = z'; + join_assoc: forall {a b c d e}, join a b d -> join d c e -> + {f : t & join b c f /\ join a f e}; + join_com: forall {a b c}, join a b c -> join b a c; + join_canc: forall {a1 a2 b c}, join a1 b c -> join a2 b c -> a1=a2; + + unit_for : t -> t -> Prop := fun e a => join e a a; + join_ex_units: forall a, {e : t & unit_for e a} +}. + +Definition joins {A} `{Join A} (a b : A) : Prop := + exists c, join a b c. + +Lemma join_joins {A} `{sepalg A}: forall {a b c}, + join a b c -> joins a b. +Proof. + firstorder. +Qed. diff --git a/test-suite/bugs/closed/shouldsucceed/2668.v b/test-suite/bugs/closed/shouldsucceed/2668.v new file mode 100644 index 00000000..74c8fa34 --- /dev/null +++ b/test-suite/bugs/closed/shouldsucceed/2668.v @@ -0,0 +1,6 @@ +Require Import MSetPositive. +Require Import MSetProperties. + +Module Pos := MSetPositive.PositiveSet. +Module PPPP := MSetProperties.WPropertiesOn(Pos). +Print Module PPPP. \ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/2734.v b/test-suite/bugs/closed/shouldsucceed/2734.v new file mode 100644 index 00000000..826361be --- /dev/null +++ b/test-suite/bugs/closed/shouldsucceed/2734.v @@ -0,0 +1,15 @@ +Require Import Arith List. +Require Import OrderedTypeEx. + +Module Adr. + Include Nat_as_OT. + Definition nat2t (i: nat) : t := i. +End Adr. + +Inductive expr := Const: Adr.t -> expr. + +Inductive control := Go: expr -> control. + +Definition program := (Adr.t * (control))%type. + +Fail Definition myprog : program := (Adr.nat2t 0, Go (Adr.nat2t 0) ). \ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/2750.v b/test-suite/bugs/closed/shouldsucceed/2750.v new file mode 100644 index 00000000..fc580f10 --- /dev/null +++ b/test-suite/bugs/closed/shouldsucceed/2750.v @@ -0,0 +1,23 @@ + +Module Type ModWithRecord. + + Record foo : Type := + { A : nat + ; B : nat + }. +End ModWithRecord. + +Module Test_ModWithRecord (M : ModWithRecord). + + Definition test1 : M.foo := + {| M.A := 0 + ; M.B := 2 + |}. + + Module B := M. + + Definition test2 : M.foo := + {| M.A := 0 + ; M.B := 2 + |}. +End Test_ModWithRecord. \ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/2928.v b/test-suite/bugs/closed/shouldsucceed/2928.v new file mode 100644 index 00000000..21e92ae2 --- /dev/null +++ b/test-suite/bugs/closed/shouldsucceed/2928.v @@ -0,0 +1,11 @@ +Class Equiv A := equiv: A -> A -> Prop. +Infix "=" := equiv : type_scope. + +Class Associative {A} f `{Equiv A} := associativity x y z : f x (f y z) = f (f x y) z. + +Class SemiGroup A op `{Equiv A} := { sg_ass :>> Associative op }. + +Class SemiLattice A op `{Equiv A} := + { semilattice_sg :>> SemiGroup A op + ; redundant : Associative op + }. diff --git a/test-suite/bugs/closed/shouldsucceed/2983.v b/test-suite/bugs/closed/shouldsucceed/2983.v new file mode 100644 index 00000000..15598352 --- /dev/null +++ b/test-suite/bugs/closed/shouldsucceed/2983.v @@ -0,0 +1,8 @@ +Module Type ModA. +End ModA. +Module Type ModB(A : ModA). +End ModB. +Module Foo(A : ModA)(B : ModB A). +End Foo. + +Print Module Foo. \ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/2995.v b/test-suite/bugs/closed/shouldsucceed/2995.v new file mode 100644 index 00000000..ba3acd08 --- /dev/null +++ b/test-suite/bugs/closed/shouldsucceed/2995.v @@ -0,0 +1,9 @@ +Module Type Interface. + Parameter error: nat. +End Interface. + +Module Implementation <: Interface. + Definition t := bool. + Definition error: t := false. +Fail End Implementation. +(* A UserError here is expected, not an uncaught Not_found *) \ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/3000.v b/test-suite/bugs/closed/shouldsucceed/3000.v new file mode 100644 index 00000000..27de34ed --- /dev/null +++ b/test-suite/bugs/closed/shouldsucceed/3000.v @@ -0,0 +1,2 @@ +Inductive t (t':Type) : Type := A | B. +Definition d := match t with _ => 1 end. (* used to fail on list_chop *) diff --git a/test-suite/bugs/closed/shouldsucceed/3004.v b/test-suite/bugs/closed/shouldsucceed/3004.v new file mode 100644 index 00000000..896b1958 --- /dev/null +++ b/test-suite/bugs/closed/shouldsucceed/3004.v @@ -0,0 +1,7 @@ +Set Implicit Arguments. +Unset Strict Implicit. +Parameter (M : nat -> Type). +Parameter (mp : forall (T1 T2 : Type) (f : T1 -> T2), list T1 -> list T2). + +Definition foo (s : list {n : nat & M n}) := + let exT := existT in mp (fun x => projT1 x) s. diff --git a/test-suite/bugs/closed/shouldsucceed/3008.v b/test-suite/bugs/closed/shouldsucceed/3008.v new file mode 100644 index 00000000..3f3a979a --- /dev/null +++ b/test-suite/bugs/closed/shouldsucceed/3008.v @@ -0,0 +1,29 @@ +Module Type Intf1. +Parameter T : Type. +Inductive a := A. +End Intf1. + +Module Impl1 <: Intf1. +Definition T := unit. +Inductive a := A. +End Impl1. + +Module Type Intf2 + (Impl1 : Intf1). +Parameter x : Impl1.A=Impl1.A -> Impl1.T. +End Intf2. + +Module Type Intf3 + (Impl1 : Intf1) + (Impl2 : Intf2(Impl1)). +End Intf3. + +Fail Module Toto + (Impl1' : Intf1) + (Impl2 : Intf2(Impl1')) + (Impl3 : Intf3(Impl1)(Impl2)). +(* A UserError is expected here, not an uncaught Not_found *) + +(* NB : the Inductive above and the A=A weren't in the initial test, + they are here only to force an access to the environment + (cf [Printer.qualid_of_global]) and check that this env is ok. *) \ No newline at end of file diff --git a/test-suite/output/inference.out b/test-suite/output/inference.out index bca3b361..4f8de1dc 100644 --- a/test-suite/output/inference.out +++ b/test-suite/output/inference.out @@ -4,3 +4,7 @@ fun e : option L => match e with | None => None end : option L -> option L +fun n : nat => let x := A n in ?12 ?15:T n + : forall n : nat, T n +fun n : nat => ?20 ?23:T n + : forall n : nat, T n diff --git a/test-suite/output/inference.v b/test-suite/output/inference.v index 968ea71a..2b564f48 100644 --- a/test-suite/output/inference.v +++ b/test-suite/output/inference.v @@ -12,3 +12,15 @@ Definition P (e:option L) := end. Print P. + +(* Check that the heuristic to solve constraints is not artificially + dependent on the presence of a let-in, and in particular that the + second [_] below is not inferred to be n, as if obtained by + first-order unification with [T n] of the conclusion [T _] of the + type of the first [_]. *) + +(* Note: exact numbers of evars are not important... *) + +Inductive T (n:nat) : Type := A : T n. +Check fun n (x:=A n:T n) => _ _ : T n. +Check fun n => _ _ : T n. diff --git a/test-suite/success/remember.v b/test-suite/success/remember.v index 5f8ed03d..0befe054 100644 --- a/test-suite/success/remember.v +++ b/test-suite/success/remember.v @@ -6,3 +6,11 @@ Fail remember nat as X. Fail remember nat as X in H. (* This line used to succeed in 8.3 *) Fail remember nat as X. Abort. + +(* Testing Ltac interpretation of remember (was not working up to r16181) *) + +Goal (1 + 2 + 3 = 6). +let name := fresh "fresh" in +remember (1 + 2) as x eqn:name. +rewrite fresh. +Abort. diff --git a/theories/Numbers/NatInt/NZOrder.v b/theories/Numbers/NatInt/NZOrder.v index 5582438b..3dae9c70 100644 --- a/theories/Numbers/NatInt/NZOrder.v +++ b/theories/Numbers/NatInt/NZOrder.v @@ -646,4 +646,4 @@ End NZOrderProp. Module NZOrderedType (NZ : NZDecOrdSig') <: DecidableTypeFull <: OrderedTypeFull - := NZ <+ NZBaseProp <+ NZOrderProp <+ Compare2EqBool <+ HasEqBool2Dec. + := NZ <+ NZBaseProp <+ NZOrderProp NZ <+ Compare2EqBool <+ HasEqBool2Dec. diff --git a/toplevel/auto_ind_decl.ml b/toplevel/auto_ind_decl.ml index 3690b924..b9ab68ec 100644 --- a/toplevel/auto_ind_decl.ml +++ b/toplevel/auto_ind_decl.ml @@ -111,7 +111,7 @@ let mkFullInd ind n = let check_bool_is_defined () = try let _ = Global.type_of_global Coqlib.glob_bool in () - with _ -> raise (UndefinedCst "bool") + with e when Errors.noncritical e -> raise (UndefinedCst "bool") let beq_scheme_kind_aux = ref (fun _ -> failwith "Undefined") @@ -304,8 +304,9 @@ let destruct_ind c = try let u,v = destApp c in let indc = destInd u in indc,v - with _-> let indc = destInd c in - indc,[||] + with e when Errors.noncritical e -> + let indc = destInd c in + indc,[||] (* In the following, avoid is the list of names to avoid. @@ -329,8 +330,9 @@ let do_replace_lb lb_scheme_key aavoid narg gls p q = else error ("Var "^(string_of_id s)^" seems unknown.") ) in mkVar (find 1) - with _ -> (* if this happen then the args have to be already declared as a - Parameter*) + with e when Errors.noncritical e -> + (* if this happen then the args have to be already declared as a + Parameter*) ( let mp,dir,lbl = repr_con (destConst v) in mkConst (make_con mp dir (mk_label ( @@ -376,8 +378,9 @@ let do_replace_bl bl_scheme_key ind gls aavoid narg lft rgt = else error ("Var "^(string_of_id s)^" seems unknown.") ) in mkVar (find 1) - with _ -> (* if this happen then the args have to be already declared as a - Parameter*) + with e when Errors.noncritical e -> + (* if this happen then the args have to be already declared as a + Parameter*) ( let mp,dir,lbl = repr_con (destConst v) in mkConst (make_con mp dir (mk_label ( @@ -394,7 +397,7 @@ let do_replace_bl bl_scheme_key ind gls aavoid narg lft rgt = else ( let u,v = try destruct_ind tt1 (* trick so that the good sequence is returned*) - with _ -> ind,[||] + with e when Errors.noncritical e -> ind,[||] in if u = ind then (Equality.replace t1 t2)::(Auto.default_auto)::(aux q1 q2) else ( @@ -427,17 +430,19 @@ let do_replace_bl bl_scheme_key ind gls aavoid narg lft rgt = | ([],[]) -> [] | _ -> error "Both side of the equality must have the same arity." in - let (ind1,ca1) = try destApp lft with - _ -> error "replace failed." - and (ind2,ca2) = try destApp rgt with - _ -> error "replace failed." + let (ind1,ca1) = + try destApp lft with e when Errors.noncritical e -> error "replace failed." + and (ind2,ca2) = + try destApp rgt with e when Errors.noncritical e -> error "replace failed." in - let (sp1,i1) = try destInd ind1 with - _ -> (try fst (destConstruct ind1) with _ -> - error "The expected type is an inductive one.") - and (sp2,i2) = try destInd ind2 with - _ -> (try fst (destConstruct ind2) with _ -> - error "The expected type is an inductive one.") + let (sp1,i1) = + try destInd ind1 with e when Errors.noncritical e -> + try fst (destConstruct ind1) with e when Errors.noncritical e -> + error "The expected type is an inductive one." + and (sp2,i2) = + try destInd ind2 with e when Errors.noncritical e -> + try fst (destConstruct ind2) with e when Errors.noncritical e -> + error "The expected type is an inductive one." in if (sp1 <> sp2) || (i1 <> i2) then (error "Eq should be on the same type") @@ -714,7 +719,8 @@ let _ = lb_scheme_kind_aux := fun () -> lb_scheme_kind (* Decidable equality *) let check_not_is_defined () = - try ignore (Coqlib.build_coq_not ()) with _ -> raise (UndefinedCst "not") + try ignore (Coqlib.build_coq_not ()) + with e when Errors.noncritical e -> raise (UndefinedCst "not") (* {n=m}+{n<>m} part *) let compute_dec_goal ind lnamesparrec nparrec = diff --git a/toplevel/autoinstance.ml b/toplevel/autoinstance.ml index 10709abc..f43fc505 100644 --- a/toplevel/autoinstance.ml +++ b/toplevel/autoinstance.ml @@ -204,7 +204,8 @@ let declare_class_instance gr ctx params = (ce,Decl_kinds.IsDefinition Decl_kinds.Instance) in Typeclasses.add_instance (Typeclasses.new_instance cl (Some 100) true (ConstRef cst)); new_instance_message ident typ def - with e -> msgnl (str"Error defining instance := "++pr_constr def++str" : "++pr_constr typ++str" "++Errors.print e) + with e when Errors.noncritical e -> + msgnl (str"Error defining instance := "++pr_constr def++str" : "++pr_constr typ++str" "++Errors.print e) let rec iter_under_prod (f:rel_context->constr->unit) (ctx:rel_context) t = f ctx t; match kind_of_term t with diff --git a/toplevel/backtrack.ml b/toplevel/backtrack.ml index 912d694e..f444fc2d 100644 --- a/toplevel/backtrack.ml +++ b/toplevel/backtrack.ml @@ -96,7 +96,9 @@ let mark_command ast = Stack.push { label = Lib.current_command_label (); nproofs = List.length (Pfedit.get_all_proof_names ()); - prfname = (try Some (Pfedit.get_current_proof_name ()) with _ -> None); + prfname = + (try Some (Pfedit.get_current_proof_name ()) + with Proof_global.NoCurrentProof -> None); prfdepth = max 0 (Pfedit.current_proof_depth ()); reachable = true; ngoals = get_ngoals (); diff --git a/toplevel/classes.ml b/toplevel/classes.ml index 6914b8f0..de4d1ab1 100644 --- a/toplevel/classes.ml +++ b/toplevel/classes.ml @@ -37,7 +37,10 @@ let set_typeclass_transparency c local b = let _ = Typeclasses.register_add_instance_hint (fun inst local pri -> - let path = try Auto.PathHints [global_of_constr inst] with _ -> Auto.PathAny in + let path = + try Auto.PathHints [global_of_constr inst] + with e when Errors.noncritical e -> Auto.PathAny + in Flags.silently (fun () -> Auto.add_hints local [typeclasses_db] (Auto.HintsResolveEntry @@ -300,8 +303,10 @@ let context l = let fullctx = Evarutil.nf_rel_context_evar !evars fullctx in let ce t = Evarutil.check_evars env Evd.empty !evars t in List.iter (fun (n, b, t) -> Option.iter ce b; ce t) fullctx; - let ctx = try named_of_rel_context fullctx with _ -> - error "Anonymous variables not allowed in contexts." + let ctx = + try named_of_rel_context fullctx + with e when Errors.noncritical e -> + error "Anonymous variables not allowed in contexts." in let fn (id, _, t) = if Lib.is_modtype () && not (Lib.sections_are_opened ()) then diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml index 66a9516a..8f954573 100644 --- a/toplevel/coqinit.ml +++ b/toplevel/coqinit.ml @@ -46,9 +46,9 @@ let load_rcfile() = mSGNL (str ("No coqrc or coqrc."^Coq_config.version^ " found. Skipping rcfile loading.")) *) - with e -> + with reraise -> (msgnl (str"Load of rcfile failed."); - raise e) + raise reraise) else Flags.if_verbose msgnl (str"Skipping rcfile loading.") diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index df388d1d..adbdb31b 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -24,7 +24,8 @@ let get_version_date () = let ver = input_line ch in let rev = input_line ch in (ver,rev) - with _ -> (Coq_config.version,Coq_config.date) + with e when Errors.noncritical e -> + (Coq_config.version,Coq_config.date) let print_header () = let (ver,rev) = (get_version_date ()) in @@ -310,7 +311,7 @@ let parse_args arglist = with Stream.Failure -> msgnl (Errors.print e); exit 1 end - | e -> begin msgnl (Errors.print e); exit 1 end + | any -> begin msgnl (Errors.print any); exit 1 end let init arglist = Sys.catch_break false; (* Ctrl-C is fatal during the initialisation *) @@ -344,10 +345,10 @@ let init arglist = load_vernacular (); compile_files (); outputstate () - with e -> + with any -> flush_all(); if not !batch_mode then message "Error during initialization:"; - msgnl (Toplevel.print_toplevel_error e); + msgnl (Toplevel.print_toplevel_error any); exit 1 end; if !batch_mode then diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml index e7b5a0f2..f550df16 100644 --- a/toplevel/himsg.ml +++ b/toplevel/himsg.ml @@ -28,6 +28,8 @@ open Logic open Printer open Glob_term open Evd +open Libnames +open Declarations let pr_lconstr c = quote (pr_lconstr c) let pr_lconstr_env e c = quote (pr_lconstr_env e c) @@ -307,7 +309,7 @@ let explain_ill_formed_rec_body env err names i fixenv vdefj = let fixenv = make_all_name_different fixenv in let pvd = pr_lconstr_env fixenv vdefj.(i).uj_val in str"Recursive definition is:" ++ spc () ++ pvd ++ str "." - with _ -> mt ()) + with e when Errors.noncritical e -> mt ()) let explain_ill_typed_rec_body env sigma i names vdefj vargs = let vdefj = jv_nf_evar sigma vdefj in @@ -542,8 +544,11 @@ let explain_not_match_error = function str "types given to " ++ str (string_of_id id) ++ str " differ" | NotConvertibleBodyField -> str "the body of definitions differs" - | NotConvertibleTypeField -> - str "types differ" + | NotConvertibleTypeField (env, typ1, typ2) -> + str "expected type" ++ spc () ++ + quote (Printer.safe_pr_lconstr_env env typ2) ++ spc () ++ + str "but found type" ++ spc () ++ + quote (Printer.safe_pr_lconstr_env env typ1) | NotSameConstructorNamesField -> str "constructor names differ" | NotSameInductiveNameInBlockField -> diff --git a/toplevel/ide_intf.ml b/toplevel/ide_intf.ml index 28f97dc8..6937eeb8 100644 --- a/toplevel/ide_intf.ml +++ b/toplevel/ide_intf.ml @@ -89,8 +89,8 @@ let abstract_eval_call handler c = | Quit -> Obj.magic (handler.quit () : unit) | About -> Obj.magic (handler.about () : coq_info) in Good res - with e -> - let (l, str) = handler.handle_exn e in + with any -> + let (l, str) = handler.handle_exn any in Fail (l,str) (** * XML data marshalling *) @@ -275,7 +275,7 @@ let to_value f = function let loc_s = int_of_string (List.assoc "loc_s" attrs) in let loc_e = int_of_string (List.assoc "loc_e" attrs) in Some (loc_s, loc_e) - with _ -> None + with e when e <> Sys.Break -> None in let msg = raw_string l in Fail (loc, msg) diff --git a/toplevel/ide_slave.ml b/toplevel/ide_slave.ml index d67b272e..6e9a0ee0 100644 --- a/toplevel/ide_slave.ml +++ b/toplevel/ide_slave.ml @@ -237,7 +237,7 @@ let status () = in let proof = try Some (Names.string_of_id (Proof_global.get_current_proof_name ())) - with _ -> None + with Proof_global.NoCurrentProof -> None in let allproofs = let l = Proof_global.get_all_proof_names () in @@ -259,7 +259,8 @@ let search flags = | (Interface.Name_Pattern s, b) :: l -> let regexp = try Str.regexp s - with _ -> Util.error ("Invalid regexp: " ^ s) + with e when Errors.noncritical e -> + Util.error ("Invalid regexp: " ^ s) in extract_flags ((regexp, b) :: name) tpe subtpe mods blacklist l | (Interface.Type_Pattern s, b) :: l -> @@ -454,12 +455,12 @@ let loop () = Xml_utils.print_xml !orig_stdout xml_answer; flush !orig_stdout done - with e -> - let msg = Printexc.to_string e in + with any -> + let msg = Printexc.to_string any in let r = "Fatal exception in coqtop:\n" ^ msg in pr_debug ("==> " ^ r); (try Xml_utils.print_xml !orig_stdout (fail r); flush !orig_stdout - with _ -> ()); + with any -> ()); exit 1 diff --git a/toplevel/ind_tables.ml b/toplevel/ind_tables.ml index 9f1a0218..77cfa6fa 100644 --- a/toplevel/ind_tables.ml +++ b/toplevel/ind_tables.ml @@ -86,8 +86,9 @@ let scheme_object_table = (Hashtbl.create 17 : (string, string * scheme_object_function) Hashtbl.t) let declare_scheme_object s aux f = - (try check_ident ("ind"^s) with _ -> - error ("Illegal induction scheme suffix: "^s)); + (try check_ident ("ind"^s) + with e when Errors.noncritical e -> + error ("Illegal induction scheme suffix: "^s)); let key = if aux = "" then s else aux in try let _ = Hashtbl.find scheme_object_table key in diff --git a/toplevel/indschemes.ml b/toplevel/indschemes.ml index fa6885af..e30404e1 100644 --- a/toplevel/indschemes.ml +++ b/toplevel/indschemes.ml @@ -159,7 +159,7 @@ let try_declare_scheme what f internal names kn = (strbrk "Required constant " ++ str s ++ str " undefined.") | AlreadyDeclared msg -> alarm what internal (msg ++ str ".") - | _ -> + | e when Errors.noncritical e -> alarm what internal (str "Unknown exception during scheme creation.") @@ -245,7 +245,8 @@ let try_declare_eq_decidability kn = let declare_eq_decidability = declare_eq_decidability_scheme_with [] -let ignore_error f x = try ignore (f x) with _ -> () +let ignore_error f x = + try ignore (f x) with e when Errors.noncritical e -> () let declare_rewriting_schemes ind = if Hipattern.is_inductive_equality ind then begin @@ -266,7 +267,7 @@ let declare_congr_scheme ind = if Hipattern.is_equality_type (mkInd ind) then begin if try Coqlib.check_required_library Coqlib.logic_module_name; true - with _ -> false + with e when Errors.noncritical e -> false then ignore (define_individual_scheme congr_scheme_kind KernelVerbose None ind) else diff --git a/toplevel/lemmas.ml b/toplevel/lemmas.ml index d6ab44c6..30f07fed 100644 --- a/toplevel/lemmas.ml +++ b/toplevel/lemmas.ml @@ -229,23 +229,32 @@ let get_proof opacity = id,{const with const_entry_opaque = opacity},do_guard,persistence,hook let save_named opacity = - let id,const,do_guard,persistence,hook = get_proof opacity in - save id const do_guard persistence hook + let p = Proof_global.give_me_the_proof () in + Proof.transaction p begin fun () -> + let id,const,do_guard,persistence,hook = get_proof opacity in + save id const do_guard persistence hook + end let check_anonymity id save_ident = if atompart_of_id id <> string_of_id (default_thm_id) then error "This command can only be used for unnamed theorem." let save_anonymous opacity save_ident = - let id,const,do_guard,persistence,hook = get_proof opacity in - check_anonymity id save_ident; - save save_ident const do_guard persistence hook + let p = Proof_global.give_me_the_proof () in + Proof.transaction p begin fun () -> + let id,const,do_guard,persistence,hook = get_proof opacity in + check_anonymity id save_ident; + save save_ident const do_guard persistence hook + end let save_anonymous_with_strength kind opacity save_ident = - let id,const,do_guard,_,hook = get_proof opacity in - check_anonymity id save_ident; - (* we consider that non opaque behaves as local for discharge *) - save save_ident const do_guard (Global, Proof kind) hook + let p = Proof_global.give_me_the_proof () in + Proof.transaction p begin fun () -> + let id,const,do_guard,_,hook = get_proof opacity in + check_anonymity id save_ident; + (* we consider that non opaque behaves as local for discharge *) + save save_ident const do_guard (Global, Proof kind) hook + end (* Starting a goal *) diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml index 775a3af4..006dc5ec 100644 --- a/toplevel/metasyntax.ml +++ b/toplevel/metasyntax.ml @@ -237,7 +237,7 @@ let parse_format (loc,str) = | _ -> error "Box closed without being opened in format." else error "Empty format." - with e -> + with e when Errors.noncritical e -> Loc.raise loc e (***********************) @@ -277,6 +277,9 @@ let split_notation_string str = let out_nt = function NonTerminal x -> x | _ -> assert false +let msg_expected_form_of_recursive_notation = + "In the notation, the special symbol \"..\" must occur in\na configuration of the form \"x symbs .. symbs y\"." + let rec find_pattern nt xl = function | Break n as x :: l, Break n' :: l' when n=n' -> find_pattern nt (x::xl) (l,l') @@ -289,13 +292,14 @@ let rec find_pattern nt xl = function | _, Break s :: _ | Break s :: _, _ -> error ("A break occurs on one side of \"..\" but not on the other side.") | _, [] -> - error ("The special symbol \"..\" must occur in a configuration of the form\n\"x symbs .. symbs y\".") + error msg_expected_form_of_recursive_notation | ((SProdList _ | NonTerminal _) :: _), _ | _, (SProdList _ :: _) -> anomaly "Only Terminal or Break expected on left, non-SProdList on right" let rec interp_list_parser hd = function | [] -> [], List.rev hd | NonTerminal id :: tl when id = ldots_var -> + if hd = [] then error msg_expected_form_of_recursive_notation; let hd = List.rev hd in let ((x,y,sl),tl') = find_pattern (List.hd hd) [] (List.tl hd,tl) in let xyl,tl'' = interp_list_parser [] tl' in @@ -337,7 +341,8 @@ let rec raw_analyze_notation_tokens = function let is_numeral symbs = match List.filter (function Break _ -> false | _ -> true) symbs with | ([Terminal "-"; Terminal x] | [Terminal x]) -> - (try let _ = Bigint.of_string x in true with _ -> false) + (try let _ = Bigint.of_string x in true + with e when Errors.noncritical e -> false) | _ -> false @@ -995,7 +1000,7 @@ let inNotation : notation_obj -> obj = let with_lib_stk_protection f x = let fs = Lib.freeze () in try let a = f x in Lib.unfreeze fs; a - with e -> Lib.unfreeze fs; raise e + with reraise -> Lib.unfreeze fs; raise reraise let with_syntax_protection f x = with_lib_stk_protection diff --git a/toplevel/mltop.ml4 b/toplevel/mltop.ml4 index 2059ca60..f08308d3 100644 --- a/toplevel/mltop.ml4 +++ b/toplevel/mltop.ml4 @@ -92,8 +92,9 @@ let dir_ml_load s = (try t.load_obj s with | (UserError _ | Failure _ | Anomaly _ | Not_found as u) -> raise u - | _ -> errorlabstrm "Mltop.load_object" (str"Cannot link ml-object " ++ - str s ++ str" to Coq code.")) + | e when Errors.noncritical e -> + errorlabstrm "Mltop.load_object" + (str"Cannot link ml-object " ++ str s ++ str" to Coq code.")) (* TO DO: .cma loading without toplevel *) | WithoutTop -> IFDEF HasDynlink THEN @@ -142,7 +143,7 @@ let add_path ~unix_path:dir ~coq_root:coq_dirpath = let convert_string d = try Names.id_of_string d - with _ -> + with e when Errors.noncritical e -> if_warn msg_warning (str ("Directory "^d^" cannot be used as a Coq identifier (skipped)")); flush_all (); @@ -269,9 +270,9 @@ let if_verbose_load verb f name fname = try f name fname; msgnl (str (info^" done]")); - with e -> + with reraise -> msgnl (str (info^" failed]")); - raise e + raise reraise (** Load a module for the first time (i.e. dynlink it) or simulate its reload (i.e. doing nothing except maybe diff --git a/toplevel/search.ml b/toplevel/search.ml index 3e182689..19d696a1 100644 --- a/toplevel/search.ml +++ b/toplevel/search.ml @@ -137,7 +137,7 @@ let pattern_filter pat _ a c = try try is_matching pat (head c) - with _ -> + with e when Errors.noncritical e -> is_matching pat (head (Typing.type_of (Global.env()) Evd.empty c)) with UserError _ -> diff --git a/toplevel/toplevel.ml b/toplevel/toplevel.ml index d5321623..cc659e36 100644 --- a/toplevel/toplevel.ml +++ b/toplevel/toplevel.ml @@ -180,7 +180,7 @@ let print_location_in_file s inlibrary fname loc = str", line " ++ int line ++ str", characters " ++ Cerrors.print_loc (make_loc (bp-bol,ep-bol))) ++ str":" ++ fnl () - with e -> + with e when Errors.noncritical e -> (close_in ic; hov 1 (errstrm ++ spc() ++ str"(invalid location):") ++ fnl ()) @@ -208,7 +208,7 @@ let valid_buffer_loc ib dloc loc = let make_prompt () = try (Names.string_of_id (Pfedit.get_current_proof_name ())) ^ " < " - with _ -> + with Proof_global.NoCurrentProof -> "Coq < " (*let build_pending_list l = @@ -340,7 +340,7 @@ let process_error = function discard_to_dot (); e with | End_of_input -> End_of_input - | de -> if is_pervasive_exn de then de else e + | any -> if is_pervasive_exn any then any else e (* do_vernac reads and executes a toplevel phrase, and print error messages when an exception is raised, except for the following: @@ -354,8 +354,8 @@ let do_vernac () = begin try raw_do_vernac top_buffer.tokens - with e -> - msgnl (print_toplevel_error (process_error e)) + with any -> + msgnl (print_toplevel_error (process_error any)) end; flush_all() @@ -374,6 +374,6 @@ let rec loop () = | Vernacexpr.Drop -> () | End_of_input -> msgerrnl (mt ()); pp_flush(); exit 0 | Vernacexpr.Quit -> exit 0 - | e -> + | any -> msgerrnl (str"Anomaly. Please report."); loop () diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index 3314e82c..ed8e215f 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -156,7 +156,7 @@ let close_input in_chan (_,verb) = match verb with | Some verb_ch -> close_in verb_ch | _ -> () - with _ -> () + with e when Errors.noncritical e -> () let verbose_phrase verbch loc = let loc = unloc loc in @@ -232,13 +232,13 @@ let rec vernac_com interpfun checknav (loc,com) = Lexer.restore_com_state cs; Pp.comments := cl; Dumpglob.coqdoc_unfreeze cds - with e -> + with reraise -> if !Flags.beautify_file then close_out !chan_beautify; chan_beautify := ch; Lexer.restore_com_state cs; Pp.comments := cl; Dumpglob.coqdoc_unfreeze cds; - raise e + raise reraise end | VernacList l -> List.iter (fun (_,v) -> interp v) l @@ -250,7 +250,7 @@ let rec vernac_com interpfun checknav (loc,com) = (* If the command actually works, ignore its effects on the state *) States.with_state_protection (fun v -> interp v; raise HasNotFailed) v - with e -> match real_error e with + with e when Errors.noncritical e -> match real_error e with | HasNotFailed -> errorlabstrm "Fail" (str "The command has not failed !") | e -> @@ -278,16 +278,16 @@ let rec vernac_com interpfun checknav (loc,com) = States.with_heavy_rollback interpfun Cerrors.process_vernac_interp_error v; restore_timeout psh - with e -> restore_timeout psh; raise e + with reraise -> restore_timeout psh; raise reraise in try checknav loc com; current_timeout := !default_timeout; if do_beautify () then pr_new_syntax loc (Some com); interp com - with e -> + with any -> Format.set_formatter_out_channel stdout; - raise (DuringCommandInterp (loc, e)) + raise (DuringCommandInterp (loc, any)) and read_vernac_file verbosely s = Flags.make_warn verbosely; @@ -316,13 +316,13 @@ and read_vernac_file verbosely s = end_inner_command (snd loc_ast); pp_flush () done - with e -> (* whatever the exception *) + with reraise -> (* whatever the exception *) Format.set_formatter_out_channel stdout; close_input in_chan input; (* we must close the file first *) - match real_error e with + match real_error reraise with | End_of_input -> if do_beautify () then pr_new_syntax (make_loc (max_int,max_int)) None - | _ -> raise_with_file fname e + | _ -> raise_with_file fname reraise (** [eval_expr : ?preserving:bool -> Pp.loc * Vernacexpr.vernac_expr -> unit] It executes one vernacular command. By default the command is @@ -359,9 +359,9 @@ let load_vernac verb file = Lib.mark_end_of_command (); (* in case we're still in coqtop init *) read_vernac_file verb file; if !Flags.beautify_file then close_out !chan_beautify; - with e -> + with reraise -> if !Flags.beautify_file then close_out !chan_beautify; - raise_with_file file e + raise_with_file file reraise (* Compile a vernac file (f is assumed without .v suffix) *) let compile verbosely f = diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 6618b695..75efe139 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -295,7 +295,7 @@ let dump_universes_gen g s = close (); msgnl (str ("Universes written to file \""^s^"\".")) with - e -> close (); raise e + reraise -> close (); raise reraise let dump_universes sorted s = let g = Global.universes () in @@ -331,7 +331,7 @@ let msg_notfound_library loc qid = function let print_located_library r = let (loc,qid) = qualid_of_reference r in try msg_found_library (Library.locate_qualified_library false qid) - with e -> msg_notfound_library loc qid e + with e when Errors.noncritical e -> msg_notfound_library loc qid e let print_located_module r = let (loc,qid) = qualid_of_reference r in @@ -364,7 +364,7 @@ let dump_global r = try let gr = Smartlocate.smart_global r in Dumpglob.add_glob (Genarg.loc_of_or_by_notation loc_of_reference r) gr - with _ -> () + with e when Errors.noncritical e -> () (**********) (* Syntax *) @@ -388,6 +388,7 @@ let vernac_notation = Metasyntax.add_notation (* Gallina *) let start_proof_and_print k l hook = + check_locality (); (* early check, cf #2975 *) start_proof_com k l hook; print_subgoals (); if !pcoq <> None then (Option.get !pcoq).start_proof () @@ -910,7 +911,9 @@ let vernac_declare_arguments local r l nargs flags = | None -> None | Some (o, k) -> try Some(ignore(Notation.find_scope k); k) - with _ -> Some (Notation.find_delimiters_scope o k)) scopes in + with e when Errors.noncritical e -> + Some (Notation.find_delimiters_scope o k)) scopes + in let some_scopes_specified = List.exists ((<>) None) scopes in let rargs = Util.list_map_filter (function (n, true) -> Some n | _ -> None) @@ -1417,7 +1420,7 @@ let vernac_reset_name id = let gr = Smartlocate.global_with_alias (Ident id) in Dumpglob.add_glob (fst id) gr; true - with _ -> false in + with e when Errors.noncritical e -> false in if not globalized then begin try begin match Lib.find_opening_node (snd id) with diff --git a/toplevel/vernacinterp.ml b/toplevel/vernacinterp.ml index c4cc4ae5..a1b76d3d 100644 --- a/toplevel/vernacinterp.ml +++ b/toplevel/vernacinterp.ml @@ -60,7 +60,7 @@ let call (opn,converted_args) = hunk() with | Drop -> raise Drop - | e -> + | reraise -> if !Flags.debug then msgnl (str"Vernac Interpreter " ++ str !loc); - raise e + raise reraise -- cgit v1.2.3