From 5cbb42e08a8032ada1788a0542a45177f798a6ac Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 5 Nov 2015 15:05:12 -0500 Subject: Fix bug #4273 Syntactic analysis of dependencies when atomizing arguments in destruct was not dealing properly with primitive projections hiding their parameters. --- tactics/tactics.ml | 32 ++++++++++++++++++++++---------- 1 file changed, 22 insertions(+), 10 deletions(-) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 2a46efd8ef..e215ff42f9 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -2825,6 +2825,14 @@ let induct_discharge dests avoid' tac (avoid,ra) names = s'embêter à regarder si un letin_tac ne fait pas des substitutions aussi sur l'argument voisin *) +let expand_projections env sigma c = + let rec aux env c = + match kind_of_term c with + | Proj (p, c) -> Retyping.expand_projection env sigma p (aux env c) [] + | _ -> map_constr_with_full_binders push_rel aux env c + in aux env c + + (* Marche pas... faut prendre en compte l'occurrence précise... *) let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = @@ -2833,11 +2841,14 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = let tmptyp0 = Tacmach.New.pf_get_hyp_typ hyp0 (Proofview.Goal.assume gl) in let reduce_to_quantified_ref = Tacmach.New.pf_apply reduce_to_quantified_ref gl in let typ0 = reduce_to_quantified_ref indref tmptyp0 in - let prods, indtyp = decompose_prod typ0 in + let prods, indtyp = decompose_prod_assum typ0 in let hd,argl = decompose_app indtyp in + let env' = push_rel_context prods env in + let sigma = Proofview.Goal.sigma gl in let params = List.firstn nparams argl in + let params' = List.map (expand_projections env' sigma) params in (* le gl est important pour ne pas préévaluer *) - let rec atomize_one i args avoid = + let rec atomize_one i args args' avoid = if Int.equal i nparams then let t = applist (hd, params@args) in Tacticals.New.tclTHEN @@ -2846,22 +2857,23 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = else let c = List.nth argl (i-1) in match kind_of_term c with - | Var id when not (List.exists (occur_var env id) args) && - not (List.exists (occur_var env id) params) -> + | Var id when not (List.exists (occur_var env id) args') && + not (List.exists (occur_var env id) params') -> (* Based on the knowledge given by the user, all constraints on the variable are generalizable in the current environment so that it is clearable after destruction *) - atomize_one (i-1) (c::args) (id::avoid) + atomize_one (i-1) (c::args) (c::args') (id::avoid) | _ -> - if List.exists (dependent c) params || - List.exists (dependent c) args + let c' = expand_projections env' sigma c in + if List.exists (dependent c) params' || + List.exists (dependent c) args' then (* This is a case where the argument is constrained in a way which would require some kind of inversion; we follow the (old) discipline of not generalizing over this term, since we don't try to invert the constraint anyway. *) - atomize_one (i-1) (c::args) avoid + atomize_one (i-1) (c::args) (c'::args') avoid else (* We reason blindly on the term and do as if it were generalizable, ignoring the constraints coming from @@ -2874,9 +2886,9 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = let x = fresh_id_in_env avoid id env in Tacticals.New.tclTHEN (letin_tac None (Name x) c None allHypsAndConcl) - (atomize_one (i-1) (mkVar x::args) (x::avoid)) + (atomize_one (i-1) (mkVar x::args) (mkVar x::args') (x::avoid)) in - atomize_one (List.length argl) [] [] + atomize_one (List.length argl) [] [] [] end (* [cook_sign] builds the lists [beforetoclear] (preceding the -- cgit v1.2.3 From ce6392e74fbe0edd5ebcaecb362fec5da9b4703b Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 5 Nov 2015 15:10:29 -0500 Subject: Add test-suite file for #4273. --- test-suite/bugs/closed/4273.v | 9 +++++++++ 1 file changed, 9 insertions(+) create mode 100644 test-suite/bugs/closed/4273.v diff --git a/test-suite/bugs/closed/4273.v b/test-suite/bugs/closed/4273.v new file mode 100644 index 0000000000..591ea4b5b2 --- /dev/null +++ b/test-suite/bugs/closed/4273.v @@ -0,0 +1,9 @@ + + +Set Primitive Projections. +Record total2 (P : nat -> Prop) := tpair { pr1 : nat; pr2 : P pr1 }. +Theorem onefiber' (q : total2 (fun y => y = 0)) : True. +Proof. assert (foo:=pr2 _ q). simpl in foo. + destruct foo. (* Error: q is used in conclusion. *) exact I. Qed. + +Print onefiber'. \ No newline at end of file -- cgit v1.2.3 From 6b3d6f9326de9e53805d14e78577411c7174a998 Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 6 Nov 2015 14:00:41 +0100 Subject: Fixing complexity issue with f_equal. Thanks to J.-H. Jourdan for reporting it. A "cut" was not appropriately chained on the second goal but on both goals, with the chaining on the first goal introducing noise. --- plugins/cc/cctac.ml | 4 ++-- test-suite/complexity/f_equal.v | 14 ++++++++++++++ 2 files changed, 16 insertions(+), 2 deletions(-) create mode 100644 test-suite/complexity/f_equal.v diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 068cb25cf2..371f76cf32 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -501,9 +501,9 @@ let f_equal = let concl = Proofview.Goal.concl gl in let cut_eq c1 c2 = try (* type_of can raise an exception *) - Tacticals.New.tclTHEN + Tacticals.New.tclTHENS (mk_eq _eq c1 c2 Tactics.cut) - (Tacticals.New.tclTRY ((new_app_global _refl_equal [||]) apply)) + [Proofview.tclUNIT ();Tacticals.New.tclTRY ((new_app_global _refl_equal [||]) apply)] with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e in Proofview.tclORELSE diff --git a/test-suite/complexity/f_equal.v b/test-suite/complexity/f_equal.v new file mode 100644 index 0000000000..30e87939ec --- /dev/null +++ b/test-suite/complexity/f_equal.v @@ -0,0 +1,14 @@ +(* Checks that f_equal does not reduce the term uselessly *) +(* Expected time < 1.00s *) + +Fixpoint stupid (n : nat) : unit := +match n with +| 0 => tt +| S n => + let () := stupid n in + let () := stupid n in + tt +end. + +Goal stupid 23 = stupid 23. +f_equal. -- cgit v1.2.3 From 951b33251addefa79d62c4344f2690014dfd62dd Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 6 Nov 2015 14:19:06 +0100 Subject: More on how to compile doc. --- INSTALL.doc | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/INSTALL.doc b/INSTALL.doc index 7658800584..2472d2b2a6 100644 --- a/INSTALL.doc +++ b/INSTALL.doc @@ -22,8 +22,8 @@ To produce all the documents, the following tools are needed: - dvips - bibtex - makeindex - - fig2dev - - convert + - fig2dev (transfig) + - convert (ImageMagick) - hevea - hacha -- cgit v1.2.3 From 76bc7f9d164c20583c6561127bf36e7247a37c6b Mon Sep 17 00:00:00 2001 From: Hugo Herbelin Date: Fri, 6 Nov 2015 18:19:38 +0100 Subject: Fixing complexity file f_equal.v. --- test-suite/complexity/f_equal.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test-suite/complexity/f_equal.v b/test-suite/complexity/f_equal.v index 30e87939ec..86698fa872 100644 --- a/test-suite/complexity/f_equal.v +++ b/test-suite/complexity/f_equal.v @@ -11,4 +11,4 @@ match n with end. Goal stupid 23 = stupid 23. -f_equal. +Timeout 5 Time f_equal. -- cgit v1.2.3 From a8b248096e5120f58157b0fc3bd06ca07118a8ab Mon Sep 17 00:00:00 2001 From: Pierre Courtieu Date: Fri, 6 Nov 2015 17:04:24 +0100 Subject: Fixing #4406 coqdep: No recursive search of ml (-I). --- tools/coqdep_common.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tools/coqdep_common.ml b/tools/coqdep_common.ml index c111137571..ca42c99470 100644 --- a/tools/coqdep_common.ml +++ b/tools/coqdep_common.ml @@ -548,7 +548,7 @@ let add_rec_dir add_file phys_dir log_dir = (** -I semantic: do not go in subdirs. *) let add_caml_dir phys_dir = - handle_unix_error (add_directory true add_caml_known phys_dir) [] + handle_unix_error (add_directory false add_caml_known phys_dir) [] let rec treat_file old_dirname old_name = -- cgit v1.2.3 From c5d380548ef5597b77c7ab1fce252704deefeaf1 Mon Sep 17 00:00:00 2001 From: Pierre Courtieu Date: Fri, 6 Nov 2015 18:49:21 +0100 Subject: Fixed #4407. Like coqc: detect if the current directory was set by options, if not: add it with empty logical path. TODO: check if coq_makefile is still correct wrt to this modification, I think yes, actually it should end being more correct. --- tools/coqdep.ml | 37 +++++++++++++++++++++---------------- tools/coqdep_boot.ml | 12 ++++++------ tools/coqdep_common.ml | 34 +++++++++++++++++++++++++++------- tools/coqdep_common.mli | 22 ++++++++++++++++++++-- 4 files changed, 74 insertions(+), 31 deletions(-) diff --git a/tools/coqdep.ml b/tools/coqdep.ml index 110d306022..e0e017e88a 100644 --- a/tools/coqdep.ml +++ b/tools/coqdep.ml @@ -426,8 +426,9 @@ let coq_dependencies_dump chan dumpboxes = end let usage () = - eprintf " usage: coqdep [-w] [-c] [-D] [-I dir] [-R dir coqdir] +\n"; + eprintf " usage: coqdep [-w] [-c] [-D] [-I dir] [-Q dir coqdir] [-R dir coqdir] +\n"; eprintf " extra options:\n"; + eprintf " -sort : output the file names ordered by dependencies\n"; eprintf " -coqlib dir : set the coq standard library directory\n"; eprintf " -exclude-dir f : skip subdirectories named 'f' during -R search\n"; eprintf " -dumpgraph f : print a dot dependency graph in file 'f'\n"; @@ -442,16 +443,17 @@ 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_dir add_known r []; - add_dir add_known r (split_period ln); - 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 add_known r (split_period ln); parse ll + | "-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 add_known r (split_period ln); parse ll - | "-Q" :: r :: ln :: ll -> add_dir add_known r (split_period ln); parse ll + | "-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 () | "-dumpgraph" :: f :: ll -> option_dump := Some (false, f); parse ll | "-dumpgraphbox" :: f :: ll -> option_dump := Some (true, f); parse ll @@ -471,23 +473,26 @@ let rec parse = function let coqdep () = if Array.length Sys.argv < 2 then usage (); parse (List.tl (Array.to_list Sys.argv)); + (* Add current dir with empty logical path if not set by options above. *) + (try ignore (Coqdep_common.find_dir_logpath (Sys.getcwd())) + with Not_found -> add_norec_dir_import add_known "." []); if not Coq_config.has_natdynlink then option_natdynlk := false; (* NOTE: These directories are searched from last to first *) if !option_boot then begin - add_rec_dir add_known "theories" ["Coq"]; - add_rec_dir add_known "plugins" ["Coq"]; - add_rec_dir (fun _ -> add_caml_known) "theories" ["Coq"]; - add_rec_dir (fun _ -> add_caml_known) "plugins" ["Coq"]; + add_rec_dir_import add_known "theories" ["Coq"]; + add_rec_dir_import add_known "plugins" ["Coq"]; + add_rec_dir_import (fun _ -> add_caml_known) "theories" ["Coq"]; + add_rec_dir_import (fun _ -> add_caml_known) "plugins" ["Coq"]; end else begin Envars.set_coqlib ~fail:Errors.error; let coqlib = Envars.coqlib () in - add_rec_dir add_coqlib_known (coqlib//"theories") ["Coq"]; - add_rec_dir add_coqlib_known (coqlib//"plugins") ["Coq"]; + add_rec_dir_import add_coqlib_known (coqlib//"theories") ["Coq"]; + add_rec_dir_import add_coqlib_known (coqlib//"plugins") ["Coq"]; let user = coqlib//"user-contrib" in - if Sys.file_exists user then add_dir add_coqlib_known user []; - List.iter (fun s -> add_dir add_coqlib_known s []) + if Sys.file_exists user then add_rec_dir_no_import add_coqlib_known user []; + List.iter (fun s -> add_rec_dir_no_import add_coqlib_known s []) (Envars.xdg_dirs (fun x -> Pp.msg_warning (Pp.str x))); - List.iter (fun s -> add_dir add_coqlib_known s []) Envars.coqpath; + List.iter (fun s -> add_rec_dir_no_import add_coqlib_known s []) Envars.coqpath; end; List.iter (fun (f,d) -> add_mli_known f d ".mli") !mliAccu; List.iter (fun (f,d) -> add_mllib_known f d ".mllib") !mllibAccu; diff --git a/tools/coqdep_boot.ml b/tools/coqdep_boot.ml index 64ce66d2d1..088ea6bfcf 100644 --- a/tools/coqdep_boot.ml +++ b/tools/coqdep_boot.ml @@ -35,15 +35,15 @@ let _ = if Array.length Sys.argv < 2 then exit 1; parse (List.tl (Array.to_list Sys.argv)); if !option_c then begin - add_rec_dir add_known "." []; - add_rec_dir (fun _ -> add_caml_known) "." ["Coq"]; + add_rec_dir_import add_known "." []; + add_rec_dir_import (fun _ -> add_caml_known) "." ["Coq"]; end else begin - add_rec_dir add_known "theories" ["Coq"]; - add_rec_dir add_known "plugins" ["Coq"]; + add_rec_dir_import add_known "theories" ["Coq"]; + add_rec_dir_import add_known "plugins" ["Coq"]; add_caml_dir "tactics"; - add_rec_dir (fun _ -> add_caml_known) "theories" ["Coq"]; - add_rec_dir (fun _ -> add_caml_known) "plugins" ["Coq"]; + add_rec_dir_import (fun _ -> add_caml_known) "theories" ["Coq"]; + add_rec_dir_import (fun _ -> add_caml_known) "plugins" ["Coq"]; end; if !option_c then mL_dependencies (); coq_dependencies () diff --git a/tools/coqdep_common.ml b/tools/coqdep_common.ml index ca42c99470..02fd19a1e2 100644 --- a/tools/coqdep_common.ml +++ b/tools/coqdep_common.ml @@ -220,6 +220,18 @@ let absolute_file_name basename odir = let dir = match odir with Some dir -> dir | None -> "." in absolute_dir dir // basename +(** [find_dir_logpath dir] Return the logical path of directory [dir] + if it has been given one. Raise [Not_found] otherwise. In + particular we can check if "." has been attributed a logical path + after processing all options and silently give the default one if + it hasn't. We may also use this to warn if ap hysical path is met + twice.*) +let register_dir_logpath,find_dir_logpath = + let tbl: (string, string list) Hashtbl.t = Hashtbl.create 19 in + let reg physdir logpath = Hashtbl.add tbl (absolute_dir physdir) logpath in + let fnd physdir = Hashtbl.find tbl (absolute_dir physdir) in + reg,fnd + let file_name s = function | None -> s | Some "." -> s @@ -339,7 +351,8 @@ let escape = Buffer.contents s' let compare_file f1 f2 = - absolute_dir (Filename.dirname f1) = absolute_dir (Filename.dirname f2) + absolute_file_name (Filename.basename f1) (Some (Filename.dirname f1)) + = absolute_file_name (Filename.basename f2) (Some (Filename.dirname f2)) let canonize f = let f' = absolute_dir (Filename.dirname f) // Filename.basename f in @@ -514,11 +527,13 @@ let add_known recur phys_dir log_dir f = List.iter (fun f -> Hashtbl.add coqlibKnown f ()) paths | _ -> () -(* Visits all the directories under [dir], including [dir], - or just [dir] if [recur=false] *) - +(** Visit directory [phys_dir] (recursively unless [recur=false]) and + apply function add_file to each regular file encountered. + [log_dir] is the logical name of the [phys_dir]. + [add_file] takes both directory names and the file. *) let rec add_directory recur add_file phys_dir log_dir = let dirh = opendir phys_dir in + register_dir_logpath phys_dir log_dir; try while true do let f = readdir dirh in @@ -531,19 +546,24 @@ let rec add_directory recur add_file phys_dir log_dir = if StrSet.mem f !norec_dirnames then () else if StrSet.mem phys_f !norec_dirs then () - else + else (* TODO: warn if already seen this physycal dir? *) add_directory recur add_file phys_f (log_dir@[f]) | S_REG -> add_file phys_dir log_dir f | _ -> () done with End_of_file -> closedir dirh +(** Simply add this directory and imports it, no subdirs. This is used + by the implicit adding of the current path (which is not recursive). *) +let add_norec_dir_import add_file phys_dir log_dir = + try add_directory false (add_file true) phys_dir log_dir with Unix_error _ -> () + (** -Q semantic: go in subdirs but only full logical paths are known. *) -let add_dir add_file phys_dir log_dir = +let add_rec_dir_no_import add_file phys_dir log_dir = try add_directory true (add_file false) phys_dir log_dir with Unix_error _ -> () (** -R semantic: go in subdirs and suffixes of logical paths are known. *) -let add_rec_dir add_file phys_dir log_dir = +let add_rec_dir_import add_file phys_dir log_dir = handle_unix_error (add_directory true (add_file true) phys_dir) log_dir (** -I semantic: do not go in subdirs. *) diff --git a/tools/coqdep_common.mli b/tools/coqdep_common.mli index d610a0558d..50cae40d9a 100644 --- a/tools/coqdep_common.mli +++ b/tools/coqdep_common.mli @@ -8,6 +8,14 @@ module StrSet : Set.S with type elt = string +(** [find_dir_logpath dir] Return the logical path of directory [dir] + if it has been given one. Raise [Not_found] otherwise. In + particular we can check if "." has been attributed a logical path + after processing all options and silently give the default one if + it hasn't. We may also use this to warn if ap hysical path is met + twice.*) +val find_dir_logpath: string -> string list + val option_c : bool ref val option_noglob : bool ref val option_boot : bool ref @@ -47,9 +55,19 @@ val add_directory : bool -> (string -> string list -> string -> unit) -> string -> string list -> unit val add_caml_dir : string -> unit -val add_dir : + +(** Simply add this directory and imports it, no subdirs. This is used + by the implicit adding of the current path. *) +val add_norec_dir_import : + (bool -> string -> string list -> string -> unit) -> string -> string list -> unit + +(** -Q semantic: go in subdirs but only full logical paths are known. *) +val add_rec_dir_no_import : (bool -> string -> string list -> string -> unit) -> string -> string list -> unit -val add_rec_dir : + +(** -R semantic: go in subdirs and suffixes of logical paths are known. *) +val add_rec_dir_import : (bool -> string -> string list -> string -> unit) -> string -> string list -> unit + val treat_file : dir -> string -> unit val error_cannot_parse : string -> int * int -> 'a -- cgit v1.2.3