diff options
180 files changed, 2317 insertions, 1600 deletions
diff --git a/Makefile.build b/Makefile.build index fc58166164..bc89d6b999 100644 --- a/Makefile.build +++ b/Makefile.build @@ -132,10 +132,11 @@ SYSMOD:=str unix dynlink threads SYSCMA:=$(addsuffix .cma,$(SYSMOD)) SYSCMXA:=$(addsuffix .cmxa,$(SYSMOD)) +# We do not repeat the dependencies already in SYSMOD here ifeq ($(CAMLP4),camlp5) -P4CMA:=gramlib.cma str.cma +P4CMA:=gramlib.cma else -P4CMA:=dynlink.cma camlp4lib.cma str.cma +P4CMA:=camlp4lib.cma endif @@ -294,9 +295,10 @@ checker/check.cmxa: | md5chk checker/check.mllib.d # Csdp to micromega special targets ########################################################################### -plugins/micromega/csdpcert$(EXE): $(CSDPCERTCMO:.cmo=$(BESTOBJ)) +plugins/micromega/csdpcert$(EXE): $(CSDPCERTCMO:.cmo=$(BESTOBJ)) \ + $(addsuffix $(BESTLIB), lib/clib) $(SHOW)'OCAMLBEST -o $@' - $(HIDE)$(call bestocaml,,nums unix) + $(HIDE)$(call bestocaml,,nums unix clib) ########################################################################### # CoqIde special targets diff --git a/checker/check.mllib b/checker/check.mllib index a029b0245c..3725989e87 100644 --- a/checker/check.mllib +++ b/checker/check.mllib @@ -18,6 +18,8 @@ Flags Control Pp_control Loc +CList +CString Serialize Stateid Feedback @@ -26,8 +28,6 @@ Segmenttree Unicodetable Unicode CObj -CList -CString CArray CStack Util diff --git a/checker/checker.ml b/checker/checker.ml index d5d9b9e3b8..da93685f98 100644 --- a/checker/checker.ml +++ b/checker/checker.ml @@ -217,12 +217,6 @@ open Type_errors let anomaly_string () = str "Anomaly: " let report () = (str "." ++ spc () ++ str "Please report.") -let print_loc loc = - if loc = Loc.ghost then - (str"<unknown>") - else - let loc = Loc.unloc loc in - (int (fst loc) ++ str"-" ++ int (snd loc)) let guill s = str "\"" ++ str s ++ str "\"" let where s = @@ -337,8 +331,6 @@ let parse_args argv = | ("-I"|"-include") :: d :: rem -> set_default_include d; parse rem | ("-I"|"-include") :: [] -> usage () - | "-R" :: d :: "-as" :: p :: rem -> set_rec_include d p;parse rem - | "-R" :: d :: "-as" :: [] -> usage () | "-R" :: d :: p :: rem -> set_rec_include d p;parse rem | "-R" :: ([] | [_]) -> usage () diff --git a/checker/safe_typing.ml b/checker/safe_typing.ml index 81a3cc035b..ee33051676 100644 --- a/checker/safe_typing.ml +++ b/checker/safe_typing.ml @@ -13,6 +13,8 @@ open Cic open Names open Environ +let pr_dirpath dp = str (DirPath.to_string dp) + (************************************************************************) (* * Global environment @@ -52,9 +54,9 @@ let check_engagement env (expected_impredicative_set,expected_type_in_type) = let report_clash f caller dir = let msg = - str "compiled library " ++ str(DirPath.to_string caller) ++ + str "compiled library " ++ pr_dirpath caller ++ spc() ++ str "makes inconsistent assumptions over library" ++ spc() ++ - str(DirPath.to_string dir) ++ fnl() in + pr_dirpath dir ++ fnl() in f msg diff --git a/checker/univ.mli b/checker/univ.mli index 02c1bbdb91..f3216feac4 100644 --- a/checker/univ.mli +++ b/checker/univ.mli @@ -130,7 +130,7 @@ val check_constraints : constraints -> universes -> bool (** {6 Support for universe polymorphism } *) (** Polymorphic maps from universe levels to 'a *) -module LMap : Map.S with type key = universe_level +module LMap : CSig.MapS with type key = universe_level module LSet : CSig.SetS with type elt = universe_level type 'a universe_map = 'a LMap.t diff --git a/dev/printers.mllib b/dev/printers.mllib index b498c2659d..7f9da4eabf 100644 --- a/dev/printers.mllib +++ b/dev/printers.mllib @@ -17,6 +17,8 @@ Backtrace IStream Pp_control Loc +CList +CString Compat Flags Control @@ -29,8 +31,6 @@ Segmenttree Unicodetable Unicode CObj -CList -CString CArray CStack Util diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 0e90026122..cbebcdfcd4 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -467,11 +467,13 @@ let pp_generic_argument arg = pp(str"<genarg:"++pr_argument_type(genarg_tag arg)++str">") let prgenarginfo arg = - let tpe = pr_argument_type (genarg_tag arg) in - try - let data = Pptactic.pr_top_generic (Global.env ()) arg in - str "<genarg:" ++ tpe ++ str " := [ " ++ data ++ str " ] >" - with _any -> + let Val.Dyn (tag, _) = arg in + let tpe = Val.repr tag in + (** FIXME *) +(* try *) +(* let data = Pptactic.pr_top_generic (Global.env ()) arg in *) +(* str "<genarg:" ++ tpe ++ str " := [ " ++ data ++ str " ] >" *) +(* with _any -> *) str "<genarg:" ++ tpe ++ str ">" let ppgenarginfo arg = pp (prgenarginfo arg) @@ -518,8 +520,7 @@ let _ = extend_vernac_command_grammar ("PrintConstr", 0) None [GramTerminal "PrintConstr"; GramNonTerminal - (Loc.ghost,rawwit wit_constr,Aentry (Entry.unsafe_of_name ("constr","constr")), - Some (Names.Id.of_string "c"))] + (Loc.ghost,rawwit wit_constr,Aentry (Entry.unsafe_of_name ("constr","constr")))] let _ = try @@ -535,8 +536,7 @@ let _ = extend_vernac_command_grammar ("PrintPureConstr", 0) None [GramTerminal "PrintPureConstr"; GramNonTerminal - (Loc.ghost,rawwit wit_constr,Aentry (Entry.unsafe_of_name ("constr","constr")), - Some (Names.Id.of_string "c"))] + (Loc.ghost,rawwit wit_constr,Aentry (Entry.unsafe_of_name ("constr","constr")))] (* Setting printer of unbound global reference *) open Names diff --git a/engine/evd.ml b/engine/evd.ml index 6651ff5f63..8476db6646 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -462,7 +462,12 @@ let new_evar evd ?naming evi = let remove d e = let undf_evars = EvMap.remove e d.undf_evars in let defn_evars = EvMap.remove e d.defn_evars in - { d with undf_evars; defn_evars; } + let principal_future_goal = match d.principal_future_goal with + | None -> None + | Some e' -> if Evar.equal e e' then None else d.principal_future_goal + in + let future_goals = List.filter (fun e' -> not (Evar.equal e e')) d.future_goals in + { d with undf_evars; defn_evars; principal_future_goal; future_goals } let find d e = try EvMap.find e d.undf_evars @@ -1225,7 +1230,7 @@ let pr_decl ((id,b,_),ok) = | Some c -> str (if ok then "(" else "{") ++ pr_id id ++ str ":=" ++ print_constr c ++ str (if ok then ")" else "}") -let rec pr_evar_source = function +let pr_evar_source = function | Evar_kinds.QuestionMark _ -> str "underscore" | Evar_kinds.CasesType false -> str "pattern-matching return predicate" | Evar_kinds.CasesType true -> diff --git a/engine/evd.mli b/engine/evd.mli index 34169b0214..7fef95f17b 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -493,8 +493,6 @@ val restrict_universe_context : evar_map -> Univ.universe_set -> evar_map val universe_of_name : evar_map -> string -> Univ.universe_level val add_universe_name : evar_map -> string -> Univ.universe_level -> evar_map -val universes : evar_map -> UGraph.t - val add_constraints_context : evar_universe_context -> Univ.constraints -> evar_universe_context @@ -516,7 +514,6 @@ val is_sort_variable : evar_map -> sorts -> Univ.universe_level option not a local sort variable declared in [evm] *) val is_flexible_level : evar_map -> Univ.Level.t -> bool -val whd_sort_variable : evar_map -> constr -> constr (* val normalize_universe_level : evar_map -> Univ.universe_level -> Univ.universe_level *) val normalize_universe : evar_map -> Univ.universe -> Univ.universe val normalize_universe_instance : evar_map -> Univ.universe_instance -> Univ.universe_instance diff --git a/engine/proofview_monad.ml b/engine/proofview_monad.ml index a9faf0a833..88c5925ceb 100644 --- a/engine/proofview_monad.ml +++ b/engine/proofview_monad.ml @@ -108,11 +108,6 @@ module Info = struct and compress f = CList.map_filter compress_tree f - let rec is_empty = let open Trace in function - | Seq(Dispatch,brs) -> List.for_all is_empty brs - | Seq(DBranch,br) -> List.for_all is_empty br - | _ -> false - (** [with_sep] is [true] when [Tactic m] must be printed with a trailing semi-colon. *) let rec pr_tree with_sep = let open Trace in function diff --git a/grammar/argextend.ml4 b/grammar/argextend.ml4 index a49291d947..639097afa8 100644 --- a/grammar/argextend.ml4 +++ b/grammar/argextend.ml4 @@ -30,13 +30,9 @@ let mk_extraarg loc s = <:expr< $lid:"wit_"^s$ >> let rec make_wit loc = function - | IntOrVarArgType -> <:expr< Constrarg.wit_int_or_var >> | IdentArgType -> <:expr< Constrarg.wit_ident >> | VarArgType -> <:expr< Constrarg.wit_var >> - | GenArgType -> <:expr< Constrarg.wit_genarg >> | ConstrArgType -> <:expr< Constrarg.wit_constr >> - | ConstrMayEvalArgType -> <:expr< Constrarg.wit_constr_may_eval >> - | OpenConstrArgType -> <:expr< Constrarg.wit_open_constr >> | ListArgType t -> <:expr< Genarg.wit_list $make_wit loc t$ >> | OptArgType t -> <:expr< Genarg.wit_opt $make_wit loc t$ >> | PairArgType (t1,t2) -> @@ -49,7 +45,7 @@ let make_topwit loc arg = <:expr< Genarg.topwit $make_wit loc arg$ >> let has_extraarg l = let check = function - | GramNonTerminal(_, t, _, _) -> + | ExtNonTerminal(EntryName (t, _), _) -> begin match Genarg.unquote t with | ExtraArgType _ -> true | _ -> false @@ -78,7 +74,7 @@ let rec get_empty_entry : type s a. (s, a) entry_key -> _ = function let statically_known_possibly_empty s (prods,_) = List.for_all (function - | GramNonTerminal(_,t,e,_) -> + | ExtNonTerminal(EntryName (t, e), _) -> begin match Genarg.unquote t with | ExtraArgType s' -> (* For ExtraArg we don't know (we'll have to test dynamically) *) @@ -87,26 +83,26 @@ let statically_known_possibly_empty s (prods,_) = | _ -> is_possibly_empty e end - | GramTerminal _ -> + | ExtTerminal _ -> (* This consumes a token for sure *) false) prods let possibly_empty_subentries loc (prods,act) = - let bind_name p v e = match p with - | None -> e - | Some id -> - let s = Names.Id.to_string id in <:expr< let $lid:s$ = $v$ in $e$ >> in + let bind_name id v e = + let s = Names.Id.to_string id in + <:expr< let $lid:s$ = $v$ in $e$ >> + in let rec aux = function | [] -> <:expr< let loc = $default_loc$ in let _ = loc in $act$ >> - | GramNonTerminal(_,_,e,p) :: tl when is_possibly_empty e -> - bind_name p (get_empty_entry e) (aux tl) - | GramNonTerminal(_,t,_,p) :: tl -> + | ExtNonTerminal(EntryName (_, e), id) :: tl when is_possibly_empty e -> + bind_name id (get_empty_entry e) (aux tl) + | ExtNonTerminal(EntryName (t, _), id) :: tl -> let t = match Genarg.unquote t with | ExtraArgType _ as t -> t | _ -> assert false in (* We check at runtime if extraarg s parses "epsilon" *) - let s = match p with None -> "_" | Some id -> Names.Id.to_string id in + let s = Names.Id.to_string id in <:expr< let $lid:s$ = match Genarg.default_empty_value $make_wit loc t$ with [ None -> raise Exit | Some v -> v ] in $aux tl$ >> @@ -139,20 +135,20 @@ let make_possibly_empty_subentries loc s cl = let make_act loc act pil = let rec make = function | [] -> <:expr< (fun loc -> $act$) >> - | GramNonTerminal (_,t,_,Some p) :: tl -> + | ExtNonTerminal (EntryName (t, _), p) :: tl -> let t = Genarg.unquote t in let p = Names.Id.to_string p in <:expr< (fun $lid:p$ -> let _ = Genarg.in_gen $make_rawwit loc t$ $lid:p$ in $make tl$) >> - | (GramTerminal _ | GramNonTerminal (_,_,_,None)) :: tl -> + | ExtTerminal _ :: tl -> <:expr< (fun _ -> $make tl$) >> in make (List.rev pil) let make_prod_item = function - | GramTerminal s -> <:expr< Pcoq.Atoken (Lexer.terminal $mlexpr_of_string s$) >> - | GramNonTerminal (_,_,g,_) -> mlexpr_of_prod_entry_key g + | ExtTerminal s -> <:expr< Pcoq.Atoken (Lexer.terminal $mlexpr_of_string s$) >> + | ExtNonTerminal (EntryName (_, g), _) -> mlexpr_of_prod_entry_key g let rec make_prod = function | [] -> <:expr< Extend.Stop >> @@ -186,17 +182,22 @@ let declare_tactic_argument loc s (typ, pr, f, g, h) cl = | None -> begin match globtyp with | Genarg.ExtraArgType s' when CString.equal s s' -> - <:expr< fun ist gl v -> (gl.Evd.sigma, v) >> + <:expr< fun ist v -> Ftactic.return v >> | _ -> - <:expr< fun ist gl x -> - let (sigma,a_interp) = - Tacinterp.interp_genarg ist - (Tacmach.pf_env gl) (Tacmach.project gl) (Tacmach.pf_concl gl) gl.Evd.it - (Genarg.in_gen $make_globwit loc globtyp$ x) - in - (sigma , out_gen $make_topwit loc globtyp$ a_interp)>> + <:expr< fun ist x -> + Ftactic.bind + (Tacinterp.interp_genarg ist (Genarg.in_gen $make_globwit loc globtyp$ x)) + (fun v -> Ftactic.return (Tacinterp.Value.cast $make_topwit loc globtyp$ v)) >> end - | Some f -> <:expr< $lid:f$>> in + | Some f -> + (** Compatibility layer, TODO: remove me *) + <:expr< + let f = $lid:f$ in + fun ist v -> Ftactic.nf_s_enter { Proofview.Goal.s_enter = fun gl -> + let (sigma, v) = Tacmach.New.of_old (fun gl -> f ist gl v) gl in + Sigma.Unsafe.of_pair (Ftactic.return v, sigma) + } + >> in let subst = match h with | None -> begin match globtyp with @@ -209,13 +210,26 @@ let declare_tactic_argument loc s (typ, pr, f, g, h) cl = (Genarg.in_gen $make_globwit loc globtyp$ x)) >> end | Some f -> <:expr< $lid:f$>> in + let dyn = match typ with + | `Uniform typ -> + let is_new = match typ with + | Genarg.ExtraArgType s' when CString.equal s s' -> true + | _ -> false + in + if is_new then <:expr< None >> + else <:expr< Some (Genarg.val_tag $make_topwit loc typ$) >> + | `Specialized _ -> <:expr< None >> + in let se = mlexpr_of_string s in let wit = <:expr< $lid:"wit_"^s$ >> in let rawwit = <:expr< Genarg.rawwit $wit$ >> in let rules = mlexpr_of_list (make_rule loc) (List.rev cl) in let default_value = <:expr< $make_possibly_empty_subentries loc s cl$ >> in declare_str_items loc - [ <:str_item< value ($lid:"wit_"^s$) = Genarg.make0 $default_value$ $se$ >>; + [ <:str_item< + value ($lid:"wit_"^s$) = + let dyn = $dyn$ in + Genarg.make0 ?dyn $default_value$ $se$ >>; <:str_item< Genintern.register_intern0 $wit$ $glob$ >>; <:str_item< Genintern.register_subst0 $wit$ $subst$ >>; <:str_item< Geninterp.register_interp0 $wit$ $interp$ >>; @@ -301,15 +315,15 @@ EXTEND ; genarg: [ [ e = LIDENT; "("; s = LIDENT; ")" -> - let EntryName (t, g) = interp_entry_name false TgAny e "" in - GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s)) + let entry = interp_entry_name false TgAny e "" in + ExtNonTerminal (entry, Names.Id.of_string s) | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" -> - let EntryName (t, g) = interp_entry_name false TgAny e sep in - GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s)) + let entry = interp_entry_name false TgAny e sep in + ExtNonTerminal (entry, Names.Id.of_string s) | s = STRING -> if String.length s > 0 && Util.is_letter s.[0] then Lexer.add_keyword s; - GramTerminal s + ExtTerminal s ] ] ; entry_name: diff --git a/grammar/grammar.mllib b/grammar/grammar.mllib index b167643d3f..6098de8f03 100644 --- a/grammar/grammar.mllib +++ b/grammar/grammar.mllib @@ -17,13 +17,13 @@ Backtrace Pp_control Flags Loc +CList +CString Serialize Stateid Feedback Pp -CList -CString CArray CStack Util diff --git a/grammar/q_coqast.ml4 b/grammar/q_coqast.ml4 index be438b54a5..494ec6ba29 100644 --- a/grammar/q_coqast.ml4 +++ b/grammar/q_coqast.ml4 @@ -223,13 +223,9 @@ let mlexpr_of_red_expr = function <:expr< Genredexpr.ExtraRedExpr $mlexpr_of_string s$ >> let rec mlexpr_of_argtype loc = function - | Genarg.IntOrVarArgType -> <:expr< Genarg.IntOrVarArgType >> | Genarg.IdentArgType -> <:expr< Genarg.IdentArgType >> | Genarg.VarArgType -> <:expr< Genarg.VarArgType >> - | Genarg.OpenConstrArgType -> <:expr< Genarg.OpenConstrArgType >> - | Genarg.GenArgType -> <:expr< Genarg.GenArgType >> | Genarg.ConstrArgType -> <:expr< Genarg.ConstrArgType >> - | Genarg.ConstrMayEvalArgType -> <:expr< Genarg.ConstrMayEvalArgType >> | Genarg.ListArgType t -> <:expr< Genarg.ListArgType $mlexpr_of_argtype loc t$ >> | Genarg.OptArgType t -> <:expr< Genarg.OptArgType $mlexpr_of_argtype loc t$ >> | Genarg.PairArgType (t1,t2) -> @@ -423,19 +419,6 @@ let rec mlexpr_of_atomic_tactic = function (* Equivalence relations *) | Tacexpr.TacSymmetry ido -> <:expr< Tacexpr.TacSymmetry $mlexpr_of_clause ido$ >> - (* Automation tactics *) - | Tacexpr.TacAuto (debug,n,lems,l) -> - let d = mlexpr_of_debug debug in - let n = mlexpr_of_option (mlexpr_of_or_var mlexpr_of_int) n in - let lems = mlexpr_of_list mlexpr_of_constr lems in - let l = mlexpr_of_option (mlexpr_of_list mlexpr_of_string) l in - <:expr< Tacexpr.TacAuto $d$ $n$ $lems$ $l$ >> - | Tacexpr.TacTrivial (debug,lems,l) -> - let d = mlexpr_of_debug debug in - let l = mlexpr_of_option (mlexpr_of_list mlexpr_of_string) l in - let lems = mlexpr_of_list mlexpr_of_constr lems in - <:expr< Tacexpr.TacTrivial $d$ $lems$ $l$ >> - | _ -> failwith "Quotation of atomic tactic expressions: TODO" and mlexpr_of_tactic : (Tacexpr.raw_tactic_expr -> MLast.expr) = function diff --git a/grammar/q_util.ml4 b/grammar/q_util.ml4 index 19f436f926..4c1f25941f 100644 --- a/grammar/q_util.ml4 +++ b/grammar/q_util.ml4 @@ -10,6 +10,10 @@ open Compat +type extend_token = +| ExtTerminal of string +| ExtNonTerminal of unit Pcoq.entry_name * Names.Id.t + let mlexpr_of_list f l = List.fold_right (fun e1 e2 -> @@ -56,6 +60,7 @@ let mlexpr_of_token = function | Tok.IDENT s -> <:expr< Tok.IDENT $mlexpr_of_string s$ >> | Tok.FIELD s -> <:expr< Tok.FIELD $mlexpr_of_string s$ >> | Tok.INT s -> <:expr< Tok.INT $mlexpr_of_string s$ >> +| Tok.INDEX s -> <:expr< Tok.INDEX $mlexpr_of_string s$ >> | Tok.STRING s -> <:expr< Tok.STRING $mlexpr_of_string s$ >> | Tok.LEFTQMARK -> <:expr< Tok.LEFTQMARK >> | Tok.BULLET s -> <:expr< Tok.BULLET $mlexpr_of_string s$ >> diff --git a/grammar/q_util.mli b/grammar/q_util.mli index d01fb1e9a0..d9359de1e8 100644 --- a/grammar/q_util.mli +++ b/grammar/q_util.mli @@ -8,6 +8,10 @@ open Compat (* necessary for camlp4 *) +type extend_token = +| ExtTerminal of string +| ExtNonTerminal of unit Pcoq.entry_name * Names.Id.t + val mlexpr_of_list : ('a -> MLast.expr) -> 'a list -> MLast.expr val mlexpr_of_pair : diff --git a/grammar/tacextend.ml4 b/grammar/tacextend.ml4 index df2209606d..bf0c4fc215 100644 --- a/grammar/tacextend.ml4 +++ b/grammar/tacextend.ml4 @@ -27,39 +27,36 @@ let plugin_name = <:expr< __coq_plugin_name >> let rec make_patt = function | [] -> <:patt< [] >> - | GramNonTerminal(loc',_,_,Some p)::l -> + | ExtNonTerminal (_, p) :: l -> let p = Names.Id.to_string p in <:patt< [ $lid:p$ :: $make_patt l$ ] >> | _::l -> make_patt l let rec make_when loc = function | [] -> <:expr< True >> - | GramNonTerminal(loc',t,_,Some p)::l -> - let loc' = of_coqloc loc' in + | ExtNonTerminal (EntryName (t, _), p) :: l -> let p = Names.Id.to_string p in let l = make_when loc l in - let loc = CompatLoc.merge loc' loc in - let t = mlexpr_of_argtype loc' (Genarg.unquote t) in + let t = mlexpr_of_argtype loc (Genarg.unquote t) in <:expr< Genarg.argument_type_eq (Genarg.genarg_tag $lid:p$) $t$ && $l$ >> | _::l -> make_when loc l let rec make_let raw e = function | [] -> <:expr< fun $lid:"ist"$ -> $e$ >> - | GramNonTerminal(loc,t,_,Some p)::l -> + | ExtNonTerminal (EntryName (t, _), p) :: l -> let t = Genarg.unquote t in - let loc = of_coqloc loc in let p = Names.Id.to_string p in - let loc = CompatLoc.merge loc (MLast.loc_of_expr e) in + let loc = MLast.loc_of_expr e in let e = make_let raw e l in let v = if raw then <:expr< Genarg.out_gen $make_rawwit loc t$ $lid:p$ >> - else <:expr< Genarg.out_gen $make_topwit loc t$ $lid:p$ >> in + else <:expr< Tacinterp.Value.cast $make_topwit loc t$ $lid:p$ >> in <:expr< let $lid:p$ = $v$ in $e$ >> | _::l -> make_let raw e l let rec extract_signature = function | [] -> [] - | GramNonTerminal (_,t,_,_) :: l -> Genarg.unquote t :: extract_signature l + | ExtNonTerminal (EntryName (t, _), _) :: l -> Genarg.unquote t :: extract_signature l | _::l -> extract_signature l @@ -73,7 +70,7 @@ let check_unicity s l = let make_clause (pt,_,e) = (make_patt pt, - vala (Some (make_when (MLast.loc_of_expr e) pt)), + vala None, make_let false e pt) let make_fun_clauses loc s l = @@ -83,37 +80,32 @@ let make_fun_clauses loc s l = let rec make_args = function | [] -> <:expr< [] >> - | GramNonTerminal(loc,t,_,Some p)::l -> + | ExtNonTerminal (EntryName (t, _), p) :: l -> let t = Genarg.unquote t in - let loc = of_coqloc loc in let p = Names.Id.to_string p in <:expr< [ Genarg.in_gen $make_topwit loc t$ $lid:p$ :: $make_args l$ ] >> | _::l -> make_args l let mlexpr_terminals_of_grammar_tactic_prod_item_expr = function - | GramTerminal s -> <:expr< Some $mlexpr_of_string s$ >> - | GramNonTerminal (loc,nt,_,sopt) -> - let loc = of_coqloc loc in <:expr< None >> + | ExtTerminal s -> <:expr< Some $mlexpr_of_string s$ >> + | ExtNonTerminal _ -> <:expr< None >> let make_prod_item = function - | GramTerminal s -> <:expr< Egramml.GramTerminal $str:s$ >> - | GramNonTerminal (loc,nt,g,sopt) -> - let loc = of_coqloc loc in + | ExtTerminal s -> <:expr< Egramml.GramTerminal $str:s$ >> + | ExtNonTerminal (EntryName (nt, g), id) -> let nt = Genarg.unquote nt in <:expr< Egramml.GramNonTerminal $default_loc$ $make_rawwit loc nt$ - $mlexpr_of_prod_entry_key g$ $mlexpr_of_option mlexpr_of_ident sopt$ >> + $mlexpr_of_prod_entry_key g$ >> let mlexpr_of_clause cl = mlexpr_of_list (fun (a,_,b) -> mlexpr_of_list make_prod_item a) cl let rec make_tags loc = function | [] -> <:expr< [] >> - | GramNonTerminal(loc',t,_,Some p)::l -> - let loc' = of_coqloc loc' in + | ExtNonTerminal (EntryName (t, _), p) :: l -> let l = make_tags loc l in - let loc = CompatLoc.merge loc' loc in let t = Genarg.unquote t in - let t = mlexpr_of_argtype loc' t in + let t = mlexpr_of_argtype loc t in <:expr< [ $t$ :: $l$ ] >> | _::l -> make_tags loc l @@ -127,7 +119,7 @@ let make_one_printing_rule (pt,_,e) = let make_printing_rule r = mlexpr_of_list make_one_printing_rule r let make_empty_check = function -| GramNonTerminal(_, t, e, _)-> +| ExtNonTerminal (EntryName (t, e), _)-> let t = Genarg.unquote t in let is_extra = match t with ExtraArgType _ -> true | _ -> false in if is_possibly_empty e || is_extra then @@ -143,16 +135,16 @@ let make_empty_check = function else (* This does not parse epsilon (this Exit is static time) *) raise Exit -| GramTerminal _ -> +| ExtTerminal _ -> (* Idem *) raise Exit let rec possibly_atomic loc = function | [] -> [] -| ((GramNonTerminal _ :: _ | []), _, _) :: rem -> +| ((ExtNonTerminal _ :: _ | []), _, _) :: rem -> (** This is not parsed by the TACTIC EXTEND rules *) assert false -| (GramTerminal s :: prods, _, _) :: rem -> +| (ExtTerminal s :: prods, _, _) :: rem -> let entry = try let l = List.map make_empty_check prods in @@ -164,8 +156,8 @@ let rec possibly_atomic loc = function (** Special treatment of constr entries *) let is_constr_gram = function -| GramTerminal _ -> false -| GramNonTerminal (_, _, e, _) -> +| ExtTerminal _ -> false +| ExtNonTerminal (EntryName (_, e), _) -> match e with | Aentry e -> begin match Entry.repr e with @@ -175,12 +167,11 @@ let is_constr_gram = function | _ -> false let make_var = function - | GramNonTerminal(loc',_,_,Some p) -> Some p - | GramNonTerminal(loc',_,_,None) -> Some (Id.of_string "_") + | ExtNonTerminal (_, p) -> Some p | _ -> assert false let declare_tactic loc s c cl = match cl with -| [(GramTerminal name) :: rem, _, tac] when List.for_all is_constr_gram rem -> +| [(ExtTerminal name) :: rem, _, tac] when List.for_all is_constr_gram rem -> (** The extension is only made of a name followed by constr entries: we do not add any grammar nor printing rule and add it as a true Ltac definition. *) let patt = make_patt rem in @@ -258,7 +249,7 @@ EXTEND c = OPT [ "=>"; "["; c = Pcaml.expr; "]" -> c ]; "->"; "["; e = Pcaml.expr; "]" -> (match l with - | GramNonTerminal _ :: _ -> + | ExtNonTerminal _ :: _ -> (* En attendant la syntaxe de tacticielles *) failwith "Tactic syntax must start with an identifier" | _ -> (l,c,e)) @@ -266,14 +257,14 @@ EXTEND ; tacargs: [ [ e = LIDENT; "("; s = LIDENT; ")" -> - let EntryName (t, g) = interp_entry_name false TgAny e "" in - GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s)) + let entry = interp_entry_name false TgAny e "" in + ExtNonTerminal (entry, Names.Id.of_string s) | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" -> - let EntryName (t, g) = interp_entry_name false TgAny e sep in - GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s)) + let entry = interp_entry_name false TgAny e sep in + ExtNonTerminal (entry, Names.Id.of_string s) | s = STRING -> if String.is_empty s then Errors.user_err_loc (!@loc,"",Pp.str "Empty terminal."); - GramTerminal s + ExtTerminal s ] ] ; tac_name: diff --git a/grammar/vernacextend.ml4 b/grammar/vernacextend.ml4 index 54638556db..8de59e5cd2 100644 --- a/grammar/vernacextend.ml4 +++ b/grammar/vernacextend.ml4 @@ -22,7 +22,7 @@ open Compat type rule = { r_head : string option; (** The first terminal grammar token *) - r_patt : Vernacexpr.vernac_expr grammar_prod_item list; + r_patt : extend_token list; (** The remaining tokens of the parsing rule *) r_class : MLast.expr option; (** An optional classifier for the STM *) @@ -34,11 +34,10 @@ type rule = { let rec make_let e = function | [] -> e - | GramNonTerminal(loc,t,_,Some p)::l -> + | ExtNonTerminal (EntryName (t, _), p) :: l -> let t = Genarg.unquote t in - let loc = of_coqloc loc in let p = Names.Id.to_string p in - let loc = CompatLoc.merge loc (MLast.loc_of_expr e) in + let loc = MLast.loc_of_expr e in let e = make_let e l in <:expr< let $lid:p$ = Genarg.out_gen $make_rawwit loc t$ $lid:p$ in $e$ >> | _::l -> make_let e l @@ -51,7 +50,7 @@ let make_clause { r_patt = pt; r_branch = e; } = (* To avoid warnings *) let mk_ignore c pt = let names = CList.map_filter (function - | GramNonTerminal(_,_,_,Some p) -> Some (Names.Id.to_string p) + | ExtNonTerminal (_, p) -> Some (Names.Id.to_string p) | _ -> None) pt in let fold accu id = <:expr< let _ = $lid:id$ in $accu$ >> in let names = List.fold_left fold <:expr< () >> names in @@ -109,7 +108,7 @@ let make_fun_classifiers loc s c l = let mlexpr_of_clause = mlexpr_of_list (fun { r_head = a; r_patt = b; } -> mlexpr_of_list make_prod_item - (Option.List.cons (Option.map (fun a -> GramTerminal a) a) b)) + (Option.List.cons (Option.map (fun a -> ExtTerminal a) a) b)) let declare_command loc s c nt cl = let se = mlexpr_of_string s in @@ -182,13 +181,13 @@ EXTEND ; args: [ [ e = LIDENT; "("; s = LIDENT; ")" -> - let EntryName (t, g) = interp_entry_name false TgAny e "" in - GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s)) + let entry = interp_entry_name false TgAny e "" in + ExtNonTerminal (entry, Names.Id.of_string s) | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" -> - let EntryName (t, g) = interp_entry_name false TgAny e sep in - GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s)) + let entry = interp_entry_name false TgAny e sep in + ExtNonTerminal (entry, Names.Id.of_string s) | s = STRING -> - GramTerminal s + ExtTerminal s ] ] ; END @@ -1,7 +1,7 @@ CoqIde FAQ Q0) What is CoqIde? -R0: A powerfull graphical interface for Coq. See http://coq.inria.fr. for more informations. +R0: A powerful graphical interface for Coq. See http://coq.inria.fr. for more informations. Q1) How to enable Emacs keybindings? R1: Insert diff --git a/ide/coq.ml b/ide/coq.ml index a60f327b4f..268a95a336 100644 --- a/ide/coq.ml +++ b/ide/coq.ml @@ -99,9 +99,6 @@ let display_coqtop_answer cmd lines = "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 (coqtop_path ()) ^" -nois -filteropts " ^ argstr in @@ -200,8 +197,6 @@ module GlibMainLoop = struct let read_all = Ideutils.io_read_all let async_chan_of_file fd = Glib.Io.channel_of_descr fd let async_chan_of_socket s = !gio_channel_of_descr_socket s - let add_timeout ~sec callback = - ignore(Glib.Timeout.add ~ms:(sec * 1000) ~callback) end module CoqTop = Spawn.Async(GlibMainLoop) diff --git a/ide/document.ml b/ide/document.ml index 9823e7576c..bb431e7914 100644 --- a/ide/document.ml +++ b/ide/document.ml @@ -124,12 +124,6 @@ let context d = let pair _ x y = try Option.get x, y with Option.IsNone -> assert false in List.map (flat pair true) top, List.map (flat pair true) bot -let iter d f = - let a, s, b = to_lists d in - List.iter (flat f false) a; - List.iter (flat f true) s; - List.iter (flat f false) b - let stateid_opt_equal = Option.equal Stateid.equal let is_in_focus d id = @@ -154,7 +148,7 @@ let cut_at d id = if stateid_opt_equal state_id (Some id) then CSig.Stop (n, zone) else CSig.Cont (n + 1, data :: zone) in let n, zone = CList.fold_left_until aux (0, []) d.stack in - for i = 1 to n do ignore(pop d) done; + for _i = 1 to n do ignore(pop d) done; List.rev zone let find_id d f = diff --git a/ide/ideutils.ml b/ide/ideutils.ml index 2e4adba735..51ae76ff54 100644 --- a/ide/ideutils.ml +++ b/ide/ideutils.ml @@ -9,8 +9,6 @@ open Preferences -exception Forbidden - let warn_image () = let img = GMisc.image () in img#set_stock `DIALOG_WARNING; @@ -31,7 +29,7 @@ let push_info,pop_info,clear_info = let size = ref 0 in (fun s -> incr size; ignore (status_context#push s)), (fun () -> decr size; status_context#pop ()), - (fun () -> for i = 1 to !size do status_context#pop () done; size := 0) + (fun () -> for _i = 1 to !size do status_context#pop () done; size := 0) let flash_info = let flash_context = status#new_context ~name:"Flash" in diff --git a/ide/preferences.ml b/ide/preferences.ml index a605014f2c..3d11e94feb 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -700,10 +700,6 @@ let configure ?(apply=(fun () -> ())) () = ~border_width:2 ~packing:scroll#add_with_viewport () in - let reset_button = GButton.button - ~label:"Reset" - ~packing:box#pack () - in let i = ref 0 in let cb = ref [] in let iter text tag = diff --git a/ide/project_file.ml4 b/ide/project_file.ml4 index 152f76cc0e..081094e2b6 100644 --- a/ide/project_file.ml4 +++ b/ide/project_file.ml4 @@ -48,7 +48,7 @@ let parse f = res let rec process_cmd_line orig_dir ((project_file,makefile,install,opt) as opts) l = function - | [] -> opts,List.rev l + | [] -> opts, l | ("-h"|"--help") :: _ -> raise Parsing_error | ("-no-opt"|"-byte") :: r -> @@ -86,7 +86,6 @@ let rec process_cmd_line orig_dir ((project_file,makefile,install,opt) as opts) process_cmd_line orig_dir opts ((Include (CUnix.correct_path d orig_dir, lp)) :: l) r | "-I" :: d :: r -> process_cmd_line orig_dir opts ((MLInclude (CUnix.correct_path d orig_dir)) :: l) r - | "-R" :: p :: "-as" :: lp :: r | "-R" :: p :: lp :: r -> process_cmd_line orig_dir opts (RInclude (CUnix.correct_path p orig_dir,lp) :: l) r | ("-Q"|"-R"|"-I"|"-custom"|"-extra"|"-extra-phony") :: _ -> @@ -128,6 +127,10 @@ let rec process_cmd_line orig_dir ((project_file,makefile,install,opt) as opts) else if (Filename.check_suffix f ".mlpack") then MLPACK f else Subdir f) :: l) r +let process_cmd_line orig_dir opts l args = + let (opts, l) = process_cmd_line orig_dir opts l args in + opts, List.rev l + let rec post_canonize f = if Filename.basename f = Filename.current_dir_name then let dir = Filename.dirname f in @@ -135,48 +138,44 @@ let rec post_canonize f = else f (* Return: ((v,(mli,ml4,ml,mllib,mlpack),special,subdir),(ml_inc,q_inc,r_inc),(args,defs)) *) -let split_arguments = - let rec aux = function - | V n :: r -> - let (v,m,o,s),i,d = aux r in ((CUnix.remove_path_dot n::v,m,o,s),i,d) - | ML n :: r -> - let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in - ((v,(mli,ml4,CUnix.remove_path_dot n::ml,mllib,mlpack),o,s),i,d) - | MLI n :: r -> - let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in - ((v,(CUnix.remove_path_dot n::mli,ml4,ml,mllib,mlpack),o,s),i,d) - | ML4 n :: r -> - let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in - ((v,(mli,CUnix.remove_path_dot n::ml4,ml,mllib,mlpack),o,s),i,d) - | MLLIB n :: r -> - let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in - ((v,(mli,ml4,ml,CUnix.remove_path_dot n::mllib,mlpack),o,s),i,d) - | MLPACK n :: r -> - let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in - ((v,(mli,ml4,ml,mllib,CUnix.remove_path_dot n::mlpack),o,s),i,d) - | Special (n,dep,is_phony,c) :: r -> - let (v,m,o,s),i,d = aux r in ((v,m,(n,dep,is_phony,c)::o,s),i,d) - | Subdir n :: r -> - let (v,m,o,s),i,d = aux r in ((v,m,o,n::s),i,d) - | MLInclude p :: r -> - let t,(ml,q,r),d = aux r in (t,((CUnix.remove_path_dot (post_canonize p), - CUnix.canonical_path_name p)::ml,q,r),d) - | Include (p,l) :: r -> - let t,(ml,i,r),d = aux r in - let i_new = (CUnix.remove_path_dot (post_canonize p),l, - CUnix.canonical_path_name p) in - (t,(ml,i_new::i,r),d) - | RInclude (p,l) :: r -> - let t,(ml,i,r),d = aux r in - let r_new = (CUnix.remove_path_dot (post_canonize p),l, - CUnix.canonical_path_name p) in - (t,(ml,i,r_new::r),d) - | Def (v,def) :: r -> - let t,i,(args,defs) = aux r in (t,i,(args,(v,def)::defs)) - | Arg a :: r -> - let t,i,(args,defs) = aux r in (t,i,(a::args,defs)) - | [] -> ([],([],[],[],[],[]),[],[]),([],[],[]),([],[]) - in aux +let split_arguments args = + List.fold_right + (fun a ((v,(mli,ml4,ml,mllib,mlpack as m),o,s as t), + (ml_inc,q_inc,r_inc as i),(args,defs as d)) -> + match a with + | V n -> + ((CUnix.remove_path_dot n::v,m,o,s),i,d) + | ML n -> + ((v,(mli,ml4,CUnix.remove_path_dot n::ml,mllib,mlpack),o,s),i,d) + | MLI n -> + ((v,(CUnix.remove_path_dot n::mli,ml4,ml,mllib,mlpack),o,s),i,d) + | ML4 n -> + ((v,(mli,CUnix.remove_path_dot n::ml4,ml,mllib,mlpack),o,s),i,d) + | MLLIB n -> + ((v,(mli,ml4,ml,CUnix.remove_path_dot n::mllib,mlpack),o,s),i,d) + | MLPACK n -> + ((v,(mli,ml4,ml,mllib,CUnix.remove_path_dot n::mlpack),o,s),i,d) + | Special (n,dep,is_phony,c) -> + ((v,m,(n,dep,is_phony,c)::o,s),i,d) + | Subdir n -> + ((v,m,o,n::s),i,d) + | MLInclude p -> + let ml_new = (CUnix.remove_path_dot (post_canonize p), + CUnix.canonical_path_name p) in + (t,(ml_new::ml_inc,q_inc,r_inc),d) + | Include (p,l) -> + let q_new = (CUnix.remove_path_dot (post_canonize p),l, + CUnix.canonical_path_name p) in + (t,(ml_inc,q_new::q_inc,r_inc),d) + | RInclude (p,l) -> + let r_new = (CUnix.remove_path_dot (post_canonize p),l, + CUnix.canonical_path_name p) in + (t,(ml_inc,q_inc,r_new::r_inc),d) + | Def (v,def) -> + (t,i,(args,(v,def)::defs)) + | Arg a -> + (t,i,(a::args,defs))) + args (([],([],[],[],[],[]),[],[]),([],[],[]),([],[])) let read_project_file f = split_arguments diff --git a/ide/sentence.ml b/ide/sentence.ml index dd6b10a461..8195051c6c 100644 --- a/ide/sentence.ml +++ b/ide/sentence.ml @@ -63,13 +63,13 @@ let grab_sentence_start (iter:GText.iter) soi = (** Search forward the first character immediately after a sentence end *) -let rec grab_sentence_stop (start:GText.iter) = +let grab_sentence_stop (start:GText.iter) = (forward_search is_sentence_end start)#forward_char (** Search forward the first character immediately after a "." sentence end (and not just a "\{" or "\}" or comment end *) -let rec grab_ending_dot (start:GText.iter) = +let grab_ending_dot (start:GText.iter) = let is_ending_dot s = is_sentence_end s && s#char = Char.code '.' in (forward_search is_ending_dot start)#forward_char diff --git a/ide/wg_Find.ml b/ide/wg_Find.ml index a0949ca0c8..dc7071c278 100644 --- a/ide/wg_Find.ml +++ b/ide/wg_Find.ml @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -type mode = [ `FIND | `REPLACE ] - let b2c = Ideutils.byte_offset_to_char_offset class finder name (view : GText.view) = diff --git a/ide/wg_ProofView.ml b/ide/wg_ProofView.ml index 148add6e9c..642a577878 100644 --- a/ide/wg_ProofView.ml +++ b/ide/wg_ProofView.ml @@ -114,19 +114,6 @@ let mode_tactic sel_cb (proof : #GText.view_skel) goals hints = match goals with (Some Tags.Proof.goal))); ignore(proof#scroll_to_mark ~use_align:true ~yalign:0.95 `INSERT) -let mode_cesar (proof : #GText.view_skel) = function - | [] -> assert false - | { Interface.goal_hyp = hyps; Interface.goal_ccl = cur_goal; } :: _ -> - proof#buffer#insert " *** Declarative Mode ***\n"; - List.iter - (fun hyp -> insert_xml proof#buffer hyp; proof#buffer#insert "\n") - hyps; - proof#buffer#insert "______________________________________\n"; - proof#buffer#insert "thesis := \n "; - insert_xml proof#buffer cur_goal; - proof#buffer#insert "\n"; - ignore (proof#scroll_to_iter (proof#buffer#get_iter_at_mark `INSERT)) - let rec flatten = function | [] -> [] | (lg, rg) :: l -> diff --git a/interp/constrarg.ml b/interp/constrarg.ml index a67143b005..44623f9c9a 100644 --- a/interp/constrarg.ml +++ b/interp/constrarg.ml @@ -22,7 +22,8 @@ let loc_of_or_by_notation f = function let unsafe_of_type (t : argument_type) : ('a, 'b, 'c) Genarg.genarg_type = Obj.magic t -let wit_int_or_var = unsafe_of_type IntOrVarArgType +let wit_int_or_var = + Genarg.make0 ~dyn:(val_tag (topwit Stdarg.wit_int)) None "int_or_var" let wit_intro_pattern : (Constrexpr.constr_expr intro_pattern_expr located, glob_constr_and_expr intro_pattern_expr located, intro_pattern) genarg_type = Genarg.make0 None "intropattern" @@ -38,18 +39,17 @@ let wit_ref = Genarg.make0 None "ref" let wit_quant_hyp = Genarg.make0 None "quant_hyp" -let wit_genarg = unsafe_of_type GenArgType - let wit_sort : (glob_sort, glob_sort, sorts) genarg_type = Genarg.make0 None "sort" let wit_constr = unsafe_of_type ConstrArgType -let wit_constr_may_eval = unsafe_of_type ConstrMayEvalArgType +let wit_constr_may_eval = + Genarg.make0 ~dyn:(val_tag (topwit wit_constr)) None "constr_may_eval" let wit_uconstr = Genarg.make0 None "uconstr" -let wit_open_constr = unsafe_of_type OpenConstrArgType +let wit_open_constr = Genarg.make0 ~dyn:(val_tag (topwit wit_constr)) None "open_constr" let wit_constr_with_bindings = Genarg.make0 None "constr_with_bindings" @@ -66,11 +66,14 @@ let wit_clause_dft_concl = (** Register location *) let () = + register_name0 wit_int_or_var "Constrarg.wit_int_or_var"; register_name0 wit_ref "Constrarg.wit_ref"; register_name0 wit_intro_pattern "Constrarg.wit_intro_pattern"; register_name0 wit_tactic "Constrarg.wit_tactic"; register_name0 wit_sort "Constrarg.wit_sort"; register_name0 wit_uconstr "Constrarg.wit_uconstr"; + register_name0 wit_open_constr "Constrarg.wit_open_constr"; + register_name0 wit_constr_may_eval "Constrarg.wit_constr_may_eval"; register_name0 wit_red_expr "Constrarg.wit_red_expr"; register_name0 wit_clause_dft_concl "Constrarg.wit_clause_dft_concl"; register_name0 wit_quant_hyp "Constrarg.wit_quant_hyp"; diff --git a/interp/constrarg.mli b/interp/constrarg.mli index fdeddd66a1..0cc111e617 100644 --- a/interp/constrarg.mli +++ b/interp/constrarg.mli @@ -26,7 +26,7 @@ val loc_of_or_by_notation : ('a -> Loc.t) -> 'a or_by_notation -> Loc.t (** {5 Additional generic arguments} *) -val wit_int_or_var : int or_var uniform_genarg_type +val wit_int_or_var : (int or_var, int or_var, int) genarg_type val wit_intro_pattern : (constr_expr intro_pattern_expr located, glob_constr_and_expr intro_pattern_expr located, intro_pattern) genarg_type @@ -38,8 +38,6 @@ val wit_ref : (reference, global_reference located or_var, global_reference) gen val wit_quant_hyp : quantified_hypothesis uniform_genarg_type -val wit_genarg : (raw_generic_argument, glob_generic_argument, typed_generic_argument) genarg_type - val wit_sort : (glob_sort, glob_sort, sorts) genarg_type val wit_constr : (constr_expr, glob_constr_and_expr, constr) genarg_type @@ -52,17 +50,17 @@ val wit_constr_may_eval : val wit_uconstr : (constr_expr , glob_constr_and_expr, Glob_term.closed_glob_constr) genarg_type val wit_open_constr : - (open_constr_expr, open_glob_constr, Evd.open_constr) genarg_type + (constr_expr, glob_constr_and_expr, constr) genarg_type val wit_constr_with_bindings : (constr_expr with_bindings, glob_constr_and_expr with_bindings, - constr with_bindings Evd.sigma) genarg_type + constr with_bindings delayed_open) genarg_type val wit_bindings : (constr_expr bindings, glob_constr_and_expr bindings, - constr bindings Evd.sigma) genarg_type + constr bindings delayed_open) genarg_type val wit_hyp_location_flag : Locus.hyp_location_flag uniform_genarg_type diff --git a/interp/constrextern.ml b/interp/constrextern.ml index ed85c38de0..5c9e80df3d 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -462,15 +462,6 @@ let is_needed_for_correct_partial_application tail imp = exception Expl -let params_implicit n impl = - let rec aux n impl = - if n == 0 then true - else match impl with - | [] -> false - | imp :: impl when is_status_implicit imp -> aux (pred n) impl - | _ -> false - in aux n impl - (* Implicit args indexes are in ascending order *) (* inctx is useful only if there is a last argument to be deduced from ctxt *) let explicitize loc inctx impl (cf,f) args = diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 918b75b0c1..68bc0b1092 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -698,19 +698,6 @@ let intern_var genv (ltacvars,ntnvars) namedctx loc id = (* [id] a goal variable *) GVar (loc,id), [], [], [] -let proj_impls r impls = - let env = Global.env () in - let f (x, l) = x, projection_implicits env r l in - List.map f impls - -let proj_scopes n scopes = - List.skipn_at_least n scopes - -let proj_impls_scopes p impls scopes = - match p with - | Some (r, n) -> proj_impls r impls, proj_scopes n scopes - | None -> impls, scopes - let find_appl_head_data c = match c with | GRef (loc,ref,_) as x -> @@ -1386,7 +1373,7 @@ let internalize globalenv env allow_patvar lvar c = let (env',rbefore) = List.fold_left intern_local_binder (env,[]) before in let ro = f (intern env') in - let n' = Option.map (fun _ -> List.length (List.filter (fun (_,(_,_,b,_)) -> (* remove let-ins *) b = None) rbefore)) n in + let n' = Option.map (fun _ -> List.count (fun (_,(_,_,b,_)) -> (* remove let-ins *) b = None) rbefore) n in n', ro, List.fold_left intern_local_binder (env',rbefore) after in let n, ro, (env',rbl) = diff --git a/interp/coqlib.ml b/interp/coqlib.ml index 5ac718e3b0..b309f26cd6 100644 --- a/interp/coqlib.ml +++ b/interp/coqlib.ml @@ -87,7 +87,7 @@ let check_required_library d = *) (* or failing ...*) errorlabstrm "Coqlib.check_required_library" - (str "Library " ++ str (DirPath.to_string dir) ++ str " has to be required first.") + (str "Library " ++ pr_dirpath dir ++ str " has to be required first.") (************************************************************************) (* Specific Coq objects *) diff --git a/interp/dumpglob.ml b/interp/dumpglob.ml index c18ceecaba..c7d3da653c 100644 --- a/interp/dumpglob.ml +++ b/interp/dumpglob.ml @@ -139,12 +139,15 @@ let interval loc = loc1, loc2-1 let dump_ref loc filepath modpath ident ty = - if !glob_output = Feedback then + match !glob_output with + | Feedback -> Pp.feedback (Feedback.GlobRef (loc, filepath, modpath, ident, ty)) - else + | NoGlob -> () + | _ when not (Loc.is_ghost loc) -> let bl,el = interval loc in dump_string (Printf.sprintf "R%d:%d %s %s %s %s\n" bl el filepath modpath ident ty) + | _ -> () let dump_reference loc modpath ident ty = let filepath = Names.DirPath.to_string (Lib.library_dp ()) in diff --git a/intf/tacexpr.mli b/intf/tacexpr.mli index ead221c5fb..05e7ea1a3b 100644 --- a/intf/tacexpr.mli +++ b/intf/tacexpr.mli @@ -162,10 +162,6 @@ type 'a gen_atomic_tactic_expr = rec_flag * evars_flag * ('trm,'dtrm,'nam) induction_clause_list | TacDoubleInduction of quantified_hypothesis * quantified_hypothesis - (* Automation tactics *) - | TacTrivial of debug * 'trm list * string list option - | TacAuto of debug * int or_var option * 'trm list * string list option - (* Context management *) | TacClear of bool * 'nam list | TacClearBody of 'nam list @@ -296,9 +292,9 @@ and 'a gen_tactic_expr = | TacFun of 'a gen_tactic_fun_ast | TacArg of 'a gen_tactic_arg located (* For ML extensions *) - | TacML of Loc.t * ml_tactic_entry * 'l generic_argument list + | TacML of Loc.t * ml_tactic_entry * 'a gen_tactic_arg list (* For syntax extensions *) - | TacAlias of Loc.t * KerName.t * (Id.t * 'l generic_argument) list + | TacAlias of Loc.t * KerName.t * 'a gen_tactic_arg list constraint 'a = < term:'t; diff --git a/intf/vernacexpr.mli b/intf/vernacexpr.mli index 4bc3a9e609..3bb86fcb20 100644 --- a/intf/vernacexpr.mli +++ b/intf/vernacexpr.mli @@ -205,7 +205,7 @@ type proof_expr = type grammar_tactic_prod_item_expr = | TacTerm of string - | TacNonTerm of Loc.t * string * (Names.Id.t * string) option + | TacNonTerm of Loc.t * string * (Names.Id.t * string) type syntax_modifier = | SetItemLevel of string list * Extend.production_level diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml index 5ba93eda05..61042ccc17 100644 --- a/kernel/cemitcodes.ml +++ b/kernel/cemitcodes.ml @@ -306,8 +306,6 @@ let init () = type emitcodes = string -let copy = String.copy - let length = String.length type to_patch = emitcodes * (patch list) * fv @@ -332,8 +330,6 @@ let subst_patch s (ri,pos) = let subst_to_patch s (code,pl,fv) = code,List.rev_map (subst_patch s) pl,fv -let subst_pconstant s (kn, u) = (fst (subst_con_kn s kn), u) - type body_code = | BCdefined of to_patch | BCalias of Names.constant diff --git a/kernel/declarations.mli b/kernel/declarations.mli index 981dfe05ef..ebf12bd60d 100644 --- a/kernel/declarations.mli +++ b/kernel/declarations.mli @@ -237,17 +237,26 @@ and module_body = { mod_mp : module_path; (** absolute path of the module *) mod_expr : module_implementation; (** implementation *) mod_type : module_signature; (** expanded type *) - (** algebraic type, kept if it's relevant for extraction *) - mod_type_alg : module_expression option; - (** set of all universes constraints in the module *) - mod_constraints : Univ.ContextSet.t; - (** quotiented set of equivalent constants and inductive names *) - mod_delta : Mod_subst.delta_resolver; + mod_type_alg : module_expression option; (** algebraic type *) + mod_constraints : Univ.ContextSet.t; (** + set of all universes constraints in the module *) + mod_delta : Mod_subst.delta_resolver; (** + quotiented set of equivalent constants and inductive names *) mod_retroknowledge : Retroknowledge.action list } +(** For a module, there are five possible situations: + - [Declare Module M : T] then [mod_expr = Abstract; mod_type_alg = Some T] + - [Module M := E] then [mod_expr = Algebraic E; mod_type_alg = None] + - [Module M : T := E] then [mod_expr = Algebraic E; mod_type_alg = Some T] + - [Module M. ... End M] then [mod_expr = FullStruct; mod_type_alg = None] + - [Module M : T. ... End M] then [mod_expr = Struct; mod_type_alg = Some T] + And of course, all these situations may be functors or not. *) + (** A [module_type_body] is just a [module_body] with no implementation ([mod_expr] always [Abstract]) and also - an empty [mod_retroknowledge] *) + an empty [mod_retroknowledge]. Its [mod_type_alg] contains + the algebraic definition of this module type, or [None] + if it has been built interactively. *) and module_type_body = module_body diff --git a/kernel/declareops.ml b/kernel/declareops.ml index 6239d3c8d6..cc11b98c3d 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -391,5 +391,3 @@ and hcons_module_body mb = mod_delta = delta'; mod_retroknowledge = retroknowledge'; } - -and hcons_module_type_body mtb = hcons_module_body mtb diff --git a/kernel/inductive.ml b/kernel/inductive.ml index f9a6e04c12..7bf1bfeb2d 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -150,7 +150,7 @@ let remember_subst u subst = (* Bind expected levels of parameters to actual levels *) (* Propagate the new levels in the signature *) -let rec make_subst env = +let make_subst env = let rec make subst = function | (_,Some _,_)::sign, exp, args -> make subst (sign, exp, args) diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index 3c58e788c7..3a75a74d91 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -21,7 +21,7 @@ open Modops open Mod_subst type 'alg translation = - module_signature * 'alg option * delta_resolver * Univ.ContextSet.t + module_signature * 'alg * delta_resolver * Univ.ContextSet.t let rec mp_from_mexpr = function | MEident mp -> mp @@ -183,8 +183,11 @@ let rec check_with_mod env struc (idl,mp1) mp equiv = begin try let mtb_old = module_type_of_module old in - Univ.ContextSet.add_constraints (Subtyping.check_subtypes env' mtb_mp1 mtb_old) old.mod_constraints - with Failure _ -> error_incorrect_with_constraint lab + let chk_cst = Subtyping.check_subtypes env' mtb_mp1 mtb_old in + Univ.ContextSet.add_constraints chk_cst old.mod_constraints + with Failure _ -> + (* TODO: where can a Failure come from ??? *) + error_incorrect_with_constraint lab end | Algebraic (NoFunctor (MEident(mp'))) -> check_modpath_equiv env' mp1 mp'; @@ -238,104 +241,89 @@ let rec check_with_mod env struc (idl,mp1) mp equiv = | Not_found -> error_no_such_label lab | Reduction.NotConvertible -> error_incorrect_with_constraint lab -let mk_alg_with alg wd = Option.map (fun a -> MEwith (a,wd)) alg - let check_with env mp (sign,alg,reso,cst) = function |WithDef(idl,c) -> let struc = destr_nofunctor sign in let struc',c',cst' = check_with_def env struc (idl,c) mp reso in - let alg' = mk_alg_with alg (WithDef (idl,(c',Univ.ContextSet.to_context cst'))) in - (NoFunctor struc'),alg',reso, cst+++cst' + let wd' = WithDef (idl,(c',Univ.ContextSet.to_context cst')) in + NoFunctor struc', MEwith (alg,wd'), reso, cst+++cst' |WithMod(idl,mp1) as wd -> let struc = destr_nofunctor sign in let struc',reso',cst' = check_with_mod env struc (idl,mp1) mp reso in - let alg' = mk_alg_with alg wd in - (NoFunctor struc'),alg',reso', cst+++cst' + NoFunctor struc', MEwith (alg,wd), reso', cst+++cst' -let mk_alg_app mpo alg arg = match mpo, alg with - | Some _, Some alg -> Some (MEapply (alg,arg)) - | _ -> None +let translate_apply env inl (sign,alg,reso,cst1) mp1 mkalg = + let farg_id, farg_b, fbody_b = destr_functor sign in + let mtb = module_type_of_module (lookup_module mp1 env) in + let cst2 = Subtyping.check_subtypes env mtb farg_b in + let mp_delta = discr_resolver mtb in + let mp_delta = inline_delta_resolver env inl mp1 farg_id farg_b mp_delta in + let subst = map_mbid farg_id mp1 mp_delta in + let body = subst_signature subst fbody_b in + let alg' = mkalg alg mp1 in + let reso' = subst_codom_delta_resolver subst reso in + body,alg',reso', Univ.ContextSet.add_constraints cst2 cst1 (** Translation of a module struct entry : - We translate to a module when a [module_path] is given, otherwise to a module type. - The first output is the expanded signature - The second output is the algebraic expression, kept for the extraction. - It is never None when translating to a module, but for module type - it could not be contain [SEBapply] or [SEBfunctor]. *) +let mk_alg_app alg arg = MEapply (alg,arg) + let rec translate_mse env mpo inl = function - |MEident mp1 -> - let sign,reso = match mpo with - |Some mp -> - let mb = strengthen_and_subst_mb (lookup_module mp1 env) mp false in - mb.mod_type, mb.mod_delta - |None -> - let mtb = lookup_modtype mp1 env in - mtb.mod_type, mtb.mod_delta + |MEident mp1 as me -> + let mb = match mpo with + |Some mp -> strengthen_and_subst_mb (lookup_module mp1 env) mp false + |None -> lookup_modtype mp1 env in - sign,Some (MEident mp1),reso,Univ.ContextSet.empty + mb.mod_type, me, mb.mod_delta, Univ.ContextSet.empty |MEapply (fe,mp1) -> - translate_apply env inl (translate_mse env mpo inl fe) mp1 (mk_alg_app mpo) + translate_apply env inl (translate_mse env mpo inl fe) mp1 mk_alg_app |MEwith(me, with_decl) -> assert (mpo == None); (* No 'with' syntax for modules *) let mp = mp_from_mexpr me in check_with env mp (translate_mse env None inl me) with_decl -and translate_apply env inl (sign,alg,reso,cst1) mp1 mkalg = - let farg_id, farg_b, fbody_b = destr_functor sign in - let mtb = module_type_of_module (lookup_module mp1 env) in - let cst2 = Subtyping.check_subtypes env mtb farg_b in - let mp_delta = discr_resolver mtb in - let mp_delta = inline_delta_resolver env inl mp1 farg_id farg_b mp_delta in - let subst = map_mbid farg_id mp1 mp_delta in - let body = subst_signature subst fbody_b in - let alg' = mkalg alg mp1 in - let reso' = subst_codom_delta_resolver subst reso in - body,alg',reso', Univ.ContextSet.add_constraints cst2 cst1 - -let mk_alg_funct mpo mbid mtb alg = match mpo, alg with - | Some _, Some alg -> Some (MoreFunctor (mbid,mtb,alg)) - | _ -> None - -let mk_mod mp e ty ty' cst reso = +let mk_mod mp e ty cst reso = { mod_mp = mp; mod_expr = e; mod_type = ty; - mod_type_alg = ty'; + mod_type_alg = None; mod_constraints = cst; mod_delta = reso; mod_retroknowledge = [] } -let mk_modtype mp ty cst reso = mk_mod mp Abstract ty None cst reso +let mk_modtype mp ty cst reso = mk_mod mp Abstract ty cst reso let rec translate_mse_funct env mpo inl mse = function |[] -> let sign,alg,reso,cst = translate_mse env mpo inl mse in - sign, Option.map (fun a -> NoFunctor a) alg, reso, cst + sign, NoFunctor alg, reso, cst |(mbid, ty) :: params -> let mp_id = MPbound mbid in let mtb = translate_modtype env mp_id inl ([],ty) in let env' = add_module_type mp_id mtb env in let sign,alg,reso,cst = translate_mse_funct env' mpo inl mse params in - let alg' = mk_alg_funct mpo mbid mtb alg in + let alg' = MoreFunctor (mbid,mtb,alg) in MoreFunctor (mbid, mtb, sign), alg',reso, cst +++ mtb.mod_constraints and translate_modtype env mp inl (params,mte) = let sign,alg,reso,cst = translate_mse_funct env None inl mte params in let mtb = mk_modtype (mp_from_mexpr mte) sign cst reso in let mtb' = subst_modtype_and_resolver mtb mp in - { mtb' with mod_type_alg = alg } + { mtb' with mod_type_alg = Some alg } (** [finalize_module] : - from an already-translated (or interactive) implementation - and a signature entry, produce a final [module_expr] *) + from an already-translated (or interactive) implementation and + an (optional) signature entry, produces a final [module_body] *) let finalize_module env mp (sign,alg,reso,cst) restype = match restype with |None -> let impl = match alg with Some e -> Algebraic e | None -> FullStruct in - mk_mod mp impl sign None cst reso + mk_mod mp impl sign cst reso |Some (params_mte,inl) -> let res_mtb = translate_modtype env mp inl params_mte in let auto_mtb = mk_modtype mp sign Univ.ContextSet.empty reso in @@ -344,33 +332,59 @@ let finalize_module env mp (sign,alg,reso,cst) restype = match restype with { res_mtb with mod_mp = mp; mod_expr = impl; - (** cst from module body typing, cst' from subtyping, - and constraints from module type. *) - mod_constraints = Univ.ContextSet.add_constraints cst' (cst +++ res_mtb.mod_constraints) } + (** cst from module body typing, + cst' from subtyping, + constraints from module type. *) + mod_constraints = + Univ.ContextSet.add_constraints cst' (cst +++ res_mtb.mod_constraints) } let translate_module env mp inl = function |MType (params,ty) -> let mtb = translate_modtype env mp inl (params,ty) in module_body_of_type mp mtb |MExpr (params,mse,oty) -> - let t = translate_mse_funct env (Some mp) inl mse params in + let (sg,alg,reso,cst) = translate_mse_funct env (Some mp) inl mse params in let restype = Option.map (fun ty -> ((params,ty),inl)) oty in - finalize_module env mp t restype + finalize_module env mp (sg,Some alg,reso,cst) restype + +(** We now forbid any Include of functors with restricted signatures. + Otherwise, we could end with the creation of undesired axioms + (see #3746). Note that restricted non-functorized modules are ok, + thanks to strengthening. *) + +let rec unfunct = function + |NoFunctor me -> me + |MoreFunctor(_,_,me) -> unfunct me + +let rec forbid_incl_signed_functor env = function + |MEapply(fe,_) -> forbid_incl_signed_functor env fe + |MEwith _ -> assert false (* No 'with' syntax for modules *) + |MEident mp1 -> + let mb = lookup_module mp1 env in + match mb.mod_type, mb.mod_type_alg, mb.mod_expr with + |MoreFunctor _, Some _, _ -> + (* functor + restricted signature = error *) + error_include_restricted_functor mp1 + |MoreFunctor _, None, Algebraic me -> + (* functor, no signature yet, a definition which may be restricted *) + forbid_incl_signed_functor env (unfunct me) + |_ -> () let rec translate_mse_inclmod env mp inl = function |MEident mp1 -> let mb = strengthen_and_subst_mb (lookup_module mp1 env) mp true in let sign = clean_bounded_mod_expr mb.mod_type in - sign,None,mb.mod_delta,Univ.ContextSet.empty + sign,(),mb.mod_delta,Univ.ContextSet.empty |MEapply (fe,arg) -> let ftrans = translate_mse_inclmod env mp inl fe in - translate_apply env inl ftrans arg (fun _ _ -> None) + translate_apply env inl ftrans arg (fun _ _ -> ()) |MEwith _ -> assert false (* No 'with' syntax for modules *) let translate_mse_incl is_mod env mp inl me = if is_mod then + let () = forbid_incl_signed_functor env me in translate_mse_inclmod env mp inl me else let mtb = translate_modtype env mp inl ([],me) in let sign = clean_bounded_mod_expr mtb.mod_type in - sign,None,mtb.mod_delta,mtb.mod_constraints + sign,(),mtb.mod_delta,mtb.mod_constraints diff --git a/kernel/mod_typing.mli b/kernel/mod_typing.mli index bc0e20205a..d07d59dd9b 100644 --- a/kernel/mod_typing.mli +++ b/kernel/mod_typing.mli @@ -14,9 +14,18 @@ open Names (** Main functions for translating module entries *) +(** [translate_module] produces a [module_body] out of a [module_entry]. + In the output fields: + - [mod_expr] is [Abstract] for a [MType] entry, or [Algebraic] for [MExpr]. + - [mod_type_alg] is [None] only for a [MExpr] without explicit signature. +*) + val translate_module : env -> module_path -> inline -> module_entry -> module_body +(** [translate_modtype] produces a [module_type_body] whose [mod_type_alg] + cannot be [None] (and of course [mod_expr] is [Abstract]). *) + val translate_modtype : env -> module_path -> inline -> module_type_entry -> module_type_body @@ -24,20 +33,21 @@ val translate_modtype : - We translate to a module when a [module_path] is given, otherwise to a module type. - The first output is the expanded signature - - The second output is the algebraic expression, kept for the extraction. - It is never None when translating to a module, but for module type - it could not be contain applications or functors. -*) + - The second output is the algebraic expression, kept mostly for + the extraction. *) type 'alg translation = - module_signature * 'alg option * delta_resolver * Univ.ContextSet.t + module_signature * 'alg * delta_resolver * Univ.ContextSet.t val translate_mse : env -> module_path option -> inline -> module_struct_entry -> module_alg_expr translation +(** From an already-translated (or interactive) implementation and + an (optional) signature entry, produces a final [module_body] *) + val finalize_module : - env -> module_path -> module_expression translation -> + env -> module_path -> (module_expression option) translation -> (module_type_entry * inline) option -> module_body @@ -46,4 +56,4 @@ val finalize_module : val translate_mse_incl : bool -> env -> module_path -> inline -> module_struct_entry -> - module_alg_expr translation + unit translation diff --git a/kernel/modops.ml b/kernel/modops.ml index cbb7963315..341c3993a3 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -67,15 +67,13 @@ type module_typing_error = | IncorrectWithConstraint of Label.t | GenerativeModuleExpected of Label.t | LabelMissing of Label.t * string + | IncludeRestrictedFunctor of module_path exception ModuleTypingError of module_typing_error let error_existing_label l = raise (ModuleTypingError (LabelAlreadyDeclared l)) -let error_application_to_not_path mexpr = - raise (ModuleTypingError (ApplicationToNotPath mexpr)) - let error_not_a_functor () = raise (ModuleTypingError NotAFunctor) @@ -112,6 +110,9 @@ let error_generative_module_expected l = let error_no_such_label_sub l l1 = raise (ModuleTypingError (LabelMissing (l,l1))) +let error_include_restricted_functor mp = + raise (ModuleTypingError (IncludeRestrictedFunctor mp)) + (** {6 Operations on functors } *) let is_functor = function diff --git a/kernel/modops.mli b/kernel/modops.mli index a335ad9b4a..86aae598c2 100644 --- a/kernel/modops.mli +++ b/kernel/modops.mli @@ -126,13 +126,12 @@ type module_typing_error = | IncorrectWithConstraint of Label.t | GenerativeModuleExpected of Label.t | LabelMissing of Label.t * string + | IncludeRestrictedFunctor of module_path exception ModuleTypingError of module_typing_error val error_existing_label : Label.t -> 'a -val error_application_to_not_path : module_struct_entry -> 'a - val error_incompatible_modtypes : module_type_body -> module_type_body -> 'a @@ -152,3 +151,5 @@ val error_incorrect_with_constraint : Label.t -> 'a val error_generative_module_expected : Label.t -> 'a val error_no_such_label_sub : Label.t->string->'a + +val error_include_restricted_functor : module_path -> 'a diff --git a/kernel/names.mli b/kernel/names.mli index d424552e44..df296ab6c6 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -409,7 +409,7 @@ end module Mindset : CSig.SetS with type elt = MutInd.t module Mindmap : Map.ExtS with type key = MutInd.t and module Set := Mindset -module Mindmap_env : Map.S with type key = MutInd.t +module Mindmap_env : CSig.MapS with type key = MutInd.t (** Designation of a (particular) inductive type. *) type inductive = MutInd.t (* the name of the inductive type *) @@ -422,10 +422,10 @@ type constructor = inductive (* designates the inductive type *) * int (* the index of the constructor BEWARE: indexing starts from 1. *) -module Indmap : Map.S with type key = inductive -module Constrmap : Map.S with type key = constructor -module Indmap_env : Map.S with type key = inductive -module Constrmap_env : Map.S with type key = constructor +module Indmap : CSig.MapS with type key = inductive +module Constrmap : CSig.MapS with type key = constructor +module Indmap_env : CSig.MapS with type key = inductive +module Constrmap_env : CSig.MapS with type key = constructor val ind_modpath : inductive -> ModPath.t val constr_modpath : constructor -> ModPath.t diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index 4d033bc999..3ff9b5702c 100644 --- a/kernel/nativelambda.ml +++ b/kernel/nativelambda.ml @@ -485,7 +485,7 @@ module Renv = let pop env = Vect.pop env.name_rel let popn env n = - for i = 1 to n do pop env done + for _i = 1 to n do pop env done let get env n = Lrel (Vect.get_last env.name_rel (n-1), n) diff --git a/kernel/nativevalues.ml b/kernel/nativevalues.ml index 40bef4bc67..6e097b6133 100644 --- a/kernel/nativevalues.ml +++ b/kernel/nativevalues.ml @@ -78,8 +78,6 @@ let accumulate_code (k:accumulator) (x:t) = let rec accumulate (x:t) = accumulate_code (Obj.magic accumulate) x -let raccumulate = ref accumulate - let mk_accu_gen rcode (a:atom) = (* Format.eprintf "size rcode =%i\n" (Obj.size (Obj.magic rcode)); *) let r = Obj.new_block 0 3 in @@ -160,31 +158,6 @@ let is_accu x = let o = Obj.repr x in Obj.is_block o && Int.equal (Obj.tag o) accumulate_tag -(*let accumulate_fix_code (k:accumulator) (a:t) = - match atom_of_accu k with - | Afix(frec,_,rec_pos,_,_) -> - let nargs = accu_nargs k in - if nargs <> rec_pos || is_accu a then - accumulate_code k a - else - let r = ref frec in - for i = 0 to nargs - 1 do - r := !r (arg_of_accu k i) - done; - !r a - | _ -> assert false - - -let rec accumulate_fix (x:t) = - accumulate_fix_code (Obj.magic accumulate_fix) x - -let raccumulate_fix = ref accumulate_fix *) - -let is_atom_fix (a:atom) = - match a with - | Afix _ -> true - | _ -> false - let mk_fix_accu rec_pos pos types bodies = mk_accu_gen accumulate (Afix(types,bodies,rec_pos, pos)) diff --git a/kernel/pre_env.mli b/kernel/pre_env.mli index 9cd940a881..1e95a3564d 100644 --- a/kernel/pre_env.mli +++ b/kernel/pre_env.mli @@ -9,7 +9,6 @@ open Names open Term open Declarations -open Univ (** The type of environments. *) diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index f86fdfa971..33aa2972b2 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -222,13 +222,6 @@ let inline_private_constants_in_constr = Term_typing.inline_side_effects let inline_private_constants_in_definition_entry = Term_typing.inline_entry_side_effects let side_effects_of_private_constants x = Term_typing.uniq_seff (List.rev x) -let constant_entry_of_private_constant = function - | { Entries.eff = Entries.SEsubproof (kn, cb, eff_env) } -> - [ kn, Term_typing.constant_entry_of_side_effect cb eff_env ] - | { Entries.eff = Entries.SEscheme (l,_) } -> - List.map (fun (_,kn,cb,eff_env) -> - kn, Term_typing.constant_entry_of_side_effect cb eff_env) l - let private_con_of_con env c = let cbo = Environ.lookup_constant c env.env in { Entries.from_env = Ephemeron.create env.revstruct; @@ -748,7 +741,7 @@ let end_modtype l senv = let add_include me is_module inl senv = let open Mod_typing in let mp_sup = senv.modpath in - let sign,_,resolver,cst = + let sign,(),resolver,cst = translate_mse_incl is_module senv.env mp_sup inl me in let senv = add_constraints (Now (false, cst)) senv in diff --git a/kernel/term.ml b/kernel/term.ml index 19f4b7a234..24f82a9ec8 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -485,8 +485,6 @@ let lambda_applist c l = let lambda_appvect c v = lambda_applist c (Array.to_list v) -let lambda_app c a = lambda_applist c [a] - let lambda_applist_assum n c l = let rec app n subst t l = if Int.equal n 0 then @@ -500,15 +498,6 @@ let lambda_applist_assum n c l = let lambda_appvect_assum n c v = lambda_applist_assum n c (Array.to_list v) -(* pseudo-reduction rule: - * [prod_app s (Prod(_,B)) N --> B[N] - * with an strip_outer_cast on the first argument to produce a product *) - -let prod_app t n = - match kind_of_term (strip_outer_cast t) with - | Prod (_,_,b) -> subst1 n b - | _ -> anomaly (str"Needed a product, but didn't find one") - (* prod_applist T [ a1 ; ... ; an ] -> (T a1 ... an) *) let prod_applist c l = let rec app subst c l = diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index db50a393b5..a4e119f0b4 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -423,11 +423,16 @@ let export_side_effects mb env ce = let trusted = check_signatures mb signatures in let push_seff env = function | kn, cb, `Nothing, _ -> - Environ.add_constant kn cb env + let env = Environ.add_constant kn cb env in + if not cb.const_polymorphic then + Environ.push_context ~strict:true cb.const_universes env + else env | kn, cb, `Opaque(_, ctx), _ -> - let env = Environ.add_constant kn cb env in - Environ.push_context_set - ~strict:(not cb.const_polymorphic) ctx env in + let env = Environ.add_constant kn cb env in + if not cb.const_polymorphic then + let env = Environ.push_context ~strict:true cb.const_universes env in + Environ.push_context_set ~strict:true ctx env + else env in let rec translate_seff sl seff acc env = match sl, seff with | _, [] -> List.rev acc, ce diff --git a/kernel/uGraph.ml b/kernel/uGraph.ml index 9e8ffbc7f2..6765f91ee1 100644 --- a/kernel/uGraph.ml +++ b/kernel/uGraph.ml @@ -139,7 +139,6 @@ let rec repr g u = | Equiv v -> repr g v | Canonical arc -> arc -let get_prop_arc g = repr g Level.prop let get_set_arc g = repr g Level.set let is_set_arc u = Level.is_set u.univ let is_prop_arc u = Level.is_prop u.univ @@ -155,7 +154,7 @@ let use_index g u = (* [safe_repr] is like [repr] but if the graph doesn't contain the searched universe, we add it. *) -let rec safe_repr g u = +let safe_repr g u = let rec safe_repr_rec entries u = match UMap.find u entries with | Equiv v -> safe_repr_rec entries v @@ -278,7 +277,7 @@ exception CycleDetected problems. arXiv preprint arXiv:1112.0784. *) (* [delta] is the timeout for backward search. It might be - usefull to tune a multiplicative constant. *) + useful to tune a multiplicative constant. *) let get_delta g = int_of_float (min (float_of_int g.n_edges ** 0.5) @@ -669,7 +668,7 @@ let check_leq g u v = is_type0m_univ u || check_eq_univs g u v || real_check_leq g u v -(* enforc_univ_eq g u v will force u=v if possible, will fail otherwise *) +(* enforce_univ_eq g u v will force u=v if possible, will fail otherwise *) let rec enforce_univ_eq u v g = let ucan = repr g u in @@ -745,9 +744,6 @@ let check_constraints c g = (* Normalization *) -let lookup_level u g = - try Some (UMap.find u g) with Not_found -> None - (** [normalize_universes g] returns a graph where all edges point directly to the canonical representent of their target. The output graph should be equivalent to the input graph from a logical point diff --git a/lib/cList.ml b/lib/cList.ml index 0ac372d8d8..bd3e09b5b2 100644 --- a/lib/cList.ml +++ b/lib/cList.ml @@ -48,6 +48,7 @@ sig val filteri : (int -> 'a -> bool) -> 'a list -> 'a list val smartfilter : ('a -> bool) -> 'a list -> 'a list + val count : ('a -> bool) -> 'a list -> int val index : 'a eq -> 'a -> 'a list -> int val index0 : 'a eq -> 'a -> 'a list -> int val iteri : (int -> 'a -> unit) -> 'a list -> unit @@ -375,6 +376,12 @@ let rec smartfilter f l = match l with else h :: tl' else tl' +let count f l = + let rec aux acc = function + | [] -> acc + | h :: t -> if f h then aux (acc + 1) t else aux acc t in + aux 0 l + let rec index_f f x l n = match l with | [] -> raise Not_found | y :: l -> if f x y then n else index_f f x l (succ n) @@ -638,12 +645,13 @@ let rec split3 = function let (rx, ry, rz) = split3 l in (x::rx, y::ry, z::rz) let firstn n l = - let rec aux acc = function - | (0, l) -> List.rev acc - | (n, (h::t)) -> aux (h::acc) (pred n, t) + let rec aux acc n l = + match n, l with + | 0, _ -> List.rev acc + | n, h::t -> aux (h::acc) (pred n) t | _ -> failwith "firstn" in - aux [] (n,l) + aux [] n l let rec last = function | [] -> failwith "List.last" diff --git a/lib/cList.mli b/lib/cList.mli index 19eeb2509a..1487f67a37 100644 --- a/lib/cList.mli +++ b/lib/cList.mli @@ -94,6 +94,8 @@ sig (** [smartfilter f [a1...an] = List.filter f [a1...an]] but if for all i [f ai = true], then [smartfilter f l == l] *) + val count : ('a -> bool) -> 'a list -> int + val index : 'a eq -> 'a -> 'a list -> int (** [index] returns the 1st index of an element in a list (counting from 1). *) diff --git a/lib/cMap.ml b/lib/cMap.ml index 876f847365..925af00c02 100644 --- a/lib/cMap.ml +++ b/lib/cMap.ml @@ -23,7 +23,7 @@ module type S = Map.S module type ExtS = sig - include Map.S + include CSig.MapS module Set : CSig.SetS with type elt = key val update : key -> 'a -> 'a t -> 'a t val modify : key -> (key -> 'a -> 'a) -> 'a t -> 'a t diff --git a/lib/cMap.mli b/lib/cMap.mli index cd3d2f5b19..f032a6d7d8 100644 --- a/lib/cMap.mli +++ b/lib/cMap.mli @@ -25,7 +25,7 @@ module type S = Map.S module type ExtS = sig - include Map.S + include CSig.MapS (** The underlying Map library *) module Set : CSig.SetS with type elt = key diff --git a/lib/cSig.mli b/lib/cSig.mli index 796e58cbfb..151cfbdca5 100644 --- a/lib/cSig.mli +++ b/lib/cSig.mli @@ -49,3 +49,34 @@ end documentation for more information. *) module type EmptyS = sig end + +module type MapS = +sig + type key + type (+'a) t + val empty: 'a t + val is_empty: 'a t -> bool + val mem: key -> 'a t -> bool + val add: key -> 'a -> 'a t -> 'a t + val singleton: key -> 'a -> 'a t + val remove: key -> 'a t -> 'a t + val merge: + (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t + val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int + val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool + val iter: (key -> 'a -> unit) -> 'a t -> unit + val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + val for_all: (key -> 'a -> bool) -> 'a t -> bool + val exists: (key -> 'a -> bool) -> 'a t -> bool + val filter: (key -> 'a -> bool) -> 'a t -> 'a t + val partition: (key -> 'a -> bool) -> 'a t -> 'a t * 'a t + val cardinal: 'a t -> int + val bindings: 'a t -> (key * 'a) list + val min_binding: 'a t -> (key * 'a) + val max_binding: 'a t -> (key * 'a) + val choose: 'a t -> (key * 'a) + val split: key -> 'a t -> 'a t * 'a option * 'a t + val find: key -> 'a t -> 'a + val map: ('a -> 'b) -> 'a t -> 'b t + val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t +end diff --git a/lib/clib.mllib b/lib/clib.mllib index 1770df1993..3c1c5da33c 100644 --- a/lib/clib.mllib +++ b/lib/clib.mllib @@ -19,11 +19,11 @@ Pp_control Flags Control Loc +CList +CString Serialize Deque CObj -CList -CString CArray CStack Util diff --git a/lib/genarg.ml b/lib/genarg.ml index 8712eda8e1..6108c15555 100644 --- a/lib/genarg.ml +++ b/lib/genarg.ml @@ -9,29 +9,67 @@ open Pp open Util +module Dyn = Dyn.Make(struct end) + +module Val = +struct + + type 'a typ = 'a Dyn.tag + + type _ tag = + | Base : 'a typ -> 'a tag + | List : 'a tag -> 'a list tag + | Opt : 'a tag -> 'a option tag + | Pair : 'a tag * 'b tag -> ('a * 'b) tag + + type t = Dyn : 'a tag * 'a -> t + + let rec eq : type a b. a tag -> b tag -> (a, b) CSig.eq option = + fun t1 t2 -> match t1, t2 with + | Base t1, Base t2 -> Dyn.eq t1 t2 + | List t1, List t2 -> + begin match eq t1 t2 with + | None -> None + | Some Refl -> Some Refl + end + | Opt t1, Opt t2 -> + begin match eq t1 t2 with + | None -> None + | Some Refl -> Some Refl + end + | Pair (t1, u1), Pair (t2, u2) -> + begin match eq t1 t2 with + | None -> None + | Some Refl -> + match eq u1 u2 with + | None -> None + | Some Refl -> Some Refl + end + | _ -> None + + let rec repr : type a. a tag -> std_ppcmds = function + | Base t -> str (Dyn.repr t) + | List t -> repr t ++ spc () ++ str "list" + | Opt t -> repr t ++ spc () ++ str "option" + | Pair (t1, t2) -> str "(" ++ repr t1 ++ str " * " ++ repr t2 ++ str ")" + +end + type argument_type = (* Basic types *) - | IntOrVarArgType | IdentArgType | VarArgType (* Specific types *) - | GenArgType | ConstrArgType - | ConstrMayEvalArgType - | OpenConstrArgType | ListArgType of argument_type | OptArgType of argument_type | PairArgType of argument_type * argument_type | ExtraArgType of string let rec argument_type_eq arg1 arg2 = match arg1, arg2 with -| IntOrVarArgType, IntOrVarArgType -> true | IdentArgType, IdentArgType -> true | VarArgType, VarArgType -> true -| GenArgType, GenArgType -> true | ConstrArgType, ConstrArgType -> true -| ConstrMayEvalArgType, ConstrMayEvalArgType -> true -| OpenConstrArgType, OpenConstrArgType -> true | ListArgType arg1, ListArgType arg2 -> argument_type_eq arg1 arg2 | OptArgType arg1, OptArgType arg2 -> argument_type_eq arg1 arg2 | PairArgType (arg1l, arg1r), PairArgType (arg2l, arg2r) -> @@ -40,13 +78,9 @@ let rec argument_type_eq arg1 arg2 = match arg1, arg2 with | _ -> false let rec pr_argument_type = function -| IntOrVarArgType -> str "int_or_var" | IdentArgType -> str "ident" | VarArgType -> str "var" -| GenArgType -> str "genarg" | ConstrArgType -> str "constr" -| ConstrMayEvalArgType -> str "constr_may_eval" -| OpenConstrArgType -> str "open_constr" | ListArgType t -> pr_argument_type t ++ spc () ++ str "list" | OptArgType t -> pr_argument_type t ++ spc () ++ str "opt" | PairArgType (t1, t2) -> @@ -133,13 +167,22 @@ let pair_unpack pack (t, obj) = match t with (** Creating args *) -let (arg0_map : Obj.t option String.Map.t ref) = ref String.Map.empty +type load = { + nil : Obj.t option; + dyn : Obj.t Val.tag; +} -let create_arg opt name = +let (arg0_map : load String.Map.t ref) = ref String.Map.empty + +let cast_tag : 'a Val.tag -> 'b Val.tag = Obj.magic + +let create_arg opt ?dyn name = if String.Map.mem name !arg0_map then Errors.anomaly (str "generic argument already declared: " ++ str name) else - let () = arg0_map := String.Map.add name (Obj.magic opt) !arg0_map in + let dyn = match dyn with None -> Val.Base (Dyn.create name) | Some dyn -> cast_tag dyn in + let obj = { nil = Option.map Obj.repr opt; dyn; } in + let () = arg0_map := String.Map.add name obj !arg0_map in ExtraArgType name let make0 = create_arg @@ -153,12 +196,73 @@ let default_empty_value t = | Some v1, Some v2 -> Some (Obj.repr (v1, v2)) | _ -> None) | ExtraArgType s -> - String.Map.find s !arg0_map + (String.Map.find s !arg0_map).nil | _ -> None in match aux t with | Some v -> Some (Obj.obj v) | None -> None +(** Beware: keep in sync with the corresponding types *) +let base_create n = Val.Base (Dyn.create n) +let ident_T = base_create "ident" +let genarg_T = base_create "genarg" +let constr_T = base_create "constr" + +let rec val_tag = function +| IdentArgType -> cast_tag ident_T +| VarArgType -> cast_tag ident_T + (** Must ensure that toplevel types of Var and Ident agree! *) +| ConstrArgType -> cast_tag constr_T +| ExtraArgType s -> cast_tag (String.Map.find s !arg0_map).dyn +| ListArgType t -> cast_tag (Val.List (val_tag t)) +| OptArgType t -> cast_tag (Val.Opt (val_tag t)) +| PairArgType (t1, t2) -> cast_tag (Val.Pair (val_tag t1, val_tag t2)) + +exception CastError of argument_type * Val.t + +let prj : type a. a Val.tag -> Val.t -> a option = fun t v -> + let Val.Dyn (t', x) = v in + match Val.eq t t' with + | None -> None + | Some Refl -> Some x + +let try_prj wit v = match prj (val_tag wit) v with +| None -> raise (CastError (wit, v)) +| Some x -> x + +let rec val_cast : type a. a typed_abstract_argument_type -> Val.t -> a = +fun wit v -> match unquote wit with +| IdentArgType +| VarArgType +| ConstrArgType +| ExtraArgType _ -> try_prj wit v +| ListArgType t -> + let Val.Dyn (tag, v) = v in + begin match tag with + | Val.List tag -> + let map x = val_cast t (Val.Dyn (tag, x)) in + Obj.magic (List.map map v) + | _ -> raise (CastError (wit, Val.Dyn (tag, v))) + end +| OptArgType t -> + let Val.Dyn (tag, v) = v in + begin match tag with + | Val.Opt tag -> + let map x = val_cast t (Val.Dyn (tag, x)) in + Obj.magic (Option.map map v) + | _ -> raise (CastError (wit, Val.Dyn (tag, v))) + end +| PairArgType (t1, t2) -> + let Val.Dyn (tag, v) = v in + begin match tag with + | Val.Pair (tag1, tag2) -> + let (v1, v2) = v in + let v1 = Val.Dyn (tag1, v1) in + let v2 = Val.Dyn (tag2, v2) in + Obj.magic (val_cast t1 v1, val_cast t2 v2) + | _ -> raise (CastError (wit, Val.Dyn (tag, v))) + end + (** Registering genarg-manipulating functions *) module type GenObj = diff --git a/lib/genarg.mli b/lib/genarg.mli index 2dcaa789f7..674ee97ae8 100644 --- a/lib/genarg.mli +++ b/lib/genarg.mli @@ -72,14 +72,35 @@ type ('raw, 'glob, 'top) genarg_type (** Generic types. ['raw] is the OCaml lowest level, ['glob] is the globalized one, and ['top] the internalized one. *) +module Val : +sig + type 'a typ + + type _ tag = + | Base : 'a typ -> 'a tag + | List : 'a tag -> 'a list tag + | Opt : 'a tag -> 'a option tag + | Pair : 'a tag * 'b tag -> ('a * 'b) tag + + type t = Dyn : 'a tag * 'a -> t + + val eq : 'a tag -> 'b tag -> ('a, 'b) CSig.eq option + val repr: 'a tag -> Pp.std_ppcmds + +end +(** Dynamic types for toplevel values. While the generic types permit to relate + objects at various levels of interpretation, toplevel values are wearing + their own type regardless of where they came from. This allows to use the + same runtime representation for several generic types. *) + type 'a uniform_genarg_type = ('a, 'a, 'a) genarg_type (** Alias for concision when the three types agree. *) -val make0 : 'raw option -> string -> ('raw, 'glob, 'top) genarg_type +val make0 : 'raw option -> ?dyn:'top Val.tag -> string -> ('raw, 'glob, 'top) genarg_type (** Create a new generic type of argument: force to associate unique ML types at each of the three levels. *) -val create_arg : 'raw option -> string -> ('raw, 'glob, 'top) genarg_type +val create_arg : 'raw option -> ?dyn:'top Val.tag -> string -> ('raw, 'glob, 'top) genarg_type (** Alias for [make0]. *) (** {5 Specialized types} *) @@ -179,23 +200,30 @@ type ('r, 'l) pair_unpacker = val pair_unpack : ('r, 'l) pair_unpacker -> 'l generic_argument -> 'r +(** {6 Dynamic toplevel values} *) + +val val_tag : 'a typed_abstract_argument_type -> 'a Val.tag +(** Retrieve the dynamic type associated to a toplevel genarg. Only works for + ground generic arguments. *) + +val val_cast : 'a typed_abstract_argument_type -> Val.t -> 'a + (** {6 Type reification} *) type argument_type = (** Basic types *) - | IntOrVarArgType | IdentArgType | VarArgType (** Specific types *) - | GenArgType | ConstrArgType - | ConstrMayEvalArgType - | OpenConstrArgType | ListArgType of argument_type | OptArgType of argument_type | PairArgType of argument_type * argument_type | ExtraArgType of string +exception CastError of argument_type * Val.t +(** Exception raised by {!val_cast} *) + val argument_type_eq : argument_type -> argument_type -> bool val pr_argument_type : argument_type -> Pp.std_ppcmds diff --git a/lib/hMap.ml b/lib/hMap.ml index 8e900cd581..b5fc523150 100644 --- a/lib/hMap.ml +++ b/lib/hMap.ml @@ -333,7 +333,6 @@ struct struct module IntM = Int.Map.Monad(M) module ExtM = Map.Monad(M) - open M let fold f s accu = let ff _ m accu = ExtM.fold f m accu in diff --git a/lib/hashcons.ml b/lib/hashcons.ml index 46ba0b6285..eeaaf2f7fc 100644 --- a/lib/hashcons.ml +++ b/lib/hashcons.ml @@ -72,7 +72,7 @@ module Make (X : HashconsedType) : (S with type t = X.t and type u = X.u) = end -(* A few usefull wrappers: +(* A few useful wrappers: * takes as argument the function [generate] above and build a function of type * u -> t -> t that creates a fresh table each time it is applied to the * sub-hcons functions. *) @@ -96,20 +96,6 @@ let recursive_hcons h f u = let () = loop := hrec in hrec -(* A set of global hashcons functions *) -let hashcons_resets = ref [] -let init() = List.iter (fun f -> f()) !hashcons_resets - -(* [register_hcons h u] registers the hcons function h, result of the above - * wrappers. It returns another hcons function that always uses the same - * table, which can be reinitialized by init() - *) -let register_hcons h u = - let hf = ref (h u) in - let reset() = hf := h u in - hashcons_resets := reset :: !hashcons_resets; - (fun x -> !hf x) - (* Basic hashcons modules for string and obj. Integers do not need be hashconsed. *) @@ -194,18 +180,3 @@ module Hobj = Make( let equal = comp_obj let hash = Hashtbl.hash end) - -(* Hashconsing functions for string and obj. Always use the same - * global tables. The latter can be reinitialized with init() - *) -(* string : string -> string *) -(* obj : Obj.t -> Obj.t *) -let string = register_hcons (simple_hcons Hstring.generate Hstring.hcons) () -let obj = register_hcons (recursive_hcons Hobj.generate Hobj.hcons) () - -(* The unsafe polymorphic hashconsing function *) -let magic_hash (c : 'a) = - init(); - let r = obj (Obj.repr c) in - init(); - (Obj.magic r : 'a) diff --git a/lib/hashset.ml b/lib/hashset.ml index 1ca6cc6418..0009ac6506 100644 --- a/lib/hashset.ml +++ b/lib/hashset.ml @@ -162,7 +162,7 @@ module Make (E : EqType) = t.hashes.(index) <- newhashes; if sz <= t.limit && newsz > t.limit then begin t.oversize <- t.oversize + 1; - for i = 0 to over_limit do test_shrink_bucket t done; + for _i = 0 to over_limit do test_shrink_bucket t done; end; if t.oversize > Array.length t.table / over_limit then resize t end else if Weak.check bucket i then begin diff --git a/lib/heap.ml b/lib/heap.ml index a19bc0d1c3..5682b87bb6 100644 --- a/lib/heap.ml +++ b/lib/heap.ml @@ -62,8 +62,6 @@ module Functional(X : Ordered) = struct let empty = Leaf - let is_empty t = t = Leaf - let rec add x = function | Leaf -> Node (Leaf, x, Leaf) diff --git a/lib/loc.ml b/lib/loc.ml index b62677d484..9043bee075 100644 --- a/lib/loc.ml +++ b/lib/loc.ml @@ -31,7 +31,7 @@ let ghost = { fname = ""; line_nb = -1; bol_pos = 0; line_nb_last = -1; bol_pos_last = 0; bp = 0; ep = 0; } -let is_ghost loc = Pervasives.(=) loc ghost (** FIXME *) +let is_ghost loc = loc.ep = 0 let merge loc1 loc2 = if loc1.bp < loc2.bp then diff --git a/lib/spawn.ml b/lib/spawn.ml index 851c6a2235..01f6a4f8d3 100644 --- a/lib/spawn.ml +++ b/lib/spawn.ml @@ -175,7 +175,7 @@ let is_alive p = p.alive let uid { pid; } = string_of_int pid let unixpid { pid; } = pid -let kill ({ pid = unixpid; oob_req; cin; cout; alive; watch } as p) = +let kill ({ pid = unixpid; oob_resp; oob_req; cin; cout; alive; watch } as p) = p.alive <- false; if not alive then prerr_endline "This process is already dead" else begin try @@ -183,6 +183,8 @@ let kill ({ pid = unixpid; oob_req; cin; cout; alive; watch } as p) = output_death_sentence (uid p) oob_req; close_in_noerr cin; close_out_noerr cout; + close_in_noerr oob_resp; + close_out_noerr oob_req; if Sys.os_type = "Unix" then Unix.kill unixpid 9; p.watch <- None with e -> prerr_endline ("kill: "^Printexc.to_string e) end @@ -247,13 +249,15 @@ let is_alive p = p.alive let uid { pid; } = string_of_int pid let unixpid { pid = pid; } = pid -let kill ({ pid = unixpid; oob_req; cin; cout; alive } as p) = +let kill ({ pid = unixpid; oob_req; oob_resp; cin; cout; alive } as p) = p.alive <- false; if not alive then prerr_endline "This process is already dead" else begin try output_death_sentence (uid p) oob_req; close_in_noerr cin; close_out_noerr cout; + close_in_noerr oob_resp; + close_out_noerr oob_req; if Sys.os_type = "Unix" then Unix.kill unixpid 9; with e -> prerr_endline ("kill: "^Printexc.to_string e) end diff --git a/lib/system.ml b/lib/system.ml index b641aad91b..31e9861d3a 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -56,7 +56,7 @@ let check_unix_dir warn dir = let apply_subdir f path name = (* we avoid all files and subdirs starting by '.' (e.g. .svn) *) (* as well as skipped files like CVS, ... *) - if name.[0] <> '.' && ok_dirname name then + if ok_dirname name then let path = if path = "." then name else path//name in match try (Unix.stat path).Unix.st_kind with Unix.Unix_error _ -> Unix.S_BLK with | Unix.S_DIR -> f (FileDir (path,name)) @@ -109,20 +109,22 @@ let make_dir_table dir = Array.fold_left filter_dotfiles StrSet.empty (Sys.readdir dir) let exists_in_dir_respecting_case dir bf = - let contents, cached = - try StrMap.find dir !dirmap, true with Not_found -> + let cache_dir dir = let contents = make_dir_table dir in dirmap := StrMap.add dir contents !dirmap; - contents, false in + contents in + let contents, fresh = + try + (* in batch mode, assume the directory content is still fresh *) + StrMap.find dir !dirmap, !Flags.batch_mode + with Not_found -> + (* in batch mode, we are not yet sure the directory exists *) + if !Flags.batch_mode && not (exists_dir dir) then StrSet.empty, true + else cache_dir dir, true in StrSet.mem bf contents || - if cached then begin + not fresh && (* rescan, there is a new file we don't know about *) - let contents = make_dir_table dir in - dirmap := StrMap.add dir contents !dirmap; - StrSet.mem bf contents - end - else - false + StrSet.mem bf (cache_dir dir) let file_exists_respecting_case path f = (* This function ensures that a file with expected lowercase/uppercase @@ -132,7 +134,7 @@ let file_exists_respecting_case path f = let df = Filename.dirname f in (String.equal df "." || aux df) && exists_in_dir_respecting_case (Filename.concat path df) bf - in Sys.file_exists (Filename.concat path f) && aux f + in (!Flags.batch_mode || Sys.file_exists (Filename.concat path f)) && aux f let rec search paths test = match paths with diff --git a/library/declare.ml b/library/declare.ml index 994a6557ad..c1697a434a 100644 --- a/library/declare.ml +++ b/library/declare.ml @@ -417,9 +417,6 @@ let assumption_message id = (** Global universe names, in a different summary *) -type universe_names = - (Univ.universe_level Idmap.t * Id.t Univ.LMap.t) - (* Discharged or not *) type universe_decl = polymorphic * (Id.t * Univ.universe_level) list diff --git a/library/goptions.mli b/library/goptions.mli index 9d87c14c50..25b5315c2a 100644 --- a/library/goptions.mli +++ b/library/goptions.mli @@ -133,7 +133,7 @@ val declare_stringopt_option: string option option_sig -> string option write_fu (** {6 Special functions supposed to be used only in vernacentries.ml } *) -module OptionMap : Map.S with type key = option_name +module OptionMap : CSig.MapS with type key = option_name val get_string_table : option_name -> diff --git a/library/keys.ml b/library/keys.ml index 3d277476f1..e30cf67175 100644 --- a/library/keys.ml +++ b/library/keys.ml @@ -12,35 +12,31 @@ open Globnames open Term open Libobject -type key = +type key = | KGlob of global_reference - | KLam + | KLam | KLet | KProd | KSort - | KEvar - | KCase - | KFix + | KCase + | KFix | KCoFix - | KRel - | KMeta + | KRel module KeyOrdered = struct type t = key let hash gr = match gr with - | KGlob gr -> 10 + RefOrdered.hash gr + | KGlob gr -> 8 + RefOrdered.hash gr | KLam -> 0 | KLet -> 1 | KProd -> 2 | KSort -> 3 - | KEvar -> 4 - | KCase -> 5 - | KFix -> 6 - | KCoFix -> 7 - | KRel -> 8 - | KMeta -> 9 + | KCase -> 4 + | KFix -> 5 + | KCoFix -> 6 + | KRel -> 7 let compare gr1 gr2 = match gr1, gr2 with @@ -62,8 +58,6 @@ module Keyset = Keymap.Set (* Mapping structure for references to be considered equivalent *) -type keys = Keyset.t Keymap.t - let keys = Summary.ref Keymap.empty ~name:"Keys_decl" let add_kv k v m = @@ -153,12 +147,10 @@ let pr_key pr_global = function | KLet -> str"Let" | KProd -> str"Product" | KSort -> str"Sort" - | KEvar -> str"Evar" | KCase -> str"Case" | KFix -> str"Fix" | KCoFix -> str"CoFix" | KRel -> str"Rel" - | KMeta -> str"Meta" let pr_keyset pr_global v = prlist_with_sep spc (pr_key pr_global) (Keyset.elements v) diff --git a/library/libnames.ml b/library/libnames.ml index cdaec6a3de..36b46ca498 100644 --- a/library/libnames.ml +++ b/library/libnames.ml @@ -13,7 +13,7 @@ open Names (**********************************************) -let pr_dirpath sl = (str (DirPath.to_string sl)) +let pr_dirpath sl = str (DirPath.to_string sl) (*s Operations on dirpaths *) @@ -197,7 +197,7 @@ let string_of_reference = function let pr_reference = function | Qualid (_,qid) -> pr_qualid qid - | Ident (_,id) -> str (Id.to_string id) + | Ident (_,id) -> Id.print id let loc_of_reference = function | Qualid (loc,qid) -> loc diff --git a/library/libnames.mli b/library/libnames.mli index b95c088715..c72f517532 100644 --- a/library/libnames.mli +++ b/library/libnames.mli @@ -60,7 +60,7 @@ val path_of_string : string -> full_path val string_of_path : full_path -> string val pr_path : full_path -> std_ppcmds -module Spmap : Map.S with type key = full_path +module Spmap : CSig.MapS with type key = full_path val restrict_path : int -> full_path -> full_path diff --git a/library/library.ml b/library/library.ml index 024ac9e6fa..db95213fe9 100644 --- a/library/library.ml +++ b/library/library.ml @@ -132,7 +132,7 @@ let try_find_library dir = try find_library dir with Not_found -> errorlabstrm "Library.find_library" - (str "Unknown library " ++ str (DirPath.to_string dir)) + (str "Unknown library " ++ pr_dirpath dir) let register_library_filename dir f = (* Not synchronized: overwrite the previous binding if one existed *) @@ -286,28 +286,18 @@ let locate_absolute_library dir = with Not_found -> [] in match find ".vo" @ find ".vio" with | [] -> raise LibNotFound - | [file] -> dir, file + | [file] -> file | [vo;vi] when Unix.((stat vo).st_mtime < (stat vi).st_mtime) -> msg_warning (str"Loading " ++ str vi ++ str " instead of " ++ str vo ++ str " because it is more recent"); - dir, vi - | [vo;vi] -> dir, vo + vi + | [vo;vi] -> vo | _ -> assert false let locate_qualified_library ?root ?(warn = true) qid = (* Search library in loadpath *) let dir, base = repr_qualid qid in - let loadpath = match root with - | None -> Loadpath.expand_path dir - | Some root -> - let filter path = - if is_dirpath_prefix_of root path then - let path = drop_dirpath_prefix root path in - is_dirpath_suffix_of dir path - else false - in - Loadpath.filter_path filter - in + let loadpath = Loadpath.expand_path ?root dir in let () = match loadpath with [] -> raise LibUnmappedDir | _ -> () in let find ext = try @@ -459,7 +449,7 @@ let intern_from_file f = module DPMap = Map.Make(DirPath) let rec intern_library (needed, contents) (dir, f) from = - Pp.feedback(Feedback.FileDependency (from, f)); + Pp.feedback(Feedback.FileDependency (from, DirPath.to_string dir)); (* Look if in the current logical environment *) try (find_library dir).libsum_digests, (needed, contents) with Not_found -> @@ -467,6 +457,7 @@ let rec intern_library (needed, contents) (dir, f) from = try (DPMap.find dir contents).library_digests, (needed, contents) with Not_found -> (* [dir] is an absolute name which matches [f] which must be in loadpath *) + let f = match f with Some f -> f | None -> try_locate_absolute_library dir in let m = intern_from_file f in if not (DirPath.equal dir m.library_name) then errorlabstrm "load_physical_library" @@ -481,13 +472,13 @@ and intern_library_deps libs dir m from = (dir :: needed, DPMap.add dir m contents ) and intern_mandatory_library caller from libs (dir,d) = - let digest, libs = intern_library libs (try_locate_absolute_library dir) from in + let digest, libs = intern_library libs (dir, None) from in if not (Safe_typing.digest_match ~actual:digest ~required:d) then - errorlabstrm "" (str "Compiled library " ++ str (DirPath.to_string caller) ++ str ".vo makes inconsistent assumptions over library " ++ str (DirPath.to_string dir)); + errorlabstrm "" (str "Compiled library " ++ pr_dirpath caller ++ str ".vo makes inconsistent assumptions over library " ++ pr_dirpath dir); libs -let rec_intern_library libs mref = - let _, libs = intern_library libs mref None in +let rec_intern_library libs (dir, f) = + let _, libs = intern_library libs (dir, Some f) None in libs let native_name_from_filename f = @@ -576,7 +567,7 @@ let safe_locate_module (loc,qid) = try Nametab.locate_module qid with Not_found -> user_err_loc - (loc,"import_library", str (string_of_qualid qid) ++ str " is not a module") + (loc,"import_library", pr_qualid qid ++ str " is not a module") let import_module export modl = (* Optimization: libraries in a raw in the list are imported @@ -601,7 +592,7 @@ let import_module export modl = try Declaremods.import_module export mp; aux [] l with Not_found -> user_err_loc (loc,"import_library", - str (string_of_qualid dir) ++ str " is not a module")) + pr_qualid dir ++ str " is not a module")) | [] -> flush acc in aux [] modl @@ -611,9 +602,9 @@ let import_module export modl = let check_coq_overwriting p id = let l = DirPath.repr p in let is_empty = match l with [] -> true | _ -> false in - if not !Flags.boot && not is_empty && String.equal (Id.to_string (List.last l)) "Coq" then + if not !Flags.boot && not is_empty && Id.equal (List.last l) coq_root then errorlabstrm "" - (str "Cannot build module " ++ str (DirPath.to_string p) ++ str "." ++ pr_id id ++ str "." ++ spc () ++ + (str "Cannot build module " ++ pr_dirpath p ++ str "." ++ pr_id id ++ str "." ++ spc () ++ str "it starts with prefix \"Coq\" which is reserved for the Coq library.") (* Verifies that a string starts by a letter and do not contain @@ -778,13 +769,6 @@ let save_library_raw f sum lib univs proofs = System.marshal_out_segment f' ch (proofs : seg_proofs); close_out ch -(************************************************************************) -(*s Display the memory use of a library. *) - -open Printf - -let mem s = Pp.mt () - module StringOrd = struct type t = string let compare = String.compare end module StringSet = Set.Make(StringOrd) diff --git a/library/library.mli b/library/library.mli index d5e610dd67..71aefdbd86 100644 --- a/library/library.mli +++ b/library/library.mli @@ -82,8 +82,5 @@ val locate_qualified_library : *) -(** {6 Statistics: display the memory use of a library. } *) -val mem : DirPath.t -> Pp.std_ppcmds - (** {6 Native compiler. } *) val native_name_from_filename : string -> string diff --git a/library/loadpath.ml b/library/loadpath.ml index 622d390a2c..f77bd1ef53 100644 --- a/library/loadpath.ml +++ b/library/loadpath.ml @@ -84,10 +84,6 @@ let add_load_path phys_path coq_path ~implicit = end | _ -> anomaly_too_many_paths phys_path -let extend_path_with_dirpath p dir = - List.fold_left Filename.concat p - (List.rev_map Id.to_string (DirPath.repr dir)) - let filter_path f = let rec aux = function | [] -> [] @@ -97,18 +93,19 @@ let filter_path f = in aux !load_paths -let expand_path dir = +let expand_path ?root dir = let rec aux = function | [] -> [] - | { path_physical = ph; path_logical = lg; path_implicit = implicit } :: l -> - match implicit with - | true -> - (** The path is implicit, so that we only want match the logical suffix *) - if is_dirpath_suffix_of dir lg then (ph, lg) :: aux l else aux l - | false -> - (** Otherwise we must match exactly *) - if DirPath.equal dir lg then (ph, lg) :: aux l else aux l - in + | { path_physical = ph; path_logical = lg; path_implicit = implicit } :: l -> + let success = + match root with + | None -> + if implicit then is_dirpath_suffix_of dir lg + else DirPath.equal dir lg + | Some root -> + is_dirpath_prefix_of root lg && + is_dirpath_suffix_of dir (drop_dirpath_prefix root lg) in + if success then (ph, lg) :: aux l else aux l in aux !load_paths let locate_file fname = diff --git a/library/loadpath.mli b/library/loadpath.mli index 269e28e0b5..732f6349fb 100644 --- a/library/loadpath.mli +++ b/library/loadpath.mli @@ -42,7 +42,7 @@ val find_load_path : CUnix.physical_path -> t val is_in_load_paths : CUnix.physical_path -> bool (** Whether a physical path is currently bound. *) -val expand_path : DirPath.t -> (CUnix.physical_path * DirPath.t) list +val expand_path : ?root:DirPath.t -> DirPath.t -> (CUnix.physical_path * DirPath.t) list (** Given a relative logical path, associate the list of absolute physical and logical paths which are possible matches of it. *) diff --git a/library/nameops.ml b/library/nameops.ml index 3a23ab97df..418d620c25 100644 --- a/library/nameops.ml +++ b/library/nameops.ml @@ -12,7 +12,7 @@ open Names (* Identifiers *) -let pr_id id = str (Id.to_string id) +let pr_id id = Id.print id let pr_name = function | Anonymous -> str "_" @@ -141,7 +141,7 @@ let name_max na1 na2 = | Name _ -> na1 | Anonymous -> na2 -let pr_lab l = str (Label.to_string l) +let pr_lab l = Label.print l let default_library = Names.DirPath.initial (* = ["Top"] *) diff --git a/library/nametab.ml b/library/nametab.ml index 5b6d7cd982..621640ef98 100644 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -523,7 +523,7 @@ let shortest_qualid_of_tactic kn = KnTab.shortest_qualid Id.Set.empty sp !the_tactictab let pr_global_env env ref = - try str (string_of_qualid (shortest_qualid_of_global env ref)) + try pr_qualid (shortest_qualid_of_global env ref) with Not_found as e -> if !Flags.debug then Pp.msg_debug (Pp.str "pr_global_env not found"); raise e diff --git a/parsing/compat.ml4 b/parsing/compat.ml4 index 4208fd364e..a214b58a60 100644 --- a/parsing/compat.ml4 +++ b/parsing/compat.ml4 @@ -266,6 +266,7 @@ IFDEF CAMLP5 THEN | Tok.PATTERNIDENT s -> "PATTERNIDENT", s | Tok.FIELD s -> "FIELD", s | Tok.INT s -> "INT", s + | Tok.INDEX s -> "INDEX", s | Tok.STRING s -> "STRING", s | Tok.LEFTQMARK -> "LEFTQMARK", "" | Tok.BULLET s -> "BULLET", s diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml index 84736f8aba..29f8555c81 100644 --- a/parsing/egramcoq.ml +++ b/parsing/egramcoq.ml @@ -257,7 +257,8 @@ let add_ml_tactic_entry name prods = let mkact i loc l : raw_tactic_expr = let open Tacexpr in let entry = { mltac_name = name; mltac_index = i } in - TacML (loc, entry, List.map snd l) + let map arg = TacGeneric arg in + TacML (loc, entry, List.map map l) in let rules = List.map_i (fun i p -> make_rule (mkact i) p) 0 prods in synchronize_level_positions (); @@ -274,7 +275,23 @@ let head_is_ident tg = match tg.tacgram_prods with let add_tactic_entry kn tg = let entry, pos = get_tactic_entry tg.tacgram_level in - let mkact loc l = (TacAlias (loc,kn,l):raw_tactic_expr) in + let mkact loc l = + let filter = function + | GramTerminal _ -> None + | GramNonTerminal (_, t, _) -> Some (Genarg.unquote t) + in + let types = List.map_filter filter tg.tacgram_prods in + let map arg t = + (** HACK to handle especially the tactic(...) entry *) + let wit = Genarg.rawwit Constrarg.wit_tactic in + if Genarg.argument_type_eq t (Genarg.unquote wit) then + Tacexp (Genarg.out_gen wit arg) + else + TacGeneric arg + in + let l = List.map2 map l types in + (TacAlias (loc,kn,l):raw_tactic_expr) + in let () = if Int.equal tg.tacgram_level 0 && not (head_is_ident tg) then error "Notation for simple tactic must start with an identifier." diff --git a/parsing/egramml.ml b/parsing/egramml.ml index 984027b815..9a380822eb 100644 --- a/parsing/egramml.ml +++ b/parsing/egramml.ml @@ -18,9 +18,9 @@ open Vernacexpr type 's grammar_prod_item = | GramTerminal of string | GramNonTerminal : - Loc.t * 'a raw_abstract_argument_type * ('s, 'a) entry_key * Id.t option -> 's grammar_prod_item + Loc.t * 'a raw_abstract_argument_type * ('s, 'a) entry_key -> 's grammar_prod_item -type 'a ty_arg = Id.t * ('a -> raw_generic_argument) +type 'a ty_arg = ('a -> raw_generic_argument) type ('self, _, 'r) ty_rule = | TyStop : ('self, 'r, 'r) ty_rule @@ -37,12 +37,9 @@ let rec ty_rule_of_gram = function let tok = Atoken (Lexer.terminal s) in let r = TyNext (rem, tok, None) in AnyTyRule r -| GramNonTerminal (_, t, tok, idopt) :: rem -> +| GramNonTerminal (_, t, tok) :: rem -> let AnyTyRule rem = ty_rule_of_gram rem in - let inj = match idopt with - | None -> None - | Some id -> Some (id, fun obj -> Genarg.in_gen t obj) - in + let inj = Some (fun obj -> Genarg.in_gen t obj) in let r = TyNext (rem, tok, inj) in AnyTyRule r @@ -50,13 +47,13 @@ let rec ty_erase : type s a r. (s, a, r) ty_rule -> (s, a, r) Extend.rule = func | TyStop -> Extend.Stop | TyNext (rem, tok, _) -> Extend.Next (ty_erase rem, tok) -type 'r gen_eval = Loc.t -> (Id.t * raw_generic_argument) list -> 'r +type 'r gen_eval = Loc.t -> raw_generic_argument list -> 'r -let rec ty_eval : type s a r. (s, a, Loc.t -> s) ty_rule -> s gen_eval -> a = function +let rec ty_eval : type s a. (s, a, Loc.t -> s) ty_rule -> s gen_eval -> a = function | TyStop -> fun f loc -> f loc [] | TyNext (rem, tok, None) -> fun f _ -> ty_eval rem f -| TyNext (rem, tok, Some (id, inj)) -> fun f x -> - let f loc args = f loc ((id, inj x) :: args) in +| TyNext (rem, tok, Some inj) -> fun f x -> + let f loc args = f loc (inj x :: args) in ty_eval rem f let make_rule f prod = @@ -81,6 +78,6 @@ let get_extend_vernac_rule (s, i) = let extend_vernac_command_grammar s nt gl = let nt = Option.default Vernac_.command nt in vernac_exts := (s,gl) :: !vernac_exts; - let mkact loc l = VernacExtend (s,List.map snd l) in + let mkact loc l = VernacExtend (s, l) in let rules = [make_rule mkact gl] in grammar_extend nt None (None, [None, None, rules]) diff --git a/parsing/egramml.mli b/parsing/egramml.mli index e3ae4e0118..8a494d70ba 100644 --- a/parsing/egramml.mli +++ b/parsing/egramml.mli @@ -16,7 +16,7 @@ open Vernacexpr type 's grammar_prod_item = | GramTerminal of string | GramNonTerminal : Loc.t * 'a Genarg.raw_abstract_argument_type * - ('s, 'a) Pcoq.entry_key * Names.Id.t option -> 's grammar_prod_item + ('s, 'a) Pcoq.entry_key -> 's grammar_prod_item val extend_vernac_command_grammar : Vernacexpr.extend_name -> vernac_expr Pcoq.Gram.entry option -> @@ -27,5 +27,5 @@ val get_extend_vernac_rule : Vernacexpr.extend_name -> vernac_expr grammar_prod_ (** Utility function reused in Egramcoq : *) val make_rule : - (Loc.t -> (Names.Id.t * Genarg.raw_generic_argument) list -> 'a) -> + (Loc.t -> Genarg.raw_generic_argument list -> 'a) -> 'a grammar_prod_item list -> 'a Extend.production_rule diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4 index 181c2395d2..3f8dd9f193 100644 --- a/parsing/g_ltac.ml4 +++ b/parsing/g_ltac.ml4 @@ -29,6 +29,12 @@ let genarg_of_unit () = in_gen (rawwit Stdarg.wit_unit) () let genarg_of_int n = in_gen (rawwit Stdarg.wit_int) n let genarg_of_ipattern pat = in_gen (rawwit Constrarg.wit_intro_pattern) pat +let reference_to_id = function + | Libnames.Ident (loc, id) -> (loc, id) + | Libnames.Qualid (loc,_) -> + Errors.user_err_loc (loc, "", + str "This expression should be a simple identifier.") + (* Tactics grammar rules *) GEXTEND Gram @@ -242,16 +248,23 @@ GEXTEND Gram | n = integer -> MsgInt n ] ] ; + ltac_def_kind: + [ [ ":=" -> false + | "::=" -> true ] ] + ; + (* Definitions for tactics *) - tacdef_body: - [ [ id = ident; it=LIST1 input_fun; ":="; body = tactic_expr -> - Vernacexpr.TacticDefinition ((!@loc,id), TacFun (it, body)) - | name = Constr.global; it=LIST1 input_fun; "::="; body = tactic_expr -> - Vernacexpr.TacticRedefinition (name, TacFun (it, body)) - | id = ident; ":="; body = tactic_expr -> - Vernacexpr.TacticDefinition ((!@loc,id), body) - | name = Constr.global; "::="; body = tactic_expr -> - Vernacexpr.TacticRedefinition (name, body) + tacdef_body: + [ [ name = Constr.global; it=LIST1 input_fun; redef = ltac_def_kind; body = tactic_expr -> + if redef then Vernacexpr.TacticRedefinition (name, TacFun (it, body)) + else + let id = reference_to_id name in + Vernacexpr.TacticDefinition (id, TacFun (it, body)) + | name = Constr.global; redef = ltac_def_kind; body = tactic_expr -> + if redef then Vernacexpr.TacticRedefinition (name, body) + else + let id = reference_to_id name in + Vernacexpr.TacticDefinition (id, body) ] ] ; tactic: diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index 3e4a6c6a1b..a7b05dd5eb 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -231,7 +231,7 @@ GEXTEND Gram [ [ id = identref -> id ] ] ; open_constr: - [ [ c = constr -> ((),c) ] ] + [ [ c = constr -> c ] ] ; uconstr: [ [ c = constr -> c ] ] @@ -281,6 +281,9 @@ GEXTEND Gram intropatterns: [ [ l = LIST0 nonsimple_intropattern -> l ]] ; + ne_intropatterns: + [ [ l = LIST1 nonsimple_intropattern -> l ]] + ; or_and_intropattern: [ [ "["; tc = LIST1 intropatterns SEP "|"; "]" -> tc | "()" -> [[]] @@ -450,15 +453,6 @@ GEXTEND Gram [ [ check_for_coloneq; "("; id = ident; bl = LIST0 simple_binder; ":="; c = lconstr; ")" -> (id, mkCLambdaN_simple bl c) ] ] ; - hintbases: - [ [ "with"; "*" -> None - | "with"; l = LIST1 [ x = IDENT -> x] -> Some l - | -> Some [] ] ] - ; - auto_using: - [ [ "using"; l = LIST1 constr SEP "," -> l - | -> [] ] ] - ; eliminator: [ [ "using"; el = constr_with_bindings -> el ] ] ; @@ -532,7 +526,10 @@ GEXTEND Gram simple_tactic: [ [ (* Basic tactics *) - IDENT "intros"; pl = intropatterns -> TacAtom (!@loc, TacIntroPattern pl) + IDENT "intros"; pl = ne_intropatterns -> + TacAtom (!@loc, TacIntroPattern pl) + | IDENT "intros" -> + TacAtom (!@loc, TacIntroPattern [!@loc,IntroForthcoming false]) | IDENT "intro"; id = ident; hto = move_location -> TacAtom (!@loc, TacIntroMove (Some id, hto)) | IDENT "intro"; hto = move_location -> TacAtom (!@loc, TacIntroMove (None, hto)) @@ -623,20 +620,6 @@ GEXTEND Gram | IDENT "edestruct"; icl = induction_clause_list -> TacAtom (!@loc, TacInductionDestruct(false,true,icl)) - (* Automation tactic *) - | IDENT "trivial"; lems = auto_using; db = hintbases -> - TacAtom (!@loc, TacTrivial (Off, lems, db)) - | IDENT "info_trivial"; lems = auto_using; db = hintbases -> - TacAtom (!@loc, TacTrivial (Info, lems, db)) - | IDENT "debug"; IDENT "trivial"; lems = auto_using; db = hintbases -> - TacAtom (!@loc, TacTrivial (Debug, lems, db)) - | IDENT "auto"; n = OPT int_or_var; lems = auto_using; db = hintbases -> - TacAtom (!@loc, TacAuto (Off, n, lems, db)) - | IDENT "info_auto"; n = OPT int_or_var; lems = auto_using; db = hintbases -> - TacAtom (!@loc, TacAuto (Info, n, lems, db)) - | IDENT "debug"; IDENT "auto"; n = OPT int_or_var; lems = auto_using; db = hintbases -> - TacAtom (!@loc, TacAuto (Debug, n, lems, db)) - (* Context management *) | IDENT "clear"; "-"; l = LIST1 id_or_meta -> TacAtom (!@loc, TacClear (true, l)) | IDENT "clear"; l = LIST0 id_or_meta -> diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 2c9894dad2..f79aa8d3dd 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -1165,7 +1165,7 @@ GEXTEND Gram production_item: [ [ s = ne_string -> TacTerm s | nt = IDENT; - po = OPT [ "("; p = ident; sep = [ -> "" | ","; sep = STRING -> sep ]; + po = [ "("; p = ident; sep = [ -> "" | ","; sep = STRING -> sep ]; ")" -> (p,sep) ] -> TacNonTerm (!@loc,nt,po) ] ] ; END diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index fdba413854..592c879197 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -219,7 +219,7 @@ module Module : module Tactic : sig - val open_constr : open_constr_expr Gram.entry + val open_constr : constr_expr Gram.entry val constr_with_bindings : constr_expr with_bindings Gram.entry val bindings : constr_expr bindings Gram.entry val hypident : (Id.t located * Locus.hyp_location_flag) Gram.entry diff --git a/plugins/cc/ccalgo.mli b/plugins/cc/ccalgo.mli index 0dcf3a870f..34c19958a9 100644 --- a/plugins/cc/ccalgo.mli +++ b/plugins/cc/ccalgo.mli @@ -20,8 +20,8 @@ type pa_fun= fnargs:int} -module PafMap : Map.S with type key = pa_fun -module PacMap : Map.S with type key = pa_constructor +module PafMap : CSig.MapS with type key = pa_fun +module PacMap : CSig.MapS with type key = pa_constructor type cinfo = {ci_constr: pconstructor; (* inductive type *) @@ -185,7 +185,7 @@ val empty_forest: unit -> forest (*type pa_constructor -module PacMap:Map.S with type key=pa_constructor +module PacMap:CSig.MapS with type key=pa_constructor type term = Symb of Term.constr diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index 7014df83fd..657a91c0c1 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -177,8 +177,7 @@ let factor_fix env l cb msb = let expand_mexpr env mp me = let inl = Some (Flags.get_inline_level()) in - let sign,_,_,_ = Mod_typing.translate_mse env (Some mp) inl me in - sign + Mod_typing.translate_mse env (Some mp) inl me (** Ad-hoc update of environment, inspired by [Mod_type.check_with_aux_def]. To check with Elie. *) @@ -231,10 +230,9 @@ let rec extract_structure_spec env mp reso = function (* From [module_expression] to specifications *) -(* Invariant: the [me] given to [extract_mexpr_spec] should either come - from a [mod_type] or [type_expr] field, or their [_alg] counterparts. - This way, any encountered [MEident] should be a true module type. -*) +(* Invariant: the [me_alg] given to [extract_mexpr_spec] and + [extract_mexpression_spec] should come from a [mod_type_alg] field. + This way, any encountered [MEident] should be a true module type. *) and extract_mexpr_spec env mp1 (me_struct,me_alg) = match me_alg with | MEident mp -> Visit.add_mp_all mp; MTident mp @@ -247,7 +245,9 @@ and extract_mexpr_spec env mp1 (me_struct,me_alg) = match me_alg with | MEwith(me',WithMod(idl,mp))-> Visit.add_mp_all mp; MTwith(extract_mexpr_spec env mp1 (me_struct,me'), ML_With_module(idl,mp)) - | MEapply _ -> extract_msignature_spec env mp1 no_delta (*TODO*) me_struct + | MEapply _ -> + (* No higher-order module type in OCaml : we use the expanded version *) + extract_msignature_spec env mp1 no_delta (*TODO*) me_struct and extract_mexpression_spec env mp1 (me_struct,me_alg) = match me_alg with | MoreFunctor (mbid, mtb, me_alg') -> @@ -335,7 +335,8 @@ and extract_mexpr env mp = function (* In Haskell/Scheme, we expand everything. For now, we also extract everything, dead code will be removed later (see [Modutil.optimize_struct]. *) - extract_msignature env mp no_delta ~all:true (expand_mexpr env mp me) + let sign,_,delta,_ = expand_mexpr env mp me in + extract_msignature env mp delta ~all:true sign | MEident mp -> if is_modfile mp && not (modular ()) then error_MPfile_as_mod mp false; Visit.add_mp_all mp; Miniml.MEident mp @@ -541,7 +542,7 @@ let print_structure_to_file (fn,si,mo) dry struc = (if dry then None else si); (* Print the buffer content via Coq standard formatter (ok with coqide). *) if not (Int.equal (Buffer.length buf) 0) then begin - Pp.msg_info (str (Buffer.contents buf)); + Pp.msg_notice (str (Buffer.contents buf)); Buffer.reset buf end @@ -635,7 +636,7 @@ let simple_extraction r = in let ans = flag ++ print_one_decl struc (modpath_of_r r) d in reset (); - Pp.msg_info ans + Pp.msg_notice ans | _ -> assert false diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index 9feaea8cdb..30486879ee 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -453,7 +453,7 @@ let check_loaded_modfile mp = match base_mp mp with if not (Library.library_is_loaded dp) then begin match base_mp (Lib.current_mp ()) with | MPfile dp' when not (DirPath.equal dp dp') -> - err (str ("Please load library "^(DirPath.to_string dp^" first."))) + err (str "Please load library " ++ pr_dirpath dp ++ str " first.") | _ -> () end | _ -> () diff --git a/plugins/extraction/table.mli b/plugins/extraction/table.mli index 916cf3ad6b..4e638a0ace 100644 --- a/plugins/extraction/table.mli +++ b/plugins/extraction/table.mli @@ -13,7 +13,7 @@ open Miniml open Declarations module Refset' : CSig.SetS with type elt = global_reference -module Refmap' : Map.S with type key = global_reference +module Refmap' : CSig.MapS with type key = global_reference val safe_basename_of_global : global_reference -> Id.t diff --git a/plugins/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.ml4 index c28da42aea..9d853a79a7 100644 --- a/plugins/firstorder/g_ground.ml4 +++ b/plugins/firstorder/g_ground.ml4 @@ -52,8 +52,15 @@ let _= in declare_int_option gdopt +let default_intuition_tac = + let tac _ _ = Auto.h_auto None [] None in + let name = { Tacexpr.mltac_plugin = "ground_plugin"; mltac_tactic = "auto_with"; } in + let entry = { Tacexpr.mltac_name = name; mltac_index = 0 } in + Tacenv.register_ml_tactic name [| tac |]; + Tacexpr.TacML (Loc.ghost, entry, []) + let (set_default_solver, default_solver, print_default_solver) = - Tactic_option.declare_tactic_option ~default:(<:tactic<auto with *>>) "Firstorder default solver" + Tactic_option.declare_tactic_option ~default:default_intuition_tac "Firstorder default solver" VERNAC COMMAND EXTEND Firstorder_Set_Solver CLASSIFIED AS SIDEFF | [ "Set" "Firstorder" "Solver" tactic(t) ] -> [ diff --git a/plugins/firstorder/sequent.mli b/plugins/firstorder/sequent.mli index dc3f05be69..760168c9f6 100644 --- a/plugins/firstorder/sequent.mli +++ b/plugins/firstorder/sequent.mli @@ -13,7 +13,7 @@ open Globnames module OrderedConstr: Set.OrderedType with type t=constr -module CM: Map.S with type key=constr +module CM: CSig.MapS with type key=constr type h_item = global_reference * (int*constr) option diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml index e5c9b27075..b1f642c1d2 100644 --- a/plugins/fourier/fourierR.ml +++ b/plugins/fourier/fourierR.ml @@ -413,13 +413,6 @@ let tac_zero_infeq_false gl (n,d) = (tac_zero_inf_pos gl (-n,d))) ;; -let create_meta () = mkMeta(Evarutil.new_meta());; - -let my_cut c gl= - let concl = pf_concl gl in - apply_type (mkProd(Anonymous,c,concl)) [create_meta()] gl -;; - let exact = exact_check;; let tac_use h = @@ -587,7 +580,7 @@ let rec fourier () = then tac_zero_inf_false gl (rational_to_fraction cres) else tac_zero_infeq_false gl (rational_to_fraction cres) in - tac:=(Tacticals.New.tclTHENS (Proofview.V82.tactic (my_cut ineq)) + tac:=(Tacticals.New.tclTHENS (cut ineq) [Tacticals.New.tclTHEN (change_concl (mkAppL [| get coq_not; ineq|] )) diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index ad18ea95a4..4eab5f9126 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -1472,7 +1472,7 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = tclCOMPLETE( Eauto.eauto_with_bases (true,5) - [Evd.empty,Lazy.force refl_equal] + [{ Tacexpr.delayed = fun _ sigma -> Sigma.here (Lazy.force refl_equal) sigma}] [Hints.Hint_db.empty empty_transparent_state false] ) ) diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index 045beb37cf..cba10ca09d 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -55,7 +55,9 @@ let pr_with_bindings_typed prc prlc (c,bl) = let pr_fun_ind_using_typed prc prlc _ opt_c = match opt_c with | None -> mt () - | Some b -> spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings_typed prc prlc b.Evd.it) + | Some b -> + let (b, _) = Tactics.run_delayed (Global.env ()) Evd.empty b in + spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings_typed prc prlc b) ARGUMENT EXTEND fun_ind_using diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 5a30da336e..10a145e036 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -1335,7 +1335,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp (Proofview.V82.of_tactic e_assumption); Eauto.eauto_with_bases (true,5) - [Evd.empty,Lazy.force refl_equal] + [{ Tacexpr.delayed = fun _ sigma -> Sigma.here (Lazy.force refl_equal) sigma}] [Hints.Hint_db.empty empty_transparent_state false] ] ) diff --git a/plugins/micromega/g_micromega.ml4 b/plugins/micromega/g_micromega.ml4 index 62f0ae5037..3c46e1eea0 100644 --- a/plugins/micromega/g_micromega.ml4 +++ b/plugins/micromega/g_micromega.ml4 @@ -21,12 +21,8 @@ open Misctypes DECLARE PLUGIN "micromega_plugin" -let out_arg = function - | ArgVar _ -> anomaly (Pp.str "Unevaluated or_var variable") - | ArgArg x -> x - TACTIC EXTEND PsatzZ -| [ "psatz_Z" int_or_var(i) ] -> [ (Coq_micromega.psatz_Z (out_arg i)) ] +| [ "psatz_Z" int_or_var(i) ] -> [ (Coq_micromega.psatz_Z i) ] | [ "psatz_Z" ] -> [ (Coq_micromega.psatz_Z (-1)) ] END @@ -63,12 +59,12 @@ TACTIC EXTEND LRA_R END TACTIC EXTEND PsatzR -| [ "psatz_R" int_or_var(i) ] -> [ (Coq_micromega.psatz_R (out_arg i)) ] +| [ "psatz_R" int_or_var(i) ] -> [ (Coq_micromega.psatz_R i) ] | [ "psatz_R" ] -> [ (Coq_micromega.psatz_R (-1)) ] END TACTIC EXTEND PsatzQ -| [ "psatz_Q" int_or_var(i) ] -> [ (Coq_micromega.psatz_Q (out_arg i)) ] +| [ "psatz_Q" int_or_var(i) ] -> [ (Coq_micromega.psatz_Q i) ] | [ "psatz_Q" ] -> [ (Coq_micromega.psatz_Q (-1)) ] END diff --git a/plugins/micromega/mfourier.ml b/plugins/micromega/mfourier.ml index 0261d73490..e22fe58434 100644 --- a/plugins/micromega/mfourier.ml +++ b/plugins/micromega/mfourier.ml @@ -120,7 +120,7 @@ and cstr_info = { (** A system of constraints has the form [\{sys = s ; vars = v\}]. [s] is a hashtable mapping a normalised vector to a [cstr_info] record where - [bound] is an interval - - [prf_idx] is the set of hypothese indexes (i.e. constraints in the initial system) used to obtain the current constraint. + - [prf_idx] is the set of hypothesis indexes (i.e. constraints in the initial system) used to obtain the current constraint. In the initial system, each constraint is given an unique singleton proof_idx. When a new constraint c is computed by a function f(c1,...,cn), its proof_idx is ISet.fold union (List.map (fun x -> x.proof_idx) [c1;...;cn] - [pos] is the number of positive values of the vector @@ -872,7 +872,7 @@ let mk_proof hyps prf = | Elim(v,prf1,prf2) -> let prfsl = mk_proof prf1 and prfsr = mk_proof prf2 in - (* I take only the pairs for which the elimination is meaningfull *) + (* I take only the pairs for which the elimination is meaningful *) forall_pairs (pivot v) prfsl prfsr | And(prf1,prf2) -> let prfsl1 = mk_proof prf1 diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 2b07ba7044..88c8465b1b 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -137,8 +137,8 @@ let closed_term_ast l = let l = List.map (fun gr -> ArgArg(Loc.ghost,gr)) l in TacFun([Some(Id.of_string"t")], TacML(Loc.ghost,tacname, - [Genarg.in_gen (Genarg.glbwit Constrarg.wit_constr) (GVar(Loc.ghost,Id.of_string"t"),None); - Genarg.in_gen (Genarg.glbwit (Genarg.wit_list Constrarg.wit_ref)) l])) + [TacGeneric (Genarg.in_gen (Genarg.glbwit Constrarg.wit_constr) (GVar(Loc.ghost,Id.of_string"t"),None)); + TacGeneric (Genarg.in_gen (Genarg.glbwit (Genarg.wit_list Constrarg.wit_ref)) l)])) (* let _ = add_tacdef false ((Loc.ghost,Id.of_string"ring_closed_term" *) @@ -209,7 +209,7 @@ let get_res = let name = { mltac_plugin = "newring_plugin"; mltac_tactic = "get_res"; } in let entry = { mltac_name = name; mltac_index = 0 } in let tac args ist = - let n = Genarg.out_gen (Genarg.topwit Stdarg.wit_int) (List.hd args) in + let n = Tacinterp.Value.cast (Genarg.topwit Stdarg.wit_int) (List.hd args) in let init i = Id.Map.find (Id.of_string ("x" ^ string_of_int i)) ist.lfun in tactic_res := Array.init n init; Proofview.tclUNIT () @@ -228,7 +228,7 @@ let exec_tactic env evd n f args = (** Build the getter *) let lid = List.init n (fun i -> Id.of_string("x"^string_of_int i)) in let n = Genarg.in_gen (Genarg.glbwit Stdarg.wit_int) n in - let get_res = TacML (Loc.ghost, get_res, [n]) in + let get_res = TacML (Loc.ghost, get_res, [TacGeneric n]) in let getter = Tacexp (TacFun (List.map (fun id -> Some id) lid, get_res)) in (** Evaluate the whole result *) let gl = dummy_goal env evd in diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index c6c397135a..af2877d34f 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -1006,21 +1006,6 @@ let postpone_non_unique_projection env evd pbty (evk,argsv as ev) sols rhs = * Note: argument f is the function used to instantiate evars. *) -let are_canonical_instances args1 args2 env = - let n1 = Array.length args1 in - let n2 = Array.length args2 in - let rec aux n = function - | (id,_,c)::sign - when n < n1 && isVarId id args1.(n) && isVarId id args2.(n) -> - aux (n+1) sign - | [] -> - let rec aux2 n = - Int.equal n n1 || - (isRelN (n1-n) args1.(n) && isRelN (n1-n) args2.(n) && aux2 (n+1)) - in aux2 n - | _ -> false in - Int.equal n1 n2 && aux 0 (named_context env) - let filter_compatible_candidates conv_algo env evd evi args rhs c = let c' = instantiate_evar_array evi c args in match conv_algo env evd Reduction.CONV rhs c' with diff --git a/pretyping/nativenorm.mli b/pretyping/nativenorm.mli index 0352038385..286cb2e079 100644 --- a/pretyping/nativenorm.mli +++ b/pretyping/nativenorm.mli @@ -8,7 +8,6 @@ open Term open Environ open Evd -open Nativelambda (** This module implements normalization by evaluation to OCaml code *) diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 6d9ed9a30c..84beaa9e3c 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -46,7 +46,7 @@ open Misctypes type typing_constraint = OfType of types | IsType | WithoutTypeConstraint type var_map = constr_under_binders Id.Map.t type uconstr_var_map = Glob_term.closed_glob_constr Id.Map.t -type unbound_ltac_var_map = Genarg.tlevel Genarg.generic_argument Id.Map.t +type unbound_ltac_var_map = Genarg.Val.t Id.Map.t type ltac_var_map = { ltac_constrs : var_map; ltac_uconstrs : uconstr_var_map; @@ -443,26 +443,12 @@ let new_type_evar env evdref loc = univ_flexible_alg ~src:(loc,Evar_kinds.InternalHole)) evdref in e -let get_projection env cst = - let cb = lookup_constant cst env in - match cb.Declarations.const_proj with - | Some {Declarations.proj_ind = mind; proj_npars = n; - proj_arg = m; proj_type = ty} -> - (cst,mind,n,m,ty) - | None -> raise Not_found - let (f_genarg_interp, genarg_interp_hook) = Hook.make () (* [pretype tycon env evdref lvar lmeta cstr] attempts to type [cstr] *) (* in environment [env], with existential variables [evdref] and *) (* the type constraint tycon *) -let is_GHole = function - | GHole _ -> true - | _ -> false - -let evars = ref Id.Map.empty - let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_var_map) t = let inh_conv_coerce_to_tycon = inh_conv_coerce_to_tycon resolve_tc in let pretype_type = pretype_type k0 resolve_tc in diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index f8587d01cd..8b76816ab2 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -29,7 +29,7 @@ type typing_constraint = OfType of types | IsType | WithoutTypeConstraint type var_map = Pattern.constr_under_binders Id.Map.t type uconstr_var_map = Glob_term.closed_glob_constr Id.Map.t -type unbound_ltac_var_map = Genarg.tlevel Genarg.generic_argument Id.Map.t +type unbound_ltac_var_map = Genarg.Val.t Id.Map.t type ltac_var_map = { ltac_constrs : var_map; @@ -152,5 +152,5 @@ val interp_sort : evar_map -> glob_sort -> evar_map * sorts val interp_elimination_sort : glob_sort -> sorts_family val genarg_interp_hook : - (types -> env -> evar_map -> Genarg.typed_generic_argument Id.Map.t -> + (types -> env -> evar_map -> unbound_ltac_var_map -> Genarg.glob_generic_argument -> constr * evar_map) Hook.t diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index 7fde7b7ac4..af48654015 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -299,7 +299,7 @@ let check_and_decompose_canonical_structure ref = | Construct ((indsp,1),u) -> indsp | _ -> error_not_structure ref in let s = try lookup_structure indsp with Not_found -> error_not_structure ref in - let ntrue_projs = List.length (List.filter (fun (_, x) -> x) s.s_PROJKIND) in + let ntrue_projs = List.count snd s.s_PROJKIND in if s.s_EXPECTEDPARAM + ntrue_projs > Array.length args then error_not_structure ref; (sp,indsp) diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 5195784a4c..55bce23089 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -221,7 +221,6 @@ val splay_prod_n : env -> evar_map -> int -> constr -> Context.Rel.t * constr val splay_lam_n : env -> evar_map -> int -> constr -> Context.Rel.t * constr val splay_prod_assum : env -> evar_map -> constr -> Context.Rel.t * constr -val is_sort : env -> evar_map -> types -> bool type 'a miota_args = { mP : constr; (** the result type *) diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 48911a5a9f..31e75e5508 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -940,8 +940,6 @@ let matches_head env sigma c t = | Proj (p, _) -> Constr_matching.matches env sigma c (mkConst (Projection.constant p)) | _ -> raise Constr_matching.PatternMatchingFailure -let is_pattern_meta = function Pattern.PMeta _ -> true | _ -> false - (** FIXME: Specific function to handle projections: it ignores what happens on the parameters. This is a temporary fix while rewrite etc... are not up to equivalence of the projection and its eta expanded form. @@ -1055,10 +1053,6 @@ let unfold env sigma name = else error (string_of_evaluable_ref env name^" is opaque.") -let is_projection env = function - | EvalVarRef _ -> false - | EvalConstRef c -> Environ.is_projection c env - (* [unfoldoccs : (readable_constraints -> (int list * full_path) -> constr -> constr)] * Unfolds the constant name in a term c following a list of occurrences occl. * at the occurrences of occ_list. If occ_list is empty, unfold all occurrences. diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index c4f22987f7..5595c3cdc2 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -435,7 +435,7 @@ let instance_constructor (cl,u) args = | None -> true | Some _ -> false in - let lenpars = List.length (List.filter filter (snd cl.cl_context)) in + let lenpars = List.count filter (snd cl.cl_context) in let pars = fst (List.chop lenpars args) in match cl.cl_impl with | IndRef ind -> diff --git a/pretyping/typing.ml b/pretyping/typing.ml index 2f9803b62f..11ad7bfdf5 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -143,8 +143,13 @@ let e_judge_of_cast env evdref cj k tj = { uj_val = mkCast (cj.uj_val, k, expected_type); uj_type = expected_type } -(* The typing machine without information, without universes but with - existential variables. *) +let enrich_env env evdref = + let penv = Environ.pre_env env in + let penv' = Pre_env.({ penv with env_stratification = + { penv.env_stratification with env_universes = Evd.universes !evdref } }) in + Environ.env_of_pre_env penv' + +(* The typing machine with universes and existential variables. *) (* cstr must be in n.f. w.r.t. evars and execute returns a judgement where both the term and type are in n.f. *) @@ -263,6 +268,7 @@ and execute_recdef env evdref (names,lar,vdef) = and execute_array env evdref = Array.map (execute env evdref) let check env evdref c t = + let env = enrich_env env evdref in let j = execute env evdref c in if not (Evarconv.e_cumul env evdref j.uj_type t) then error_actual_type env j (nf_evar !evdref t) @@ -270,12 +276,15 @@ let check env evdref c t = (* Type of a constr *) let unsafe_type_of env evd c = - let j = execute env (ref evd) c in + let evdref = ref evd in + let env = enrich_env env evdref in + let j = execute env evdref c in j.uj_type (* Sort of a type *) let sort_of env evdref c = + let env = enrich_env env evdref in let j = execute env evdref c in let a = e_type_judgment env evdref j in a.utj_type @@ -284,6 +293,7 @@ let sort_of env evdref c = let type_of ?(refresh=false) env evd c = let evdref = ref evd in + let env = enrich_env env evdref in let j = execute env evdref c in (* side-effect on evdref *) if refresh then @@ -291,6 +301,7 @@ let type_of ?(refresh=false) env evd c = else !evdref, j.uj_type let e_type_of ?(refresh=false) env evdref c = + let env = enrich_env env evdref in let j = execute env evdref c in (* side-effect on evdref *) if refresh then @@ -300,6 +311,7 @@ let e_type_of ?(refresh=false) env evdref c = else j.uj_type let solve_evars env evdref c = + let env = enrich_env env evdref in let c = (execute env evdref c).uj_val in (* side-effect on evdref *) nf_evar !evdref c diff --git a/pretyping/vnorm.mli b/pretyping/vnorm.mli index 9421b2d859..b75fe7c928 100644 --- a/pretyping/vnorm.mli +++ b/pretyping/vnorm.mli @@ -8,7 +8,6 @@ open Term open Environ -open Evd (** {6 Reduction functions } *) val cbv_vm : env -> constr -> types -> constr diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index 56429410cb..c07057a096 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -136,8 +136,6 @@ end) = struct let pr_sep_com sep f c = pr_with_comments (constr_loc c) (sep() ++ f c) - let pr_in_comment pr x = str "(* " ++ pr x ++ str " *)" - let pr_univ l = match l with | [_,x] -> str x @@ -153,11 +151,11 @@ end) = struct let pr_qualid sp = let (sl, id) = repr_qualid sp in - let id = tag_ref (str (Id.to_string id)) in + let id = tag_ref (pr_id id) in let sl = match List.rev (DirPath.repr sl) with | [] -> mt () | sl -> - let pr dir = tag_path (str (Id.to_string dir)) ++ str "." in + let pr dir = tag_path (pr_id dir) ++ str "." in prlist pr sl in sl ++ id @@ -182,7 +180,7 @@ end) = struct let pr_reference = function | Qualid (_, qid) -> pr_qualid qid - | Ident (_, id) -> tag_var (str (Id.to_string id)) + | Ident (_, id) -> tag_var (pr_id id) let pr_cref ref us = pr_reference ref ++ pr_universe_instance us diff --git a/printing/pptactic.ml b/printing/pptactic.ml index 4d14cae7a7..a5716279f3 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -267,15 +267,9 @@ module Make let rec pr_raw_generic_rec prc prlc prtac prpat prref (x:Genarg.rlevel Genarg.generic_argument) = match Genarg.genarg_tag x with - | IntOrVarArgType -> pr_or_var int (out_gen (rawwit wit_int_or_var) x) | IdentArgType -> pr_id (out_gen (rawwit wit_ident) x) | VarArgType -> pr_located pr_id (out_gen (rawwit wit_var) x) - | GenArgType -> pr_raw_generic_rec prc prlc prtac prpat prref (out_gen (rawwit wit_genarg) x) | ConstrArgType -> prc (out_gen (rawwit wit_constr) x) - | ConstrMayEvalArgType -> - pr_may_eval prc prlc (pr_or_by_notation prref) prpat - (out_gen (rawwit wit_constr_may_eval) x) - | OpenConstrArgType -> prc (snd (out_gen (rawwit wit_open_constr) x)) | ListArgType _ -> let list_unpacker wit l = let map x = pr_raw_generic_rec prc prlc prtac prpat prref (in_gen (rawwit wit) x) in @@ -303,16 +297,9 @@ module Make let rec pr_glb_generic_rec prc prlc prtac prpat x = match Genarg.genarg_tag x with - | IntOrVarArgType -> pr_or_var int (out_gen (glbwit wit_int_or_var) x) | IdentArgType -> pr_id (out_gen (glbwit wit_ident) x) | VarArgType -> pr_located pr_id (out_gen (glbwit wit_var) x) - | GenArgType -> pr_glb_generic_rec prc prlc prtac prpat (out_gen (glbwit wit_genarg) x) | ConstrArgType -> prc (out_gen (glbwit wit_constr) x) - | ConstrMayEvalArgType -> - pr_may_eval prc prlc - (pr_or_var (pr_and_short_name pr_evaluable_reference)) prpat - (out_gen (glbwit wit_constr_may_eval) x) - | OpenConstrArgType -> prc (snd (out_gen (glbwit wit_open_constr) x)) | ListArgType _ -> let list_unpacker wit l = let map x = pr_glb_generic_rec prc prlc prtac prpat (in_gen (glbwit wit) x) in @@ -339,13 +326,9 @@ module Make let rec pr_top_generic_rec prc prlc prtac prpat x = match Genarg.genarg_tag x with - | IntOrVarArgType -> pr_or_var int (out_gen (topwit wit_int_or_var) x) | IdentArgType -> pr_id (out_gen (topwit wit_ident) x) | VarArgType -> pr_id (out_gen (topwit wit_var) x) - | GenArgType -> pr_top_generic_rec prc prlc prtac prpat (out_gen (topwit wit_genarg) x) | ConstrArgType -> prc (out_gen (topwit wit_constr) x) - | ConstrMayEvalArgType -> prc (out_gen (topwit wit_constr_may_eval) x) - | OpenConstrArgType -> prc (snd (out_gen (topwit wit_open_constr) x)) | ListArgType _ -> let list_unpacker wit l = let map x = pr_top_generic_rec prc prlc prtac prpat (in_gen (topwit wit) x) in @@ -388,10 +371,11 @@ module Make in pr_sequence (fun x -> x) l - let pr_extend_gen pr_gen lev { mltac_name = s; mltac_index = i } l = + let pr_extend_gen check pr_gen lev { mltac_name = s; mltac_index = i } l = try let pp_rules = Hashtbl.find prtac_tab s in let pp = pp_rules.(i) in + let () = if not (List.for_all2eq check pp.pptac_args l) then raise Not_found in let (lev', pl) = pp.pptac_prods in let p = pr_tacarg_using_rule pr_gen (pl,l) in if lev' > lev then surround p else p @@ -406,28 +390,35 @@ module Make in str "<" ++ name ++ str ">" ++ args - let pr_alias_gen pr_gen lev key l = + let pr_alias_gen check pr_gen lev key l = try let pp = KNmap.find key !prnotation_tab in let (lev', pl) = pp.pptac_prods in + let () = if not (List.for_all2eq check pp.pptac_args l) then raise Not_found in let p = pr_tacarg_using_rule pr_gen (pl, l) in if lev' > lev then surround p else p with Not_found -> KerName.print key ++ spc() ++ pr_sequence pr_gen l ++ str" (* Generic printer *)" + let check_type t arg = match arg with + | TacGeneric arg -> argument_type_eq t (genarg_tag arg) + | _ -> false + + let unwrap_gen f = function TacGeneric x -> f x | _ -> assert false + let pr_raw_extend_rec prc prlc prtac prpat = - pr_extend_gen (pr_raw_generic_rec prc prlc prtac prpat pr_reference) + pr_extend_gen check_type (unwrap_gen (pr_raw_generic_rec prc prlc prtac prpat pr_reference)) let pr_glob_extend_rec prc prlc prtac prpat = - pr_extend_gen (pr_glb_generic_rec prc prlc prtac prpat) + pr_extend_gen check_type (unwrap_gen (pr_glb_generic_rec prc prlc prtac prpat)) let pr_extend_rec prc prlc prtac prpat = - pr_extend_gen (pr_top_generic_rec prc prlc prtac prpat) + pr_extend_gen check_type (unwrap_gen (pr_top_generic_rec prc prlc prtac prpat)) let pr_raw_alias prc prlc prtac prpat = - pr_alias_gen (pr_raw_generic_rec prc prlc prtac prpat pr_reference) + pr_alias_gen check_type (unwrap_gen (pr_raw_generic_rec prc prlc prtac prpat pr_reference)) let pr_glob_alias prc prlc prtac prpat = - pr_alias_gen (pr_glb_generic_rec prc prlc prtac prpat) + pr_alias_gen check_type (unwrap_gen (pr_glb_generic_rec prc prlc prtac prpat)) let pr_alias prc prlc prtac prpat = - pr_alias_gen (pr_top_generic_rec prc prlc prtac prpat) + pr_alias_gen check_type (unwrap_gen (pr_top_generic_rec prc prlc prtac prpat)) (**********************************************************************) (* The tactic printer *) @@ -694,11 +685,6 @@ module Make | l -> spc () ++ hov 2 (keyword "using" ++ spc () ++ prlist_with_sep pr_comma prc l) - let string_of_debug = function - | Off -> "" - | Debug -> "debug " - | Info -> "info_" - let pr_then () = str ";" let ltop = (5,E) @@ -733,8 +719,8 @@ module Make pr_reference : 'ref -> std_ppcmds; pr_name : 'nam -> std_ppcmds; pr_generic : 'lev generic_argument -> std_ppcmds; - pr_extend : int -> ml_tactic_entry -> 'lev generic_argument list -> std_ppcmds; - pr_alias : int -> KerName.t -> 'lev generic_argument list -> std_ppcmds; + pr_extend : int -> ml_tactic_entry -> 'a gen_tactic_arg list -> std_ppcmds; + pr_alias : int -> KerName.t -> 'a gen_tactic_arg list -> std_ppcmds; } constraint 'a = < @@ -821,8 +807,6 @@ module Make let rec pr_atom0 a = tag_atom a (match a with | TacIntroPattern [] -> primitive "intros" | TacIntroMove (None,MoveLast) -> primitive "intro" - | TacTrivial (d,[],Some []) -> str (string_of_debug d) ++ primitive "trivial" - | TacAuto (d,None,[],Some []) -> str (string_of_debug d) ++ primitive "auto" | TacClear (true,[]) -> primitive "clear" | t -> str "(" ++ pr_atom1 t ++ str ")" ) @@ -931,23 +915,6 @@ module Make ++ pr_arg pr_quantified_hypothesis h2 ) - (* Automation tactics *) - | TacTrivial (_,[],Some []) as x -> - pr_atom0 x - | TacTrivial (d,lems,db) -> - hov 0 ( - str (string_of_debug d) ++ primitive "trivial" - ++ pr_auto_using pr.pr_constr lems ++ pr_hintbases db - ) - | TacAuto (_,None,[],Some []) as x -> - pr_atom0 x - | TacAuto (d,n,lems,db) -> - hov 0 ( - str (string_of_debug d) ++ primitive "auto" - ++ pr_opt (pr_or_var int) n - ++ pr_auto_using pr.pr_constr lems ++ pr_hintbases db - ) - (* Context management *) | TacClear (true,[]) as t -> pr_atom0 t @@ -1229,7 +1196,7 @@ module Make | TacML (loc,s,l) -> pr_with_comments loc (pr.pr_extend 1 s l), lcall | TacAlias (loc,kn,l) -> - pr_with_comments loc (pr.pr_alias (level_of inherited) kn (List.map snd l)), latom + pr_with_comments loc (pr.pr_alias (level_of inherited) kn l), latom ) in if prec_less prec inherited then strm @@ -1296,7 +1263,7 @@ module Make let pr_pat_and_constr_expr pr ((c,_),_) = pr c - let rec pr_glob_tactic_level env n t = + let pr_glob_tactic_level env n t = let glob_printers = (strip_prod_binders_glob_constr) in @@ -1388,9 +1355,18 @@ module Make (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) (pr_glob_tactic_level env) (pr_pat_and_constr_expr (pr_glob_constr_env env)) - let pr_extend env = pr_extend_rec - (pr_constr_env env Evd.empty) (pr_lconstr_env env Evd.empty) - (pr_glob_tactic_level env) pr_constr_pattern + let check_val_type t arg = + let t = Genarg.val_tag (Obj.magic t) in (** FIXME *) + let Val.Dyn (t', _) = arg in + match Genarg.Val.eq t t' with + | None -> false + | Some _ -> true + + let pr_alias pr lev key args = + pr_alias_gen check_val_type pr lev key args + + let pr_extend pr lev ml args = + pr_extend_gen check_val_type pr lev ml args let pr_tactic env = pr_tactic_level env ltop @@ -1435,6 +1411,8 @@ let () = let pr_bool b = if b then str "true" else str "false" in let pr_unit _ = str "()" in let pr_string s = str "\"" ++ str s ++ str "\"" in + Genprint.register_print0 Constrarg.wit_int_or_var + (pr_or_var int) (pr_or_var int) int; Genprint.register_print0 Constrarg.wit_ref pr_reference (pr_or_var (pr_located pr_global)) pr_global; Genprint.register_print0 @@ -1456,6 +1434,12 @@ let () = (fun (c,_) -> Printer.pr_glob_constr c) Printer.pr_closed_glob ; + Genprint.register_print0 + Constrarg.wit_open_constr + Ppconstr.pr_constr_expr + (fun (c, _) -> Printer.pr_glob_constr c) + Printer.pr_constr + ; Genprint.register_print0 Constrarg.wit_red_expr (pr_red_expr (pr_constr_expr, pr_lconstr_expr, pr_or_by_notation pr_reference, pr_constr_pattern_expr)) (pr_red_expr (pr_and_constr_expr pr_glob_constr, pr_lglob_constr, pr_or_var (pr_and_short_name pr_evaluable_reference), pr_pat_and_constr_expr pr_glob_constr)) @@ -1464,11 +1448,16 @@ let () = Genprint.register_print0 Constrarg.wit_bindings (pr_bindings_no_with pr_constr_expr pr_lconstr_expr) (pr_bindings_no_with (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr)) - (fun { Evd.it = it } -> pr_bindings_no_with pr_constr pr_lconstr it); + (fun it -> pr_bindings_no_with pr_constr pr_lconstr (fst (run_delayed it))); + Genprint.register_print0 Constrarg.wit_constr_may_eval + (pr_may_eval pr_constr_expr pr_lconstr_expr (pr_or_by_notation pr_reference) pr_constr_pattern_expr) + (pr_may_eval (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr) + (pr_or_var (pr_and_short_name pr_evaluable_reference)) (pr_pat_and_constr_expr pr_glob_constr)) + pr_constr; Genprint.register_print0 Constrarg.wit_constr_with_bindings (pr_with_bindings pr_constr_expr pr_lconstr_expr) (pr_with_bindings (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr)) - (fun { Evd.it = it } -> pr_with_bindings pr_constr pr_lconstr it); + (fun it -> pr_with_bindings pr_constr pr_lconstr (fst (run_delayed it))); Genprint.register_print0 Stdarg.wit_int int int int; Genprint.register_print0 Stdarg.wit_bool pr_bool pr_bool pr_bool; Genprint.register_print0 Stdarg.wit_unit pr_unit pr_unit pr_unit; diff --git a/printing/pptacticsig.mli b/printing/pptacticsig.mli index 1c17d04928..5b89266553 100644 --- a/printing/pptacticsig.mli +++ b/printing/pptacticsig.mli @@ -8,11 +8,9 @@ open Pp open Genarg -open Constrexpr open Tacexpr open Ppextend open Environ -open Pattern open Misctypes module type Pp = sig @@ -40,13 +38,16 @@ module type Pp = sig val pr_top_generic : env -> tlevel generic_argument -> std_ppcmds val pr_raw_extend: env -> int -> - ml_tactic_entry -> raw_generic_argument list -> std_ppcmds + ml_tactic_entry -> raw_tactic_arg list -> std_ppcmds val pr_glob_extend: env -> int -> - ml_tactic_entry -> glob_generic_argument list -> std_ppcmds + ml_tactic_entry -> glob_tactic_arg list -> std_ppcmds - val pr_extend : env -> int -> - ml_tactic_entry -> typed_generic_argument list -> std_ppcmds + val pr_extend : + (Val.t -> std_ppcmds) -> int -> ml_tactic_entry -> Val.t list -> std_ppcmds + + val pr_alias : (Val.t -> std_ppcmds) -> + int -> Names.KerName.t -> Val.t list -> std_ppcmds val pr_ltac_constant : Nametab.ltac_constant -> std_ppcmds diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index f216c599d0..daba18bad2 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -105,10 +105,9 @@ module Make else id let pr_production_item = function - | TacNonTerm (loc,nt,Some (p,sep)) -> + | TacNonTerm (loc, nt, (p, sep)) -> let pp_sep = if not (String.is_empty sep) then str "," ++ quote (str sep) else mt () in str nt ++ str"(" ++ pr_id (strip_meta p) ++ pp_sep ++ str")" - | TacNonTerm (loc,nt,None) -> str nt | TacTerm s -> qs s let pr_comment pr_c = function @@ -1034,7 +1033,7 @@ module Make let pr_tac_body tacdef_body = let id, redef, body = match tacdef_body with - | TacticDefinition ((_,id), body) -> str (Id.to_string id), false, body + | TacticDefinition ((_,id), body) -> pr_id id, false, body | TacticRedefinition (id, body) -> pr_ltac_ref id, true, body in let idl, body = diff --git a/printing/prettyp.ml b/printing/prettyp.ml index 84649e6ebf..08228cb209 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -132,7 +132,7 @@ let print_renames_list prefix l = let need_expansion impl ref = let typ = Global.type_of_global_unsafe ref in let ctx = prod_assum typ in - let nprods = List.length (List.filter (fun (_,b,_) -> Option.is_empty b) ctx) in + let nprods = List.count (fun (_,b,_) -> Option.is_empty b) ctx in not (List.is_empty impl) && List.length impl >= nprods && let _,lastimpl = List.chop nprods impl in List.exists is_status_implicit lastimpl diff --git a/printing/printer.ml b/printing/printer.ml index 773127c772..08fd0186a0 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -639,8 +639,8 @@ let pr_open_subgoals ?(proof=Proof_global.give_me_the_proof ()) () = | _ , _, _ -> let end_cmd = str "This subproof is complete, but there are some unfocused goals." ++ - (match Proof_global.Bullet.suggest p - with None -> str"" | Some s -> fnl () ++ str s) ++ + (let s = Proof_global.Bullet.suggest p in + if Pp.is_empty s then s else fnl () ++ s) ++ fnl () in pr_subgoals ~pr_first:false (Some end_cmd) bsigma seeds shelf [] bgoals @@ -777,7 +777,7 @@ let pr_assumptionset env s = let (v, a, o, tr) = accu in match t with | Variable id -> - let var = str (Id.to_string id) ++ str " : " ++ pr_ltype typ in + let var = pr_id id ++ str " : " ++ pr_ltype typ in (var :: v, a, o, tr) | Axiom (kn,[]) -> let ax = safe_pr_constant env kn ++ safe_pr_ltype typ in @@ -786,7 +786,7 @@ let pr_assumptionset env s = let ax = safe_pr_constant env kn ++ safe_pr_ltype typ ++ cut() ++ prlist_with_sep cut (fun (lbl, ctx, ty) -> - str " used in " ++ str (Names.Label.to_string lbl) ++ + str " used in " ++ pr_label lbl ++ str " to prove:" ++ safe_pr_ltype_relctx (ctx,ty)) l in (v, ax :: a, o, tr) diff --git a/printing/printmod.ml b/printing/printmod.ml index d277d3782a..3973c2db67 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -263,7 +263,7 @@ let nametab_register_modparam mbid mtb = List.iter (nametab_register_body mp dir) struc let print_body is_impl env mp (l,body) = - let name = str (Label.to_string l) in + let name = pr_label l in hov 2 (match body with | SFBmodule _ -> keyword "Module" ++ spc () ++ name | SFBmodtype _ -> keyword "Module Type" ++ spc () ++ name diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 5cfec1b0db..22aab6585c 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -466,7 +466,7 @@ module Bullet = struct type behavior = { name : string; put : Proof.proof -> t -> Proof.proof; - suggest: Proof.proof -> string option + suggest: Proof.proof -> std_ppcmds } let behaviors = Hashtbl.create 4 @@ -476,7 +476,7 @@ module Bullet = struct let none = { name = "None"; put = (fun x _ -> x); - suggest = (fun _ -> None) + suggest = (fun _ -> mt ()) } let _ = register_behavior none @@ -492,26 +492,20 @@ module Bullet = struct (* give a message only if more informative than the standard coq message *) let suggest_on_solved_goal sugg = match sugg with - | NeedClosingBrace -> Some "Try unfocusing with \"}\"." - | NoBulletInUse -> None - | ProofFinished -> None - | Suggest b -> Some ("Focus next goal with bullet " - ^ Pp.string_of_ppcmds (Pp.(pr_bullet b)) - ^".") - | Unfinished b -> Some ("The current bullet " - ^ Pp.string_of_ppcmds (Pp.(pr_bullet b)) - ^ " is unfinished.") + | NeedClosingBrace -> str"Try unfocusing with \"}\"." + | NoBulletInUse -> mt () + | ProofFinished -> mt () + | Suggest b -> str"Focus next goal with bullet " ++ pr_bullet b ++ str"." + | Unfinished b -> str"The current bullet " ++ pr_bullet b ++ str" is unfinished." (* give always a message. *) let suggest_on_error sugg = match sugg with - | NeedClosingBrace -> "Try unfocusing with \"}\"." + | NeedClosingBrace -> str"Try unfocusing with \"}\"." | NoBulletInUse -> assert false (* This should never raise an error. *) - | ProofFinished -> "No more subgoals." - | Suggest b -> ("Bullet " ^ Pp.string_of_ppcmds (Pp.(pr_bullet b)) - ^ " is mandatory here.") - | Unfinished b -> ("Current bullet " ^ Pp.string_of_ppcmds (Pp.(pr_bullet b)) - ^ " is not finished.") + | ProofFinished -> str"No more subgoals." + | Suggest b -> str"Bullet " ++ pr_bullet b ++ str" is mandatory here." + | Unfinished b -> str"Current bullet " ++ pr_bullet b ++ str" is not finished." exception FailedBullet of t * suggestion @@ -519,8 +513,8 @@ module Bullet = struct Errors.register_handler (function | FailedBullet (b,sugg) -> - let prefix = "Wrong bullet " ^ Pp.string_of_ppcmds (Pp.(pr_bullet b)) ^ " : " in - Errors.errorlabstrm "Focus" (str prefix ++ str (suggest_on_error sugg)) + let prefix = str"Wrong bullet " ++ pr_bullet b ++ str" : " in + Errors.errorlabstrm "Focus" (prefix ++ suggest_on_error sugg) | _ -> raise Errors.Unhandled) diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index 5f11589508..5d89044c3d 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -172,7 +172,7 @@ module Bullet : sig type behavior = { name : string; put : Proof.proof -> t -> Proof.proof; - suggest: Proof.proof -> string option + suggest: Proof.proof -> Pp.std_ppcmds } (** A registered behavior can then be accessed in Coq @@ -189,7 +189,7 @@ module Bullet : sig (** Handles focusing/defocusing with bullets: *) val put : Proof.proof -> t -> Proof.proof - val suggest : Proof.proof -> string option + val suggest : Proof.proof -> Pp.std_ppcmds end diff --git a/proofs/proofview.ml b/proofs/proofview.ml index 9ee7df14c8..e01bed5dad 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -353,7 +353,7 @@ exception NoSuchGoals of int (* This hook returns a string to be appended to the usual message. Primarily used to add a suggestion about the right bullet to use to focus the next goal, if applicable. *) -let nosuchgoals_hook:(int -> string option) ref = ref ((fun n -> None)) +let nosuchgoals_hook:(int -> std_ppcmds) ref = ref (fun n -> mt ()) let set_nosuchgoals_hook f = nosuchgoals_hook := f @@ -361,10 +361,9 @@ let set_nosuchgoals_hook f = nosuchgoals_hook := f (* This uses the hook above *) let _ = Errors.register_handler begin function | NoSuchGoals n -> - let suffix:string option = (!nosuchgoals_hook) n in + let suffix = !nosuchgoals_hook n in Errors.errorlabstrm "" - (str "No such " ++ str (String.plural n "goal") ++ str "." - ++ pr_opt str suffix) + (str "No such " ++ str (String.plural n "goal") ++ str "." ++ suffix) | _ -> raise Errors.Unhandled end diff --git a/proofs/proofview.mli b/proofs/proofview.mli index aac56e565e..1c968e427e 100644 --- a/proofs/proofview.mli +++ b/proofs/proofview.mli @@ -235,7 +235,7 @@ val tclBREAK : (iexn -> iexn option) -> 'a tactic -> 'a tactic This hook is used to add a suggestion about bullets when applicable. *) exception NoSuchGoals of int -val set_nosuchgoals_hook: (int -> string option) -> unit +val set_nosuchgoals_hook: (int -> Pp.std_ppcmds) -> unit val tclFOCUS : int -> int -> 'a tactic -> 'a tactic diff --git a/proofs/redexpr.ml b/proofs/redexpr.ml index be92f2b04c..89ecdb0df2 100644 --- a/proofs/redexpr.ml +++ b/proofs/redexpr.ml @@ -158,8 +158,6 @@ let make_flag env f = f.rConst red in red -let is_reference = function PRef _ | PVar _ -> true | _ -> false - (* table of custom reductino fonctions, not synchronized, filled via ML calls to [declare_reduction] *) let reduction_tab = ref String.Map.empty diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml index e525031e63..e0315dec52 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -60,9 +60,7 @@ module Make(T : Task) = struct type more_data = | MoreDataUnivLevel of Univ.universe_level list - - let request_expiry_of_task (t, c) = T.request_of_task t, c - + let slave_respond (Request r) = let res = T.perform r in Response res @@ -125,8 +123,9 @@ module Make(T : Task) = struct "-async-proofs-worker-priority"; Flags.string_of_priority !Flags.async_proofs_worker_priority] | ("-ideslave"|"-emacs"|"-emacs-U"|"-batch")::tl -> set_slave_opt tl - | ("-async-proofs" |"-toploop" |"-vi2vo" |"-compile" - |"-load-vernac-source" |"-compile-verbose" + | ("-async-proofs" |"-toploop" |"-vi2vo" + |"-load-vernac-source" |"-l" |"-load-vernac-source-verbose" |"-lv" + |"-compile" |"-compile-verbose" |"-async-proofs-worker-priority" |"-worker-id") :: _ :: tl -> set_slave_opt tl | x::tl -> x :: set_slave_opt tl in diff --git a/stm/lemmas.mli b/stm/lemmas.mli index e2ddf79df8..93f24b42cb 100644 --- a/stm/lemmas.mli +++ b/stm/lemmas.mli @@ -9,8 +9,6 @@ open Names open Term open Decl_kinds -open Constrexpr -open Vernacexpr open Pfedit type 'a declaration_hook diff --git a/stm/stm.ml b/stm/stm.ml index e0e7875036..e08f69a0e9 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -1470,6 +1470,18 @@ end = struct (* {{{ *) try Reach.known_state ~cache:`No id; let t, uc = Future.purify (fun () -> + let _,_,_,_,sigma0 = Proof.proof (Proof_global.give_me_the_proof ()) in + let g = Evd.find sigma0 r_goal in + if not ( + Evarutil.is_ground_term sigma0 Evd.(evar_concl g) && + List.for_all (fun (_,bo,ty) -> + Evarutil.is_ground_term sigma0 ty && + Option.cata (Evarutil.is_ground_term sigma0) true bo) + Evd.(evar_context g)) + then + Errors.errorlabstrm "Stm" (strbrk("the par: goal selector supports ground "^ + "goals only")) + else begin vernac_interp r_state_fb r_ast; let _,_,_,_,sigma = Proof.proof (Proof_global.give_me_the_proof ()) in match Evd.(evar_body (find sigma r_goal)) with @@ -1478,9 +1490,10 @@ end = struct (* {{{ *) let t = Evarutil.nf_evar sigma t in if Evarutil.is_ground_term sigma t then t, Evd.evar_universe_context sigma - else Errors.errorlabstrm "Stm" (str"The solution is not ground")) - () in - RespBuiltSubProof (t,uc) + else Errors.errorlabstrm "Stm" (str"The solution is not ground") + end) () + in + RespBuiltSubProof (t,uc) with e when Errors.noncritical e -> RespError (Errors.print e) let name_of_task { t_name } = t_name @@ -1616,7 +1629,7 @@ end = struct (* {{{ *) let vernac_interp switch prev id q = assert(TaskQueue.n_workers (Option.get !queue) > 0); TaskQueue.enqueue_task (Option.get !queue) - QueryTask.({ QueryTask.t_where = prev; t_for = id; t_what = q }, switch) + QueryTask.({ t_where = prev; t_for = id; t_what = q }, switch) let init () = queue := Some (TaskQueue.create (if !Flags.async_proofs_full then 1 else 0)) diff --git a/stm/texmacspp.ml b/stm/texmacspp.ml index 1996d35259..b18e35a472 100644 --- a/stm/texmacspp.ml +++ b/stm/texmacspp.ml @@ -20,9 +20,6 @@ let unlock loc = let start, stop = Loc.unloc loc in (string_of_int start, string_of_int stop) -let xmlNoop = (* almost noop *) - PCData "" - let xmlWithLoc loc ename attr xml = let start, stop = unlock loc in Element(ename, [ "begin", start; "end", stop ] @ attr, xml) diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index 58e26de841..dcb6700941 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -60,7 +60,7 @@ let undo_classifier = ref (fun _ -> assert false) let set_undo_classifier f = undo_classifier := f let rec classify_vernac e = - let rec static_classifier e = match e with + let static_classifier e = match e with (* PG compatibility *) | VernacUnsetOption (["Silent"]|["Undo"]|["Printing";"Depth"]) | VernacSetOption ((["Silent"]|["Undo"]|["Printing";"Depth"]),_) diff --git a/tactics/auto.ml b/tactics/auto.ml index a170c27fb9..726422c6f7 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -67,9 +67,6 @@ let auto_unif_flags_of st1 st2 useeager = let auto_unif_flags = auto_unif_flags_of full_transparent_state empty_transparent_state false -let auto_flags_of_state st = - auto_unif_flags_of full_transparent_state st false - (* Try unification with the precompiled clause, then use registered Apply *) let connect_hint_clenv poly (c, _, ctx) clenv gl = @@ -296,9 +293,6 @@ let tclTRY_dbg d tac = (* Papageno : cette fonction a été pas mal simplifiée depuis que la base de Hint impérative a été remplacée par plusieurs bases fonctionnelles *) -let auto_unif_flags = - auto_unif_flags_of full_transparent_state empty_transparent_state false - let flags_of_state st = auto_unif_flags_of st st false diff --git a/tactics/auto.mli b/tactics/auto.mli index 1132478aac..3e05d88217 100644 --- a/tactics/auto.mli +++ b/tactics/auto.mli @@ -10,7 +10,6 @@ open Names open Term open Clenv open Pattern -open Evd open Decl_kinds open Hints @@ -44,24 +43,24 @@ val conclPattern : constr -> constr_pattern option -> Tacexpr.glob_tactic_expr - "nocore" amongst the databases. *) val auto : ?debug:Tacexpr.debug -> - int -> open_constr list -> hint_db_name list -> unit Proofview.tactic + int -> Tacexpr.delayed_open_constr list -> hint_db_name list -> unit Proofview.tactic (** Auto with more delta. *) val new_auto : ?debug:Tacexpr.debug -> - int -> open_constr list -> hint_db_name list -> unit Proofview.tactic + int -> Tacexpr.delayed_open_constr list -> hint_db_name list -> unit Proofview.tactic (** auto with default search depth and with the hint database "core" *) val default_auto : unit Proofview.tactic (** auto with all hint databases except the "v62" compatibility database *) val full_auto : ?debug:Tacexpr.debug -> - int -> open_constr list -> unit Proofview.tactic + int -> Tacexpr.delayed_open_constr list -> unit Proofview.tactic (** auto with all hint databases except the "v62" compatibility database and doing delta *) val new_full_auto : ?debug:Tacexpr.debug -> - int -> open_constr list -> unit Proofview.tactic + int -> Tacexpr.delayed_open_constr list -> unit Proofview.tactic (** auto with default search depth and with all hint databases except the "v62" compatibility database *) @@ -69,19 +68,19 @@ val default_full_auto : unit Proofview.tactic (** The generic form of auto (second arg [None] means all bases) *) val gen_auto : ?debug:Tacexpr.debug -> - int option -> open_constr list -> hint_db_name list option -> unit Proofview.tactic + int option -> Tacexpr.delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic (** The hidden version of auto *) val h_auto : ?debug:Tacexpr.debug -> - int option -> open_constr list -> hint_db_name list option -> unit Proofview.tactic + int option -> Tacexpr.delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic (** Trivial *) val trivial : ?debug:Tacexpr.debug -> - open_constr list -> hint_db_name list -> unit Proofview.tactic + Tacexpr.delayed_open_constr list -> hint_db_name list -> unit Proofview.tactic val gen_trivial : ?debug:Tacexpr.debug -> - open_constr list -> hint_db_name list option -> unit Proofview.tactic + Tacexpr.delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic val full_trivial : ?debug:Tacexpr.debug -> - open_constr list -> unit Proofview.tactic + Tacexpr.delayed_open_constr list -> unit Proofview.tactic val h_trivial : ?debug:Tacexpr.debug -> - open_constr list -> hint_db_name list option -> unit Proofview.tactic + Tacexpr.delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index e4ff1c9069..dce6f674a6 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -197,7 +197,8 @@ let gen_auto_multi_rewrite conds tac_main lbas cl = try_do_hyps (fun id -> id) ids end }) -let auto_multi_rewrite ?(conds=Naive) = gen_auto_multi_rewrite conds (Proofview.tclUNIT()) +let auto_multi_rewrite ?(conds=Naive) lems cl = + Proofview.V82.wrap_exceptions (fun () -> gen_auto_multi_rewrite conds (Proofview.tclUNIT()) lems cl) let auto_multi_rewrite_with ?(conds=Naive) tac_main lbas cl = let onconcl = match cl.Locus.concl_occs with NoOccurrences -> false | _ -> true in @@ -206,7 +207,7 @@ let auto_multi_rewrite_with ?(conds=Naive) tac_main lbas cl = (* autorewrite with .... in clause using tac n'est sur que si clause represente soit le but soit UNE hypothese *) - gen_auto_multi_rewrite conds tac_main lbas cl + Proofview.V82.wrap_exceptions (fun () -> gen_auto_multi_rewrite conds tac_main lbas cl) | _ -> Tacticals.New.tclZEROMSG (strbrk "autorewrite .. in .. using can only be used either with a unique hypothesis or on the conclusion.") diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 4f0ffa024e..8cd7b1ad60 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -569,14 +569,6 @@ let rec fix_limit limit (t : 'a tac) : 'a tac = if Int.equal limit 0 then fail_tac ReachedLimit else then_tac t { skft = fun sk fk -> (fix_limit (pred limit) t).skft sk fk } -let fix_iterative' t = - let rec aux depth = - { skft = fun sk fk gls -> - (fix_limit depth t).skft sk - (function NotApplicable as e -> fk e - | ReachedLimit -> (aux (succ depth)).skft sk fk gls) gls } - in aux 1 - let fix_iterative t = let rec aux depth = or_else_tac (fix_limit depth t) diff --git a/tactics/coretactics.ml4 b/tactics/coretactics.ml4 index 92d4960a7c..10de3e866a 100644 --- a/tactics/coretactics.ml4 +++ b/tactics/coretactics.ml4 @@ -74,15 +74,13 @@ END TACTIC EXTEND left_with [ "left" "with" bindings(bl) ] -> [ - let { Evd.sigma = sigma ; it = bl } = bl in - Tacticals.New.tclWITHHOLES false (Tactics.left_with_bindings false bl) sigma + Tacticals.New.tclDELAYEDWITHHOLES false bl (fun bl -> Tactics.left_with_bindings false bl) ] END TACTIC EXTEND eleft_with [ "eleft" "with" bindings(bl) ] -> [ - let { Evd.sigma = sigma ; it = bl } = bl in - Tacticals.New.tclWITHHOLES true (Tactics.left_with_bindings true bl) sigma + Tacticals.New.tclDELAYEDWITHHOLES true bl (fun bl -> Tactics.left_with_bindings true bl) ] END @@ -98,15 +96,13 @@ END TACTIC EXTEND right_with [ "right" "with" bindings(bl) ] -> [ - let { Evd.sigma = sigma ; it = bl } = bl in - Tacticals.New.tclWITHHOLES false (Tactics.right_with_bindings false bl) sigma + Tacticals.New.tclDELAYEDWITHHOLES false bl (fun bl -> Tactics.right_with_bindings false bl) ] END TACTIC EXTEND eright_with [ "eright" "with" bindings(bl) ] -> [ - let { Evd.sigma = sigma ; it = bl } = bl in - Tacticals.New.tclWITHHOLES true (Tactics.right_with_bindings true bl) sigma + Tacticals.New.tclDELAYEDWITHHOLES true bl (fun bl -> Tactics.right_with_bindings true bl) ] END @@ -115,28 +111,22 @@ END TACTIC EXTEND constructor [ "constructor" ] -> [ Tactics.any_constructor false None ] | [ "constructor" int_or_var(i) ] -> [ - let i = Tacinterp.interp_int_or_var ist i in Tactics.constructor_tac false None i NoBindings ] | [ "constructor" int_or_var(i) "with" bindings(bl) ] -> [ - let { Evd.sigma = sigma; it = bl } = bl in - let i = Tacinterp.interp_int_or_var ist i in - let tac = Tactics.constructor_tac false None i bl in - Tacticals.New.tclWITHHOLES false tac sigma + let tac bl = Tactics.constructor_tac false None i bl in + Tacticals.New.tclDELAYEDWITHHOLES false bl tac ] END TACTIC EXTEND econstructor [ "econstructor" ] -> [ Tactics.any_constructor true None ] | [ "econstructor" int_or_var(i) ] -> [ - let i = Tacinterp.interp_int_or_var ist i in Tactics.constructor_tac true None i NoBindings ] | [ "econstructor" int_or_var(i) "with" bindings(bl) ] -> [ - let { Evd.sigma = sigma; it = bl } = bl in - let i = Tacinterp.interp_int_or_var ist i in - let tac = Tactics.constructor_tac true None i bl in - Tacticals.New.tclWITHHOLES true tac sigma + let tac bl = Tactics.constructor_tac true None i bl in + Tacticals.New.tclDELAYEDWITHHOLES true bl tac ] END @@ -144,9 +134,7 @@ END TACTIC EXTEND specialize [ "specialize" constr_with_bindings(c) ] -> [ - let { Evd.sigma = sigma; it = c } = c in - let specialize = Proofview.V82.tactic (Tactics.specialize c) in - Tacticals.New.tclWITHHOLES false specialize sigma + Tacticals.New.tclDELAYEDWITHHOLES false c Tactics.specialize ] END @@ -166,15 +154,13 @@ END TACTIC EXTEND split_with [ "split" "with" bindings(bl) ] -> [ - let { Evd.sigma = sigma ; it = bl } = bl in - Tacticals.New.tclWITHHOLES false (Tactics.split_with_bindings false [bl]) sigma + Tacticals.New.tclDELAYEDWITHHOLES false bl (fun bl -> Tactics.split_with_bindings false [bl]) ] END TACTIC EXTEND esplit_with [ "esplit" "with" bindings(bl) ] -> [ - let { Evd.sigma = sigma ; it = bl } = bl in - Tacticals.New.tclWITHHOLES true (Tactics.split_with_bindings true [bl]) sigma + Tacticals.New.tclDELAYEDWITHHOLES true bl (fun bl -> Tactics.split_with_bindings true [bl]) ] END @@ -225,8 +211,6 @@ let initial_atomic () = "intro", TacIntroMove(None,MoveLast); "intros", TacIntroPattern []; "cofix", TacCofix None; - "trivial", TacTrivial (Off,[],None); - "auto", TacAuto(Off,None,[],None); ] in let iter (s, t) = Tacenv.register_ltac false false (Id.of_string s) t in diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4 index 2241fb821c..fe10b92c36 100644 --- a/tactics/eauto.ml4 +++ b/tactics/eauto.ml4 @@ -64,6 +64,16 @@ let registered_e_assumption = (Tacmach.New.pf_ids_of_hyps gl)) end } +let eval_uconstrs ist cs = + let flags = { + Pretyping.use_typeclasses = false; + use_unif_heuristics = true; + use_hook = Some Pfedit.solve_by_implicit_tactic; + fail_evar = false; + expand_evars = true + } in + List.map (fun c -> Tacinterp.type_uconstr ~flags ist c) cs + (************************************************************************) (* PROLOG tactic *) (************************************************************************) @@ -103,18 +113,19 @@ let out_term = function | IsGlobRef gr -> fst (Universes.fresh_global_instance (Global.env ()) gr) let prolog_tac l n gl = - let l = List.map (fun x -> out_term (pf_apply (prepare_hint false (false,true)) gl x)) l in - let n = - match n with - | ArgArg n -> n - | _ -> error "Prolog called with a non closed argument." + let map c = + let (c, sigma) = Tactics.run_delayed (pf_env gl) (project gl) c in + let c = pf_apply (prepare_hint false (false,true)) gl (sigma, c) in + out_term c in + let l = List.map map l in try (prolog l n gl) with UserError ("Refiner.tclFIRST",_) -> errorlabstrm "Prolog.prolog" (str "Prolog failed.") TACTIC EXTEND prolog -| [ "prolog" "[" open_constr_list(l) "]" int_or_var(n) ] -> [ Proofview.V82.tactic (prolog_tac l n) ] +| [ "prolog" "[" uconstr_list(l) "]" int_or_var(n) ] -> + [ Proofview.V82.tactic (prolog_tac (eval_uconstrs ist l) n) ] END open Auto @@ -219,7 +230,7 @@ type search_state = { dblist : hint_db list; localdb : hint_db list; prev : prev_search_state; - local_lemmas : Evd.open_constr list; + local_lemmas : Tacexpr.delayed_open_constr list; } and prev_search_state = (* for info eauto *) @@ -436,77 +447,48 @@ let gen_eauto ?(debug=Off) np lems = function let make_depth = function | None -> !default_search_depth - | Some (ArgArg d) -> d - | _ -> error "eauto called with a non closed argument." + | Some d -> d let make_dimension n = function | None -> (true,make_depth n) - | Some (ArgArg d) -> (false,d) - | _ -> error "eauto called with a non closed argument." + | Some d -> (false,d) open Genarg +open G_auto -(* Hint bases *) - -let pr_hintbases _prc _prlc _prt = Pptactic.pr_hintbases - -ARGUMENT EXTEND hintbases - TYPED AS preident_list_opt - PRINTED BY pr_hintbases -| [ "with" "*" ] -> [ None ] -| [ "with" ne_preident_list(l) ] -> [ Some l ] -| [ ] -> [ Some [] ] -END - -let pr_constr_coma_sequence prc _ _ = - prlist_with_sep pr_comma (fun (_,c) -> prc c) - -ARGUMENT EXTEND constr_coma_sequence - TYPED AS open_constr_list - PRINTED BY pr_constr_coma_sequence -| [ open_constr(c) "," constr_coma_sequence(l) ] -> [ c::l ] -| [ open_constr(c) ] -> [ [c] ] -END - -let pr_auto_using prc _prlc _prt = Pptactic.pr_auto_using (fun (_,c) -> prc c) - -ARGUMENT EXTEND auto_using - TYPED AS open_constr_list - PRINTED BY pr_auto_using -| [ "using" constr_coma_sequence(l) ] -> [ l ] -| [ ] -> [ [] ] -END +let hintbases = G_auto.hintbases +let wit_hintbases = G_auto.wit_hintbases TACTIC EXTEND eauto | [ "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) hintbases(db) ] -> - [ Proofview.V82.tactic (gen_eauto (make_dimension n p) lems db) ] + [ Proofview.V82.tactic (gen_eauto (make_dimension n p) (eval_uconstrs ist lems) db) ] END TACTIC EXTEND new_eauto | [ "new" "auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> [ match db with - | None -> new_full_auto (make_depth n) lems - | Some l -> new_auto (make_depth n) lems l ] + | None -> new_full_auto (make_depth n) (eval_uconstrs ist lems) + | Some l -> new_auto (make_depth n) (eval_uconstrs ist lems) l ] END TACTIC EXTEND debug_eauto | [ "debug" "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) hintbases(db) ] -> - [ Proofview.V82.tactic (gen_eauto ~debug:Debug (make_dimension n p) lems db) ] + [ Proofview.V82.tactic (gen_eauto ~debug:Debug (make_dimension n p) (eval_uconstrs ist lems) db) ] END TACTIC EXTEND info_eauto | [ "info_eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) hintbases(db) ] -> - [ Proofview.V82.tactic (gen_eauto ~debug:Info (make_dimension n p) lems db) ] + [ Proofview.V82.tactic (gen_eauto ~debug:Info (make_dimension n p) (eval_uconstrs ist lems) db) ] END TACTIC EXTEND dfs_eauto | [ "dfs" "eauto" int_or_var_opt(p) auto_using(lems) hintbases(db) ] -> - [ Proofview.V82.tactic (gen_eauto (true, make_depth p) lems db) ] + [ Proofview.V82.tactic (gen_eauto (true, make_depth p) (eval_uconstrs ist lems) db) ] END let cons a l = a :: l diff --git a/tactics/eauto.mli b/tactics/eauto.mli index b55c70fa12..985c08f93f 100644 --- a/tactics/eauto.mli +++ b/tactics/eauto.mli @@ -8,31 +8,24 @@ open Term open Proof_type -open Evd open Hints val hintbases : hint_db_name list option Pcoq.Gram.entry val wit_hintbases : hint_db_name list option Genarg.uniform_genarg_type -val wit_auto_using : - (Tacexpr.open_constr_expr list, - Tacexpr.open_glob_constr list, Evd.open_constr list) - Genarg.genarg_type - - val e_assumption : unit Proofview.tactic val registered_e_assumption : unit Proofview.tactic val e_give_exact : ?flags:Unification.unify_flags -> constr -> unit Proofview.tactic -val gen_eauto : ?debug:Tacexpr.debug -> bool * int -> open_constr list -> +val gen_eauto : ?debug:Tacexpr.debug -> bool * int -> Tacexpr.delayed_open_constr list -> hint_db_name list option -> tactic val eauto_with_bases : ?debug:Tacexpr.debug -> bool * int -> - open_constr list -> hint_db list -> Proof_type.tactic + Tacexpr.delayed_open_constr list -> hint_db list -> Proof_type.tactic val autounfold : hint_db_name list -> Locus.clause -> tactic diff --git a/tactics/equality.ml b/tactics/equality.ml index 7d15e9ee66..ac41c94646 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -1319,13 +1319,13 @@ let inject_at_positions env sigma l2r (eq,_,(t,t1,t2)) eq_clause posns tac = tclZEROMSG (str "Failed to decompose the equality.") else Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) - (Proofview.tclBIND - (Proofview.Monad.List.map + (Tacticals.New.tclTHENFIRST + (Proofview.tclIGNORE (Proofview.Monad.List.map (fun (pf,ty) -> tclTHENS (cut ty) [inject_if_homogenous_dependent_pair ty; Proofview.V82.tactic (refine pf)]) - (if l2r then List.rev injectors else injectors)) - (fun _ -> tac (List.length injectors))) + (if l2r then List.rev injectors else injectors))) + (tac (List.length injectors))) let injEqThen tac l2r (eq,_,(t,t1,t2) as u) eq_clause = let sigma = eq_clause.evd in diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index f311e47f63..15765bab5e 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -31,34 +31,42 @@ DECLARE PLUGIN "extratactics" (* replace, discriminate, injection, simplify_eq *) (* cutrewrite, dependent rewrite *) -let replace_in_clause_maybe_by (sigma1,c1) c2 cl tac = - Tacticals.New.tclWITHHOLES false - (replace_in_clause_maybe_by c1 c2 cl (Option.map Tacinterp.eval_tactic tac)) - sigma1 - -let replace_term dir_opt (sigma,c) cl = - Tacticals.New.tclWITHHOLES false - (replace_term dir_opt c cl) - sigma +let with_delayed_uconstr ist c tac = + let flags = { + Pretyping.use_typeclasses = false; + use_unif_heuristics = true; + use_hook = Some Pfedit.solve_by_implicit_tactic; + fail_evar = false; + expand_evars = true + } in + let c = Tacinterp.type_uconstr ~flags ist c in + Tacticals.New.tclDELAYEDWITHHOLES false c tac + +let replace_in_clause_maybe_by ist c1 c2 cl tac = + with_delayed_uconstr ist c1 + (fun c1 -> replace_in_clause_maybe_by c1 c2 cl (Option.map Tacinterp.eval_tactic tac)) + +let replace_term ist dir_opt c cl = + with_delayed_uconstr ist c (fun c -> replace_term dir_opt c cl) TACTIC EXTEND replace - ["replace" open_constr(c1) "with" constr(c2) clause(cl) by_arg_tac(tac) ] --> [ replace_in_clause_maybe_by c1 c2 cl tac ] + ["replace" uconstr(c1) "with" constr(c2) clause(cl) by_arg_tac(tac) ] +-> [ replace_in_clause_maybe_by ist c1 c2 cl tac ] END TACTIC EXTEND replace_term_left - [ "replace" "->" open_constr(c) clause(cl) ] - -> [ replace_term (Some true) c cl ] + [ "replace" "->" uconstr(c) clause(cl) ] + -> [ replace_term ist (Some true) c cl ] END TACTIC EXTEND replace_term_right - [ "replace" "<-" open_constr(c) clause(cl) ] - -> [ replace_term (Some false) c cl ] + [ "replace" "<-" uconstr(c) clause(cl) ] + -> [ replace_term ist (Some false) c cl ] END TACTIC EXTEND replace_term - [ "replace" open_constr(c) clause(cl) ] - -> [ replace_term None c cl ] + [ "replace" uconstr(c) clause(cl) ] + -> [ replace_term ist None c cl ] END let induction_arg_of_quantified_hyp = function @@ -70,8 +78,8 @@ let induction_arg_of_quantified_hyp = function ElimOnIdent and not as "constr" *) let elimOnConstrWithHoles tac with_evars c = - Tacticals.New.tclWITHHOLES with_evars - (tac with_evars (Some (None,ElimOnConstr c.it))) c.sigma + Tacticals.New.tclDELAYEDWITHHOLES with_evars c + (fun c -> tac with_evars (Some (None,ElimOnConstr c))) TACTIC EXTEND simplify_eq_main | [ "simplify_eq" constr_with_bindings(c) ] -> @@ -116,7 +124,7 @@ END open Proofview.Notations let discrHyp id = Proofview.tclEVARMAP >>= fun sigma -> - discr_main {it = Term.mkVar id,NoBindings; sigma = sigma;} + discr_main { delayed = fun env sigma -> Sigma.here (Term.mkVar id, NoBindings) sigma } let injection_main c = elimOnConstrWithHoles (injClause None) false c @@ -161,7 +169,7 @@ END let injHyp id = Proofview.tclEVARMAP >>= fun sigma -> - injection_main { it = Term.mkVar id,NoBindings; sigma = sigma; } + injection_main { delayed = fun env sigma -> Sigma.here (Term.mkVar id, NoBindings) sigma } TACTIC EXTEND dependent_rewrite | [ "dependent" "rewrite" orient(b) constr(c) ] -> [ rewriteInConcl b c ] @@ -201,7 +209,7 @@ END let onSomeWithHoles tac = function | None -> tac None - | Some c -> Tacticals.New.tclWITHHOLES false (tac (Some c.it)) c.sigma + | Some c -> Tacticals.New.tclDELAYEDWITHHOLES false c (fun c -> tac (Some c)) TACTIC EXTEND contradiction [ "contradiction" constr_with_bindings_opt(c) ] -> @@ -243,22 +251,22 @@ END (**********************************************************************) (* Rewrite star *) -let rewrite_star clause orient occs (sigma,c) (tac : glob_tactic_expr option) = +let rewrite_star ist clause orient occs c (tac : glob_tactic_expr option) = let tac' = Option.map (fun t -> Tacinterp.eval_tactic t, FirstSolved) tac in - Tacticals.New.tclWITHHOLES false - (general_rewrite_ebindings_clause clause orient occs ?tac:tac' true true (c,NoBindings) true) sigma + with_delayed_uconstr ist c + (fun c -> general_rewrite_ebindings_clause clause orient occs ?tac:tac' true true (c,NoBindings) true) TACTIC EXTEND rewrite_star -| [ "rewrite" "*" orient(o) open_constr(c) "in" hyp(id) "at" occurrences(occ) by_arg_tac(tac) ] -> - [ rewrite_star (Some id) o (occurrences_of occ) c tac ] -| [ "rewrite" "*" orient(o) open_constr(c) "at" occurrences(occ) "in" hyp(id) by_arg_tac(tac) ] -> - [ rewrite_star (Some id) o (occurrences_of occ) c tac ] -| [ "rewrite" "*" orient(o) open_constr(c) "in" hyp(id) by_arg_tac(tac) ] -> - [ rewrite_star (Some id) o Locus.AllOccurrences c tac ] -| [ "rewrite" "*" orient(o) open_constr(c) "at" occurrences(occ) by_arg_tac(tac) ] -> - [ rewrite_star None o (occurrences_of occ) c tac ] -| [ "rewrite" "*" orient(o) open_constr(c) by_arg_tac(tac) ] -> - [ rewrite_star None o Locus.AllOccurrences c tac ] +| [ "rewrite" "*" orient(o) uconstr(c) "in" hyp(id) "at" occurrences(occ) by_arg_tac(tac) ] -> + [ rewrite_star ist (Some id) o (occurrences_of occ) c tac ] +| [ "rewrite" "*" orient(o) uconstr(c) "at" occurrences(occ) "in" hyp(id) by_arg_tac(tac) ] -> + [ rewrite_star ist (Some id) o (occurrences_of occ) c tac ] +| [ "rewrite" "*" orient(o) uconstr(c) "in" hyp(id) by_arg_tac(tac) ] -> + [ rewrite_star ist (Some id) o Locus.AllOccurrences c tac ] +| [ "rewrite" "*" orient(o) uconstr(c) "at" occurrences(occ) by_arg_tac(tac) ] -> + [ rewrite_star ist None o (occurrences_of occ) c tac ] +| [ "rewrite" "*" orient(o) uconstr(c) by_arg_tac(tac) ] -> + [ rewrite_star ist None o Locus.AllOccurrences c tac ] END (**********************************************************************) @@ -347,22 +355,14 @@ END (**********************************************************************) (* Refine *) -let refine_tac simple {Glob_term.closure=closure;term=term} = +let refine_tac ist simple c = Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in let flags = Pretyping.all_no_fail_flags in - let tycon = Pretyping.OfType concl in - let lvar = { Pretyping.empty_lvar with - Pretyping.ltac_constrs = closure.Glob_term.typed; - Pretyping.ltac_uconstrs = closure.Glob_term.untyped; - Pretyping.ltac_idents = closure.Glob_term.idents; - } in - let update = { run = begin fun sigma -> - let sigma = Sigma.to_evar_map sigma in - let (sigma, c) = Pretyping.understand_ltac flags env sigma lvar tycon term in - Sigma.Unsafe.of_pair (c, sigma) - end } in + let expected_type = Pretyping.OfType concl in + let c = Tacinterp.type_uconstr ~flags ~expected_type ist c in + let update = { run = fun sigma -> c.delayed env sigma } in let refine = Proofview.Refine.refine ~unsafe:false update in if simple then refine else refine <*> @@ -371,11 +371,11 @@ let refine_tac simple {Glob_term.closure=closure;term=term} = end } TACTIC EXTEND refine -| [ "refine" uconstr(c) ] -> [ refine_tac false c ] +| [ "refine" uconstr(c) ] -> [ refine_tac ist false c ] END TACTIC EXTEND simple_refine -| [ "simple" "refine" uconstr(c) ] -> [ refine_tac true c ] +| [ "simple" "refine" uconstr(c) ] -> [ refine_tac ist true c ] END (**********************************************************************) @@ -622,10 +622,6 @@ let subst_hole_with_term occ tc t = open Tacmach -let out_arg = function - | ArgVar _ -> anomaly (Pp.str "Unevaluated or_var variable") - | ArgArg x -> x - let hResolve id c occ t = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in @@ -664,7 +660,7 @@ let hResolve_auto id c t = resolve_auto 1 TACTIC EXTEND hresolve_core -| [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "at" int_or_var(occ) "in" constr(t) ] -> [ hResolve id c (out_arg occ) t ] +| [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "at" int_or_var(occ) "in" constr(t) ] -> [ hResolve id c occ t ] | [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "in" constr(t) ] -> [ hResolve_auto id c t ] END @@ -686,7 +682,7 @@ let hget_evar n = end } TACTIC EXTEND hget_evar -| [ "hget_evar" int_or_var(n) ] -> [ hget_evar (out_arg n) ] +| [ "hget_evar" int_or_var(n) ] -> [ hget_evar n ] END (**********************************************************************) @@ -909,12 +905,12 @@ END (* cycles [n] goals *) TACTIC EXTEND cycle -| [ "cycle" int_or_var(n) ] -> [ Proofview.cycle (out_arg n) ] +| [ "cycle" int_or_var(n) ] -> [ Proofview.cycle n ] END (* swaps goals number [i] and [j] *) TACTIC EXTEND swap -| [ "swap" int_or_var(i) int_or_var(j) ] -> [ Proofview.swap (out_arg i) (out_arg j) ] +| [ "swap" int_or_var(i) int_or_var(j) ] -> [ Proofview.swap i j ] END (* reverses the list of focused goals *) diff --git a/tactics/extratactics.mli b/tactics/extratactics.mli index 72c2679c06..1d2e497d51 100644 --- a/tactics/extratactics.mli +++ b/tactics/extratactics.mli @@ -11,4 +11,4 @@ val injHyp : Names.Id.t -> unit Proofview.tactic (* val refine_tac : Evd.open_constr -> unit Proofview.tactic *) -val onSomeWithHoles : ('a option -> unit Proofview.tactic) -> 'a Evd.sigma option -> unit Proofview.tactic +val onSomeWithHoles : ('a option -> unit Proofview.tactic) -> 'a Tacexpr.delayed_open option -> unit Proofview.tactic diff --git a/tactics/ftactic.ml b/tactics/ftactic.ml index a688b94879..a8abffc8d1 100644 --- a/tactics/ftactic.ml +++ b/tactics/ftactic.ml @@ -37,16 +37,32 @@ let bind (type a) (type b) (m : a t) (f : a -> b t) : b t = m >>= function Proofview.tclDISPATCHL (List.map f l) >>= fun l -> Proofview.tclUNIT (Depends (List.concat l)) +let goals = Proofview.Goal.goals >>= fun l -> Proofview.tclUNIT (Depends l) +let set_sigma r = + let Sigma.Sigma (ans, sigma, _) = r in + Proofview.Unsafe.tclEVARS (Sigma.to_evar_map sigma) >>= fun () -> ans + let nf_enter f = - bind (Proofview.Goal.goals >>= fun l -> Proofview.tclUNIT (Depends l)) + bind goals + (fun gl -> + gl >>= fun gl -> + Proofview.Goal.normalize gl >>= fun nfgl -> + Proofview.V82.wrap_exceptions (fun () -> f.enter nfgl)) + +let nf_s_enter f = + bind goals (fun gl -> gl >>= fun gl -> Proofview.Goal.normalize gl >>= fun nfgl -> - Proofview.V82.wrap_exceptions (fun () -> f nfgl)) + Proofview.V82.wrap_exceptions (fun () -> set_sigma (f.s_enter nfgl))) let enter f = - bind (Proofview.Goal.goals >>= fun l -> Proofview.tclUNIT (Depends l)) - (fun gl -> gl >>= fun gl -> Proofview.V82.wrap_exceptions (fun () -> f gl)) + bind goals + (fun gl -> gl >>= fun gl -> Proofview.V82.wrap_exceptions (fun () -> f.enter gl)) + +let s_enter f = + bind goals + (fun gl -> gl >>= fun gl -> Proofview.V82.wrap_exceptions (fun () -> set_sigma (f.s_enter gl))) let with_env t = t >>= function @@ -84,3 +100,9 @@ module Ftac = Monad.Make(Self) module List = Ftac.List let debug_prompt = Tactic_debug.debug_prompt + +module Notations = +struct + let (>>=) = bind + let (<*>) = fun m n -> bind m (fun () -> n) +end diff --git a/tactics/ftactic.mli b/tactics/ftactic.mli index 4496499229..f0466341f0 100644 --- a/tactics/ftactic.mli +++ b/tactics/ftactic.mli @@ -6,6 +6,8 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Proofview.Notations + (** Potentially focussing tactics *) type +'a focus @@ -37,14 +39,19 @@ val run : 'a t -> ('a -> unit Proofview.tactic) -> unit Proofview.tactic (** {5 Focussing} *) -val nf_enter : (([ `NF ], 'r) Proofview.Goal.t -> 'a t) -> 'a t +val nf_enter : ([ `NF ], 'a t) enter -> 'a t (** Enter a goal. The resulting tactic is focussed. *) -(** FIXME: Should be polymorphic over the stage. *) -val enter : (([ `LZ ], 'r) Proofview.Goal.t -> 'a t) -> 'a t +val enter : ([ `LZ ], 'a t) enter -> 'a t (** Enter a goal, without evar normalization. The resulting tactic is focussed. *) -(** FIXME: Should be polymorphic over the stage. *) + +val s_enter : ([ `LZ ], 'a t) s_enter -> 'a t +(** Enter a goal and put back an evarmap. The resulting tactic is focussed. *) + +val nf_s_enter : ([ `NF ], 'a t) s_enter -> 'a t +(** Enter a goal, without evar normalization and put back an evarmap. The + resulting tactic is focussed. *) val with_env : 'a t -> (Environ.env*'a) t (** [with_env t] returns, in addition to the return type of [t], an @@ -67,3 +74,11 @@ module List : Monad.ListS with type 'a t := 'a t val debug_prompt : int -> Tacexpr.glob_tactic_expr -> (Tactic_debug.debug_info -> 'a t) -> 'a t + +(** {5 Notations} *) + +module Notations : +sig + val (>>=) : 'a t -> ('a -> 'b t) -> 'b t + val (<*>) : unit t -> 'a t -> 'a t +end diff --git a/tactics/g_auto.ml4 b/tactics/g_auto.ml4 new file mode 100644 index 0000000000..3a2cee9f72 --- /dev/null +++ b/tactics/g_auto.ml4 @@ -0,0 +1,76 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i camlp4deps: "grammar/grammar.cma" i*) + +open Pp +open Genarg +open Tacexpr + +DECLARE PLUGIN "g_auto" + +(* Hint bases *) + +let pr_hintbases _prc _prlc _prt = Pptactic.pr_hintbases + +ARGUMENT EXTEND hintbases + TYPED AS preident_list_opt + PRINTED BY pr_hintbases +| [ "with" "*" ] -> [ None ] +| [ "with" ne_preident_list(l) ] -> [ Some l ] +| [ ] -> [ Some [] ] +END + +let eval_uconstrs ist cs = + let flags = { + Pretyping.use_typeclasses = false; + use_unif_heuristics = true; + use_hook = Some Pfedit.solve_by_implicit_tactic; + fail_evar = false; + expand_evars = true + } in + List.map (fun c -> Tacinterp.type_uconstr ~flags ist c) cs + +let pr_auto_using _ _ _ = Pptactic.pr_auto_using (fun _ -> mt ()) + +ARGUMENT EXTEND auto_using + TYPED AS uconstr_list + PRINTED BY pr_auto_using +| [ "using" ne_uconstr_list_sep(l, ",") ] -> [ l ] +| [ ] -> [ [] ] +END + +TACTIC EXTEND trivial +| [ "trivial" auto_using(lems) hintbases(db) ] -> + [ Auto.h_trivial (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND info_trivial +| [ "info_trivial" auto_using(lems) hintbases(db) ] -> + [ Auto.h_trivial ~debug:Info (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND debug_trivial +| [ "debug" "trivial" auto_using(lems) hintbases(db) ] -> + [ Auto.h_trivial ~debug:Debug (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND auto +| [ "auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> + [ Auto.h_auto n (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND info_auto +| [ "info_auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> + [ Auto.h_auto ~debug:Info n (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND debug_auto +| [ "debug" "auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> + [ Auto.h_auto ~debug:Debug n (eval_uconstrs ist lems) db ] +END diff --git a/tactics/geninterp.ml b/tactics/geninterp.ml index d44c4ac3a0..dff87d3a82 100644 --- a/tactics/geninterp.ml +++ b/tactics/geninterp.ml @@ -12,11 +12,10 @@ open Genarg module TacStore = Store.Make(struct end) type interp_sign = { - lfun : tlevel generic_argument Id.Map.t; + lfun : Val.t Id.Map.t; extra : TacStore.t } -type ('glb, 'top) interp_fun = interp_sign -> - Goal.goal Evd.sigma -> 'glb -> Evd.evar_map * 'top +type ('glb, 'top) interp_fun = interp_sign -> 'glb -> 'top Ftactic.t module InterpObj = struct @@ -30,9 +29,10 @@ module Interp = Register(InterpObj) let interp = Interp.obj let register_interp0 = Interp.register0 -let generic_interp ist gl v = +let generic_interp ist v = + let open Ftactic.Notations in let unpacker wit v = - let (sigma, ans) = interp wit ist gl (glb v) in - (sigma, in_gen (topwit wit) ans) + interp wit ist (glb v) >>= fun ans -> + Ftactic.return (Val.Dyn (val_tag (topwit wit), ans)) in unpack { unpacker; } v diff --git a/tactics/geninterp.mli b/tactics/geninterp.mli index 3c653697d2..34261c507c 100644 --- a/tactics/geninterp.mli +++ b/tactics/geninterp.mli @@ -14,15 +14,14 @@ open Genarg module TacStore : Store.S type interp_sign = { - lfun : tlevel generic_argument Id.Map.t; + lfun : Val.t Id.Map.t; extra : TacStore.t } -type ('glb, 'top) interp_fun = interp_sign -> - Goal.goal Evd.sigma -> 'glb -> Evd.evar_map * 'top +type ('glb, 'top) interp_fun = interp_sign -> 'glb -> 'top Ftactic.t val interp : ('raw, 'glb, 'top) genarg_type -> ('glb, 'top) interp_fun -val generic_interp : (glob_generic_argument, typed_generic_argument) interp_fun +val generic_interp : (glob_generic_argument, Val.t) interp_fun val register_interp0 : ('raw, 'glb, 'top) genarg_type -> ('glb, 'top) interp_fun -> unit diff --git a/tactics/hightactics.mllib b/tactics/hightactics.mllib index ff2e1ff6aa..30e97f62d5 100644 --- a/tactics/hightactics.mllib +++ b/tactics/hightactics.mllib @@ -1,6 +1,7 @@ Extraargs Coretactics Extratactics +G_auto Eauto Class_tactics G_class diff --git a/tactics/hints.ml b/tactics/hints.ml index 6250886821..8d8b5fcc67 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -33,6 +33,7 @@ open Pfedit open Tacred open Printer open Vernacexpr +open Sigma.Notations (****************************************) (* General functions *) @@ -153,27 +154,6 @@ let fresh_key = in KerName.make mp dir (Label.of_id lbl) -let eq_hints_path_atom p1 p2 = match p1, p2 with -| PathHints gr1, PathHints gr2 -> List.equal eq_gr gr1 gr2 -| PathAny, PathAny -> true -| (PathHints _ | PathAny), _ -> false - -let eq_auto_tactic t1 t2 = match t1, t2 with -| Res_pf (c1, _), Res_pf (c2, _) -> Constr.equal c1 c2 -| ERes_pf (c1, _), ERes_pf (c2, _) -> Constr.equal c1 c2 -| Give_exact (c1, _), Give_exact (c2, _) -> Constr.equal c1 c2 -| Res_pf_THEN_trivial_fail (c1, _), Res_pf_THEN_trivial_fail (c2, _) -> Constr.equal c1 c2 -| Unfold_nth gr1, Unfold_nth gr2 -> eq_egr gr1 gr2 -| Extern tac1, Extern tac2 -> tac1 == tac2 (** May cause redundancy in addkv *) -| (Res_pf _ | ERes_pf _ | Give_exact _ | Res_pf_THEN_trivial_fail _ - | Unfold_nth _ | Extern _), _ -> false - -let eq_hint_metadata t1 t2 = - Int.equal t1.pri t2.pri && - Option.equal constr_pattern_eq t1.pat t2.pat && - eq_hints_path_atom t1.name t2.name && - eq_auto_tactic t1.code t2.code - let pri_order_int (id1, {pri=pri1}) (id2, {pri=pri2}) = let d = pri1 - pri2 in if Int.equal d 0 then id2 - id1 @@ -1184,6 +1164,12 @@ let add_hint_lemmas env sigma eapply lems hint_db = Hint_db.add_list env sigma hintlist' hint_db let make_local_hint_db env sigma ts eapply lems = + let map c = + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma (c, sigma, _) = c.delayed env sigma in + (Sigma.to_evar_map sigma, c) + in + let lems = List.map map lems in let sign = Environ.named_context env in let ts = match ts with | None -> Hint_db.transparent_state (searchtable_map "core") diff --git a/tactics/hints.mli b/tactics/hints.mli index b48fb776eb..c9187f54a9 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -213,7 +213,7 @@ val extern_intern_tac : Useful to take the current goal hypotheses as hints; Boolean tells if lemmas with evars are allowed *) -val make_local_hint_db : env -> evar_map -> ?ts:transparent_state -> bool -> open_constr list -> hint_db +val make_local_hint_db : env -> evar_map -> ?ts:transparent_state -> bool -> Tacexpr.delayed_open_constr list -> hint_db val make_db_list : hint_db_name list -> hint_db list diff --git a/tactics/taccoerce.ml b/tactics/taccoerce.ml index ab71f5f2e7..7fb79d4fe0 100644 --- a/tactics/taccoerce.ml +++ b/tactics/taccoerce.ml @@ -24,15 +24,27 @@ let (wit_constr_context : (Empty.t, Empty.t, constr) Genarg.genarg_type) = let (wit_constr_under_binders : (Empty.t, Empty.t, constr_under_binders) Genarg.genarg_type) = Genarg.create_arg None "constr_under_binders" +let has_type : type a. Val.t -> a typed_abstract_argument_type -> bool = fun v wit -> + let Val.Dyn (t, _) = v in + match Val.eq t (val_tag wit) with + | None -> false + | Some Refl -> true + +let prj : type a. a Val.tag -> Val.t -> a option = fun t v -> + let Val.Dyn (t', x) = v in + match Val.eq t t' with + | None -> None + | Some Refl -> Some x + +let in_gen wit v = Val.Dyn (val_tag wit, v) +let out_gen wit v = match prj (val_tag wit) v with None -> assert false | Some x -> x + module Value = struct -type t = tlevel generic_argument +type t = Val.t -let rec normalize v = - if has_type v (topwit wit_genarg) then - normalize (out_gen (topwit wit_genarg) v) - else v +let normalize v = v let of_constr c = in_gen (topwit wit_constr) c @@ -64,9 +76,21 @@ let to_int v = let to_list v = let v = normalize v in - let list_unpacker wit l = List.map (fun v -> in_gen (topwit wit) v) (top l) in - try Some (list_unpack { list_unpacker } v) - with Failure _ -> None + let Val.Dyn (tag, v) = v in + match tag with + | Val.List t -> Some (List.map (fun x -> Val.Dyn (t, x)) v) + | _ -> None + +let of_list t v = Val.Dyn (Val.List t, v) + +let to_option v = + let v = normalize v in + let Val.Dyn (tag, v) = v in + match tag with + | Val.Opt t -> Some (Option.map (fun x -> Val.Dyn (t, x)) v) + | _ -> None + +let of_option t v = Val.Dyn (Val.Opt t, v) end diff --git a/tactics/taccoerce.mli b/tactics/taccoerce.mli index 85bad364d7..56a90e8d5b 100644 --- a/tactics/taccoerce.mli +++ b/tactics/taccoerce.mli @@ -29,8 +29,7 @@ exception CannotCoerceTo of string module Value : sig - type t = tlevel generic_argument - (** Tactics manipulate [tlevel generic_argument]. *) + type t = Val.t val normalize : t -> t (** Eliminated the leading dynamic type casts. *) @@ -42,6 +41,9 @@ sig val of_int : int -> t val to_int : t -> int option val to_list : t -> t list option + val of_list : 'a Val.tag -> 'a list -> t + val to_option : t -> t option option + val of_option : 'a Val.tag -> 'a option -> t end (** {5 Coercion functions} *) @@ -55,9 +57,6 @@ val coerce_to_intro_pattern : Environ.env -> Value.t -> Tacexpr.delayed_open_con val coerce_to_intro_pattern_naming : Environ.env -> Value.t -> intro_pattern_naming_expr -val coerce_to_intro_pattern_naming : - Environ.env -> Value.t -> intro_pattern_naming_expr - val coerce_to_hint_base : Value.t -> string val coerce_to_int : Value.t -> int diff --git a/tactics/tacenv.ml b/tactics/tacenv.ml index c1e4d72e38..c7339acea7 100644 --- a/tactics/tacenv.ml +++ b/tactics/tacenv.ml @@ -15,9 +15,10 @@ open Tacexpr (** Tactic notations (TacAlias) *) type alias = KerName.t +type alias_tactic = Id.t list * glob_tactic_expr let alias_map = Summary.ref ~name:"tactic-alias" - (KNmap.empty : glob_tactic_expr KNmap.t) + (KNmap.empty : alias_tactic KNmap.t) let register_alias key tac = alias_map := KNmap.add key tac !alias_map @@ -31,7 +32,7 @@ let check_alias key = KNmap.mem key !alias_map (** ML tactic extensions (TacML) *) type ml_tactic = - typed_generic_argument list -> Geninterp.interp_sign -> unit Proofview.tactic + Val.t list -> Geninterp.interp_sign -> unit Proofview.tactic module MLName = struct diff --git a/tactics/tacenv.mli b/tactics/tacenv.mli index 47d9efda57..65fd693435 100644 --- a/tactics/tacenv.mli +++ b/tactics/tacenv.mli @@ -17,10 +17,13 @@ open Tacexpr type alias = KerName.t (** Type of tactic alias, used in the [TacAlias] node. *) -val register_alias : alias -> glob_tactic_expr -> unit +type alias_tactic = Id.t list * glob_tactic_expr +(** Contents of a tactic notation *) + +val register_alias : alias -> alias_tactic -> unit (** Register a tactic alias. *) -val interp_alias : alias -> glob_tactic_expr +val interp_alias : alias -> alias_tactic (** Recover the the body of an alias. Raises an anomaly if it does not exist. *) val check_alias : alias -> bool @@ -61,7 +64,7 @@ val ltac_entries : unit -> ltac_entry KNmap.t (** {5 ML tactic extensions} *) type ml_tactic = - typed_generic_argument list -> Geninterp.interp_sign -> unit Proofview.tactic + Val.t list -> Geninterp.interp_sign -> unit Proofview.tactic (** Type of external tactics, used by [TacML]. *) val register_ml_tactic : ?overwrite:bool -> ml_tactic_name -> ml_tactic array -> unit diff --git a/tactics/tacintern.ml b/tactics/tacintern.ml index ac1229f2f7..e6273401dd 100644 --- a/tactics/tacintern.ml +++ b/tactics/tacintern.ml @@ -97,7 +97,6 @@ let intern_or_var f ist = function | ArgArg x -> ArgArg (f x) let intern_int_or_var = intern_or_var (fun (n : int) -> n) -let intern_id_or_var = intern_or_var (fun (id : Id.t) -> id) let intern_string_or_var = intern_or_var (fun (s : string) -> s) let intern_global_reference ist = function @@ -339,7 +338,7 @@ let intern_typed_pattern ist p = (* type it, so we remember the pattern as a glob_constr only *) (intern_constr_gen true false ist p,dummy_pat) -let rec intern_typed_pattern_or_ref_with_occurrences ist (l,p) = +let intern_typed_pattern_or_ref_with_occurrences ist (l,p) = let interp_ref r = try Inl (intern_evaluable ist r) with e when Logic.catchable_exception e -> @@ -517,12 +516,6 @@ let rec intern_atomic lf ist x = (clause_app (intern_hyp_location ist) cls),b, (Option.map (intern_intro_pattern_naming_loc lf ist) eqpat)) - (* Automation tactics *) - | TacTrivial (d,lems,l) -> TacTrivial (d,List.map (intern_constr ist) lems,l) - | TacAuto (d,n,lems,l) -> - TacAuto (d,Option.map (intern_int_or_var ist) n, - List.map (intern_constr ist) lems,l) - (* Derived basic tactics *) | TacInductionDestruct (ev,isrec,(l,el)) -> TacInductionDestruct (ev,isrec,(List.map (fun (c,(ipato,ipats),cls) -> @@ -663,11 +656,11 @@ and intern_tactic_seq onlytac ist = function (* For extensions *) | TacAlias (loc,s,l) -> - let l = List.map (fun (id,a) -> (id,intern_genarg ist a)) l in + let l = List.map (intern_tacarg !strict_check false ist) l in ist.ltacvars, TacAlias (loc,s,l) | TacML (loc,opn,l) -> let _ignore = Tacenv.interp_ml_tactic opn in - ist.ltacvars, TacML (adjust_loc loc,opn,List.map (intern_genarg ist) l) + ist.ltacvars, TacML (adjust_loc loc,opn,List.map (intern_tacarg !strict_check false ist) l) and intern_tactic_as_arg loc onlytac ist a = match intern_tacarg !strict_check onlytac ist a with @@ -707,7 +700,7 @@ and intern_tacarg strict onlytac ist = function | TacNumgoals -> TacNumgoals | Tacexp t -> Tacexp (intern_tactic onlytac ist t) | TacGeneric arg -> - let (_, arg) = Genintern.generic_intern ist arg in + let arg = intern_genarg ist arg in TacGeneric arg (* Reads the rules of a Match Context or a Match *) @@ -727,20 +720,13 @@ and intern_match_rule onlytac ist = function and intern_genarg ist x = match genarg_tag x with - | IntOrVarArgType -> map_raw wit_int_or_var intern_int_or_var ist x | IdentArgType -> let lf = ref Id.Set.empty in map_raw wit_ident (intern_ident lf) ist x | VarArgType -> map_raw wit_var intern_hyp ist x - | GenArgType -> - map_raw wit_genarg intern_genarg ist x | ConstrArgType -> map_raw wit_constr intern_constr ist x - | ConstrMayEvalArgType -> - map_raw wit_constr_may_eval intern_constr_may_eval ist x - | OpenConstrArgType -> - map_raw wit_open_constr (fun ist -> on_snd (intern_constr ist)) ist x | ListArgType _ -> let list_unpacker wit l = let map x = @@ -838,14 +824,17 @@ let () = Genintern.register_intern0 wit_clause_dft_concl intern_clause let () = + Genintern.register_intern0 wit_int_or_var (lift intern_int_or_var); Genintern.register_intern0 wit_ref (lift intern_global_reference); Genintern.register_intern0 wit_tactic (lift intern_tactic_or_tacarg); Genintern.register_intern0 wit_sort (fun ist s -> (ist, s)); Genintern.register_intern0 wit_quant_hyp (lift intern_quantified_hypothesis); Genintern.register_intern0 wit_uconstr (fun ist c -> (ist,intern_constr ist c)); + Genintern.register_intern0 wit_open_constr (fun ist c -> (ist,intern_constr ist c)); Genintern.register_intern0 wit_red_expr (lift intern_red_expr); Genintern.register_intern0 wit_bindings (lift intern_bindings); Genintern.register_intern0 wit_constr_with_bindings (lift intern_constr_with_bindings); + Genintern.register_intern0 wit_constr_may_eval (lift intern_constr_may_eval); () (***************************************************************************) diff --git a/tactics/tacintern.mli b/tactics/tacintern.mli index a6e28d568d..1124756948 100644 --- a/tactics/tacintern.mli +++ b/tactics/tacintern.mli @@ -12,7 +12,6 @@ open Tacexpr open Genarg open Constrexpr open Misctypes -open Nametab (** Globalization of tactic expressions : Conversion from [raw_tactic_expr] to [glob_tactic_expr] *) diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 3295b932b9..74ddd6b575 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -43,25 +43,46 @@ open Taccoerce open Sigma.Notations open Proofview.Notations +let has_type : type a. Val.t -> a typed_abstract_argument_type -> bool = fun v wit -> + let Val.Dyn (t, _) = v in + match Val.eq t (val_tag wit) with + | None -> false + | Some Refl -> true + +let prj : type a. a Val.tag -> Val.t -> a option = fun t v -> + let Val.Dyn (t', x) = v in + match Val.eq t t' with + | None -> None + | Some Refl -> Some x + +let in_gen wit v = Val.Dyn (val_tag wit, v) +let out_gen wit v = match prj (val_tag wit) v with None -> assert false | Some x -> x + +let val_tag wit = val_tag (topwit wit) + +let pr_argument_type arg = + let Val.Dyn (tag, _) = arg in + Val.repr tag + let safe_msgnl s = Proofview.NonLogical.catch (Proofview.NonLogical.print_debug (s++fnl())) (fun _ -> Proofview.NonLogical.print_warning (str "bug in the debugger: an exception is raised while printing debug information"++fnl())) -type value = tlevel generic_argument +type value = Val.t (** Abstract application, to print ltac functions *) type appl = | UnnamedAppl (** For generic applications: nothing is printed *) - | GlbAppl of (Names.kernel_name * typed_generic_argument list) list + | GlbAppl of (Names.kernel_name * Val.t list) list (** For calls to global constants, some may alias other. *) let push_appl appl args = match appl with | UnnamedAppl -> UnnamedAppl | GlbAppl l -> GlbAppl (List.map (fun (h,vs) -> (h,vs@args)) l) -let pr_generic arg = - try Pptactic.pr_top_generic (Global.env ()) arg - with e when Errors.noncritical e -> str"<generic>" +let pr_generic arg = (** FIXME *) + let Val.Dyn (tag, _) = arg in + str"<" ++ Val.repr tag ++ str ">" let pr_appl h vs = Pptactic.pr_ltac_constant h ++ spc () ++ Pp.prlist_with_sep spc pr_generic vs @@ -123,8 +144,20 @@ module Value = struct let closure = VFun (UnnamedAppl,extract_trace ist, ist.lfun, [], tac) in of_tacvalue closure + let cast_error wit v = + let pr_v = mt () in (** FIXME *) + let Val.Dyn (tag, _) = v in + let tag = Val.repr tag in + errorlabstrm "" (str "Type error: value " ++ pr_v ++ str "is a " ++ tag + ++ str " while type " ++ Genarg.pr_argument_type wit ++ str " was expected.") + + let cast wit v = + try val_cast wit v with CastError (wit, v) -> cast_error wit v + end +let print_top_val env v = mt () (** FIXME *) + let dloc = Loc.ghost let catching_error call_trace fail (e, info) = @@ -176,13 +209,13 @@ let pr_value env v = | Some (env,sigma) -> pr_lconstr_under_binders_env env sigma c | _ -> str "a term" else - str "a value of type" ++ spc () ++ pr_argument_type (genarg_tag v) + str "a value of type" ++ spc () ++ pr_argument_type v let pr_closure env ist body = let pp_body = Pptactic.pr_glob_tactic env body in let pr_sep () = fnl () in let pr_iarg (id, arg) = - let arg = pr_argument_type (genarg_tag arg) in + let arg = pr_argument_type arg in hov 0 (pr_id id ++ spc () ++ str ":" ++ spc () ++ arg) in let pp_iargs = v 0 (prlist_with_sep pr_sep pr_iarg (Id.Map.bindings ist)) in @@ -199,7 +232,7 @@ let pr_inspect env expr result = | VRec (ist, body) -> str "a recursive closure" ++ fnl () ++ pr_closure env !ist body else - let pp_type = pr_argument_type (genarg_tag result) in + let pp_type = pr_argument_type result in str "an object of type" ++ spc () ++ pp_type in pp_expr ++ fnl() ++ str "this is " ++ pp_result @@ -248,9 +281,9 @@ let coerce_to_tactic loc id v = | _ -> fail () else fail () +let intro_pattern_of_ident id = (Loc.ghost, IntroNaming (IntroIdentifier id)) let value_of_ident id = - in_gen (topwit wit_intro_pattern) - (Loc.ghost, IntroNaming (IntroIdentifier id)) + in_gen (topwit wit_intro_pattern) (intro_pattern_of_ident id) let (+++) lfun1 lfun2 = Id.Map.fold Id.Map.add lfun1 lfun2 @@ -325,10 +358,6 @@ let interp_intro_pattern_naming_var loc ist env sigma id = try try_interp_ltac_var (coerce_to_intro_pattern_naming env) ist (Some (env,sigma)) (loc,id) with Not_found -> IntroIdentifier id -let interp_hint_base ist s = - try try_interp_ltac_var coerce_to_hint_base ist None (dloc,Id.of_string s) - with Not_found -> s - let interp_int ist locid = try try_interp_ltac_var coerce_to_int ist None locid with Not_found -> @@ -621,9 +650,9 @@ let pf_interp_constr ist gl = let new_interp_constr ist c k = let open Proofview in - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> let (sigma, c) = interp_constr ist (Goal.env gl) (Tacmach.New.project gl) c in - Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (k c) + Sigma.Unsafe.of_pair (k c, sigma) end } let interp_constr_in_compound_list inj_fun dest_fun interp_fun ist env sigma l = @@ -647,14 +676,28 @@ let interp_constr_list ist env sigma c = let interp_open_constr_list = interp_constr_in_compound_list (fun x -> x) (fun x -> x) interp_open_constr -let interp_auto_lemmas ist env sigma lems = - let local_sigma, lems = interp_open_constr_list ist env sigma lems in - List.map (fun lem -> (local_sigma,lem)) lems - (* Interprets a type expression *) let pf_interp_type ist gl = interp_type ist (pf_env gl) (project gl) +(* Fully evaluate an untyped constr *) +let type_uconstr ?(flags = constr_flags) + ?(expected_type = WithoutTypeConstraint) ist c = + { delayed = begin fun env sigma -> + let open Pretyping in + let { closure; term } = c in + let vars = { + ltac_constrs = closure.typed; + ltac_uconstrs = closure.untyped; + ltac_idents = closure.idents; + ltac_genargs = ist.lfun; + } in + let sigma = Sigma.to_evar_map sigma in + let (sigma, c) = understand_ltac flags env sigma vars expected_type term in + Sigma.Unsafe.of_pair (c, sigma) + end } + + (* Interprets a reduction expression *) let interp_unfold ist env sigma (occs,qid) = (interp_occurrences ist occs,interp_evaluable ist env sigma qid) @@ -779,12 +822,12 @@ let rec message_of_value v = Ftactic.return (str "<tactic>") else if has_type v (topwit wit_constr) then let v = out_gen (topwit wit_constr) v in - Ftactic.nf_enter begin fun gl -> Ftactic.return (pr_constr_env (pf_env gl) (Tacmach.New.project gl) v) end + Ftactic.nf_enter {enter = begin fun gl -> Ftactic.return (pr_constr_env (pf_env gl) (Tacmach.New.project gl) v) end } else if has_type v (topwit wit_constr_under_binders) then let c = out_gen (topwit wit_constr_under_binders) v in - Ftactic.nf_enter begin fun gl -> + Ftactic.nf_enter { enter = begin fun gl -> Ftactic.return (pr_constr_under_binders_env (pf_env gl) (Tacmach.New.project gl) c) - end + end } else if has_type v (topwit wit_unit) then Ftactic.return (str "()") else if has_type v (topwit wit_int) then @@ -792,24 +835,24 @@ let rec message_of_value v = else if has_type v (topwit wit_intro_pattern) then let p = out_gen (topwit wit_intro_pattern) v in let print env sigma c = pr_constr_env env sigma (fst (Tactics.run_delayed env Evd.empty c)) in - Ftactic.nf_enter begin fun gl -> + Ftactic.nf_enter { enter = begin fun gl -> Ftactic.return (Miscprint.pr_intro_pattern (fun c -> print (pf_env gl) (Tacmach.New.project gl) c) p) - end + end } else if has_type v (topwit wit_constr_context) then let c = out_gen (topwit wit_constr_context) v in - Ftactic.nf_enter begin fun gl -> Ftactic.return (pr_constr_env (pf_env gl) (Tacmach.New.project gl) c) end + Ftactic.nf_enter { enter = begin fun gl -> Ftactic.return (pr_constr_env (pf_env gl) (Tacmach.New.project gl) c) end } else if has_type v (topwit wit_uconstr) then let c = out_gen (topwit wit_uconstr) v in - Ftactic.nf_enter begin fun gl -> + Ftactic.nf_enter { enter = begin fun gl -> Ftactic.return (pr_closed_glob_env (pf_env gl) (Tacmach.New.project gl) c) - end + end } else match Value.to_list v with | Some l -> Ftactic.List.map message_of_value l >>= fun l -> Ftactic.return (prlist_with_sep spc (fun x -> x) l) | None -> - let tag = pr_argument_type (genarg_tag v) in + let tag = pr_argument_type v in Ftactic.return (str "<" ++ tag ++ str ">") (** TODO *) let interp_message_token ist = function @@ -826,11 +869,6 @@ let interp_message ist l = Ftactic.List.map (interp_message_token ist) l >>= fun l -> Ftactic.return (prlist_with_sep spc (fun x -> x) l) -let interp_message ist l = - let open Ftactic in - Ftactic.List.map (interp_message_token ist) l >>= fun l -> - Ftactic.return (prlist_with_sep spc (fun x -> x) l) - let rec interp_intro_pattern ist env sigma = function | loc, IntroAction pat -> let (sigma,pat) = interp_intro_pattern_action ist env sigma pat in @@ -939,19 +977,11 @@ let interp_constr_with_bindings ist env sigma (c,bl) = let sigma, c = interp_open_constr ist env sigma c in sigma, (c,bl) -let interp_constr_with_bindings_arg ist env sigma (keep,c) = - let sigma, c = interp_constr_with_bindings ist env sigma c in - sigma, (keep,c) - let interp_open_constr_with_bindings ist env sigma (c,bl) = let sigma, bl = interp_bindings ist env sigma bl in let sigma, c = interp_open_constr ist env sigma c in sigma, (c, bl) -let interp_open_constr_with_bindings_arg ist env sigma (keep,c) = - let sigma, c = interp_open_constr_with_bindings ist env sigma c in - sigma,(keep,c) - let loc_of_bindings = function | NoBindings -> Loc.ghost | ImplicitBindings l -> loc_of_glob_constr (fst (List.last l)) @@ -1085,17 +1115,17 @@ let rec read_match_rule lfun ist env sigma = function (* misc *) -let mk_open_constr_value ist gl c = - let (sigma,c_interp) = pf_apply (interp_open_constr ist) gl c in - sigma, Value.of_constr c_interp -let mk_hyp_value ist env sigma c = - Value.of_constr (mkVar (interp_hyp ist env sigma c)) -let mk_int_or_var_value ist c = in_gen (topwit wit_int) (interp_int_or_var ist c) - -let pack_sigma (sigma,c) = {it=c;sigma=sigma;} +let interp_focussed wit f v = + Ftactic.nf_enter { enter = begin fun gl -> + let v = Genarg.out_gen (glbwit wit) v in + let env = Proofview.Goal.env gl in + let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + let v = in_gen (topwit wit) (f env sigma v) in + Ftactic.return v + end } (* Interprets an l-tac expression into a value *) -let rec val_interp ist ?(appl=UnnamedAppl) (tac:glob_tactic_expr) : typed_generic_argument Ftactic.t = +let rec val_interp ist ?(appl=UnnamedAppl) (tac:glob_tactic_expr) : Val.t Ftactic.t = (* The name [appl] of applied top-level Ltac names is ignored in [value_interp]. It is installed in the second step by a call to [name_vfun], because it gives more opportunities to detect a @@ -1205,87 +1235,12 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with eval_tactic ist tac (* For extensions *) | TacAlias (loc,s,l) -> - let body = Tacenv.interp_alias s in - let rec f x = match genarg_tag x with - | ConstrArgType - | ListArgType ConstrArgType - | OptArgType _ | PairArgType _ -> (** generic handler *) - Ftactic.nf_enter begin fun gl -> - let sigma = Tacmach.New.project gl in - let env = Proofview.Goal.env gl in - let concl = Proofview.Goal.concl gl in - let goal = Proofview.Goal.goal gl in - let (sigma, arg) = interp_genarg ist env sigma concl goal x in - Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return arg) - end - | _ as tag -> (** Special treatment. TODO: use generic handler *) - Ftactic.nf_enter begin fun gl -> - let sigma = Tacmach.New.project gl in - let env = Proofview.Goal.env gl in - match tag with - | IntOrVarArgType -> - Ftactic.return (mk_int_or_var_value ist (out_gen (glbwit wit_int_or_var) x)) - | IdentArgType -> - Ftactic.return (value_of_ident (interp_ident ist env sigma - (out_gen (glbwit wit_ident) x))) - | VarArgType -> - Ftactic.return (mk_hyp_value ist env sigma (out_gen (glbwit wit_var) x)) - | GenArgType -> f (out_gen (glbwit wit_genarg) x) - | OpenConstrArgType -> - let (sigma,v) = - Tacmach.New.of_old (fun gl -> mk_open_constr_value ist gl (snd (out_gen (glbwit wit_open_constr) x))) gl in - Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return v) - | ConstrMayEvalArgType -> - let (sigma,c_interp) = - interp_constr_may_eval ist env sigma - (out_gen (glbwit wit_constr_may_eval) x) - in - Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return (Value.of_constr c_interp)) - | ListArgType VarArgType -> - let wit = glbwit (wit_list wit_var) in - Ftactic.return ( - let ans = List.map (mk_hyp_value ist env sigma) (out_gen wit x) in - in_gen (topwit (wit_list wit_genarg)) ans - ) - | ListArgType IntOrVarArgType -> - let wit = glbwit (wit_list wit_int_or_var) in - let ans = List.map (mk_int_or_var_value ist) (out_gen wit x) in - Ftactic.return (in_gen (topwit (wit_list wit_genarg)) ans) - | ListArgType IdentArgType -> - let wit = glbwit (wit_list wit_ident) in - let mk_ident x = value_of_ident (interp_ident ist env sigma x) in - let ans = List.map mk_ident (out_gen wit x) in - Ftactic.return (in_gen (topwit (wit_list wit_genarg)) ans) - | ListArgType t -> - let open Ftactic in - let list_unpacker wit l = - let map x = - f (in_gen (glbwit wit) x) >>= fun v -> - Ftactic.return (out_gen (topwit wit) v) - in - Ftactic.List.map map (glb l) >>= fun l -> - Ftactic.return (in_gen (topwit (wit_list wit)) l) - in - list_unpack { list_unpacker } x - | ExtraArgType _ -> - (** Special treatment of tactics *) - if has_type x (glbwit wit_tactic) then - let tac = out_gen (glbwit wit_tactic) x in - val_interp ist tac - else - let goal = Proofview.Goal.goal gl in - let (newsigma,v) = Geninterp.generic_interp ist {Evd.it=goal;sigma} x in - Ftactic.(lift (Proofview.Unsafe.tclEVARS newsigma) <*> return v) - | _ -> assert false - end - in + let (ids, body) = Tacenv.interp_alias s in let (>>=) = Ftactic.bind in - let interp_vars = - Ftactic.List.map (fun (x,v) -> f v >>= fun v -> Ftactic.return (x,v)) l - in - let addvar (x, v) accu = Id.Map.add x v accu in + let interp_vars = Ftactic.List.map (fun v -> interp_tacarg ist v) l in let tac l = - let lfun = List.fold_right addvar l ist.lfun in + let addvar x v accu = Id.Map.add x v accu in + let lfun = List.fold_right2 addvar ids l ist.lfun in let trace = push_trace (loc,LtacNotationCall s) ist in let ist = { lfun = lfun; @@ -1294,52 +1249,35 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with Ftactic.lift (tactic_of_value ist v) in let tac = - Ftactic.with_env interp_vars >>= fun (env,l) -> - let name () = Pptactic.pr_tactic env (TacAlias(loc,s,l)) in - Proofview.Trace.name_tactic name (tac l) + Ftactic.with_env interp_vars >>= fun (env, lr) -> + let name () = Pptactic.pr_alias (fun v -> print_top_val env v) 0 s lr in + Proofview.Trace.name_tactic name (tac lr) (* spiwack: this use of name_tactic is not robust to a change of implementation of [Ftactic]. In such a situation, some more elaborate solution will have to be used. *) in + let tac = + let len1 = List.length ids in + let len2 = List.length l in + if len1 = len2 then tac + else Tacticals.New.tclZEROMSG (str "Arguments length mismatch: \ + expected " ++ int len1 ++ str ", found " ++ int len2) + in Ftactic.run tac (fun () -> Proofview.tclUNIT ()) - | TacML (loc,opn,l) when List.for_all global_genarg l -> - let trace = push_trace (loc,LtacMLCall tac) ist in - let ist = { ist with extra = TacStore.set ist.extra f_trace trace; } in - (* spiwack: a special case for tactics (from TACTIC EXTEND) when - every argument can be interpreted without a - [Proofview.Goal.nf_enter]. *) - let tac = Tacenv.interp_ml_tactic opn in - (* dummy values, will be ignored *) - let env = Environ.empty_env in - let sigma = Evd.empty in - let concl = Term.mkRel (-1) in - let goal = Evar.unsafe_of_int (-1) in - (* /dummy values *) - let args = List.map (fun a -> snd(interp_genarg ist env sigma concl goal a)) l in - let name () = Pptactic.pr_tactic env (TacML(loc,opn,args)) in - Proofview.Trace.name_tactic name - (catch_error_tac trace (tac args ist)) | TacML (loc,opn,l) -> + let open Ftactic.Notations in let trace = push_trace (loc,LtacMLCall tac) ist in let ist = { ist with extra = TacStore.set ist.extra f_trace trace; } in - Proofview.Goal.nf_enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let goal_sigma = Tacmach.New.project gl in - let concl = Proofview.Goal.concl gl in - let goal = Proofview.Goal.goal gl in - let tac = Tacenv.interp_ml_tactic opn in - let (sigma,args) = - Evd.MonadR.List.map_right - (fun a sigma -> interp_genarg ist env sigma concl goal a) l goal_sigma - in - Proofview.Unsafe.tclEVARS sigma <*> - let name () = Pptactic.pr_tactic env (TacML(loc,opn,args)) in - Proofview.Trace.name_tactic name - (catch_error_tac trace (tac args ist)) - end } + let tac = Tacenv.interp_ml_tactic opn in + let args = Ftactic.List.map_right (fun a -> interp_tacarg ist a) l in + let tac args = + let name () = Pptactic.pr_extend (fun v -> print_top_val () v) 0 opn args in + Proofview.Trace.name_tactic name (catch_error_tac trace (tac args ist)) + in + Ftactic.run args tac -and force_vrec ist v : typed_generic_argument Ftactic.t = +and force_vrec ist v : Val.t Ftactic.t = let v = Value.normalize v in if has_type v (topwit wit_tacvalue) then let v = to_tacvalue v in @@ -1348,7 +1286,7 @@ and force_vrec ist v : typed_generic_argument Ftactic.t = | v -> Ftactic.return (of_tacvalue v) else Ftactic.return v -and interp_ltac_reference loc' mustbetac ist r : typed_generic_argument Ftactic.t = +and interp_ltac_reference loc' mustbetac ist r : Val.t Ftactic.t = match r with | ArgVar (loc,id) -> let v = @@ -1368,28 +1306,22 @@ and interp_ltac_reference loc' mustbetac ist r : typed_generic_argument Ftactic. let appl = GlbAppl[r,[]] in val_interp ~appl ist (Tacenv.interp_ltac r) -and interp_tacarg ist arg : typed_generic_argument Ftactic.t = +and interp_tacarg ist arg : Val.t Ftactic.t = match arg with - | TacGeneric arg -> - Ftactic.nf_enter begin fun gl -> - let sigma = Tacmach.New.project gl in - let goal = Proofview.Goal.goal gl in - let (sigma,v) = Geninterp.generic_interp ist {Evd.it=goal;sigma} arg in - Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return v) - end + | TacGeneric arg -> interp_genarg ist arg | Reference r -> interp_ltac_reference dloc false ist r | ConstrMayEval c -> - Ftactic.enter begin fun gl -> + Ftactic.s_enter { s_enter = begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let (sigma,c_interp) = interp_constr_may_eval ist env sigma c in - Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return (Value.of_constr c_interp)) - end + Sigma.Unsafe.of_pair (Ftactic.return (Value.of_constr c_interp), sigma) + end } | UConstr c -> - Ftactic.enter begin fun gl -> + Ftactic.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in Ftactic.return (Value.of_uconstr (interp_uconstr ist env c)) - end + end } | MetaIdArg (loc,_,id) -> assert false | TacCall (loc,r,[]) -> interp_ltac_reference loc true ist r @@ -1399,26 +1331,18 @@ and interp_tacarg ist arg : typed_generic_argument Ftactic.t = Ftactic.List.map (fun a -> interp_tacarg ist a) l >>= fun largs -> interp_app loc ist fv largs | TacFreshId l -> - Ftactic.enter begin fun gl -> + Ftactic.enter { enter = begin fun gl -> let id = interp_fresh_id ist (Tacmach.New.pf_env gl) (Tacmach.New.project gl) l in Ftactic.return (in_gen (topwit wit_intro_pattern) (dloc, IntroNaming (IntroIdentifier id))) - end + end } | TacPretype c -> - Ftactic.enter begin fun gl -> - let sigma = Tacmach.New.project gl in + Ftactic.s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in - let {closure;term} = interp_uconstr ist env c in - let vars = { - Pretyping.ltac_constrs = closure.typed; - Pretyping.ltac_uconstrs = closure.untyped; - Pretyping.ltac_idents = closure.idents; - Pretyping.ltac_genargs = ist.lfun; - } in - let (sigma,c_interp) = - Pretyping.understand_ltac constr_flags env sigma vars WithoutTypeConstraint term - in - Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return (Value.of_constr c_interp)) - end + let c = interp_uconstr ist env c in + let Sigma (c, sigma, p) = (type_uconstr ist c).delayed env sigma in + Sigma (Ftactic.return (Value.of_constr c), sigma, p) + end } | TacNumgoals -> Ftactic.lift begin let open Proofview.Notations in @@ -1428,7 +1352,7 @@ and interp_tacarg ist arg : typed_generic_argument Ftactic.t = | Tacexp t -> val_interp ist t (* Interprets an application node *) -and interp_app loc ist fv largs : typed_generic_argument Ftactic.t = +and interp_app loc ist fv largs : Val.t Ftactic.t = let (>>=) = Ftactic.bind in let fail = Tacticals.New.tclZEROMSG (str "Illegal tactic application.") in let fv = Value.normalize fv in @@ -1572,16 +1496,16 @@ and interp_match ist lz constr lmr = Proofview.tclZERO ~info e end end >>= fun constr -> - Ftactic.enter begin fun gl -> + Ftactic.enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let ilr = read_match_rule (extract_ltac_constr_values ist env) ist env sigma lmr in interp_match_successes lz ist (Tactic_matching.match_term env sigma constr ilr) - end + end } (* Interprets the Match Context expressions *) and interp_match_goal ist lz lr lmr = - Ftactic.nf_enter begin fun gl -> + Ftactic.nf_enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let hyps = Proofview.Goal.hyps gl in @@ -1589,107 +1513,82 @@ and interp_match_goal ist lz lr lmr = let concl = Proofview.Goal.concl gl in let ilr = read_match_rule (extract_ltac_constr_values ist env) ist env sigma lmr in interp_match_successes lz ist (Tactic_matching.match_goal env sigma hyps concl ilr) - end + end } (* Interprets extended tactic generic arguments *) -(* spiwack: interp_genarg has an argument [concl] for the case of - "casted open constr". And [gl] for [Geninterp]. I haven't changed - the interface for geninterp yet as it is used by ARGUMENT EXTEND - (in turn used by plugins). At the time I'm writing this comment - though, the only concerned plugins are the declarative mode (which - needs the [extra] field of goals to interprete rules) and ssreflect - (a handful of time). I believe we'd need to address "casted open - constr" and the declarative mode rules to provide a reasonable - interface. *) -and interp_genarg ist env sigma concl gl x = - let evdref = ref sigma in - let rec interp_genarg x = +and interp_genarg ist x : Val.t Ftactic.t = + let open Ftactic.Notations in match genarg_tag x with - | IntOrVarArgType -> - in_gen (topwit wit_int_or_var) - (ArgArg (interp_int_or_var ist (out_gen (glbwit wit_int_or_var) x))) | IdentArgType -> - in_gen (topwit wit_ident) - (interp_ident ist env sigma (out_gen (glbwit wit_ident) x)) + interp_focussed wit_ident (interp_ident ist) x | VarArgType -> - in_gen (topwit wit_var) (interp_hyp ist env sigma (out_gen (glbwit wit_var) x)) - | GenArgType -> - in_gen (topwit wit_genarg) (interp_genarg (out_gen (glbwit wit_genarg) x)) + interp_focussed wit_var (interp_hyp ist) x | ConstrArgType -> - let (sigma,c_interp) = - interp_constr ist env !evdref (out_gen (glbwit wit_constr) x) - in - evdref := sigma; - in_gen (topwit wit_constr) c_interp - | ConstrMayEvalArgType -> - let (sigma,c_interp) = interp_constr_may_eval ist env !evdref (out_gen (glbwit wit_constr_may_eval) x) in - evdref := sigma; - in_gen (topwit wit_constr_may_eval) c_interp - | OpenConstrArgType -> - let expected_type = WithoutTypeConstraint in - in_gen (topwit wit_open_constr) - (interp_open_constr ~expected_type - ist env !evdref - (snd (out_gen (glbwit wit_open_constr) x))) + Ftactic.nf_s_enter { s_enter = begin fun gl -> + let c = Genarg.out_gen (glbwit wit_constr) x in + let env = Proofview.Goal.env gl in + let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + let (sigma, c) = interp_constr ist env sigma c in + let c = in_gen (topwit wit_constr) c in + Sigma.Unsafe.of_pair (Ftactic.return c, sigma) + end } | ListArgType ConstrArgType -> - let (sigma,v) = interp_genarg_constr_list ist env !evdref x in - evdref := sigma; - v - | ListArgType VarArgType -> interp_genarg_var_list ist env sigma x + interp_genarg_constr_list ist x + | ListArgType VarArgType -> + interp_genarg_var_list ist x | ListArgType _ -> let list_unpacker wit l = let map x = - out_gen (topwit wit) (interp_genarg (in_gen (glbwit wit) x)) + interp_genarg ist (Genarg.in_gen (glbwit wit) x) >>= fun x -> + Ftactic.return (Value.cast (topwit wit) x) in - in_gen (topwit (wit_list wit)) (List.map map (glb l)) + Ftactic.List.map map (glb l) >>= fun l -> + Ftactic.return (Value.of_list (val_tag wit) l) in list_unpack { list_unpacker } x | OptArgType _ -> let opt_unpacker wit o = match glb o with - | None -> in_gen (topwit (wit_opt wit)) None + | None -> Ftactic.return (Value.of_option (val_tag wit) None) | Some x -> - let x = out_gen (topwit wit) (interp_genarg (in_gen (glbwit wit) x)) in - in_gen (topwit (wit_opt wit)) (Some x) + interp_genarg ist (Genarg.in_gen (glbwit wit) x) >>= fun x -> + let x = Value.cast (topwit wit) x in + Ftactic.return (Value.of_option (val_tag wit) (Some x)) in opt_unpack { opt_unpacker } x | PairArgType _ -> let pair_unpacker wit1 wit2 o = let (p, q) = glb o in - let p = out_gen (topwit wit1) (interp_genarg (in_gen (glbwit wit1) p)) in - let q = out_gen (topwit wit2) (interp_genarg (in_gen (glbwit wit2) q)) in - in_gen (topwit (wit_pair wit1 wit2)) (p, q) + interp_genarg ist (Genarg.in_gen (glbwit wit1) p) >>= fun p -> + interp_genarg ist (Genarg.in_gen (glbwit wit2) q) >>= fun q -> + let p = Value.cast (topwit wit1) p in + let q = Value.cast (topwit wit2) q in + Ftactic.return (Val.Dyn (Val.Pair (val_tag wit1, val_tag wit2), (p, q))) in pair_unpack { pair_unpacker } x - | ExtraArgType s -> - let (sigma,v) = Geninterp.generic_interp ist { Evd.it=gl;sigma=(!evdref) } x in - evdref:=sigma; - v - in - let v = interp_genarg x in - !evdref , v - + | ExtraArgType _ -> + Geninterp.generic_interp ist x (** returns [true] for genargs which have the same meaning independently of goals. *) -and global_genarg = - let rec global_tag = function - | IntOrVarArgType | GenArgType -> true - | ListArgType t | OptArgType t -> global_tag t - | PairArgType (t1,t2) -> global_tag t1 && global_tag t2 - | _ -> false - in - fun x -> global_tag (genarg_tag x) - -and interp_genarg_constr_list ist env sigma x = - let lc = out_gen (glbwit (wit_list wit_constr)) x in +and interp_genarg_constr_list ist x = + Ftactic.nf_s_enter { s_enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + let lc = Genarg.out_gen (glbwit (wit_list wit_constr)) x in let (sigma,lc) = interp_constr_list ist env sigma lc in - sigma , in_gen (topwit (wit_list wit_constr)) lc + let lc = Value.of_list (val_tag wit_constr) lc in + Sigma.Unsafe.of_pair (Ftactic.return lc, sigma) + end } -and interp_genarg_var_list ist env sigma x = - let lc = out_gen (glbwit (wit_list wit_var)) x in +and interp_genarg_var_list ist x = + Ftactic.nf_enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + let lc = Genarg.out_gen (glbwit (wit_list wit_var)) x in let lc = interp_hyp_list ist env sigma lc in - in_gen (topwit (wit_list wit_var)) lc + Ftactic.return (Value.of_list (val_tag wit_var) lc) + end } (* Interprets tactic expressions : returns a "constr" *) and interp_ltac_constr ist e : constr Ftactic.t = @@ -1698,7 +1597,7 @@ and interp_ltac_constr ist e : constr Ftactic.t = (val_interp ist e) begin function (err, info) -> match err with | Not_found -> - Ftactic.enter begin fun gl -> + Ftactic.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in Proofview.tclLIFT begin debugging_step ist (fun () -> @@ -1706,11 +1605,11 @@ and interp_ltac_constr ist e : constr Ftactic.t = Pptactic.pr_glob_tactic env e) end <*> Proofview.tclZERO Not_found - end + end } | err -> Proofview.tclZERO ~info err end end >>= fun result -> - Ftactic.enter begin fun gl -> + Ftactic.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let result = Value.normalize result in @@ -1727,7 +1626,7 @@ and interp_ltac_constr ist e : constr Ftactic.t = let env = Proofview.Goal.env gl in Tacticals.New.tclZEROMSG (str "Must evaluate to a closed term" ++ fnl() ++ str "offending expression: " ++ fnl() ++ pr_inspect env e result) - end + end } (* Interprets tactic expressions : returns a "tactic" *) @@ -1757,7 +1656,7 @@ and interp_atomic ist tac : unit Proofview.tactic = (TacIntroPattern l) (* spiwack: print uninterpreted, not sure if it is the expected behaviour. *) - (Tactics.intros_patterns l')) sigma + (Tactics.intro_patterns l')) sigma end } | TacIntroMove (ido,hto) -> Proofview.Goal.enter { enter = begin fun gl -> @@ -1940,48 +1839,12 @@ and interp_atomic ist tac : unit Proofview.tactic = ((sigma,sigma'),c) clp eqpat) sigma') end } - (* Automation tactics *) - | TacTrivial (debug,lems,l) -> - begin if debug == Tacexpr.Info then - msg_warning - (strbrk"The \"info_trivial\" tactic" ++ spc () - ++strbrk"does not print traces anymore." ++ spc() - ++strbrk"Use \"Info 1 trivial\", instead.") - end; - Proofview.Goal.enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in - let lems = interp_auto_lemmas ist env sigma lems in - name_atomic ~env - (TacTrivial(debug,List.map snd lems,l)) - (Auto.h_trivial ~debug - lems - (Option.map (List.map (interp_hint_base ist)) l)) - end } - | TacAuto (debug,n,lems,l) -> - begin if debug == Tacexpr.Info then - msg_warning - (strbrk"The \"info_auto\" tactic" ++ spc () - ++strbrk"does not print traces anymore." ++ spc() - ++strbrk"Use \"Info 1 auto\", instead.") - end; - Proofview.Goal.enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in - let lems = interp_auto_lemmas ist env sigma lems in - name_atomic ~env - (TacAuto(debug,n,List.map snd lems,l)) - (Auto.h_auto ~debug (Option.map (interp_int_or_var ist) n) - lems - (Option.map (List.map (interp_hint_base ist)) l)) - end } - (* Derived basic tactics *) | TacInductionDestruct (isrec,ev,(l,el)) -> (* spiwack: some unknown part of destruct needs the goal to be prenormalised. *) Proofview.V82.nf_evar_goals <*> - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let sigma,l = @@ -2000,11 +1863,11 @@ and interp_atomic ist tac : unit Proofview.tactic = let l,lp = List.split l in let sigma,el = Option.fold_map (interp_constr_with_bindings ist env) sigma el in - name_atomic ~env + let tac = name_atomic ~env (TacInductionDestruct(isrec,ev,(lp,el))) - (Tacticals.New.tclTHEN - (Proofview.Unsafe.tclEVARS sigma) - (Tactics.induction_destruct isrec ev (l,el))) + (Tactics.induction_destruct isrec ev (l,el)) + in + Sigma.Unsafe.of_pair (tac, sigma) end } | TacDoubleInduction (h1,h2) -> let h1 = interp_quantified_hypothesis ist h1 in @@ -2201,16 +2064,17 @@ and interp_atomic ist tac : unit Proofview.tactic = (Inv.inv_clause k ids_interp hyps dqhyps)) sigma end } | TacInversion (InversionUsing (c,idl),hyp) -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let (sigma,c_interp) = interp_constr ist env sigma c in let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in let hyps = interp_hyp_list ist env sigma idl in - Proofview.Unsafe.tclEVARS sigma <*> - name_atomic ~env + let tac = name_atomic ~env (TacInversion (InversionUsing (c_interp,hyps),dqhyps)) (Leminv.lemInv_clause dqhyps c_interp hyps) + in + Sigma.Unsafe.of_pair (tac, sigma) end } (* Initial call for interpretation *) @@ -2270,7 +2134,7 @@ let hide_interp global t ot = let def_intern ist x = (ist, x) let def_subst _ x = x -let def_interp ist gl x = (project gl, x) +let def_interp ist x = Ftactic.return x let declare_uniform t = Genintern.register_intern0 t def_intern; @@ -2292,39 +2156,55 @@ let () = let () = declare_uniform wit_pre_ident -let lift f = (); fun ist gl x -> (project gl, f ist (pf_env gl) (project gl) x) -let lifts f = (); fun ist gl x -> f ist (pf_env gl) (project gl) x +let lift f = (); fun ist x -> Ftactic.nf_enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + Ftactic.return (f ist env sigma x) +end } + +let lifts f = (); fun ist x -> Ftactic.nf_s_enter { s_enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + let (sigma, v) = f ist env sigma x in + Sigma.Unsafe.of_pair (Ftactic.return v, sigma) +end } -let interp_bindings' ist gl bl = - let (sigma, bl) = interp_bindings ist (pf_env gl) (project gl) bl in - (project gl, pack_sigma (sigma, bl)) +let interp_bindings' ist bl = Ftactic.return { delayed = fun env sigma -> + let (sigma, bl) = interp_bindings ist env (Sigma.to_evar_map sigma) bl in + Sigma.Unsafe.of_pair (bl, sigma) + } -let interp_constr_with_bindings' ist gl c = - let (sigma, c) = interp_constr_with_bindings ist (pf_env gl) (project gl) c in - (project gl, pack_sigma (sigma, c)) +let interp_constr_with_bindings' ist c = Ftactic.return { delayed = fun env sigma -> + let (sigma, c) = interp_constr_with_bindings ist env (Sigma.to_evar_map sigma) c in + Sigma.Unsafe.of_pair (c, sigma) + } let () = + Geninterp.register_interp0 wit_int_or_var (fun ist n -> Ftactic.return (interp_int_or_var ist n)); Geninterp.register_interp0 wit_ref (lift interp_reference); Geninterp.register_interp0 wit_intro_pattern (lifts interp_intro_pattern); Geninterp.register_interp0 wit_clause_dft_concl (lift interp_clause); Geninterp.register_interp0 wit_sort (lifts (fun _ _ evd s -> interp_sort evd s)); - Geninterp.register_interp0 wit_tacvalue (fun ist gl c -> project gl, c); + Geninterp.register_interp0 wit_tacvalue (fun ist v -> Ftactic.return v); Geninterp.register_interp0 wit_red_expr (lifts interp_red_expr); Geninterp.register_interp0 wit_quant_hyp (lift interp_declared_or_quantified_hypothesis); + Geninterp.register_interp0 wit_open_constr (lifts interp_open_constr); Geninterp.register_interp0 wit_bindings interp_bindings'; - Geninterp.register_interp0 wit_constr_with_bindings interp_constr_with_bindings' + Geninterp.register_interp0 wit_constr_with_bindings interp_constr_with_bindings'; + Geninterp.register_interp0 wit_constr_may_eval (lifts interp_constr_may_eval); + () let () = - let interp ist gl tac = + let interp ist tac = let f = VFun (UnnamedAppl,extract_trace ist, ist.lfun, [], tac) in - (project gl, TacArg (dloc, TacGeneric (Genarg.in_gen (glbwit wit_tacvalue) f))) + Ftactic.return (TacArg (dloc, TacGeneric (Genarg.in_gen (glbwit wit_tacvalue) f))) in Geninterp.register_interp0 wit_tactic interp let () = - Geninterp.register_interp0 wit_uconstr (fun ist gl c -> - project gl , interp_uconstr ist (pf_env gl) c - ) + Geninterp.register_interp0 wit_uconstr (fun ist c -> Ftactic.nf_enter { enter = begin fun gl -> + Ftactic.return (interp_uconstr ist (Proofview.Goal.env gl) c) + end }) (***************************************************************************) (* Other entry points *) @@ -2344,8 +2224,8 @@ let interp_redexp env sigma r = let _ = let eval ty env sigma lfun arg = let ist = { lfun = lfun; extra = TacStore.empty; } in - if has_type arg (glbwit wit_tactic) then - let tac = out_gen (glbwit wit_tactic) arg in + if Genarg.has_type arg (glbwit wit_tactic) then + let tac = Genarg.out_gen (glbwit wit_tactic) arg in let tac = interp_tactic ist tac in Pfedit.refine_by_tactic env sigma ty tac else diff --git a/tactics/tacinterp.mli b/tactics/tacinterp.mli index 88802bf350..47a16a3bc0 100644 --- a/tactics/tacinterp.mli +++ b/tactics/tacinterp.mli @@ -16,13 +16,14 @@ open Misctypes module Value : sig - type t = tlevel generic_argument + type t = Val.t val of_constr : constr -> t val to_constr : t -> constr option val of_int : int -> t val to_int : t -> int option val to_list : t -> t list option val of_closure : Geninterp.interp_sign -> glob_tactic_expr -> t + val cast : 'a typed_abstract_argument_type -> Val.t -> 'a end (** Values for interpretation *) @@ -53,10 +54,7 @@ val get_debug : unit -> debug_info (** Adds an interpretation function for extra generic arguments *) -(* spiwack: the [Term.constr] argument is the conclusion of the goal, - for "casted open constr" *) -val interp_genarg : interp_sign -> Environ.env -> Evd.evar_map -> Term.constr -> Goal.goal -> - glob_generic_argument -> Evd.evar_map * typed_generic_argument +val interp_genarg : interp_sign -> glob_generic_argument -> Value.t Ftactic.t (** Interprets any expression *) val val_interp : interp_sign -> glob_tactic_expr -> (value -> unit Proofview.tactic) -> unit Proofview.tactic @@ -64,6 +62,11 @@ val val_interp : interp_sign -> glob_tactic_expr -> (value -> unit Proofview.tac (** Interprets an expression that evaluates to a constr *) val interp_ltac_constr : interp_sign -> glob_tactic_expr -> (constr -> unit Proofview.tactic) -> unit Proofview.tactic +val type_uconstr : + ?flags:Pretyping.inference_flags -> + ?expected_type:Pretyping.typing_constraint -> + interp_sign -> Glob_term.closed_glob_constr -> constr delayed_open + (** Interprets redexp arguments *) val interp_redexp : Environ.env -> Evd.evar_map -> raw_red_expr -> Evd.evar_map * red_expr diff --git a/tactics/tacsubst.ml b/tactics/tacsubst.ml index 6d32aa81b9..754c886205 100644 --- a/tactics/tacsubst.ml +++ b/tactics/tacsubst.ml @@ -154,10 +154,6 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with | TacLetTac (id,c,clp,b,eqpat) -> TacLetTac (id,subst_glob_constr subst c,clp,b,eqpat) - (* Automation tactics *) - | TacTrivial (d,lems,l) -> TacTrivial (d,List.map (subst_glob_constr subst) lems,l) - | TacAuto (d,n,lems,l) -> TacAuto (d,n,List.map (subst_glob_constr subst) lems,l) - (* Derived basic tactics *) | TacInductionDestruct (isrec,ev,(l,el)) -> let l' = List.map (fun (c,ids,cls) -> @@ -249,8 +245,8 @@ and subst_tactic subst (t:glob_tactic_expr) = match t with (* For extensions *) | TacAlias (_,s,l) -> let s = subst_kn subst s in - TacAlias (dloc,s,List.map (fun (id,a) -> (id,subst_genarg subst a)) l) - | TacML (_loc,opn,l) -> TacML (dloc,opn,List.map (subst_genarg subst) l) + TacAlias (dloc,s,List.map (subst_tacarg subst) l) + | TacML (_loc,opn,l) -> TacML (dloc,opn,List.map (subst_tacarg subst) l) and subst_tactic_fun subst (var,body) = (var,subst_tactic subst body) @@ -265,7 +261,7 @@ and subst_tacarg subst = function | TacPretype c -> TacPretype (subst_glob_constr subst c) | TacNumgoals -> TacNumgoals | Tacexp t -> Tacexp (subst_tactic subst t) - | TacGeneric arg -> TacGeneric (Genintern.generic_substitute subst arg) + | TacGeneric arg -> TacGeneric (subst_genarg subst arg) (* Reads the rules of a Match Context or a Match *) and subst_match_rule subst = function @@ -280,18 +276,11 @@ and subst_match_rule subst = function and subst_genarg subst (x:glob_generic_argument) = match genarg_tag x with - | IntOrVarArgType -> in_gen (glbwit wit_int_or_var) (out_gen (glbwit wit_int_or_var) x) | IdentArgType -> in_gen (glbwit wit_ident) (out_gen (glbwit wit_ident) x) | VarArgType -> in_gen (glbwit wit_var) (out_gen (glbwit wit_var) x) - | GenArgType -> in_gen (glbwit wit_genarg) (subst_genarg subst (out_gen (glbwit wit_genarg) x)) | ConstrArgType -> in_gen (glbwit wit_constr) (subst_glob_constr subst (out_gen (glbwit wit_constr) x)) - | ConstrMayEvalArgType -> - in_gen (glbwit wit_constr_may_eval) (subst_raw_may_eval subst (out_gen (glbwit wit_constr_may_eval) x)) - | OpenConstrArgType -> - in_gen (glbwit wit_open_constr) - ((),subst_glob_constr subst (snd (out_gen (glbwit wit_open_constr) x))) | ListArgType _ -> let list_unpacker wit l = let map x = @@ -323,14 +312,17 @@ and subst_genarg subst (x:glob_generic_argument) = (** Registering *) let () = + Genintern.register_subst0 wit_int_or_var (fun _ v -> v); Genintern.register_subst0 wit_ref subst_global_reference; Genintern.register_subst0 wit_intro_pattern (fun _ v -> v); Genintern.register_subst0 wit_tactic subst_tactic; Genintern.register_subst0 wit_sort (fun _ v -> v); Genintern.register_subst0 wit_clause_dft_concl (fun _ v -> v); Genintern.register_subst0 wit_uconstr (fun subst c -> subst_glob_constr subst c); + Genintern.register_subst0 wit_open_constr (fun subst c -> subst_glob_constr subst c); Genintern.register_subst0 wit_red_expr subst_redexp; Genintern.register_subst0 wit_quant_hyp subst_declared_or_quantified_hypothesis; Genintern.register_subst0 wit_bindings subst_bindings; Genintern.register_subst0 wit_constr_with_bindings subst_glob_with_bindings; + Genintern.register_subst0 wit_constr_may_eval subst_raw_may_eval; () diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index aaef0f072f..750ec8fb1e 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -514,6 +514,14 @@ module New = struct in Proofview.Unsafe.tclEVARS sigma <*> tac >>= check_evars_if + let tclDELAYEDWITHHOLES check x tac = + Proofview.Goal.nf_enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let Sigma (x, sigma, _) = x.Tacexpr.delayed env sigma in + tclWITHHOLES check (tac x) (Sigma.to_evar_map sigma) + end } + let tclTIMEOUT n t = Proofview.tclOR (Proofview.tclTIMEOUT n t) diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index d8aa3161e8..147f1f0f20 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -218,6 +218,7 @@ module New : sig val tclSOLVE : unit tactic list -> unit tactic val tclPROGRESS : unit tactic -> unit tactic val tclWITHHOLES : bool -> 'a tactic -> Evd.evar_map -> 'a tactic + val tclDELAYEDWITHHOLES : bool -> 'a delayed_open -> ('a -> unit tactic) -> unit tactic val tclTIMEOUT : int -> unit tactic -> unit tactic val tclTIME : string option -> 'a tactic -> 'a tactic diff --git a/tactics/tactics.ml b/tactics/tactics.ml index f2319804ec..588bdc8ed9 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1891,41 +1891,6 @@ let rec intros_clearing = function Tacticals.New.tclTHENLIST [ intro; Tacticals.New.onLastHypId (fun id -> Proofview.V82.tactic (clear [id])); intros_clearing tl] -(* Modifying/Adding an hypothesis *) - -let specialize (c,lbind) g = - let tac, term = - if lbind == NoBindings then - let evd = Typeclasses.resolve_typeclasses (pf_env g) (project g) in - tclEVARS evd, nf_evar evd c - else - let clause = Tacmach.pf_apply make_clenv_binding g (c,Tacmach.pf_unsafe_type_of g c) lbind in - let flags = { (default_unify_flags ()) with resolve_evars = true } in - let clause = clenv_unify_meta_types ~flags clause in - let (thd,tstack) = whd_nored_stack clause.evd (clenv_value clause) in - let rec chk = function - | [] -> [] - | t::l -> if occur_meta t then [] else t :: chk l - in - let tstack = chk tstack in - let term = applist(thd,List.map (nf_evar clause.evd) tstack) in - if occur_meta term then - errorlabstrm "" (str "Cannot infer an instance for " ++ - pr_name (meta_name clause.evd (List.hd (collect_metas term))) ++ - str "."); - tclEVARS clause.evd, term - in - match kind_of_term (fst(decompose_app (snd(decompose_lam_assum c)))) with - | Var id when Id.List.mem id (Tacmach.pf_ids_of_hyps g) -> - tclTHEN tac - (tclTHENFIRST - (fun g -> Proofview.V82.of_tactic (assert_before_replacing id (Tacmach.pf_unsafe_type_of g term)) g) - (exact_no_check term)) g - | _ -> tclTHEN tac - (tclTHENLAST - (fun g -> Proofview.V82.of_tactic (cut (Tacmach.pf_unsafe_type_of g term)) g) - (exact_no_check term)) g - (* Keeping only a few hypotheses *) let keep hyps = @@ -1944,6 +1909,53 @@ let keep hyps = Proofview.V82.tactic (fun gl -> thin cl gl) end } +(*********************************) +(* Basic generalization tactics *) +(*********************************) + +(* Given a type [T] convertible to [forall x1..xn:A1..An(x1..xn-1), G(x1..xn)] + and [a1..an:A1..An(a1..an-1)] such that the goal is [G(a1..an)], + this generalizes [hyps |- goal] into [hyps |- T] *) + +let apply_type newcl args = + Proofview.Goal.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let store = Proofview.Goal.extra gl in + Proofview.Refine.refine { run = begin fun sigma -> + let newcl = nf_betaiota (Sigma.to_evar_map sigma) newcl (* As in former Logic.refine *) in + let Sigma (ev, sigma, p) = + Evarutil.new_evar env sigma ~principal:true ~store newcl in + Sigma (applist (ev, args), sigma, p) + end } + end } + +(* Given a context [hyps] with domain [x1..xn], possibly with let-ins, + and well-typed in the current goal, [bring_hyps hyps] generalizes + [ctxt |- G(x1..xn] into [ctxt |- forall hyps, G(x1..xn)] *) + +let bring_hyps hyps = + if List.is_empty hyps then Tacticals.New.tclIDTAC + else + Proofview.Goal.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let store = Proofview.Goal.extra gl in + let concl = Tacmach.New.pf_nf_concl gl in + let newcl = List.fold_right mkNamedProd_or_LetIn hyps concl in + let args = Array.of_list (Context.Named.to_instance hyps) in + Proofview.Refine.refine { run = begin fun sigma -> + let Sigma (ev, sigma, p) = + Evarutil.new_evar env sigma ~principal:true ~store newcl in + Sigma (mkApp (ev, args), sigma, p) + end } + end } + +let revert hyps = + Proofview.Goal.enter { enter = begin fun gl -> + let gl = Proofview.Goal.assume gl in + let ctx = List.map (fun id -> Tacmach.New.pf_get_hyp id gl) hyps in + (bring_hyps ctx) <*> (Proofview.V82.tactic (clear hyps)) + end } + (************************) (* Introduction tactics *) (************************) @@ -2117,7 +2129,7 @@ let rewrite_hyp assert_style l2r id = Tacticals.New.tclTHEN (rew_on l2r onConcl) (Proofview.V82.tactic (clear [id])) end } -let rec prepare_naming loc = function +let prepare_naming loc = function | IntroIdentifier id -> NamingMustBe (loc,id) | IntroAnonymous -> NamingAvoid [] | IntroFresh id -> NamingBasedOn (id,[]) @@ -2239,7 +2251,7 @@ and intro_pattern_action loc b style pat thin destopt tac id = match pat with | IntroInjection l' -> intro_decomp_eq loc l' thin tac id | IntroRewrite l2r -> - Tacticals.New.tclTHENLAST + Tacticals.New.tclTHENFIRST (* Skip the side conditions of the rewriting step *) (rewrite_hyp style l2r id) (tac thin None []) @@ -2508,40 +2520,6 @@ let enough_by na t tac = forward false (Some tac) (ipat_of_name na) t (* Generalization tactics *) (***************************) -(* Given a type [T] convertible to [forall x1..xn:A1..An(x1..xn-1), G(x1..xn)] - and [a1..an:A1..An(a1..an-1)] such that the goal is [G(a1..an)], - this generalizes [hyps |- goal] into [hyps |- T] *) - -let apply_type hdcty argl gl = - refine (applist (mkCast (Evarutil.mk_new_meta(),DEFAULTcast, hdcty),argl)) gl - -(* Given a context [hyps] with domain [x1..xn], possibly with let-ins, - and well-typed in the current goal, [bring_hyps hyps] generalizes - [ctxt |- G(x1..xn] into [ctxt |- forall hyps, G(x1..xn)] *) - -let bring_hyps hyps = - if List.is_empty hyps then Tacticals.New.tclIDTAC - else - Proofview.Goal.enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let store = Proofview.Goal.extra gl in - let concl = Tacmach.New.pf_nf_concl gl in - let newcl = List.fold_right mkNamedProd_or_LetIn hyps concl in - let args = Array.of_list (Context.Named.to_instance hyps) in - Proofview.Refine.refine { run = begin fun sigma -> - let Sigma (ev, sigma, p) = - Evarutil.new_evar env sigma ~principal:true ~store newcl in - Sigma (mkApp (ev, args), sigma, p) - end } - end } - -let revert hyps = - Proofview.Goal.enter { enter = begin fun gl -> - let gl = Proofview.Goal.assume gl in - let ctx = List.map (fun id -> Tacmach.New.pf_get_hyp id gl) hyps in - (bring_hyps ctx) <*> (Proofview.V82.tactic (clear hyps)) - end } - (* Compute a name for a generalization *) let generalized_name c t ids cl = function @@ -2565,18 +2543,19 @@ let generalized_name c t ids cl = function [forall x, x1:A1(x1), .., xi:Ai(x). T(x)] with all [c] abtracted in [Ai] but only those at [occs] in [T] *) -let generalize_goal_gen env ids i ((occs,c,b),na) t (cl,evd) = +let generalize_goal_gen env sigma ids i ((occs,c,b),na) t cl = let decls,cl = decompose_prod_n_assum i cl in let dummy_prod = it_mkProd_or_LetIn mkProp decls in let newdecls,_ = decompose_prod_n_assum i (subst_term_gen eq_constr_nounivs c dummy_prod) in - let cl',evd' = subst_closed_term_occ env evd (AtOccs occs) c (it_mkProd_or_LetIn cl newdecls) in + let cl',sigma' = subst_closed_term_occ env sigma (AtOccs occs) c (it_mkProd_or_LetIn cl newdecls) in let na = generalized_name c t ids cl' na in - mkProd_or_LetIn (na,b,t) cl', evd' + mkProd_or_LetIn (na,b,t) cl', sigma' -let generalize_goal gl i ((occs,c,b),na as o) cl = - let t = Tacmach.pf_unsafe_type_of gl c in +let generalize_goal gl i ((occs,c,b),na as o) (cl,sigma) = let env = Tacmach.pf_env gl in - generalize_goal_gen env (Tacmach.pf_ids_of_hyps gl) i o t cl + let ids = Tacmach.pf_ids_of_hyps gl in + let sigma, t = Typing.type_of env sigma c in + generalize_goal_gen env sigma ids i o t cl let generalize_dep ?(with_let=false) c gl = let env = pf_env gl in @@ -2611,7 +2590,7 @@ let generalize_dep ?(with_let=false) c gl = let args = Context.Named.to_instance to_quantify_rev in tclTHENLIST [tclEVARS evd; - apply_type cl'' (if Option.is_empty body then c::args else args); + Proofview.V82.of_tactic (apply_type cl'' (if Option.is_empty body then c::args else args)); thin (List.rev tothin')] gl @@ -2621,9 +2600,9 @@ let generalize_gen_let lconstr gl = List.fold_right_i (generalize_goal gl) 0 lconstr (Tacmach.pf_concl gl,Tacmach.project gl) in - tclTHEN (tclEVARS evd) + Proofview.V82.of_tactic (Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS evd) (apply_type newcl (List.map_filter (fun ((_,c,b),_) -> - if Option.is_empty b then Some c else None) lconstr)) gl + if Option.is_empty b then Some c else None) lconstr))) gl let new_generalize_gen_let lconstr = Proofview.Goal.s_enter { s_enter = begin fun gl -> @@ -2633,13 +2612,14 @@ let new_generalize_gen_let lconstr = let sigma = Sigma.to_evar_map sigma in let env = Proofview.Goal.env gl in let ids = Tacmach.New.pf_ids_of_hyps gl in - let (newcl, sigma), args = + let newcl, sigma, args = List.fold_right_i - (fun i ((_,c,b),_ as o) (cl, args) -> - let t = Tacmach.New.pf_unsafe_type_of gl c in + (fun i ((_,c,b),_ as o) (cl, sigma, args) -> + let sigma, t = Typing.type_of env sigma c in let args = if Option.is_empty b then c :: args else args in - generalize_goal_gen env ids i o t cl, args) - 0 lconstr ((concl, sigma), []) + let cl, sigma = generalize_goal_gen env sigma ids i o t cl in + (cl, sigma, args)) + 0 lconstr (concl, sigma, []) in let tac = Proofview.Refine.refine { run = begin fun sigma -> @@ -2677,6 +2657,49 @@ let quantify lconstr = tclIDTAC *) +(* Modifying/Adding an hypothesis *) + +let specialize (c,lbind) = + Proofview.Goal.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + let sigma, term = + if lbind == NoBindings then + let sigma = Typeclasses.resolve_typeclasses env sigma in + sigma, nf_evar sigma c + else + let clause = make_clenv_binding env sigma (c,Retyping.get_type_of env sigma c) lbind in + let flags = { (default_unify_flags ()) with resolve_evars = true } in + let clause = clenv_unify_meta_types ~flags clause in + let (thd,tstack) = whd_nored_stack clause.evd (clenv_value clause) in + let rec chk = function + | [] -> [] + | t::l -> if occur_meta t then [] else t :: chk l + in + let tstack = chk tstack in + let term = applist(thd,List.map (nf_evar clause.evd) tstack) in + if occur_meta term then + errorlabstrm "" (str "Cannot infer an instance for " ++ + pr_name (meta_name clause.evd (List.hd (collect_metas term))) ++ + str "."); + clause.evd, term in + let typ = Retyping.get_type_of env sigma term in + match kind_of_term (fst(decompose_app (snd(decompose_lam_assum c)))) with + | Var id when Id.List.mem id (Tacmach.New.pf_ids_of_hyps gl) -> + Tacticals.New.tclTHEN + (Proofview.Unsafe.tclEVARS sigma) + (Tacticals.New.tclTHENFIRST + (assert_before_replacing id typ) + (new_exact_no_check term)) + | _ -> + (* To deprecate in favor of generalize? *) + Tacticals.New.tclTHEN + (Proofview.Unsafe.tclEVARS sigma) + (Tacticals.New.tclTHENLAST + (cut typ) + (new_exact_no_check term)) + end } + (*****************************) (* Ad hoc unfold *) (*****************************) @@ -3849,7 +3872,7 @@ let apply_induction_in_context hyp0 inhyps elim indvars names induct_tac = (if isrec then Tacticals.New.tclTHENFIRSTn else Tacticals.New.tclTHENLASTn) (Tacticals.New.tclTHENLIST [ (* Generalize dependent hyps (but not args) *) - if deps = [] then Proofview.tclUNIT () else Proofview.V82.tactic (apply_type tmpcl deps_cstr); + if deps = [] then Proofview.tclUNIT () else apply_type tmpcl deps_cstr; (* side-conditions in elim (resp case) schemes come last (resp first) *) induct_tac elim; Proofview.V82.tactic (tclMAP expand_hyp toclear) diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 873a11bd29..2ae72f4a5a 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -169,7 +169,7 @@ val unfold_body : Id.t -> tactic val keep : Id.t list -> unit Proofview.tactic val apply_clear_request : clear_flag -> bool -> constr -> unit Proofview.tactic -val specialize : constr with_bindings -> tactic +val specialize : constr with_bindings -> unit Proofview.tactic val move_hyp : Id.t -> Id.t move_location -> tactic val rename_hyp : (Id.t * Id.t) list -> unit Proofview.tactic @@ -178,7 +178,7 @@ val revert : Id.t list -> unit Proofview.tactic (** {6 Resolution tactics. } *) -val apply_type : constr -> constr list -> tactic +val apply_type : constr -> constr list -> unit Proofview.tactic val bring_hyps : Context.Named.t -> unit Proofview.tactic val apply : constr -> unit Proofview.tactic diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4 index 537d10dd55..f0805f7d08 100644 --- a/tactics/tauto.ml4 +++ b/tactics/tauto.ml4 @@ -59,7 +59,7 @@ let wit_tauto_flags : tauto_flags uniform_genarg_type = let assoc_flags ist = let v = Id.Map.find (Names.Id.of_string "tauto_flags") ist.lfun in - try Genarg.out_gen (topwit wit_tauto_flags) v with _ -> assert false + try Value.cast (topwit wit_tauto_flags) v with _ -> assert false (* Whether inner not are unfolded *) let negation_unfolding = ref true @@ -210,7 +210,7 @@ let constructor i = (** Take care of the index: this is the second entry in constructor. *) let name = { Tacexpr.mltac_name = name; mltac_index = 1 } in let i = in_gen (rawwit Constrarg.wit_int_or_var) (Misctypes.ArgArg i) in - Tacexpr.TacML (Loc.ghost, name, [i]) + Tacexpr.TacML (Loc.ghost, name, [TacGeneric i]) let is_disj _ ist = let flags = assoc_flags ist in @@ -310,7 +310,7 @@ let simplif ist = let t_simplif = tacticIn simplif "simplif" let tauto_intuit flags t_reduce solver = - let flags = Genarg.in_gen (topwit wit_tauto_flags) flags in + let flags = Genarg.Val.Dyn (Genarg.val_tag (topwit wit_tauto_flags), flags) in let lfun = make_lfun [("t_solver", solver); ("tauto_flags", flags)] in let ist = { default_ist () with lfun = lfun; } in let vars = [Id.of_string "t_solver"] in @@ -393,7 +393,9 @@ let tauto_gen flags = tauto_intuitionistic flags end -let default_intuition_tac = <:tactic< auto with * >> +let default_intuition_tac = + let tac _ _ = Auto.h_auto None [] None in + register_tauto_tactic tac "auto_with" (* This is the uniform mode dealing with ->, not, iff and types isomorphic to /\ and *, \/ and +, False and Empty_set, True and unit, _and_ eq-like types. diff --git a/test-suite/bugs/closed/3743.v b/test-suite/bugs/closed/3743.v index 4dfb3380a8..c799d4393f 100644 --- a/test-suite/bugs/closed/3743.v +++ b/test-suite/bugs/closed/3743.v @@ -3,7 +3,7 @@ coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (d65496f09c4b68fa318783e53f9cd6d5c18e1eb7) *) Require Export Coq.Setoids.Setoid. -Fail Add Parametric Relation A +Add Parametric Relation A : A (@eq A) transitivity proved by transitivity as refine_rel. diff --git a/test-suite/bugs/closed/3746.v b/test-suite/bugs/closed/3746.v new file mode 100644 index 0000000000..a9463f94bb --- /dev/null +++ b/test-suite/bugs/closed/3746.v @@ -0,0 +1,92 @@ + +(* Bug report #3746 : Include and restricted signature *) + +Module Type MT. Parameter p : nat. End MT. +Module Type EMPTY. End EMPTY. +Module Empty. End Empty. + +(* Include of an applied functor with restricted sig : + Used to create axioms (bug report #3746), now forbidden. *) + +Module F (X:EMPTY) : MT. + Definition p := 0. +End F. + +Module InclFunctRestr. + Fail Include F(Empty). +End InclFunctRestr. + +(* A few variants (indirect restricted signature), also forbidden. *) + +Module F1 := F. +Module F2 (X:EMPTY) := F X. + +Module F3a (X:EMPTY). Definition p := 0. End F3a. +Module F3 (X:EMPTY) : MT := F3a X. + +Module InclFunctRestrBis. + Fail Include F1(Empty). + Fail Include F2(Empty). + Fail Include F3(Empty). +End InclFunctRestrBis. + +(* Recommended workaround: manual instance before the include. *) + +Module InclWorkaround. + Module Temp := F(Empty). + Include Temp. +End InclWorkaround. + +Compute InclWorkaround.p. +Print InclWorkaround.p. +Print Assumptions InclWorkaround.p. (* Closed under the global context *) + + + +(* Related situations which are ok, just to check *) + +(* A) Include of non-functor with restricted signature : + creates a proxy to initial stuff *) + +Module M : MT. + Definition p := 0. +End M. + +Module InclNonFunct. + Include M. +End InclNonFunct. + +Definition check : InclNonFunct.p = M.p := eq_refl. +Print Assumptions InclNonFunct.p. (* Closed *) + + +(* B) Include of a module type with opaque content: + The opaque content is "copy-pasted". *) + +Module Type SigOpaque. + Definition p : nat. Proof. exact 0. Qed. +End SigOpaque. + +Module InclSigOpaque. + Include SigOpaque. +End InclSigOpaque. + +Compute InclSigOpaque.p. +Print InclSigOpaque.p. +Print Assumptions InclSigOpaque.p. (* Closed *) + + +(* C) Include of an applied functor with opaque proofs : + opaque proof "copy-pasted" (and substituted). *) + +Module F' (X:EMPTY). + Definition p : nat. Proof. exact 0. Qed. +End F'. + +Module InclFunctOpa. + Include F'(Empty). +End InclFunctOpa. + +Compute InclFunctOpa.p. +Print InclFunctOpa.p. +Print Assumptions InclFunctOpa.p. (* Closed *) diff --git a/test-suite/bugs/opened/3849.v b/test-suite/bugs/closed/3849.v index 5290054a06..a8dc3af9cf 100644 --- a/test-suite/bugs/opened/3849.v +++ b/test-suite/bugs/closed/3849.v @@ -5,4 +5,4 @@ Tactic Notation "bar" hyp_list(hs) := foo hs. Goal True. do 5 pose proof 0 as ?n0. foo n1 n2. -Fail bar n3 n4. +bar n3 n4. diff --git a/test-suite/bugs/closed/4453.v b/test-suite/bugs/closed/4453.v new file mode 100644 index 0000000000..009dd5e3ca --- /dev/null +++ b/test-suite/bugs/closed/4453.v @@ -0,0 +1,8 @@ + +Section Foo. +Variable A : Type. +Lemma foo : A -> True. now intros _. Qed. +Goal Type -> True. +rename A into B. +intros A. +Fail apply foo. diff --git a/test-suite/bugs/closed/4456.v b/test-suite/bugs/closed/4456.v new file mode 100644 index 0000000000..a32acf789c --- /dev/null +++ b/test-suite/bugs/closed/4456.v @@ -0,0 +1,647 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs" "-R" "." "Fiat" "-top" "BooleanRecognizerMin" "-R" "." "Top") -*- *) +(* File reduced by coq-bug-finder from original input, then from 2475 lines to 729 lines, then from 746 lines to 658 lines, then from 675 lines to 658 lines *) +(* coqc version 8.5beta3 (November 2015) compiled on Nov 11 2015 18:23:0 with OCaml 4.01.0 + coqtop version 8.5beta3 (November 2015) *) +(* Variable P : forall n m : nat, n = m -> Prop. *) +(* Axiom Prefl : forall n : nat, P n n eq_refl. *) +Axiom proof_admitted : False. + +Tactic Notation "admit" := case proof_admitted. + +Require Coq.Program.Program. +Require Coq.Strings.String. +Require Coq.omega.Omega. +Module Export Fiat_DOT_Common. +Module Export Fiat. +Module Common. +Import Coq.Lists.List. +Export Coq.Program.Program. + +Global Set Implicit Arguments. + +Global Coercion is_true : bool >-> Sortclass. +Coercion bool_of_sum {A B} (b : sum A B) : bool := if b then true else false. + +Fixpoint ForallT {T} (P : T -> Type) (ls : list T) : Type + := match ls return Type with + | nil => True + | x::xs => (P x * ForallT P xs)%type + end. +Fixpoint Forall_tails {T} (P : list T -> Type) (ls : list T) : Type + := match ls with + | nil => P nil + | x::xs => (P (x::xs) * Forall_tails P xs)%type + end. + +End Common. + +End Fiat. + +End Fiat_DOT_Common. +Module Export Fiat_DOT_Parsers_DOT_StringLike_DOT_Core. +Module Export Fiat. +Module Export Parsers. +Module Export StringLike. +Module Export Core. +Import Coq.Relations.Relation_Definitions. +Import Coq.Classes.Morphisms. + +Local Coercion is_true : bool >-> Sortclass. + +Module Export StringLike. + Class StringLike {Char : Type} := + { + String :> Type; + is_char : String -> Char -> bool; + length : String -> nat; + take : nat -> String -> String; + drop : nat -> String -> String; + get : nat -> String -> option Char; + unsafe_get : nat -> String -> Char; + bool_eq : String -> String -> bool; + beq : relation String := fun x y => bool_eq x y + }. + + Arguments StringLike : clear implicits. + Infix "=s" := (@beq _ _) (at level 70, no associativity) : type_scope. + Notation "s ~= [ ch ]" := (is_char s ch) (at level 70, no associativity) : string_like_scope. + Local Open Scope string_like_scope. + + Class StringLikeProperties (Char : Type) `{StringLike Char} := + { + singleton_unique : forall s ch ch', s ~= [ ch ] -> s ~= [ ch' ] -> ch = ch'; + singleton_exists : forall s, length s = 1 -> exists ch, s ~= [ ch ]; + get_0 : forall s ch, take 1 s ~= [ ch ] <-> get 0 s = Some ch; + get_S : forall n s, get (S n) s = get n (drop 1 s); + unsafe_get_correct : forall n s ch, get n s = Some ch -> unsafe_get n s = ch; + length_singleton : forall s ch, s ~= [ ch ] -> length s = 1; + bool_eq_char : forall s s' ch, s ~= [ ch ] -> s' ~= [ ch ] -> s =s s'; + is_char_Proper :> Proper (beq ==> eq ==> eq) is_char; + length_Proper :> Proper (beq ==> eq) length; + take_Proper :> Proper (eq ==> beq ==> beq) take; + drop_Proper :> Proper (eq ==> beq ==> beq) drop; + bool_eq_Equivalence :> Equivalence beq; + bool_eq_empty : forall str str', length str = 0 -> length str' = 0 -> str =s str'; + take_short_length : forall str n, n <= length str -> length (take n str) = n; + take_long : forall str n, length str <= n -> take n str =s str; + take_take : forall str n m, take n (take m str) =s take (min n m) str; + drop_length : forall str n, length (drop n str) = length str - n; + drop_0 : forall str, drop 0 str =s str; + drop_drop : forall str n m, drop n (drop m str) =s drop (n + m) str; + drop_take : forall str n m, drop n (take m str) =s take (m - n) (drop n str); + take_drop : forall str n m, take n (drop m str) =s drop m (take (n + m) str); + bool_eq_from_get : forall str str', (forall n, get n str = get n str') -> str =s str' + }. +Global Arguments StringLikeProperties _ {_}. +End StringLike. + +End Core. + +End StringLike. + +End Parsers. + +End Fiat. + +End Fiat_DOT_Parsers_DOT_StringLike_DOT_Core. + +Module Export Fiat_DOT_Parsers_DOT_ContextFreeGrammar_DOT_Core. +Module Export Fiat. +Module Export Parsers. +Module Export ContextFreeGrammar. +Module Export Core. +Import Coq.Strings.String. +Import Coq.Lists.List. +Export Fiat.Parsers.StringLike.Core. + +Section cfg. + Context {Char : Type}. + + Section definitions. + + Inductive item := + | Terminal (_ : Char) + | NonTerminal (_ : string). + + Definition production := list item. + Definition productions := list production. + + Record grammar := + { + Start_symbol :> string; + Lookup :> string -> productions; + Start_productions :> productions := Lookup Start_symbol; + Valid_nonterminals : list string; + Valid_productions : list productions := map Lookup Valid_nonterminals + }. + End definitions. + + End cfg. + +Arguments item _ : clear implicits. +Arguments production _ : clear implicits. +Arguments productions _ : clear implicits. +Arguments grammar _ : clear implicits. + +End Core. + +End ContextFreeGrammar. + +End Parsers. + +End Fiat. + +End Fiat_DOT_Parsers_DOT_ContextFreeGrammar_DOT_Core. + +Module Export Fiat_DOT_Parsers_DOT_BaseTypes. +Module Export Fiat. +Module Export Parsers. +Module Export BaseTypes. +Import Coq.Arith.Wf_nat. + +Local Coercion is_true : bool >-> Sortclass. + +Section recursive_descent_parser. + Context {Char} {HSL : StringLike Char} {G : grammar Char}. + + Class parser_computational_predataT := + { nonterminals_listT : Type; + nonterminal_carrierT : Type; + of_nonterminal : String.string -> nonterminal_carrierT; + to_nonterminal : nonterminal_carrierT -> String.string; + initial_nonterminals_data : nonterminals_listT; + nonterminals_length : nonterminals_listT -> nat; + is_valid_nonterminal : nonterminals_listT -> nonterminal_carrierT -> bool; + remove_nonterminal : nonterminals_listT -> nonterminal_carrierT -> nonterminals_listT }. + + Class parser_removal_dataT' `{predata : parser_computational_predataT} := + { nonterminals_listT_R : nonterminals_listT -> nonterminals_listT -> Prop + := ltof _ nonterminals_length; + nonterminals_length_zero : forall ls, + nonterminals_length ls = 0 + -> forall nt, is_valid_nonterminal ls nt = false; + remove_nonterminal_dec : forall ls nonterminal, + is_valid_nonterminal ls nonterminal + -> nonterminals_listT_R (remove_nonterminal ls nonterminal) ls; + remove_nonterminal_noninc : forall ls nonterminal, + ~nonterminals_listT_R ls (remove_nonterminal ls nonterminal); + initial_nonterminals_correct : forall nonterminal, + is_valid_nonterminal initial_nonterminals_data (of_nonterminal nonterminal) <-> List.In nonterminal (Valid_nonterminals G); + initial_nonterminals_correct' : forall nonterminal, + is_valid_nonterminal initial_nonterminals_data nonterminal <-> List.In (to_nonterminal nonterminal) (Valid_nonterminals G); + to_of_nonterminal : forall nonterminal, + List.In nonterminal (Valid_nonterminals G) + -> to_nonterminal (of_nonterminal nonterminal) = nonterminal; + of_to_nonterminal : forall nonterminal, + is_valid_nonterminal initial_nonterminals_data nonterminal + -> of_nonterminal (to_nonterminal nonterminal) = nonterminal; + ntl_wf : well_founded nonterminals_listT_R + := well_founded_ltof _ _; + remove_nonterminal_1 + : forall ls ps ps', + is_valid_nonterminal (remove_nonterminal ls ps) ps' + -> is_valid_nonterminal ls ps'; + remove_nonterminal_2 + : forall ls ps ps', + is_valid_nonterminal (remove_nonterminal ls ps) ps' = false + <-> is_valid_nonterminal ls ps' = false \/ ps = ps' }. + + Class split_dataT := + { split_string_for_production + : item Char -> production Char -> String -> list nat }. + + Class boolean_parser_dataT := + { predata :> parser_computational_predataT; + split_data :> split_dataT }. +End recursive_descent_parser. + +End BaseTypes. + +End Parsers. + +End Fiat. + +End Fiat_DOT_Parsers_DOT_BaseTypes. + +Module Export Fiat_DOT_Common_DOT_List_DOT_Operations. +Module Export Fiat. +Module Export Common. +Module Export List. +Module Export Operations. + +Import Coq.Lists.List. + +Module Export List. + Section InT. + Context {A : Type} (a : A). + + Fixpoint InT (ls : list A) : Set + := match ls return Set with + | nil => False + | b :: m => (b = a) + InT m + end%type. + End InT. + + End List. + +End Operations. + +End List. + +End Common. + +End Fiat. + +End Fiat_DOT_Common_DOT_List_DOT_Operations. + +Module Export Fiat_DOT_Parsers_DOT_StringLike_DOT_Properties. +Module Export Fiat. +Module Export Parsers. +Module Export StringLike. +Module Export Properties. + +Section String. + Context {Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char}. + + Lemma take_length {str n} + : length (take n str) = min n (length str). +admit. +Defined. + + End String. + +End Properties. + +End StringLike. + +End Parsers. + +End Fiat. + +End Fiat_DOT_Parsers_DOT_StringLike_DOT_Properties. + +Module Export Fiat_DOT_Parsers_DOT_ContextFreeGrammar_DOT_Properties. +Module Export Fiat. +Module Export Parsers. +Module Export ContextFreeGrammar. +Module Export Properties. + +Local Open Scope list_scope. +Definition production_is_reachableT {Char} (G : grammar Char) (p : production Char) + := { nt : _ + & { prefix : _ + & List.In nt (Valid_nonterminals G) + * List.InT + (prefix ++ p) + (Lookup G nt) } }%type. + +End Properties. + +End ContextFreeGrammar. + +End Parsers. + +End Fiat. + +End Fiat_DOT_Parsers_DOT_ContextFreeGrammar_DOT_Properties. + +Module Export Fiat_DOT_Parsers_DOT_MinimalParse. +Module Export Fiat. +Module Export Parsers. +Module Export MinimalParse. +Import Coq.Lists.List. +Import Fiat.Parsers.ContextFreeGrammar.Core. + +Local Coercion is_true : bool >-> Sortclass. +Local Open Scope string_like_scope. + +Section cfg. + Context {Char} {HSL : StringLike Char} {G : grammar Char}. + Context {predata : @parser_computational_predataT} + {rdata' : @parser_removal_dataT' _ G predata}. + + Inductive minimal_parse_of + : forall (len0 : nat) (valid : nonterminals_listT) + (str : String), + productions Char -> Type := + | MinParseHead : forall len0 valid str pat pats, + @minimal_parse_of_production len0 valid str pat + -> @minimal_parse_of len0 valid str (pat::pats) + | MinParseTail : forall len0 valid str pat pats, + @minimal_parse_of len0 valid str pats + -> @minimal_parse_of len0 valid str (pat::pats) + with minimal_parse_of_production + : forall (len0 : nat) (valid : nonterminals_listT) + (str : String), + production Char -> Type := + | MinParseProductionNil : forall len0 valid str, + length str = 0 + -> @minimal_parse_of_production len0 valid str nil + | MinParseProductionCons : forall len0 valid str n pat pats, + length str <= len0 + -> @minimal_parse_of_item len0 valid (take n str) pat + -> @minimal_parse_of_production len0 valid (drop n str) pats + -> @minimal_parse_of_production len0 valid str (pat::pats) + with minimal_parse_of_item + : forall (len0 : nat) (valid : nonterminals_listT) + (str : String), + item Char -> Type := + | MinParseTerminal : forall len0 valid str ch, + str ~= [ ch ] + -> @minimal_parse_of_item len0 valid str (Terminal ch) + | MinParseNonTerminal + : forall len0 valid str (nt : String.string), + @minimal_parse_of_nonterminal len0 valid str nt + -> @minimal_parse_of_item len0 valid str (NonTerminal nt) + with minimal_parse_of_nonterminal + : forall (len0 : nat) (valid : nonterminals_listT) + (str : String), + String.string -> Type := + | MinParseNonTerminalStrLt + : forall len0 valid (nt : String.string) str, + length str < len0 + -> is_valid_nonterminal initial_nonterminals_data (of_nonterminal nt) + -> @minimal_parse_of (length str) initial_nonterminals_data str (Lookup G nt) + -> @minimal_parse_of_nonterminal len0 valid str nt + | MinParseNonTerminalStrEq + : forall len0 str valid nonterminal, + length str = len0 + -> is_valid_nonterminal initial_nonterminals_data (of_nonterminal nonterminal) + -> is_valid_nonterminal valid (of_nonterminal nonterminal) + -> @minimal_parse_of len0 (remove_nonterminal valid (of_nonterminal nonterminal)) str (Lookup G nonterminal) + -> @minimal_parse_of_nonterminal len0 valid str nonterminal. + +End cfg. + +End MinimalParse. + +End Parsers. + +End Fiat. + +End Fiat_DOT_Parsers_DOT_MinimalParse. + +Module Export Fiat_DOT_Parsers_DOT_CorrectnessBaseTypes. +Module Export Fiat. +Module Export Parsers. +Module Export CorrectnessBaseTypes. +Import Coq.Lists.List. +Import Fiat.Parsers.ContextFreeGrammar.Core. +Import Fiat_DOT_Common.Fiat.Common. +Section general. + Context {Char} {HSL : StringLike Char} {G : grammar Char}. + + Definition split_list_completeT_for {data : @parser_computational_predataT} + {len0 valid} + (it : item Char) (its : production Char) + (str : String) + (pf : length str <= len0) + (split_list : list nat) + + := ({ n : nat + & (minimal_parse_of_item (G := G) (predata := data) len0 valid (take n str) it) + * (minimal_parse_of_production (G := G) len0 valid (drop n str) its) }%type) + -> ({ n : nat + & (In (min (length str) n) (map (min (length str)) split_list)) + * (minimal_parse_of_item (G := G) len0 valid (take n str) it) + * (minimal_parse_of_production (G := G) len0 valid (drop n str) its) }%type). + + Definition split_list_completeT {data : @parser_computational_predataT} + (splits : item Char -> production Char -> String -> list nat) + := forall len0 valid str (pf : length str <= len0) nt, + is_valid_nonterminal initial_nonterminals_data (of_nonterminal nt) + -> ForallT + (Forall_tails + (fun prod + => match prod return Type with + | nil => True + | it::its + => @split_list_completeT_for data len0 valid it its str pf (splits it its str) + end)) + (Lookup G nt). + + Class boolean_parser_completeness_dataT' {data : boolean_parser_dataT} := + { split_string_for_production_complete + : split_list_completeT split_string_for_production }. +End general. + +End CorrectnessBaseTypes. + +End Parsers. + +End Fiat. + +End Fiat_DOT_Parsers_DOT_CorrectnessBaseTypes. + +Module Export Fiat. +Module Export Parsers. +Module Export ContextFreeGrammar. +Module Export Valid. +Export Fiat.Parsers.StringLike.Core. + +Section cfg. + Context {Char : Type} {HSL : StringLike Char} (G : grammar Char) + {predata : parser_computational_predataT}. + + Definition item_valid (it : item Char) + := match it with + | Terminal _ => True + | NonTerminal nt' => is_true (is_valid_nonterminal initial_nonterminals_data (of_nonterminal nt')) + end. + + Definition production_valid pat + := List.Forall item_valid pat. + + Definition productions_valid pats + := List.Forall production_valid pats. + + Definition grammar_valid + := forall nt, + List.In nt (Valid_nonterminals G) + -> productions_valid (Lookup G nt). +End cfg. + +End Valid. + +Section app. + Context {Char : Type} {HSL : StringLike Char} (G : grammar Char) + {predata : parser_computational_predataT}. + + Lemma hd_production_valid + (it : item Char) + (its : production Char) + (H : production_valid (it :: its)) + : item_valid it. +admit. +Defined. + + Lemma production_valid_cons + (it : item Char) + (its : production Char) + (H : production_valid (it :: its)) + : production_valid its. +admit. +Defined. + + End app. + +Import Coq.Lists.List. +Import Coq.omega.Omega. +Import Fiat_DOT_Common.Fiat.Common. +Import Fiat.Parsers.ContextFreeGrammar.Valid. +Local Open Scope string_like_scope. + +Section recursive_descent_parser. + Context {Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char} (G : grammar Char). + Context {data : @boolean_parser_dataT Char _} + {cdata : @boolean_parser_completeness_dataT' Char _ G data} + {rdata : @parser_removal_dataT' _ G _} + {gvalid : grammar_valid G}. + + Local Notation dec T := (T + (T -> False))%type (only parsing). + + Local Notation iffT x y := ((x -> y) * (y -> x))%type (only parsing). + + Lemma dec_prod {A B} (HA : dec A) (HB : dec B) : dec (A * B). +admit. +Defined. + + Lemma dec_In {A} {P : A -> Type} (HA : forall a, dec (P a)) ls + : dec { a : _ & (In a ls * P a) }. +admit. +Defined. + + Section item. + Context {len0 valid} + (str : String) + (str_matches_nonterminal' + : nonterminal_carrierT -> bool) + (str_matches_nonterminal + : forall nt : nonterminal_carrierT, + dec (minimal_parse_of_nonterminal (G := G) len0 valid str (to_nonterminal nt))). + + Section valid. + Context (Hmatches + : forall nt, + is_valid_nonterminal initial_nonterminals_data nt + -> str_matches_nonterminal nt = str_matches_nonterminal' nt :> bool) + (it : item Char) + (Hvalid : item_valid it). + + Definition parse_item' + : dec (minimal_parse_of_item (G := G) len0 valid str it). + Proof. + clear Hvalid. + refine (match it return dec (minimal_parse_of_item len0 valid str it) with + | Terminal ch => if Sumbool.sumbool_of_bool (str ~= [ ch ]) + then inl (MinParseTerminal _ _ _ _ _) + else inr (fun _ => !) + | NonTerminal nt => if str_matches_nonterminal (of_nonterminal nt) + then inl (MinParseNonTerminal _) + else inr (fun _ => !) + end); + clear str_matches_nonterminal Hmatches; + admit. + Defined. + End valid. + + End item. + Context {len0 valid} + (parse_nonterminal + : forall (str : String) (len : nat) (Hlen : length str = len) (pf : len <= len0) (nt : nonterminal_carrierT), + dec (minimal_parse_of_nonterminal (G := G) len0 valid str (to_nonterminal nt))). + + Lemma dec_in_helper {ls it its str} + : iffT {n0 : nat & + (In (min (length str) n0) (map (min (length str)) ls) * + minimal_parse_of_item (G := G) len0 valid (take n0 str) it * + minimal_parse_of_production (G := G) len0 valid (drop n0 str) its)%type} + {n0 : nat & + (In n0 ls * + (minimal_parse_of_item (G := G) len0 valid (take n0 str) it * + minimal_parse_of_production (G := G) len0 valid (drop n0 str) its))%type}. +admit. +Defined. + + Lemma parse_production'_helper {str it its} (pf : length str <= len0) + : dec {n0 : nat & + (minimal_parse_of_item (G := G) len0 valid (take n0 str) it * + minimal_parse_of_production (G := G) len0 valid (drop n0 str) its)%type} + -> dec (minimal_parse_of_production (G := G) len0 valid str (it :: its)). +admit. +Defined. + Local Ltac t_parse_production_for := repeat + match goal with + | [ H : (beq_nat _ _) = true |- _ ] => apply EqNat.beq_nat_true in H + | _ => progress subst + | _ => solve [ constructor; assumption ] + | [ H : minimal_parse_of_production _ _ _ nil |- _ ] => (inversion H; clear H) + | [ H : minimal_parse_of_production _ _ _ (_::_) |- _ ] => (inversion H; clear H) + | [ H : ?x = 0, H' : context[?x] |- _ ] => rewrite H in H' + | _ => progress simpl in * + | _ => discriminate + | [ H : forall x, (_ * _)%type -> _ |- _ ] => specialize (fun x y z => H x (y, z)) + | _ => solve [ eauto with nocore ] + | _ => solve [ apply Min.min_case_strong; omega ] + | _ => omega + | [ H : production_valid (_::_) |- _ ] + => let H' := fresh in + pose proof H as H'; + apply production_valid_cons in H; + apply hd_production_valid in H' + end. + + Definition parse_production'_for + (splits : item Char -> production Char -> String -> list nat) + (Hsplits : forall str it its (Hreachable : production_is_reachableT G (it::its)) pf', split_list_completeT_for (len0 := len0) (G := G) (valid := valid) it its str pf' (splits it its str)) + (str : String) + (len : nat) + (Hlen : length str = len) + (pf : len <= len0) + (prod : production Char) + (Hreachable : production_is_reachableT G prod) + : dec (minimal_parse_of_production (G := G) len0 valid str prod). + Proof. + revert prod Hreachable str len Hlen pf. + refine + ((fun pf_helper => + list_rect + (fun prod => + forall (Hreachable : production_is_reachableT G prod) + (str : String) + (len : nat) + (Hlen : length str = len) + (pf : len <= len0), + dec (minimal_parse_of_production (G := G) len0 valid str prod)) + ( + fun Hreachable str len Hlen pf + => match Utils.dec (beq_nat len 0) with + | left H => inl _ + | right H => inr (fun p => _) + end) + (fun it its parse_production' Hreachable str len Hlen pf + => parse_production'_helper + _ + (let parse_item := (fun n pf => parse_item' (parse_nonterminal (take n str) (len := min n len) (eq_trans take_length (f_equal (min _) Hlen)) pf) it) in + let parse_item := (fun n => parse_item n (Min.min_case_strong n len (fun k => k <= len0) (fun Hlen => (Nat.le_trans _ _ _ Hlen pf)) (fun Hlen => pf))) in + let parse_production := (fun n => parse_production' (pf_helper it its Hreachable) (drop n str) (len - n) (eq_trans (drop_length _ _) (f_equal (fun x => x - _) Hlen)) (Nat.le_trans _ _ _ (Nat.le_sub_l _ _) pf)) in + match dec_In + (fun n => dec_prod (parse_item n) (parse_production n)) + (splits it its str) + with + | inl p => inl (existT _ (projT1 p) (snd (projT2 p))) + | inr p + => let pf' := (Nat.le_trans _ _ _ (Nat.eq_le_incl _ _ Hlen) pf) in + let H := (_ : split_list_completeT_for (G := G) (len0 := len0) (valid := valid) it its str pf' (splits it its str)) in + inr (fun p' => p (fst dec_in_helper (H p'))) + end) + )) _); + [ clear parse_nonterminal Hsplits splits rdata cdata + | clear parse_nonterminal Hsplits splits rdata cdata + | .. + | admit ]. + abstract t_parse_production_for. + abstract t_parse_production_for. + abstract t_parse_production_for. + abstract t_parse_production_for. + Defined. diff --git a/test-suite/bugs/closed/4462.v b/test-suite/bugs/closed/4462.v new file mode 100644 index 0000000000..c680518c6a --- /dev/null +++ b/test-suite/bugs/closed/4462.v @@ -0,0 +1,7 @@ +Variables P Q : Prop. +Axiom pqrw : P <-> Q. + +Require Setoid. + +Goal P -> Q. +unshelve (rewrite pqrw). diff --git a/test-suite/bugs/closed/4479.v b/test-suite/bugs/closed/4479.v new file mode 100644 index 0000000000..921579d1e1 --- /dev/null +++ b/test-suite/bugs/closed/4479.v @@ -0,0 +1,3 @@ +Goal True. +Fail autorewrite with foo. +try autorewrite with foo. diff --git a/test-suite/success/Injection.v b/test-suite/success/Injection.v index 25e464d677..8fd0394625 100644 --- a/test-suite/success/Injection.v +++ b/test-suite/success/Injection.v @@ -68,6 +68,12 @@ einjection (H O). instantiate (1:=O). Abort. +Goal (forall x y : nat, x = y -> S x = S y) -> True. +intros. +einjection (H O) as H0. +instantiate (y:=O). +Abort. + (* Test the injection intropattern *) Goal forall (a b:nat) l l', cons a l = cons b l' -> a=b. diff --git a/test-suite/success/intros.v b/test-suite/success/intros.v index 11156aa0ee..69d66f1008 100644 --- a/test-suite/success/intros.v +++ b/test-suite/success/intros.v @@ -84,3 +84,17 @@ Qed. Goal forall x : nat, True. intros y%(fun x => x). Abort. + +(* Fixing a bug in the order of side conditions of a "->" step *) + +Goal (True -> 1=0) -> 1=1. +intros ->. +- reflexivity. +- exact I. +Qed. + +Goal forall x, (True -> x=0) -> 0=x. +intros x ->. +- reflexivity. +- exact I. +Qed. diff --git a/theories/Classes/RelationClasses.v b/theories/Classes/RelationClasses.v index 15cb02d37f..6248babd0e 100644 --- a/theories/Classes/RelationClasses.v +++ b/theories/Classes/RelationClasses.v @@ -208,6 +208,10 @@ Hint Extern 4 (subrelation (flip _) _) => class_apply @subrelation_symmetric : typeclass_instances. Arguments irreflexivity {A R Irreflexive} [x] _. +Arguments symmetry {A} {R} {_} [x] [y] _. +Arguments asymmetry {A} {R} {_} [x] [y] _ _. +Arguments transitivity {A} {R} {_} [x] [y] [z] _ _. +Arguments Antisymmetric A eqA {_} _. Hint Resolve irreflexivity : ord. diff --git a/theories/Init/Notations.v b/theories/Init/Notations.v index a7bdba90aa..2f6d824d2a 100644 --- a/theories/Init/Notations.v +++ b/theories/Init/Notations.v @@ -85,6 +85,7 @@ Open Scope type_scope. Declare ML Module "coretactics". Declare ML Module "extratactics". +Declare ML Module "g_auto". Declare ML Module "eauto". Declare ML Module "g_class". Declare ML Module "g_eqdecide". diff --git a/theories/Structures/OrdersFacts.v b/theories/Structures/OrdersFacts.v index 88fbd8c11c..954d3df203 100644 --- a/theories/Structures/OrdersFacts.v +++ b/theories/Structures/OrdersFacts.v @@ -90,7 +90,7 @@ Module Type OrderedTypeFullFacts (Import O:OrderedTypeFull'). Instance le_order : PartialOrder eq le. Proof. compute; iorder. Qed. - Instance le_antisym : Antisymmetric eq le. + Instance le_antisym : Antisymmetric _ eq le. Proof. apply partial_order_antisym; auto with *. Qed. Lemma le_not_gt_iff : forall x y, x<=y <-> ~y<x. diff --git a/tools/coqc.ml b/tools/coqc.ml index e7239da682..034c9b7f4e 100644 --- a/tools/coqc.ml +++ b/tools/coqc.ml @@ -70,17 +70,6 @@ let parse_args () = | "-byte" :: rem -> binary := "coqtop.byte"; parse (cfiles,args) rem | "-opt" :: rem -> binary := "coqtop"; parse (cfiles,args) rem -(* Obsolete options *) - - | "-libdir" :: _ :: rem -> - print_string "Warning: option -libdir deprecated and ignored\n"; - flush stdout; - parse (cfiles,args) rem - | ("-db"|"-debugger") :: rem -> - print_string "Warning: option -db/-debugger deprecated and ignored\n"; - flush stdout; - parse (cfiles,args) rem - (* Informative options *) | ("-?"|"-h"|"-H"|"-help"|"--help") :: _ -> usage () @@ -124,21 +113,11 @@ let parse_args () = | s :: rem' -> parse (cfiles,s::o::args) rem' | [] -> usage () end + | ("-I"|"-include" as o) :: s :: rem -> parse (cfiles,s::o::args) rem (* Options for coqtop : c) options with 1 argument and possibly more *) - | ("-I"|"-include" as o) :: rem -> - begin - match rem with - | s :: "-as" :: t :: rem' -> parse (cfiles,t::"-as"::s::o::args) rem' - | s :: "-as" :: [] -> usage () - | s :: rem' -> parse (cfiles,s::o::args) rem' - | [] -> usage () - end - | "-R" :: s :: "-as" :: t :: rem -> parse (cfiles,t::"-as"::s::"-R"::args) rem - | "-R" :: s :: "-as" :: [] -> usage () - | "-R" :: s :: t :: rem -> parse (cfiles,t::s::"-R"::args) rem - | "-Q" :: s :: t :: rem -> parse (cfiles,t::s::"-Q"::args) rem + | ("-R"|"-Q" as o) :: s :: t :: rem -> parse (cfiles,t::s::o::args) rem | ("-schedule-vio-checking" |"-check-vio-tasks" | "-schedule-vio2vo" as o) :: s :: rem -> let nodash, rem = diff --git a/tools/coqdep.ml b/tools/coqdep.ml index aacfccfd77..0634f97fa6 100644 --- a/tools/coqdep.ml +++ b/tools/coqdep.ml @@ -444,15 +444,8 @@ let rec parse = function | "-boot" :: ll -> option_boot := true; parse ll | "-sort" :: ll -> option_sort := true; parse ll | ("-noglob" | "-no-glob") :: ll -> option_noglob := true; parse ll - | "-I" :: r :: "-as" :: ln :: ll -> - add_rec_dir_no_import add_known r []; - add_rec_dir_no_import add_known r (split_period ln); - parse ll - | "-I" :: r :: "-as" :: [] -> usage () | "-I" :: r :: ll -> add_caml_dir r; parse ll | "-I" :: [] -> usage () - | "-R" :: r :: "-as" :: ln :: ll -> add_rec_dir_import add_known r (split_period ln); parse ll - | "-R" :: r :: "-as" :: [] -> usage () | "-R" :: r :: ln :: ll -> add_rec_dir_import add_known r (split_period ln); parse ll | "-Q" :: r :: ln :: ll -> add_rec_dir_no_import add_known r (split_period ln); parse ll | "-R" :: ([] | [_]) -> usage () diff --git a/tools/coqdep_common.ml b/tools/coqdep_common.ml index b66529bb38..65fbd628a5 100644 --- a/tools/coqdep_common.ml +++ b/tools/coqdep_common.ml @@ -165,11 +165,6 @@ let warning_module_notfound f s = eprintf "*** Warning: in file %s, library %s is required and has not been found in the loadpath!\n%!" f (String.concat "." s) -let warning_notfound f s = - eprintf "*** Warning: in file %s, the file " f; - eprintf "%s.v is required and has not been found!\n" s; - flush stderr - let warning_declare f s = eprintf "*** Warning: in file %s, declared ML module " f; eprintf "%s has not been found!\n" s; diff --git a/tools/coqmktop.ml b/tools/coqmktop.ml index a6254b2a44..d2780e763a 100644 --- a/tools/coqmktop.ml +++ b/tools/coqmktop.ml @@ -279,7 +279,7 @@ let main () = (* - We add topstart.cmo explicitly because we shunted ocamlmktop wrapper. - With the coq .cma, we MUST use the -linkall option. *) let args = - "-linkall" :: "-rectypes" :: flags @ copts @ options @ + "-linkall" :: "-rectypes" :: "-w" :: "-31" :: flags @ copts @ options @ (std_includes basedir) @ tolink @ [ main_file ] @ topstart in if !echo then begin diff --git a/tools/ocamllibdep.mll b/tools/ocamllibdep.mll index 1bcbe7c0e8..670ff487c5 100644 --- a/tools/ocamllibdep.mll +++ b/tools/ocamllibdep.mll @@ -164,7 +164,7 @@ let traite_fichier_modules md ext = let addQueue q v = q := v :: !q -let rec treat_file old_name = +let treat_file old_name = let name = Filename.basename old_name in let dirname = Some (Filename.dirname old_name) in match get_extension name [".mllib"] with diff --git a/toplevel/assumptions.mli b/toplevel/assumptions.mli index 61beb26c8e..21039f571a 100644 --- a/toplevel/assumptions.mli +++ b/toplevel/assumptions.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Util open Names open Term open Globnames diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 2aad417e8d..bd0a79caf9 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -443,10 +443,6 @@ let parse_args arglist = end |"-R" -> begin match rem with - | d :: "-as" :: [] -> error_missing_arg opt - | d :: "-as" :: p :: rem -> - warning "option -R * -as * deprecated, remove the -as"; - set_include d p true; args := rem | d :: p :: rem -> set_include d p true; args := rem | _ -> error_missing_arg opt end diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml index 8f380830db..3ac537297e 100644 --- a/toplevel/himsg.ml +++ b/toplevel/himsg.ml @@ -260,7 +260,7 @@ let explain_generalization env sigma (name,var) j = str "it has type" ++ spc () ++ pt ++ spc () ++ str "which should be Set, Prop or Type." -let rec explain_unification_error env sigma p1 p2 = function +let explain_unification_error env sigma p1 p2 = function | None -> mt() | Some e -> let rec aux p1 p2 = function @@ -822,7 +822,7 @@ let explain_not_match_error = function | ModuleTypeFieldExpected -> strbrk "a module type is expected" | NotConvertibleInductiveField id | NotConvertibleConstructorField id -> - str "types given to " ++ str (Id.to_string id) ++ str " differ" + str "types given to " ++ pr_id id ++ str " differ" | NotConvertibleBodyField -> str "the body of definitions differs" | NotConvertibleTypeField (env, typ1, typ2) -> @@ -847,7 +847,7 @@ let explain_not_match_error = function | 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 (Id.to_string id) | _ -> str "_") nal + pr_enum (function Name id -> pr_id id | _ -> str "_") nal | NotEqualInductiveAliases -> str "Aliases to inductive types do not match" | NoTypeConstraintExpected -> @@ -896,11 +896,11 @@ let explain_not_equal_module_paths mp1 mp2 = str "Non equal modules." let explain_no_such_label l = - str "No such label " ++ str (Label.to_string l) ++ str "." + str "No such label " ++ pr_label l ++ str "." let explain_incompatible_labels l l' = str "Opening and closing labels are not the same: " ++ - str (Label.to_string l) ++ str " <> " ++ str (Label.to_string l') ++ str "!" + pr_label l ++ str " <> " ++ pr_label l' ++ str "!" let explain_not_a_module s = quote (str s) ++ str " is not a module." @@ -909,21 +909,27 @@ let explain_not_a_module_type s = quote (str s) ++ str " is not a module type." let explain_not_a_constant l = - quote (Label.print l) ++ str " is not a constant." + quote (pr_label l) ++ str " is not a constant." let explain_incorrect_label_constraint l = str "Incorrect constraint for label " ++ - quote (Label.print l) ++ str "." + quote (pr_label l) ++ str "." let explain_generative_module_expected l = - str "The module " ++ str (Label.to_string l) ++ str " is not generative." ++ + str "The module " ++ pr_label l ++ str " is not generative." ++ strbrk " Only components of generative modules can be changed" ++ strbrk " using the \"with\" construct." let explain_label_missing l s = - str "The field " ++ str (Label.to_string l) ++ str " is missing in " + str "The field " ++ pr_label l ++ str " is missing in " ++ str s ++ str "." +let explain_include_restricted_functor mp = + let q = Nametab.shortest_qualid_of_module mp in + str "Cannot include the functor " ++ Libnames.pr_qualid q ++ + strbrk " since it has a restricted signature. " ++ + strbrk "You may name first an instance of this functor, and include it." + let explain_module_error = function | SignatureMismatch (l,spec,err) -> explain_signature_mismatch l spec err | LabelAlreadyDeclared l -> explain_label_already_declared l @@ -940,6 +946,7 @@ let explain_module_error = function | IncorrectWithConstraint l -> explain_incorrect_label_constraint l | GenerativeModuleExpected l -> explain_generative_module_expected l | LabelMissing (l,s) -> explain_label_missing l s + | IncludeRestrictedFunctor mp -> explain_include_restricted_functor mp (* Module internalization errors *) diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml index 7714cc8108..6ba5f4f875 100644 --- a/toplevel/metasyntax.ml +++ b/toplevel/metasyntax.ml @@ -47,10 +47,9 @@ let add_token_obj s = Lib.add_anonymous_leaf (inToken s) let interp_prod_item lev = function | TacTerm s -> GramTerminal s - | TacNonTerm (loc, nt, po) -> - let sep = match po with Some (_,sep) -> sep | _ -> "" in + | TacNonTerm (loc, nt, (_, sep)) -> let EntryName (etyp, e) = interp_entry_name true (TgTactic lev) nt sep in - GramNonTerminal (loc, etyp, e, Option.map fst po) + GramNonTerminal (loc, etyp, e) let make_terminal_status = function | GramTerminal s -> Some s @@ -58,7 +57,7 @@ let make_terminal_status = function let rec make_tags = function | GramTerminal s :: l -> make_tags l - | GramNonTerminal (loc, etyp, _, po) :: l -> Genarg.unquote etyp :: make_tags l + | GramNonTerminal (loc, etyp, _) :: l -> Genarg.unquote etyp :: make_tags l | [] -> [] let make_fresh_key = @@ -81,7 +80,7 @@ type tactic_grammar_obj = { tacobj_local : locality_flag; tacobj_tacgram : tactic_grammar; tacobj_tacpp : Pptactic.pp_tactic; - tacobj_body : Tacexpr.glob_tactic_expr + tacobj_body : Id.t list * Tacexpr.glob_tactic_expr; } let check_key key = @@ -111,9 +110,10 @@ let load_tactic_notation i (_, tobj) = Egramcoq.extend_tactic_grammar key tobj.tacobj_tacgram let subst_tactic_notation (subst, tobj) = + let (ids, body) = tobj.tacobj_body in { tobj with tacobj_key = Mod_subst.subst_kn subst tobj.tacobj_key; - tacobj_body = Tacsubst.subst_tactic subst tobj.tacobj_body; + tacobj_body = (ids, Tacsubst.subst_tactic subst body); } let classify_tactic_notation tacobj = Substitute tacobj @@ -126,18 +126,18 @@ let inTacticGrammar : tactic_grammar_obj -> obj = subst_function = subst_tactic_notation; classify_function = classify_tactic_notation} -let cons_production_parameter l = function - | GramTerminal _ -> l - | GramNonTerminal (_,_,_,ido) -> Option.List.cons ido l +let cons_production_parameter = function +| TacTerm _ -> None +| TacNonTerm (_, _, (id, _)) -> Some id let add_tactic_notation (local,n,prods,e) = + let ids = List.map_filter cons_production_parameter prods in let prods = List.map (interp_prod_item n) prods in let tags = make_tags prods in let pprule = { Pptactic.pptac_args = tags; pptac_prods = (n, List.map make_terminal_status prods); } in - let ids = List.fold_left cons_production_parameter [] prods in let tac = Tacintern.glob_tactic_env ids (Global.env()) e in let parule = { tacgram_level = n; @@ -148,7 +148,7 @@ let add_tactic_notation (local,n,prods,e) = tacobj_local = local; tacobj_tacgram = parule; tacobj_tacpp = pprule; - tacobj_body = tac; + tacobj_body = (ids, tac); } in Lib.add_anonymous_leaf (inTacticGrammar tacobj) @@ -171,6 +171,7 @@ let extend_atomic_tactic name entries = | None -> () | Some args -> let open Tacexpr in + let args = List.map (fun a -> TacGeneric a) args in let entry = { mltac_name = name; mltac_index = i } in let body = TacML (Loc.ghost, entry, args) in Tacenv.register_ltac false false (Names.Id.of_string id) body diff --git a/toplevel/obligations.ml b/toplevel/obligations.ml index e27e414377..fd91cfb5c3 100644 --- a/toplevel/obligations.ml +++ b/toplevel/obligations.ml @@ -265,7 +265,7 @@ let reduce c = exception NoObligations of Id.t option let explain_no_obligations = function - Some ident -> str "No obligations for program " ++ str (Id.to_string ident) + Some ident -> str "No obligations for program " ++ Id.print ident | None -> str "No obligations remaining" type obligation_info = @@ -995,7 +995,7 @@ let show_obligations_of_prg ?(msg=true) prg = if !showed > 0 then ( decr showed; msg_info (str "Obligation" ++ spc() ++ int (succ i) ++ spc () ++ - str "of" ++ spc() ++ str (Id.to_string n) ++ str ":" ++ spc () ++ + str "of" ++ spc() ++ Id.print n ++ str ":" ++ spc () ++ hov 1 (Printer.pr_constr_env (Global.env ()) Evd.empty x.obl_type ++ str "." ++ fnl ()))) | Some _ -> ()) @@ -1012,14 +1012,14 @@ let show_obligations ?(msg=true) n = let show_term n = let prg = get_prog_err n in let n = prg.prg_name in - (str (Id.to_string n) ++ spc () ++ str":" ++ spc () ++ + (Id.print n ++ spc () ++ str":" ++ spc () ++ Printer.pr_constr_env (Global.env ()) Evd.empty prg.prg_type ++ spc () ++ str ":=" ++ fnl () ++ Printer.pr_constr_env (Global.env ()) Evd.empty prg.prg_body) let add_definition n ?term t ctx ?(implicits=[]) ?(kind=Global,false,Definition) ?tactic ?(reduce=reduce) ?(hook=Lemmas.mk_hook (fun _ _ _ -> ())) ?(opaque = false) obls = let sign = Decls.initialize_named_context_for_proof () in - let info = str (Id.to_string n) ++ str " has type-checked" in + let info = Id.print n ++ str " has type-checked" in let prg = init_prog_info sign ~opaque n term t ctx [] None [] obls implicits kind reduce hook in let obls,_ = prg.prg_obligations in if Int.equal (Array.length obls) 0 then ( diff --git a/toplevel/record.ml b/toplevel/record.ml index 12699b02b4..408d3fa5f6 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -170,7 +170,7 @@ let warning_or_error coe indsp err = let st = match err with | MissingProj (fi,projs) -> let s,have = if List.length projs > 1 then "s","were" else "","was" in - (str(Id.to_string fi) ++ + (pr_id fi ++ strbrk" cannot be defined because the projection" ++ str s ++ spc () ++ prlist_with_sep pr_comma pr_id projs ++ spc () ++ str have ++ strbrk " not defined.") diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 2dacc04f09..55e57ec692 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -156,7 +156,7 @@ let show_match id = (* "Print" commands *) let print_path_entry p = - let dir = str (DirPath.to_string (Loadpath.logical p)) in + let dir = pr_dirpath (Loadpath.logical p) in let path = str (Loadpath.physical p) in (dir ++ str " " ++ tbrk (0, 0) ++ path) @@ -947,7 +947,7 @@ let register_ltac local tacl = match tactic_body with | TacticDefinition ((loc,id), body) -> let kn = Lib.make_kn id in - let id_pp = str (Id.to_string id) in + let id_pp = pr_id id in let () = if is_defined_tac kn then Errors.user_err_loc (loc, "", str "There is already an Ltac named " ++ id_pp ++ str".") @@ -1584,7 +1584,7 @@ let print_about_hyp_globs ref_or_by_not glnumopt = let natureofid = match bdyopt with | None -> "Hypothesis" | Some bdy ->"Constant (let in)" in - v 0 (str (Id.to_string id) ++ str":" ++ pr_constr typ ++ fnl() ++ fnl() + v 0 (pr_id id ++ str":" ++ pr_constr typ ++ fnl() ++ fnl() ++ str natureofid ++ str " of the goal context.") with (* fallback to globals *) | NoHyp | Not_found -> print_about ref_or_by_not |