diff options
| author | Emilio Jesus Gallego Arias | 2019-11-21 15:38:39 +0100 |
|---|---|---|
| committer | Emilio Jesus Gallego Arias | 2019-11-21 15:38:39 +0100 |
| commit | d016f69818b30b75d186fb14f440b93b0518fc66 (patch) | |
| tree | 32cd948273f79a2c01ad27b4ed0244ea60d7e2f9 | |
| parent | b680b06b31c27751a7d551d95839aea38f7fbea1 (diff) | |
[coq] Untabify the whole ML codebase.
We also remove trailing whitespace.
Script used:
```bash
for i in `find . -name '*.ml' -or -name '*.mli' -or -name '*.mlg'`; do expand -i "$i" | sponge "$i"; sed -e's/[[:space:]]*$//' -i.bak "$i"; done
```
319 files changed, 12235 insertions, 12235 deletions
diff --git a/checker/check.ml b/checker/check.ml index 09ecd675f7..ffb2928d55 100644 --- a/checker/check.ml +++ b/checker/check.ml @@ -155,24 +155,24 @@ let add_load_path (phys_path,coq_path) = let physical, logical = !load_paths in match List.filter2 (fun p d -> p = phys_path) physical logical with | _,[dir] -> - if coq_path <> dir + if coq_path <> dir (* If this is not the default -I . to coqtop *) && not (phys_path = CUnix.canonical_path_name Filename.current_dir_name - && coq_path = default_root_prefix) - then - begin + && coq_path = default_root_prefix) + then + begin (* Assume the user is concerned by library naming *) - if dir <> default_root_prefix then - Feedback.msg_warning - (str phys_path ++ strbrk " was previously bound to " ++ - pr_dirpath dir ++ strbrk "; it is remapped to " ++ - pr_dirpath coq_path); - remove_load_path phys_path; - load_paths := (phys_path::fst !load_paths, coq_path::snd !load_paths) - end + if dir <> default_root_prefix then + Feedback.msg_warning + (str phys_path ++ strbrk " was previously bound to " ++ + pr_dirpath dir ++ strbrk "; it is remapped to " ++ + pr_dirpath coq_path); + remove_load_path phys_path; + load_paths := (phys_path::fst !load_paths, coq_path::snd !load_paths) + end | _,[] -> - load_paths := (phys_path :: fst !load_paths, coq_path :: snd !load_paths) + load_paths := (phys_path :: fst !load_paths, coq_path :: snd !load_paths) | _ -> anomaly (Pp.str ("Two logical paths are associated to "^phys_path^".")) let load_paths_of_dir_path dir = diff --git a/checker/checker.ml b/checker/checker.ml index d08e9e698d..5f93148be6 100644 --- a/checker/checker.ml +++ b/checker/checker.ml @@ -29,7 +29,7 @@ let parse_dir s = if n>=len then dirs else let pos = try - String.index_from s n '.' + String.index_from s n '.' with Not_found -> len in let dir = String.sub s n (pos-n) in @@ -241,8 +241,8 @@ let explain_exn = function hov 0 (str "Stack overflow") | Match_failure(filename,pos1,pos2) -> hov 1 (anomaly_string () ++ str "Match failure in file " ++ - guill filename ++ str " at line " ++ int pos1 ++ - str " character " ++ int pos2 ++ report ()) + guill filename ++ str " at line " ++ int pos1 ++ + str " character " ++ int pos2 ++ report ()) | Not_found -> hov 0 (anomaly_string () ++ str "uncaught exception Not_found" ++ report ()) | Failure s -> @@ -312,12 +312,12 @@ let explain_exn = function | Assert_failure (s,b,e) -> hov 0 (anomaly_string () ++ str "assert failure" ++ spc () ++ - (if s = "" then mt () - else - (str "(file \"" ++ str s ++ str "\", line " ++ int b ++ - str ", characters " ++ int e ++ str "-" ++ - int (e+6) ++ str ")")) ++ - report ()) + (if s = "" then mt () + else + (str "(file \"" ++ str s ++ str "\", line " ++ int b ++ + str ", characters " ++ int e ++ str "-" ++ + int (e+6) ++ str ")")) ++ + report ()) | e -> CErrors.print e (* for anomalies and other uncaught exceptions *) let deprecated flag = @@ -333,8 +333,8 @@ let parse_args argv = indices_matter:=true; parse rem | "-coqlib" :: s :: rem -> - if not (exists_dir s) then - fatal_error (str "Directory '" ++ str s ++ str "' does not exist") false; + if not (exists_dir s) then + fatal_error (str "Directory '" ++ str s ++ str "' does not exist") false; Envars.set_user_coqlib s; parse rem diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml index 3128e125dd..44b7089fd0 100644 --- a/checker/mod_checking.ml +++ b/checker/mod_checking.ml @@ -163,6 +163,6 @@ and check_signature env sign mp_mse res = match sign with MoreFunctor(arg_id,mtb,body) | NoFunctor struc -> let (_:env) = List.fold_left (fun env (lab,mb) -> - check_structure_field env mp_mse lab res mb) env struc + check_structure_field env mp_mse lab res mb) env struc in NoFunctor struc diff --git a/checker/validate.ml b/checker/validate.ml index 678af9f2d5..070a112bb6 100644 --- a/checker/validate.ml +++ b/checker/validate.ml @@ -105,7 +105,7 @@ and val_tuple ?name vs ctx o = else fail ctx o ("tuple size: found "^string_of_int (Obj.size o)^ - ", expected "^string_of_int n) + ", expected "^string_of_int n) (* Check that the object is either a constant constructor of tag < cc, or a constructed variant. each element of vv is an array of diff --git a/checker/values.ml b/checker/values.ml index 3882f88391..56321a27ff 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -117,7 +117,7 @@ let v_binder_annot x = v_tuple "binder_annot" [|x;v_relevance|] let v_puniverses v = v_tuple "punivs" [|v;v_instance|] -let v_boollist = List v_bool +let v_boollist = List v_bool let v_caseinfo = let v_cstyle = v_enum "case_style" 5 in diff --git a/clib/bigint.ml b/clib/bigint.ml index f8625c599e..ccbc8e6322 100644 --- a/clib/bigint.ml +++ b/clib/bigint.ml @@ -283,15 +283,15 @@ let euclid m d = else m.(!i) / d.(0) in q.(!i) <- q.(!i) + v; - sub_mult m d v !i + sub_mult m d v !i end else begin let v = (m.(!i) * base + m.(!i+1)) / (d.(0) + 1) in q.(!i) <- q.(!i) + v / base; - sub_mult m d (v / base) !i; + sub_mult m d (v / base) !i; q.(!i+1) <- q.(!i+1) + v mod base; - if q.(!i+1) >= base then - (q.(!i+1) <- q.(!i+1)-base; q.(!i) <- q.(!i)+1); - sub_mult m d (v mod base) (!i+1) + if q.(!i+1) >= base then + (q.(!i+1) <- q.(!i+1)-base; q.(!i) <- q.(!i)+1); + sub_mult m d (v mod base) (!i+1) end done; (normalize q, normalize m) in @@ -465,9 +465,9 @@ let pow = let quo = m lsr 1 (* i.e. m/2 *) and odd = not (Int.equal (m land 1) 0) in pow_aux - (if odd then mult n odd_rest else odd_rest) - (mult n n) - quo + (if odd then mult n odd_rest else odd_rest) + (mult n n) + quo in pow_aux one diff --git a/clib/cArray.ml b/clib/cArray.ml index bff796ac33..be59ae57d0 100644 --- a/clib/cArray.ml +++ b/clib/cArray.ml @@ -123,7 +123,7 @@ let equal_norefl cmp t1 t2 = let equal cmp t1 t2 = if t1 == t2 then true else equal_norefl cmp t1 t2 - + let is_empty array = Int.equal (Array.length array) 0 diff --git a/clib/cArray.mli b/clib/cArray.mli index 090d2bf627..f94af26515 100644 --- a/clib/cArray.mli +++ b/clib/cArray.mli @@ -110,7 +110,7 @@ sig (** Same with two arrays, folding on the left *) val distinct : 'a array -> bool - (** Return [true] if every element of the array is unique (for default + (** Return [true] if every element of the array is unique (for default equality). *) val rev_of_list : 'a list -> 'a array diff --git a/clib/cList.mli b/clib/cList.mli index 9125c3b68b..d294088dc9 100644 --- a/clib/cList.mli +++ b/clib/cList.mli @@ -45,7 +45,7 @@ sig (** {6 Creating lists} *) val interval : int -> int -> int list - (** [interval i j] creates the list [[i; i + 1; ...; j]], or [[]] when + (** [interval i j] creates the list [[i; i + 1; ...; j]], or [[]] when [j <= i]. *) val make : int -> 'a -> 'a list diff --git a/clib/cThread.ml b/clib/cThread.ml index 434b234ba1..953b51ed02 100644 --- a/clib/cThread.ml +++ b/clib/cThread.ml @@ -16,7 +16,7 @@ let thread_friendly_read_fd fd s ~off ~len = let rec loop () = try Unix.read fd s off len with Unix.Unix_error(Unix.EINTR,_,_) -> loop () - in + in loop () let thread_friendly_read ic s ~off ~len = diff --git a/clib/heap.ml b/clib/heap.ml index daade01cb7..361f7945a4 100644 --- a/clib/heap.ml +++ b/clib/heap.ml @@ -129,8 +129,8 @@ module Functional(X : Ordered) = struct let rec fold f h x0 = match h with | Leaf -> - x0 + x0 | Node (l, x, r) -> - fold f l (fold f r (f x x0)) + fold f l (fold f r (f x x0)) end diff --git a/clib/option.ml b/clib/option.ml index fd88257238..17024e988b 100644 --- a/clib/option.ml +++ b/clib/option.ml @@ -200,8 +200,8 @@ module List = let rec find f = function | [] -> None | h :: t -> match f h with - | None -> find f t - | x -> x + | None -> find f t + | x -> x let map f l = let rec aux f l = match l with diff --git a/clib/predicate.mli b/clib/predicate.mli index cee3b0bd39..d599b92dd4 100644 --- a/clib/predicate.mli +++ b/clib/predicate.mli @@ -9,7 +9,7 @@ module type OrderedType = type t (** The type of the elements in the set. - The chosen [t] {b must be infinite}. *) + The chosen [t] {b must be infinite}. *) val compare : t -> t -> int (** A total ordering function over the set elements. diff --git a/clib/segmenttree.ml b/clib/segmenttree.ml index 3518fc130d..b22a9b921c 100644 --- a/clib/segmenttree.ml +++ b/clib/segmenttree.ml @@ -11,7 +11,7 @@ (** This module is a very simple implementation of "segment trees". A segment tree of type ['a t] represents a mapping from a union of - disjoint segments to some values of type 'a. + disjoint segments to some values of type 'a. *) (** Misc. functions. *) @@ -24,15 +24,15 @@ let list_iteri f l = let log2 x = log x /. log 2. -let log2n x = int_of_float (ceil (log2 (float_of_int x))) +let log2n x = int_of_float (ceil (log2 (float_of_int x))) (** We focus on integers but this module can be generalized. *) type elt = int -(** A value of type [domain] is interpreted differently given its position - in the tree. On internal nodes, a domain represents the set of - integers which are _not_ in the set of keys handled by the tree. On - leaves, a domain represents the st of integers which are in the set of +(** A value of type [domain] is interpreted differently given its position + in the tree. On internal nodes, a domain represents the set of + integers which are _not_ in the set of keys handled by the tree. On + leaves, a domain represents the st of integers which are in the set of keys. *) type domain = | Interval of elt * elt @@ -61,14 +61,14 @@ let right_child i = 2 * i + 2 let value_of i t = match t.(i) with (_, Some x) -> x | _ -> raise Not_found (** Initialize the array to store [n] leaves. *) -let create n init = +let create n init = Array.make (1 lsl (log2n n + 1) - 1) init -(** Make a complete interval tree from a list of disjoint segments. +(** Make a complete interval tree from a list of disjoint segments. Precondition : the segments must be sorted. *) -let make segments = +let make segments = let nsegments = List.length segments in - let tree = create nsegments (Universe, None) in + let tree = create nsegments (Universe, None) in let leaves_offset = (1 lsl (log2n nsegments)) - 1 in (* The algorithm proceeds in two steps using an intermediate tree @@ -79,62 +79,62 @@ let make segments = with the given segments... *) list_iteri (fun i ((start, stop), value) -> - let k = leaves_offset + i in - let i = Interval (start, stop) in - tree.(k) <- (i, Some i)) + let k = leaves_offset + i in + let i = Interval (start, stop) in + tree.(k) <- (i, Some i)) segments; (* ... the remaining leaves are initialized with neutral information. *) - for k = leaves_offset + nsegments to Array.length tree -1 do + for k = leaves_offset + nsegments to Array.length tree -1 do tree.(k) <- (Universe, Some Universe) done; - + (* We traverse the tree bottom-up and compute the interval and annotation associated to each node from the annotations of its children. *) for k = leaves_offset - 1 downto 0 do - let node, annotation = - match value_of (left_child k) tree, value_of (right_child k) tree with - | Interval (left_min, left_max), Interval (right_min, right_max) -> - (Interval (left_max, right_min), Interval (left_min, right_max)) - | Interval (min, max), Universe -> - (Interval (max, max), Interval (min, max)) - | Universe, Universe -> Universe, Universe - | Universe, _ -> assert false + let node, annotation = + match value_of (left_child k) tree, value_of (right_child k) tree with + | Interval (left_min, left_max), Interval (right_min, right_max) -> + (Interval (left_max, right_min), Interval (left_min, right_max)) + | Interval (min, max), Universe -> + (Interval (max, max), Interval (min, max)) + | Universe, Universe -> Universe, Universe + | Universe, _ -> assert false in - tree.(k) <- (node, Some annotation) + tree.(k) <- (node, Some annotation) done; (* Finally, annotation are replaced with the image related to each leaf. *) - let final_tree = + let final_tree = Array.mapi (fun i (segment, value) -> (segment, None)) tree in - list_iteri - (fun i ((start, stop), value) -> - final_tree.(leaves_offset + i) - <- (Interval (start, stop), Some value)) - segments; + list_iteri + (fun i ((start, stop), value) -> + final_tree.(leaves_offset + i) + <- (Interval (start, stop), Some value)) + segments; final_tree -(** [lookup k t] looks for an image for key [k] in the interval tree [t]. +(** [lookup k t] looks for an image for key [k] in the interval tree [t]. Raise [Not_found] if it fails. *) -let lookup k t = - let i = ref 0 in +let lookup k t = + let i = ref 0 in while (snd t.(!i) = None) do match fst t.(!i) with - | Interval (start, stop) -> - if k <= start then i := left_child !i - else if k >= stop then i:= right_child !i - else raise Not_found - | Universe -> raise Not_found + | Interval (start, stop) -> + if k <= start then i := left_child !i + else if k >= stop then i:= right_child !i + else raise Not_found + | Universe -> raise Not_found done; match fst t.(!i) with - | Interval (start, stop) -> - if k >= start && k <= stop then - match snd t.(!i) with - | Some v -> v - | None -> assert false - else - raise Not_found + | Interval (start, stop) -> + if k >= start && k <= stop then + match snd t.(!i) with + | Some v -> v + | None -> assert false + else + raise Not_found | Universe -> assert false - + diff --git a/clib/segmenttree.mli b/clib/segmenttree.mli index fa198f7ad6..eb2a7569fd 100644 --- a/clib/segmenttree.mli +++ b/clib/segmenttree.mli @@ -11,7 +11,7 @@ (** This module is a very simple implementation of "segment trees". A segment tree of type ['a t] represents a mapping from a union of - disjoint segments to some values of type 'a. + disjoint segments to some values of type 'a. *) (** A mapping from a union of disjoint segments to some values of type ['a]. *) @@ -19,11 +19,11 @@ type 'a t (** [make [(i1, j1), v1; (i2, j2), v2; ...]] creates a mapping that associates to every integer [x] the value [v1] if [i1 <= x <= j1], - [v2] if [i2 <= x <= j2], and so one. + [v2] if [i2 <= x <= j2], and so one. Precondition: the segments must be sorted. *) val make : ((int * int) * 'a) list -> 'a t -(** [lookup k t] looks for an image for key [k] in the interval tree [t]. +(** [lookup k t] looks for an image for key [k] in the interval tree [t]. Raise [Not_found] if it fails. *) val lookup : int -> 'a t -> 'a diff --git a/clib/unionfind.ml b/clib/unionfind.ml index 4de9fb8faa..8b7918a020 100644 --- a/clib/unionfind.ml +++ b/clib/unionfind.ml @@ -99,9 +99,9 @@ module Make (S:SetS)(M:MapS with type key = S.elt) = struct match !node with | Canon _ -> x, node | Equiv y -> - let ((z,_) as res) = lookup y p in - if not (z == y) then node := Equiv z; - res + let ((z,_) as res) = lookup y p in + if not (z == y) then node := Equiv z; + res let add x p = if not (M.mem x !p) then ignore (fresh x p) @@ -117,10 +117,10 @@ module Make (S:SetS)(M:MapS with type key = S.elt) = struct let xcan, ycan = if x < y then xcan, ycan else ycan, xcan in let x,xnode = xcan and y,ynode = ycan in match !xnode, !ynode with - | Canon lx, Canon ly -> - xnode := Canon (S.union lx ly); - ynode := Equiv x; - | _ -> assert false + | Canon lx, Canon ly -> + xnode := Canon (S.union lx ly); + ynode := Equiv x; + | _ -> assert false let union_set s p = try @@ -130,9 +130,9 @@ module Make (S:SetS)(M:MapS with type key = S.elt) = struct let partition p = List.rev (M.fold - (fun x node acc -> match !node with - | Equiv _ -> acc - | Canon lx -> lx::acc) - !p []) + (fun x node acc -> match !node with + | Equiv _ -> acc + | Canon lx -> lx::acc) + !p []) end diff --git a/configure.ml b/configure.ml index 411578445c..60ba8b1101 100644 --- a/configure.ml +++ b/configure.ml @@ -526,8 +526,8 @@ let camlbin, caml_version, camllib, findlib_version = | None -> try reset_caml_find camlexec (which camlexec.find) with Not_found -> - die (sprintf "Error: cannot find '%s' in your path!\n" camlexec.find ^ - "Please adjust your path or use the -ocamlfind option of ./configure") + die (sprintf "Error: cannot find '%s' in your path!\n" camlexec.find ^ + "Please adjust your path or use the -ocamlfind option of ./configure") in if not (is_executable camlexec.find) then die ("Error: cannot find the executable '"^camlexec.find^"'.") diff --git a/dev/top_printers.ml b/dev/top_printers.ml index ccb8658eee..f7f2bcdcff 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -143,9 +143,9 @@ let pP s = pp (hov 0 s) let safe_pr_global = let open GlobRef in function | ConstRef kn -> pp (str "CONSTREF(" ++ Constant.debug_print kn ++ str ")") | IndRef (kn,i) -> pp (str "INDREF(" ++ MutInd.debug_print kn ++ str "," ++ - int i ++ str ")") + int i ++ str ")") | ConstructRef ((kn,i),j) -> pp (str "CONSTRUCTREF(" ++ MutInd.debug_print kn ++ str "," ++ - int i ++ str "," ++ int j ++ str ")") + int i ++ str "," ++ int j ++ str ")") | VarRef id -> pp (str "VARREF(" ++ Id.print id ++ str ")") let ppglobal x = try pp(pr_global x) with _ -> safe_pr_global x @@ -225,7 +225,7 @@ let ppuniverse_level_subst l = pp (Univ.pr_universe_level_subst l) let ppevar_universe_context l = pp (Termops.pr_evar_universe_context l) let ppconstraints c = pp (pr_constraints Level.pr c) let ppuniverseconstraints c = pp (UnivProblem.Set.pr c) -let ppuniverse_context_future c = +let ppuniverse_context_future c = let ctx = Future.force c in ppuniverse_context ctx let ppuniverses u = pp (UGraph.pr_universes Level.pr u) @@ -327,9 +327,9 @@ let constr_display csr = | Set -> "Set" | Prop -> "Prop" | Type u -> univ_display u; - "Type("^(string_of_int !cnt)^")" + "Type("^(string_of_int !cnt)^")" - and universes_display l = + and universes_display l = Array.fold_right (fun x i -> level_display x; (string_of_int !cnt)^(if not(i="") then (" "^i) else "")) (Instance.to_array l) "" @@ -398,7 +398,7 @@ let print_pure_constr csr = print_string "Constr("; sp_display sp; print_string ","; - print_int i; print_string ","; print_int j; + print_int i; print_string ","; print_int j; print_string ","; universes_display u; print_string ")" | Case (ci,p,c,bl) -> @@ -418,12 +418,12 @@ let print_pure_constr csr = open_vbox 0; let print_fix () = for k = 0 to (Array.length tl) - 1 do - open_vbox 0; - name_display lna.(k); print_string "/"; - print_int t.(k); print_cut(); print_string ":"; - box_display tl.(k) ; print_cut(); print_string ":="; - box_display bl.(k); close_box (); - print_cut() + open_vbox 0; + name_display lna.(k); print_string "/"; + print_int t.(k); print_cut(); print_string ":"; + box_display tl.(k) ; print_cut(); print_string ":="; + box_display bl.(k); close_box (); + print_cut() done in print_string"{"; print_fix(); print_string"}" | CoFix(i,(lna,tl,bl)) -> @@ -433,10 +433,10 @@ let print_pure_constr csr = let print_fix () = for k = 0 to (Array.length tl) - 1 do open_vbox 1; - name_display lna.(k); print_cut(); print_string ":"; - box_display tl.(k) ; print_cut(); print_string ":="; - box_display bl.(k); close_box (); - print_cut(); + name_display lna.(k); print_cut(); print_string ":"; + box_display tl.(k) ; print_cut(); print_string ":="; + box_display bl.(k); close_box (); + print_cut(); done in print_string"{"; print_fix (); print_string"}" | Int i -> @@ -454,7 +454,7 @@ let print_pure_constr csr = | Set -> print_string "Set" | Prop -> print_string "Prop" | Type u -> open_hbox(); - print_string "Type("; pp (pr_uni u); print_string ")"; close_box() + print_string "Type("; pp (pr_uni u); print_string ")"; close_box() and name_display x = match x.binder_name with | Name id -> print_string (Id.to_string id) @@ -465,8 +465,8 @@ let print_pure_constr csr = let ls = match List.rev_map Id.to_string (DirPath.repr dir) with ("Top"::l)-> l - | ("Coq"::_::l) -> l - | l -> l + | ("Coq"::_::l) -> l + | l -> l in List.iter (fun x -> print_string x; print_string ".") ls;*) print_string (MutInd.debug_to_string sp) and sp_con_display sp = @@ -474,8 +474,8 @@ let print_pure_constr csr = let ls = match List.rev_map Id.to_string (DirPath.repr dir) with ("Top"::l)-> l - | ("Coq"::_::l) -> l - | l -> l + | ("Coq"::_::l) -> l + | l -> l in List.iter (fun x -> print_string x; print_string ".") ls;*) print_string (Constant.debug_to_string sp) @@ -483,8 +483,8 @@ let print_pure_constr csr = try box_display csr; print_flush() with e -> - print_string (Printexc.to_string e);print_flush (); - raise e + print_string (Printexc.to_string e);print_flush (); + raise e let print_pure_econstr c = print_pure_constr EConstr.Unsafe.(to_constr c) ;; @@ -568,12 +568,12 @@ let raw_string_of_ref ?loc _ = let open GlobRef in function | IndRef (kn,i) -> let (mp,id) = MutInd.repr2 kn in encode_path ?loc "IND" (Some mp) [Label.to_id id] - (Id.of_string ("_"^string_of_int i)) + (Id.of_string ("_"^string_of_int i)) | ConstructRef ((kn,i),j) -> let (mp,id) = MutInd.repr2 kn in encode_path ?loc "CSTR" (Some mp) - [Label.to_id id;Id.of_string ("_"^string_of_int i)] - (Id.of_string ("_"^string_of_int j)) + [Label.to_id id;Id.of_string ("_"^string_of_int i)] + (Id.of_string ("_"^string_of_int j)) | VarRef id -> encode_path ?loc "SECVAR" None [] id @@ -589,7 +589,7 @@ let short_string_of_ref ?loc _ = let open GlobRef in function [Label.to_id (MutInd.label kn);Id.of_string ("_"^string_of_int i)] (Id.of_string ("_"^string_of_int j)) -(* Anticipate that printers can be used from ocamldebug and that +(* Anticipate that printers can be used from ocamldebug and that pretty-printer should not make calls to the global env since ocamldebug runs in a different process and does not have the proper env at hand *) let _ = Flags.in_debugger := true diff --git a/dev/vm_printers.ml b/dev/vm_printers.ml index 11565b99eb..73cf1b0195 100644 --- a/dev/vm_printers.ml +++ b/dev/vm_printers.ml @@ -51,7 +51,7 @@ let rec ppzipper z = let n = nargs args in open_hbox (); for i = 0 to n-2 do - ppvalues (arg args i);print_string ";";print_space() + ppvalues (arg args i);print_string ";";print_space() done; if n-1 >= 0 then ppvalues (arg args (n-1)); close_box() diff --git a/engine/eConstr.ml b/engine/eConstr.ml index 46a80239cf..150dad16c2 100644 --- a/engine/eConstr.ml +++ b/engine/eConstr.ml @@ -463,16 +463,16 @@ let test_constr_universes env sigma leq m n = if Sorts.equal s1 s2 then true else (cstrs := Set.add (UEq (Sorts.univ_of_sort s1,Sorts.univ_of_sort s2)) !cstrs; - true) + true) in - let leq_sorts s1 s2 = + let leq_sorts s1 s2 = let s1 = ESorts.kind sigma s1 in let s2 = ESorts.kind sigma s2 in if Sorts.equal s1 s2 then true - else + else (cstrs := Set.add (ULe (Sorts.univ_of_sort s1,Sorts.univ_of_sort s2)) !cstrs; - true) + true) in let rec eq_constr' nargs m n = compare_gen kind eq_universes eq_sorts eq_constr' nargs m n in let res = @@ -496,20 +496,20 @@ let compare_head_gen_proj env sigma equ eqs eqc' nargs m n = let kind c = kind sigma c in match kind m, kind n with | Proj (p, c), App (f, args) - | App (f, args), Proj (p, c) -> + | App (f, args), Proj (p, c) -> (match kind f with - | Const (p', u) when Constant.equal (Projection.constant p) p' -> + | Const (p', u) when Constant.equal (Projection.constant p) p' -> let npars = Projection.npars p in if Array.length args == npars + 1 then eqc' 0 c args.(npars) - else false + else false | _ -> false) | _ -> Constr.compare_head_gen_with kind kind equ eqs eqc' nargs m n let eq_constr_universes_proj env sigma m n = let open UnivProblem in if m == n then Some Set.empty - else + else let cstrs = ref Set.empty in let eq_universes ref l l' = eq_universes env sigma cstrs Reduction.CONV ref l l' in let eq_sorts s1 s2 = @@ -519,7 +519,7 @@ let eq_constr_universes_proj env sigma m n = else (cstrs := Set.add (UEq (Sorts.univ_of_sort s1, Sorts.univ_of_sort s2)) !cstrs; - true) + true) in let rec eq_constr' nargs m n = m == n || compare_head_gen_proj env sigma eq_universes eq_sorts eq_constr' nargs m n diff --git a/engine/evarutil.ml b/engine/evarutil.ml index 5444d88e47..b09cc87f97 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -562,19 +562,19 @@ let rec check_and_clear_in_constr env evdref err ids global c = c | Evar (evk,l as ev) -> - if Evd.is_defined !evdref evk then - (* If evk is already defined we replace it by its definition *) + if Evd.is_defined !evdref evk then + (* If evk is already defined we replace it by its definition *) let nc = Evd.existential_value !evdref (EConstr.of_existential ev) in let nc = EConstr.Unsafe.to_constr nc in - (check_and_clear_in_constr env evdref err ids global nc) - else - (* We check for dependencies to elements of ids in the - evar_info corresponding to e and in the instance of - arguments. Concurrently, we build a new evar - corresponding to e where hypotheses of ids have been - removed *) - let evi = Evd.find_undefined !evdref evk in - let ctxt = Evd.evar_filtered_context evi in + (check_and_clear_in_constr env evdref err ids global nc) + else + (* We check for dependencies to elements of ids in the + evar_info corresponding to e and in the instance of + arguments. Concurrently, we build a new evar + corresponding to e where hypotheses of ids have been + removed *) + let evi = Evd.find_undefined !evdref evk in + let ctxt = Evd.evar_filtered_context evi in let (rids,filter) = List.fold_right2 (fun h a (ri,filter) -> @@ -594,11 +594,11 @@ let rec check_and_clear_in_constr env evdref err ids global c = (* No dependency at all, we can keep this ev's context hyp *) (ri, true::filter) with Depends id -> (Id.Map.add (NamedDecl.get_id h) id ri, false::filter)) - ctxt (Array.to_list l) (Id.Map.empty,[]) in - (* Check if some rid to clear in the context of ev has dependencies - in the type of ev and adjust the source of the dependency *) - let _nconcl = - try + ctxt (Array.to_list l) (Id.Map.empty,[]) in + (* Check if some rid to clear in the context of ev has dependencies + in the type of ev and adjust the source of the dependency *) + let _nconcl = + try let nids = Id.Map.domain rids in let global = Id.Set.exists is_section_variable nids in let concl = EConstr.Unsafe.to_constr (evar_concl evi) in @@ -694,7 +694,7 @@ let gather_dependent_evars q evm = let (is_dependent,e) = Queue.pop q in (* checks if [e] has already been added to [!acc] *) begin if not (Evar.Map.mem e !acc) then - acc := process_dependent_evar q !acc evm is_dependent e + acc := process_dependent_evar q !acc evm is_dependent e end done; !acc @@ -736,7 +736,7 @@ let undefined_evars_of_term evd t = match EConstr.kind evd c with | Evar (n, l) -> let acc = Evar.Set.add n acc in - Array.fold_left evrec acc l + Array.fold_left evrec acc l | _ -> EConstr.fold evd evrec acc c in evrec Evar.Set.empty t @@ -751,10 +751,10 @@ let undefined_evars_of_evar_info evd evi = Evar.Set.union (undefined_evars_of_term evd evi.evar_concl) (Evar.Set.union (match evi.evar_body with - | Evar_empty -> Evar.Set.empty + | Evar_empty -> Evar.Set.empty | Evar_defined b -> undefined_evars_of_term evd b) (undefined_evars_of_named_context evd - (named_context_of_val evi.evar_hyps))) + (named_context_of_val evi.evar_hyps))) type undefined_evars_cache = { mutable cache : (EConstr.named_declaration * Evar.Set.t) ref Id.Map.t; diff --git a/engine/evarutil.mli b/engine/evarutil.mli index 7877b94582..65a069a280 100644 --- a/engine/evarutil.mli +++ b/engine/evarutil.mli @@ -58,7 +58,7 @@ val new_pure_evar : val new_pure_evar_full : evar_map -> ?typeclass_candidate:bool -> evar_info -> evar_map * Evar.t -(** Create a new Type existential variable, as we keep track of +(** Create a new Type existential variable, as we keep track of them during type-checking and unification. *) val new_type_evar : ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> diff --git a/engine/evd.ml b/engine/evd.ml index f051334f69..94868d9bdd 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -652,7 +652,7 @@ let existential_type0 = existential_type let add_constraints d c = { d with universes = UState.add_constraints d.universes c } -let add_universe_constraints d c = +let add_universe_constraints d c = { d with universes = UState.add_universe_constraints d.universes c } (*** /Lifting... ***) @@ -664,7 +664,7 @@ let is_empty d = List.is_empty d.conv_pbs && Metamap.is_empty d.metas -let cmap f evd = +let cmap f evd = { evd with metas = Metamap.map (map_clb f) evd.metas; defn_evars = EvMap.map (map_evar_info f) evd.defn_evars; @@ -701,7 +701,7 @@ let empty = { extras = Store.empty; } -let from_env e = +let from_env e = { empty with universes = UState.make ~lbound:(Environ.universes_lbound e) (Environ.universes e) } let from_ctx ctx = { empty with universes = ctx } @@ -711,7 +711,7 @@ let has_undefined evd = not (EvMap.is_empty evd.undf_evars) let evars_reset_evd ?(with_conv_pbs=false) ?(with_univs=true) evd d = let conv_pbs = if with_conv_pbs then evd.conv_pbs else d.conv_pbs in let last_mods = if with_conv_pbs then evd.last_mods else d.last_mods in - let universes = + let universes = if not with_univs then evd.universes else UState.union evd.universes d.universes in @@ -812,10 +812,10 @@ let extract_conv_pbs evd p = let (pbs,pbs1) = List.fold_left (fun (pbs,pbs1) pb -> - if p pb then - (pb::pbs,pbs1) + if p pb then + (pb::pbs,pbs1) else - (pbs,pb::pbs1)) + (pbs,pb::pbs1)) ([],[]) evd.conv_pbs in @@ -866,7 +866,7 @@ let universe_subst evd = let merge_context_set ?loc ?(sideff=false) rigid evd ctx' = {evd with universes = UState.merge ?loc ~sideff rigid evd.universes ctx'} -let merge_universe_subst evd subst = +let merge_universe_subst evd subst = {evd with universes = UState.merge_subst evd.universes subst } let with_context_set ?loc rigid d (a, ctx) = @@ -915,7 +915,7 @@ let fresh_global ?loc ?(rigid=univ_flexible) ?names env evd gr = let is_sort_variable evd s = UState.is_sort_variable evd.universes s -let is_flexible_level evd l = +let is_flexible_level evd l = let uctx = evd.universes in Univ.LMap.mem l (UState.subst uctx) @@ -947,7 +947,7 @@ let normalize_universe_instance evd l = let normalize_sort evars s = match s with | SProp | Prop | Set -> s - | Type u -> + | Type u -> let u' = normalize_universe evars u in if u' == u then s else Sorts.sort_of_univ u' @@ -974,7 +974,7 @@ let set_eq_instances ?(flex=false) d u1 u2 = (UnivProblem.enforce_eq_instances_univs flex u1 u2 UnivProblem.Set.empty) let set_leq_sort env evd s1 s2 = - let s1 = normalize_sort evd s1 + let s1 = normalize_sort evd s1 and s2 = normalize_sort evd s2 in match is_eq_sort s1 s2 with | None -> evd @@ -982,7 +982,7 @@ let set_leq_sort env evd s1 s2 = if not (type_in_type env) then add_universe_constraints evd (UnivProblem.Set.singleton (UnivProblem.ULe (u1,u2))) else evd - + let check_eq evd s s' = UGraph.check_eq (UState.ugraph evd.universes) s s' @@ -1256,7 +1256,7 @@ type 'a sigma = { let sig_it x = x.it let sig_sig x = x.sigma -let on_sig s f = +let on_sig s f = let sigma', v = f s.sigma in { s with sigma = sigma' }, v diff --git a/engine/evd.mli b/engine/evd.mli index 5ab53947f7..7876e9a48f 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -141,7 +141,7 @@ val empty : evar_map (** The empty evar map. *) val from_env : env -> evar_map -(** The empty evar map with given universe context, taking its initial +(** The empty evar map with given universe context, taking its initial universes from env. *) val from_ctx : UState.t -> evar_map @@ -251,7 +251,7 @@ val evar_instance_array : (Constr.named_declaration -> 'a -> bool) -> evar_info val instantiate_evar_array : evar_info -> econstr -> econstr array -> econstr -val evars_reset_evd : ?with_conv_pbs:bool -> ?with_univs:bool -> +val evars_reset_evd : ?with_conv_pbs:bool -> ?with_univs:bool -> evar_map -> evar_map -> evar_map (** spiwack: this function seems to somewhat break the abstraction. *) @@ -596,8 +596,8 @@ val make_flexible_variable : evar_map -> algebraic:bool -> Univ.Level.t -> evar_ val make_nonalgebraic_variable : evar_map -> Univ.Level.t -> evar_map (** See [UState.make_nonalgebraic_variable]. *) -val is_sort_variable : evar_map -> Sorts.t -> Univ.Level.t option -(** [is_sort_variable evm s] returns [Some u] or [None] if [s] is +val is_sort_variable : evar_map -> Sorts.t -> Univ.Level.t option +(** [is_sort_variable evm s] returns [Some u] or [None] if [s] is not a local sort variable declared in [evm] *) val is_flexible_level : evar_map -> Univ.Level.t -> bool @@ -610,7 +610,7 @@ val set_leq_sort : env -> evar_map -> Sorts.t -> Sorts.t -> evar_map val set_eq_sort : env -> evar_map -> Sorts.t -> Sorts.t -> evar_map val set_eq_level : evar_map -> Univ.Level.t -> Univ.Level.t -> evar_map val set_leq_level : evar_map -> Univ.Level.t -> Univ.Level.t -> evar_map -val set_eq_instances : ?flex:bool -> +val set_eq_instances : ?flex:bool -> evar_map -> Univ.Instance.t -> Univ.Instance.t -> evar_map val check_eq : evar_map -> Univ.Universe.t -> Univ.Universe.t -> bool diff --git a/engine/namegen.ml b/engine/namegen.ml index b850f38b4d..56277e8092 100644 --- a/engine/namegen.ml +++ b/engine/namegen.ml @@ -153,15 +153,15 @@ let hdchar env sigma c = | Var id -> lowercase_first_char id | Sort s -> sort_hdchar (ESorts.kind sigma s) | Rel n -> - (if n<=k then "p" (* the initial term is flexible product/function *) - else + (if n<=k then "p" (* the initial term is flexible product/function *) + else try match let d = lookup_rel (n-k) env in get_name d, get_type d with | Name id, _ -> lowercase_first_char id | Anonymous, t -> hdrec 0 (lift (n-k) t) - with Not_found -> "y") + with Not_found -> "y") | Fix ((_,i),(lna,_,_)) | CoFix (i,(lna,_,_)) -> let id = match lna.(i).binder_name with Name id -> id | _ -> assert false in - lowercase_first_char id + lowercase_first_char id | Evar _ (* We could do better... *) | Meta _ | Case (_, _, _, _) -> "y" | Int _ -> "i" @@ -196,7 +196,7 @@ let name_context env sigma hyps = snd (List.fold_left (fun (env,hyps) d -> - let d' = name_assumption env sigma d in (push_rel d' env, d' :: hyps)) + let d' = name_assumption env sigma d in (push_rel d' env, d' :: hyps)) (env,[]) (List.rev hyps)) let mkProd_or_LetIn_name env sigma b d = mkProd_or_LetIn (name_assumption env sigma d) b @@ -356,8 +356,8 @@ let next_name_away_with_default_using_types default na avoid t = let id = match na with | Name id -> id | Anonymous -> match !reserved_type_name t with - | Name id -> id - | Anonymous -> Id.of_string default in + | Name id -> id + | Anonymous -> Id.of_string default in next_ident_away id avoid let next_name_away = next_name_away_with_default default_non_dependent_string @@ -458,12 +458,12 @@ let rename_bound_vars_as_displayed sigma avoid env c = let rec rename avoid env c = match EConstr.kind sigma c with | Prod (na,c1,c2) -> - let na',avoid' = + let na',avoid' = compute_displayed_name_in sigma (RenamingElsewhereFor (env,c2)) avoid na.binder_name c2 in mkProd ({na with binder_name=na'}, c1, rename avoid' (na' :: env) c2) | LetIn (na,c1,t,c2) -> - let na',avoid' = + let na',avoid' = compute_displayed_let_name_in sigma (RenamingElsewhereFor (env,c2)) avoid na.binder_name c2 in mkLetIn ({na with binder_name=na'},c1,t, rename avoid' (na' :: env) c2) diff --git a/engine/namegen.mli b/engine/namegen.mli index 7a8544f2d6..4a1cd4d44f 100644 --- a/engine/namegen.mli +++ b/engine/namegen.mli @@ -88,7 +88,7 @@ val next_ident_away : Id.t -> Id.Set.t -> Id.t (** Avoid clashing with a name already used in current module *) val next_ident_away_in_goal : Id.t -> Id.Set.t -> Id.t -(** Avoid clashing with a name already used in current module +(** Avoid clashing with a name already used in current module but tolerate overwriting section variables, as in goals *) val next_global_ident_away : Id.t -> Id.Set.t -> Id.t diff --git a/engine/nameops.ml b/engine/nameops.ml index baa19050d7..fe0a91e3ba 100644 --- a/engine/nameops.ml +++ b/engine/nameops.ml @@ -72,13 +72,13 @@ let cut_ident skip_quote s = else let c = Char.code (String.get s (n-1)) in if Int.equal c code_of_0 && not (Int.equal n slen) then - numpart (n-1) n' + numpart (n-1) n' else if code_of_0 <= c && c <= code_of_9 then - numpart (n-1) (n-1) + numpart (n-1) (n-1) else if skip_quote && (Int.equal c (Char.code '\'') || Int.equal c (Char.code '_')) then - numpart (n-1) (n-1) + numpart (n-1) (n-1) else - n' + n' in numpart slen slen @@ -126,20 +126,20 @@ let increment_subscript id = let c = id.[carrypos] in if is_digit c then if Int.equal (Char.code c) (Char.code '9') then begin - assert (carrypos>0); - add (carrypos-1) + assert (carrypos>0); + add (carrypos-1) end else begin - let newid = Bytes.of_string id in - Bytes.fill newid (carrypos+1) (len-1-carrypos) '0'; - Bytes.set newid carrypos (Char.chr (Char.code c + 1)); - newid + let newid = Bytes.of_string id in + Bytes.fill newid (carrypos+1) (len-1-carrypos) '0'; + Bytes.set newid carrypos (Char.chr (Char.code c + 1)); + newid end else begin let newid = Bytes.of_string (id^"0") in if carrypos < len-1 then begin - Bytes.fill newid (carrypos+1) (len-1-carrypos) '0'; - Bytes.set newid (carrypos+1) '1' + Bytes.fill newid (carrypos+1) (len-1-carrypos) '0'; + Bytes.set newid (carrypos+1) '1' end; newid end diff --git a/engine/proofview.ml b/engine/proofview.ml index d6f5aab1d1..ed44372045 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -130,7 +130,7 @@ let focus_context (left,right) = i]. *) let focus_sublist i j l = let (left,sub_right) = CList.goto (i-1) l in - let (sub, right) = + let (sub, right) = try CList.chop (j-i+1) sub_right with Failure _ -> raise CList.IndexOutOfRange in @@ -479,7 +479,7 @@ let fold_left2_goal i s l = let err = return () >>= fun () -> (* Delay the computation of list lengths. *) tclZERO (SizeMismatch (CList.length initial.comb,CList.length l)) - in + in Proof.List.fold_left2 err begin fun ((r,subgoals) as cur) goal a -> Solution.get >>= fun step -> match cleared_alias step goal with @@ -515,7 +515,7 @@ let fold_left2_goal i s l = let tclDISPATCHGEN0 join tacs = match tacs with | [] -> - begin + begin let open Proof in Comb.get >>= function | [] -> tclUNIT (join []) @@ -1012,7 +1012,7 @@ module Unsafe = struct let tclEVARSADVANCE evd = Pv.modify (fun ps -> { ps with solution = evd; comb = undefined evd ps.comb }) - let tclEVARUNIVCONTEXT ctx = + let tclEVARUNIVCONTEXT ctx = Pv.modify (fun ps -> { ps with solution = Evd.set_universe_context ps.solution ctx }) let reset_future_goals p = @@ -1229,7 +1229,7 @@ module V82 = struct let (_goals,evd) = Evd.Monad.List.map map comb ps.solution in { ps with solution = evd; } end - + let has_unresolved_evar pv = Evd.has_undefined pv.solution @@ -1238,8 +1238,8 @@ module V82 = struct let undef = Evd.undefined_map pv.solution in let goals = CList.rev_map fst (Evar.Map.bindings undef) in { pv with comb = List.map with_empty_state goals } - - + + let top_goals initial { solution=solution; } = let goals = CList.map (fun (t,_) -> fst (Constr.destEvar (EConstr.Unsafe.to_constr t))) initial in diff --git a/engine/proofview.mli b/engine/proofview.mli index 764a4a0058..8ec53ac78c 100644 --- a/engine/proofview.mli +++ b/engine/proofview.mli @@ -145,7 +145,7 @@ val unfocus : focus_context -> proofview -> proofview (** The abstract type of tactics *) -type +'a tactic +type +'a tactic (** Applies a tactic to the current proofview. Returns a tuple [a,pv,(b,sh,gu)] where [a] is the return value of the tactic, [pv] @@ -170,7 +170,7 @@ val apply (** Unit of the tactic monad. *) val tclUNIT : 'a -> 'a tactic - + (** Bind operation of the tactic monad. *) val tclBIND : 'a tactic -> ('a -> 'b tactic) -> 'b tactic @@ -440,7 +440,7 @@ module Unsafe : sig goal. If goals have been solved in [sigma] they will still appear as unsolved goals. *) val tclEVARS : Evd.evar_map -> unit tactic - + (** Like {!tclEVARS} but also checks whether goals have been solved. *) val tclEVARSADVANCE : Evd.evar_map -> unit tactic diff --git a/engine/termops.ml b/engine/termops.ml index 90fa8546ce..a65b8275e6 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -95,15 +95,15 @@ let pr_meta_map env sigma = | _ -> mt() in let pr_meta_binding = function | (mv,Cltyp (na,b)) -> - hov 0 - (pr_meta mv ++ pr_name na ++ str " : " ++ + hov 0 + (pr_meta mv ++ pr_name na ++ str " : " ++ print_constr env sigma b.rebus ++ fnl ()) | (mv,Clval(na,(b,s),t)) -> - hov 0 - (pr_meta mv ++ pr_name na ++ str " := " ++ + hov 0 + (pr_meta mv ++ pr_name na ++ str " := " ++ print_constr env sigma b.rebus ++ str " : " ++ print_constr env sigma t.rebus ++ - spc () ++ pr_instance_status s ++ fnl ()) + spc () ++ pr_instance_status s ++ fnl ()) in prlist pr_meta_binding (meta_list sigma) @@ -232,7 +232,7 @@ let pr_evar_universe_context ctx = let prl = pr_uctx_level ctx in if UState.is_empty ctx then mt () else - (str"UNIVERSES:"++brk(0,1)++ + (str"UNIVERSES:"++brk(0,1)++ h 0 (Univ.pr_universe_context_set prl (UState.context_set ctx)) ++ fnl () ++ str"ALGEBRAIC UNIVERSES:"++brk(0,1)++ h 0 (Univ.LSet.pr prl (UState.algebraics ctx)) ++ fnl() ++ @@ -387,10 +387,10 @@ let pr_var_decl env decl = let pbody = match decl with | LocalAssum _ -> mt () | LocalDef (_,c,_) -> - (* Force evaluation *) - let c = EConstr.of_constr c in + (* Force evaluation *) + let c = EConstr.of_constr c in let pb = print_constr_env env sigma c in - (str" := " ++ pb ++ cut () ) in + (str" := " ++ pb ++ cut () ) in let pt = print_constr_env env sigma (EConstr.of_constr (get_type decl)) in let ptyp = (str" : " ++ pt) in (Id.print (get_id decl) ++ hov 0 (pbody ++ ptyp)) @@ -401,10 +401,10 @@ let pr_rel_decl env decl = let pbody = match decl with | LocalAssum _ -> mt () | LocalDef (_,c,_) -> - (* Force evaluation *) - let c = EConstr.of_constr c in + (* Force evaluation *) + let c = EConstr.of_constr c in let pb = print_constr_env env sigma c in - (str":=" ++ spc () ++ pb ++ spc ()) in + (str":=" ++ spc () ++ pb ++ spc ()) in let ptyp = print_constr_env env sigma (EConstr.of_constr (get_type decl)) in match get_name decl with | Anonymous -> hov 0 (str"<>" ++ spc () ++ pbody ++ str":" ++ spc () ++ ptyp) @@ -412,13 +412,13 @@ let pr_rel_decl env decl = let print_named_context env = hv 0 (fold_named_context - (fun env d pps -> - pps ++ ws 2 ++ pr_var_decl env d) + (fun env d pps -> + pps ++ ws 2 ++ pr_var_decl env d) env ~init:(mt ())) let print_rel_context env = hv 0 (fold_rel_context - (fun env d pps -> pps ++ ws 2 ++ pr_rel_decl env d) + (fun env d pps -> pps ++ ws 2 ++ pr_rel_decl env d) env ~init:(mt ())) let print_env env = @@ -426,7 +426,7 @@ let print_env env = fold_named_context (fun env d pps -> let pidt = pr_var_decl env d in - (pps ++ fnl () ++ pidt)) + (pps ++ fnl () ++ pidt)) env ~init:(mt ()) in let db_env = @@ -517,9 +517,9 @@ let it_mkLambda_or_LetIn_from_no_LetIn c decls = let rec strip_head_cast sigma c = match EConstr.kind sigma c with | App (f,cl) -> let rec collapse_rec f cl2 = match EConstr.kind sigma f with - | App (g,cl1) -> collapse_rec g (Array.append cl1 cl2) - | Cast (c,_,_) -> collapse_rec c cl2 - | _ -> if Int.equal (Array.length cl2) 0 then f else EConstr.mkApp (f,cl2) + | App (g,cl1) -> collapse_rec g (Array.append cl1 cl2) + | Cast (c,_,_) -> collapse_rec c cl2 + | _ -> if Int.equal (Array.length cl2) 0 then f else EConstr.mkApp (f,cl2) in collapse_rec f cl | Cast (c,_,_) -> strip_head_cast sigma c @@ -531,7 +531,7 @@ let rec drop_extra_implicit_args sigma c = match EConstr.kind sigma c with | App (f,args) when EConstr.isEvar sigma (Array.last args) -> let open EConstr in drop_extra_implicit_args sigma - (mkApp (f,fst (Array.chop (Array.length args - 1) args))) + (mkApp (f,fst (Array.chop (Array.length args - 1) args))) | _ -> c (* Get the last arg of an application *) @@ -601,27 +601,27 @@ let map_constr_with_binders_left_to_right sigma g f l c = match EConstr.kind sigma c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _ | Int _ | Float _) -> c - | Cast (b,k,t) -> - let b' = f l b in + | Cast (b,k,t) -> + let b' = f l b in let t' = f l t in if b' == b && t' == t then c else mkCast (b',k,t') | Prod (na,t,b) -> let t' = f l t in let b' = f (g (LocalAssum (na,t)) l) b in - if t' == t && b' == b then c - else mkProd (na, t', b') + if t' == t && b' == b then c + else mkProd (na, t', b') | Lambda (na,t,b) -> let t' = f l t in let b' = f (g (LocalAssum (na,t)) l) b in - if t' == t && b' == b then c - else mkLambda (na, t', b') + if t' == t && b' == b then c + else mkLambda (na, t', b') | LetIn (na,bo,t,b) -> let bo' = f l bo in let t' = f l t in let b' = f (g (LocalDef (na,bo,t)) l) b in - if bo' == bo && t' == t && b' == b then c - else mkLetIn (na, bo', t', b') + if bo' == bo && t' == t && b' == b then c + else mkLetIn (na, bo', t', b') | App (c,[||]) -> assert false | App (t,al) -> (*Special treatment to be able to recognize partially applied subterms*) @@ -629,13 +629,13 @@ let map_constr_with_binders_left_to_right sigma g f l c = let app = (mkApp (t, Array.sub al 0 (Array.length al - 1))) in let app' = f l app in let a' = f l a in - if app' == app && a' == a then c - else mkApp (app', [| a' |]) + if app' == app && a' == a then c + else mkApp (app', [| a' |]) | Proj (p,b) -> let b' = f l b in if b' == b then c else mkProj (p, b') - | Evar (e,al) -> + | Evar (e,al) -> let al' = Array.map_left (f l) al in if Array.for_all2 (==) al' al then c else mkEvar (e, al') @@ -644,20 +644,20 @@ let map_constr_with_binders_left_to_right sigma g f l c = let b' = f l b in let p' = f l p in let bl' = Array.map_left (f l) bl in - if b' == b && p' == p && bl' == bl then c - else mkCase (ci, p', b', bl') + if b' == b && p' == p && bl' == bl then c + else mkCase (ci, p', b', bl') | Fix (ln,(lna,tl,bl as fx)) -> let l' = fold_rec_types g fx l in let (tl', bl') = map_left2 (f l) tl (f l') bl in - if Array.for_all2 (==) tl tl' && Array.for_all2 (==) bl bl' - then c - else mkFix (ln,(lna,tl',bl')) + if Array.for_all2 (==) tl tl' && Array.for_all2 (==) bl bl' + then c + else mkFix (ln,(lna,tl',bl')) | CoFix(ln,(lna,tl,bl as fx)) -> let l' = fold_rec_types g fx l in let (tl', bl') = map_left2 (f l) tl (f l') bl in - if Array.for_all2 (==) tl tl' && Array.for_all2 (==) bl bl' - then c - else mkCoFix (ln,(lna,tl',bl')) + if Array.for_all2 (==) tl tl' && Array.for_all2 (==) bl bl' + then c + else mkCoFix (ln,(lna,tl',bl')) let map_under_context_with_full_binders sigma g f l n d = let open EConstr in @@ -703,9 +703,9 @@ let map_constr_with_full_binders_gen userview sigma g f l cstr = let c' = f l c in let al' = Array.map (f l) al in if c==c' && Array.for_all2 (==) al al' then cstr else mkApp (c', al') - | Proj (p,c) -> + | Proj (p,c) -> let c' = f l c in - if c' == c then cstr else mkProj (p, c') + if c' == c then cstr else mkProj (p, c') | Evar (e,al) -> let al' = Array.map (f l) al in if Array.for_all2 (==) al al' then cstr else mkEvar (e, al') @@ -867,14 +867,14 @@ let dependent_main noevar sigma m t = raise Occur else match EConstr.kind sigma m, EConstr.kind sigma t with - | App (fm,lm), App (ft,lt) when Array.length lm < Array.length lt -> - deprec m (mkApp (ft,Array.sub lt 0 (Array.length lm))); + | App (fm,lm), App (ft,lt) when Array.length lm < Array.length lt -> + deprec m (mkApp (ft,Array.sub lt 0 (Array.length lm))); Array.Fun1.iter deprec m - (Array.sub lt - (Array.length lm) ((Array.length lt) - (Array.length lm))) - | _, Cast (c,_,_) when noevar && isMeta sigma c -> () - | _, Evar _ when noevar -> () - | _ -> EConstr.iter_with_binders sigma (fun c -> Vars.lift 1 c) deprec m t + (Array.sub lt + (Array.length lm) ((Array.length lt) - (Array.length lm))) + | _, Cast (c,_,_) when noevar && isMeta sigma c -> () + | _, Evar _ when noevar -> () + | _ -> EConstr.iter_with_binders sigma (fun c -> Vars.lift 1 c) deprec m t in try deprec m t; false with Occur -> true @@ -895,14 +895,14 @@ let count_occurrences sigma m t = incr n else match EConstr.kind sigma m, EConstr.kind sigma t with - | App (fm,lm), App (ft,lt) when Array.length lm < Array.length lt -> - countrec m (mkApp (ft,Array.sub lt 0 (Array.length lm))); - Array.iter (countrec m) - (Array.sub lt - (Array.length lm) ((Array.length lt) - (Array.length lm))) - | _, Cast (c,_,_) when isMeta sigma c -> () - | _, Evar _ -> () - | _ -> EConstr.iter_with_binders sigma (Vars.lift 1) countrec m t + | App (fm,lm), App (ft,lt) when Array.length lm < Array.length lt -> + countrec m (mkApp (ft,Array.sub lt 0 (Array.length lm))); + Array.iter (countrec m) + (Array.sub lt + (Array.length lm) ((Array.length lt) - (Array.length lm))) + | _, Cast (c,_,_) when isMeta sigma c -> () + | _, Evar _ -> () + | _ -> EConstr.iter_with_binders sigma (Vars.lift 1) countrec m t in countrec m t; !n @@ -949,13 +949,13 @@ let prefix_application sigma eq_fun (k,c) t = let c' = collapse_appl sigma c and t' = collapse_appl sigma t in match EConstr.kind sigma c', EConstr.kind sigma t' with | App (f1,cl1), App (f2,cl2) -> - let l1 = Array.length cl1 - and l2 = Array.length cl2 in - if l1 <= l2 - && eq_fun sigma c' (mkApp (f2, Array.sub cl2 0 l1)) then - Some (mkApp (mkRel k, Array.sub cl2 l1 (l2 - l1))) - else - None + let l1 = Array.length cl1 + and l2 = Array.length cl2 in + if l1 <= l2 + && eq_fun sigma c' (mkApp (f2, Array.sub cl2 0 l1)) then + Some (mkApp (mkRel k, Array.sub cl2 l1 (l2 - l1))) + else + None | _ -> None let my_prefix_application sigma eq_fun (k,c) by_c t = @@ -963,13 +963,13 @@ let my_prefix_application sigma eq_fun (k,c) by_c t = let c' = collapse_appl sigma c and t' = collapse_appl sigma t in match EConstr.kind sigma c', EConstr.kind sigma t' with | App (f1,cl1), App (f2,cl2) -> - let l1 = Array.length cl1 - and l2 = Array.length cl2 in - if l1 <= l2 - && eq_fun sigma c' (mkApp (f2, Array.sub cl2 0 l1)) then - Some (mkApp ((Vars.lift k by_c), Array.sub cl2 l1 (l2 - l1))) - else - None + let l1 = Array.length cl1 + and l2 = Array.length cl2 in + if l1 <= l2 + && eq_fun sigma c' (mkApp (f2, Array.sub cl2 0 l1)) then + Some (mkApp ((Vars.lift k by_c), Array.sub cl2 l1 (l2 - l1))) + else + None | _ -> None (* Recognizing occurrences of a given subterm in a term: [subst_term c t] @@ -1002,7 +1002,7 @@ let replace_term_gen sigma eq_fun c by_c in_t = | None -> (if eq_fun sigma c t then (EConstr.Vars.lift k by_c) else EConstr.map_with_binders sigma (fun (k,c) -> (k+1,EConstr.Vars.lift 1 c)) - substrec kc t) + substrec kc t) in substrec (0,c) in_t @@ -1127,7 +1127,7 @@ let compare_constr_univ sigma f cv_pb t1 t2 = match EConstr.kind sigma t1, EConstr.kind sigma t2 with Sort s1, Sort s2 -> base_sort_cmp cv_pb (ESorts.kind sigma s1) (ESorts.kind sigma s2) | Prod (_,t1,c1), Prod (_,t2,c2) -> - f Reduction.CONV t1 t2 && f cv_pb c1 c2 + f Reduction.CONV t1 t2 && f cv_pb c1 c2 | Const (c, u), Const (c', u') -> Constant.equal c c' | Ind (i, _), Ind (i', _) -> eq_ind i i' | Construct (i, _), Construct (i', _) -> eq_constructor i i' @@ -1145,9 +1145,9 @@ let split_app sigma c = match EConstr.kind sigma c with App(c,l) -> let len = Array.length l in if Int.equal len 0 then ([],c) else - let last = Array.get l (len-1) in - let prev = Array.sub l 0 (len-1) in - c::(Array.to_list prev), last + let last = Array.get l (len-1) in + let prev = Array.sub l 0 (len-1) in + c::(Array.to_list prev), last | _ -> assert false type subst = (EConstr.rel_context * EConstr.constr) Evar.Map.t @@ -1177,15 +1177,15 @@ let filtering sigma env cv_pb c1 c2 = | _ -> assert false end | Prod (n,t1,c1), Prod (_,t2,c2) -> - aux env cv_pb t1 t2; - aux (RelDecl.LocalAssum (n,t1) :: env) cv_pb c1 c2 + aux env cv_pb t1 t2; + aux (RelDecl.LocalAssum (n,t1) :: env) cv_pb c1 c2 | _, Evar (ev,_) -> define cv_pb env ev c1 | Evar (ev,_), _ -> define cv_pb env ev c2 | _ -> - if compare_constr_univ sigma - (fun pb c1 c2 -> aux env pb c1 c2; true) cv_pb c1 c2 then () - else raise CannotFilter - (* TODO: le reste des binders *) + if compare_constr_univ sigma + (fun pb c1 c2 -> aux env pb c1 c2; true) cv_pb c1 c2 then () + else raise CannotFilter + (* TODO: le reste des binders *) in aux env cv_pb c1 c2; !evm @@ -1241,18 +1241,18 @@ let rec eta_reduce_head sigma c = let open Vars in match EConstr.kind sigma c with | Lambda (_,c1,c') -> - (match EConstr.kind sigma (eta_reduce_head sigma c') with + (match EConstr.kind sigma (eta_reduce_head sigma c') with | App (f,cl) -> let lastn = (Array.length cl) - 1 in if lastn < 0 then anomaly (Pp.str "application without arguments.") else (match EConstr.kind sigma cl.(lastn) with | Rel 1 -> - let c' = + let c' = if Int.equal lastn 0 then f - else mkApp (f, Array.sub cl 0 lastn) - in - if noccurn sigma 1 c' + else mkApp (f, Array.sub cl 0 lastn) + in + if noccurn sigma 1 c' then lift (-1) c' else c | _ -> c) @@ -1278,9 +1278,9 @@ let assums_of_rel_context sign = let map_rel_context_in_env f env sign = let rec aux env acc = function | d::sign -> - aux (push_rel d env) (RelDecl.map_constr (f env) d :: acc) sign + aux (push_rel d env) (RelDecl.map_constr (f env) d :: acc) sign | [] -> - acc + acc in aux env [] (List.rev sign) diff --git a/engine/uState.ml b/engine/uState.ml index ba17cdde93..3546ece581 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -15,7 +15,7 @@ open Names open Univ module UNameMap = Names.Id.Map - + type uinfo = { uname : Id.t option; uloc : Loc.t option; @@ -93,12 +93,12 @@ let union ctx ctx' = { uctx_names = (names, names_rev); uctx_local = local; uctx_seff_univs = seff; - uctx_univ_variables = + uctx_univ_variables = LMap.subst_union ctx.uctx_univ_variables ctx'.uctx_univ_variables; - uctx_univ_algebraic = + uctx_univ_algebraic = LSet.union ctx.uctx_univ_algebraic ctx'.uctx_univ_algebraic; uctx_initial_universes = declarenew ctx.uctx_initial_universes; - uctx_universes = + uctx_universes = (if local == ctx.uctx_local then ctx.uctx_universes else let cstrsr = ContextSet.constraints ctx'.uctx_local in @@ -234,7 +234,7 @@ let process_universe_constraints ctx cstrs = let unify_universes cst local = let cst = nf_constraint cst in if UnivProblem.is_trivial cst then local - else + else match cst with | ULe (l, r) -> begin match Univ.Universe.level r with @@ -273,7 +273,7 @@ let process_universe_constraints ctx cstrs = if not !drop_weak_constraints then weak := UPairSet.add (l,r) !weak; local | UEq (l, r) -> equalize_universes l r local in - let local = + let local = UnivProblem.Set.fold unify_universes cstrs Constraint.empty in !vars, !weak, local @@ -326,9 +326,9 @@ let constrain_variables diff ctx = diff (univs, ctx.uctx_univ_variables, local) in { ctx with uctx_local = (univs, local); uctx_univ_variables = vars } - + let qualid_of_level uctx = - let map, map_rev = uctx.uctx_names in + let map, map_rev = uctx.uctx_names in fun l -> try Some (Libnames.qualid_of_ident (Option.get (LMap.find l map_rev).uname)) with Not_found | Option.IsNone -> @@ -463,7 +463,7 @@ let restrict ctx vars = let uctx' = restrict_universe_context ~lbound:ctx.uctx_universes_lbound ctx.uctx_local vars in { ctx with uctx_local = uctx' } -type rigid = +type rigid = | UnivRigid | UnivFlexible of bool (** Is substitution by an algebraic ok? *) @@ -558,20 +558,20 @@ let new_univ_variable ?loc rigid name let uctx', pred = match rigid with | UnivRigid -> uctx, true - | UnivFlexible b -> + | UnivFlexible b -> let uvars' = LMap.add u None uvars in if b then {uctx with uctx_univ_variables = uvars'; uctx_univ_algebraic = LSet.add u avars}, false else {uctx with uctx_univ_variables = uvars'}, false in - let names = + let names = match name with | Some n -> add_uctx_names ?loc n u uctx.uctx_names | None -> add_uctx_loc u loc uctx.uctx_names in let initial = UGraph.add_universe ~lbound:uctx.uctx_universes_lbound ~strict:false u uctx.uctx_initial_universes - in + in let uctx' = {uctx' with uctx_names = names; uctx_local = ctx'; uctx_universes = UGraph.add_universe ~lbound:uctx.uctx_universes_lbound ~strict:false @@ -590,7 +590,7 @@ let add_global_univ uctx u = let initial = UGraph.add_universe ~lbound:Univ.Level.set ~strict:true u uctx.uctx_initial_universes in - let univs = + let univs = UGraph.add_universe ~lbound:Univ.Level.set ~strict:true u uctx.uctx_universes in { uctx with uctx_local = ContextSet.add_universe u uctx.uctx_local; @@ -631,11 +631,11 @@ let make_nonalgebraic_variable ctx u = let make_flexible_nonalgebraic ctx = {ctx with uctx_univ_algebraic = LSet.empty} -let is_sort_variable uctx s = - match s with - | Sorts.Type u -> +let is_sort_variable uctx s = + match s with + | Sorts.Type u -> (match universe_level u with - | Some l as x -> + | Some l as x -> if LSet.mem l (ContextSet.levels uctx.uctx_local) then x else None | None -> None) @@ -673,7 +673,7 @@ let normalize_variables uctx = uctx_universes = univs } let abstract_undefined_variables uctx = - let vars' = + let vars' = LMap.fold (fun u v acc -> if v == None then LSet.remove u acc else acc) @@ -682,11 +682,11 @@ let abstract_undefined_variables uctx = uctx_univ_algebraic = vars' } let fix_undefined_variables uctx = - let algs', vars' = + let algs', vars' = LMap.fold (fun u v (algs, vars as acc) -> if v == None then (LSet.remove u algs, LMap.remove u vars) else acc) - uctx.uctx_univ_variables + uctx.uctx_univ_variables (uctx.uctx_univ_algebraic, uctx.uctx_univ_variables) in { uctx with uctx_univ_variables = vars'; @@ -698,7 +698,7 @@ let refresh_undefined_univ_variables uctx = let alg = LSet.fold (fun u acc -> LSet.add (subst_fn u) acc) uctx.uctx_univ_algebraic LSet.empty in - let vars = + let vars = LMap.fold (fun u v acc -> LMap.add (subst_fn u) @@ -736,14 +736,14 @@ let minimize uctx = { uctx_names = uctx.uctx_names; uctx_local = us'; uctx_seff_univs = uctx.uctx_seff_univs; (* not sure about this *) - uctx_univ_variables = vars'; + uctx_univ_variables = vars'; uctx_univ_algebraic = algs'; uctx_universes = universes; uctx_universes_lbound = lbound; uctx_initial_universes = uctx.uctx_initial_universes; uctx_weak_constraints = UPairSet.empty; (* weak constraints are consumed *) } -let universe_of_name uctx s = +let universe_of_name uctx s = UNameMap.find s (fst uctx.uctx_names) let pr_weak prl {uctx_weak_constraints=weak} = diff --git a/engine/uState.mli b/engine/uState.mli index 23ef84c55d..8855a6bea6 100644 --- a/engine/uState.mli +++ b/engine/uState.mli @@ -100,7 +100,7 @@ val restrict_universe_context : lbound:Univ.Level.t -> ContextSet.t -> LSet.t -> universes are preserved. *) val restrict : t -> Univ.LSet.t -> t -type rigid = +type rigid = | UnivRigid | UnivFlexible of bool (** Is substitution by an algebraic ok? *) diff --git a/ide/configwin.mli b/ide/configwin.mli index fa22846d19..b5c3e74aec 100644 --- a/ide/configwin.mli +++ b/ide/configwin.mli @@ -42,13 +42,13 @@ type configuration_structure = type return_button = Return_apply (** The user clicked on Apply at least once before - closing the window with Cancel or the window manager. *) + closing the window with Cancel or the window manager. *) | Return_ok (** The user closed the window with the ok button. *) | Return_cancel (** The user closed the window with the cancel - button or the window manager but never clicked - on the apply button.*) + button or the window manager but never clicked + on the apply button.*) (** {2 Functions to create parameters} *) @@ -84,7 +84,7 @@ val strings : ?editable: bool -> ?help: string -> ?f: (string list -> unit) -> ?eq: (string -> string -> bool) -> ?add: (unit -> string list) -> - string -> string list -> parameter_kind + string -> string list -> parameter_kind (** [list label f_strings value] creates a list parameter. [f_strings] is a function taking a value and returning a list @@ -113,13 +113,13 @@ val list : ?editable: bool -> ?help: string -> ?f: ('a list -> unit) -> ?eq: ('a -> 'a -> bool) -> ?edit: ('a -> 'a) -> - ?add: (unit -> 'a list) -> - ?titles: string list -> - ?color: ('a -> string option) -> - string -> - ('a -> string list) -> - 'a list -> - parameter_kind + ?add: (unit -> 'a list) -> + ?titles: string list -> + ?color: ('a -> string option) -> + string -> + ('a -> string list) -> + 'a list -> + parameter_kind *) (** [combo label choices value] creates a combo parameter. diff --git a/ide/configwin_ihm.ml b/ide/configwin_ihm.ml index 0f3fd38a7a..e768131dcf 100644 --- a/ide/configwin_ihm.ml +++ b/ide/configwin_ihm.ml @@ -38,15 +38,15 @@ let modifiers_to_string m = | c :: m -> iter m (( match c with - `CONTROL -> "<ctrl>" - | `SHIFT -> "<shft>" - | `LOCK -> "<lock>" - | `MOD1 -> "<alt>" - | `MOD2 -> "<mod2>" - | `MOD3 -> "<mod3>" - | `MOD4 -> "<mod4>" - | `MOD5 -> "<mod5>" - | _ -> raise Not_found + `CONTROL -> "<ctrl>" + | `SHIFT -> "<shft>" + | `LOCK -> "<lock>" + | `MOD1 -> "<alt>" + | `MOD2 -> "<mod2>" + | `MOD3 -> "<mod3>" + | `MOD4 -> "<mod4>" + | `MOD5 -> "<mod5>" + | _ -> raise Not_found ) ^ s) in iter m "" @@ -89,13 +89,13 @@ class ['a] list_selection_box let wlist = match titles_opt with None -> GList.clist ~selection_mode: `MULTIPLE - ~titles_show: false - ~packing: wscroll#add () + ~titles_show: false + ~packing: wscroll#add () | Some l -> GList.clist ~selection_mode: `MULTIPLE - ~titles: l - ~titles_show: true - ~packing: wscroll#add () + ~titles: l + ~titles_show: true + ~packing: wscroll#add () in let _ = set_help_tip wev help_opt in (* the vbox for the buttons *) @@ -146,18 +146,18 @@ class ['a] list_selection_box wlist#freeze (); wlist#clear (); List.iter - (fun ele -> - ignore (wlist#append (f_strings ele)); - match f_color ele with - None -> () - | Some c -> - try wlist#set_row ~foreground: (`NAME c) (wlist#rows - 1) - with _ -> () - ) - !listref; + (fun ele -> + ignore (wlist#append (f_strings ele)); + match f_color ele with + None -> () + | Some c -> + try wlist#set_row ~foreground: (`NAME c) (wlist#rows - 1) + with _ -> () + ) + !listref; (match titles_opt with - None -> wlist#columns_autosize () + None -> wlist#columns_autosize () | Some _ -> GToolbox.autosize_clist wlist); wlist#thaw (); (* the list of selectd elements is now empty *) @@ -166,18 +166,18 @@ class ['a] list_selection_box (** Move up the selected rows. *) method up_selected = let rec iter n selrows l = - match selrows with - [] -> (l, []) - | m :: qrows -> - match l with - [] -> ([],[]) - | [_] -> (l,[]) - | e1 :: e2 :: q when m = n + 1 -> - let newl, newrows = iter (n+1) qrows (e1 :: q) in - (e2 :: newl, n :: newrows) - | e1 :: q -> - let newl, newrows = iter (n+1) selrows q in - (e1 :: newl, newrows) + match selrows with + [] -> (l, []) + | m :: qrows -> + match l with + [] -> ([],[]) + | [_] -> (l,[]) + | e1 :: e2 :: q when m = n + 1 -> + let newl, newrows = iter (n+1) qrows (e1 :: q) in + (e2 :: newl, n :: newrows) + | e1 :: q -> + let newl, newrows = iter (n+1) selrows q in + (e1 :: newl, newrows) in let sorted_select = List.sort compare list_select in let new_list, new_rows = iter 0 sorted_select !listref in @@ -188,24 +188,24 @@ class ['a] list_selection_box method edit_selected f_edit = let sorted_select = List.sort compare list_select in match sorted_select with - [] -> () + [] -> () | n :: _ -> - try - let ele = List.nth !listref n in - let ele2 = f_edit ele in - let rec iter m = function - [] -> [] - | e :: q -> - if n = m then - ele2 :: q - else - e :: (iter (m+1) q) - in - self#update (iter 0 !listref); - wlist#select n 0 - with - Not_found -> - () + try + let ele = List.nth !listref n in + let ele2 = f_edit ele in + let rec iter m = function + [] -> [] + | e :: q -> + if n = m then + ele2 :: q + else + e :: (iter (m+1) q) + in + self#update (iter 0 !listref); + wlist#select n 0 + with + Not_found -> + () initializer @@ -228,14 +228,14 @@ class ['a] list_selection_box in let f_remove () = (* remove the selected items from the listref and the clist *) - let rec iter n = function - [] -> [] - | h :: q -> - if List.mem n list_select then - iter (n+1) q - else - h :: (iter (n+1) q) - in + let rec iter n = function + [] -> [] + | h :: q -> + if List.mem n list_select then + iter (n+1) q + else + h :: (iter (n+1) q) + in let new_list = iter 0 !listref in self#update new_list in @@ -248,10 +248,10 @@ class ['a] list_selection_box ignore (wb_up#connect#clicked ~callback:(fun () -> self#up_selected)); ( match f_edit_opt with - None -> () + None -> () | Some f -> - let _ = dbg "list_selection_box: connecting wb_edit" in - ignore (wb_edit#connect#clicked ~callback:(fun () -> self#edit_selected f)) + let _ = dbg "list_selection_box: connecting wb_edit" in + ignore (wb_edit#connect#clicked ~callback:(fun () -> self#edit_selected f)) ); (* connect the selection and deselection of items in the clist *) let f_select ~row ~column ~event = @@ -303,10 +303,10 @@ class string_param_box param = method apply = let new_value = param.string_of_string we#text in if new_value <> param.string_value then - let _ = param.string_f_apply new_value in - param.string_value <- new_value + let _ = param.string_f_apply new_value in + param.string_value <- new_value else - () + () end ;; (** This class is used to build a box for a combo parameter.*) @@ -318,16 +318,16 @@ class combo_param_box param = let _ = set_help_tip wev param.combo_help in let get_value = if not param.combo_new_allowed then let wc = GEdit.combo_box_text - ~strings: param.combo_choices - ?active:(let rec aux i = function - |[] -> None - |h::_ when h = param.combo_value -> Some i - |_::t -> aux (succ i) t - in aux 0 param.combo_choices) - ~packing: (hbox#pack ~expand: param.combo_expand ~padding: 2) - () + ~strings: param.combo_choices + ?active:(let rec aux i = function + |[] -> None + |h::_ when h = param.combo_value -> Some i + |_::t -> aux (succ i) t + in aux 0 param.combo_choices) + ~packing: (hbox#pack ~expand: param.combo_expand ~padding: 2) + () in - fun () -> match GEdit.text_combo_get_active wc with |None -> "" |Some s -> s + fun () -> match GEdit.text_combo_get_active wc with |None -> "" |Some s -> s else let (wc,_) = GEdit.combo_box_entry_text ~strings: param.combo_choices @@ -347,10 +347,10 @@ object (self) method apply = let new_value = get_value () in if new_value <> param.combo_value then - let _ = param.combo_f_apply new_value in - param.combo_value <- new_value + let _ = param.combo_f_apply new_value in + param.combo_value <- new_value else - () + () end ;; (** Class used to pack a custom box. *) @@ -360,9 +360,9 @@ class custom_param_box param = match param.custom_framed with None -> param.custom_box#coerce | Some l -> - let wf = GBin.frame ~label: l () in - wf#add param.custom_box#coerce; - wf#coerce + let wf = GBin.frame ~label: l () in + wf#add param.custom_box#coerce; + wf#coerce in object (self) method box = top @@ -401,13 +401,13 @@ class text_param_box param = method apply = let v = param.string_of_string (buffer#get_text ()) in if v <> param.string_value then - ( - dbg "apply new value!"; - let _ = param.string_f_apply v in - param.string_value <- v - ) + ( + dbg "apply new value!"; + let _ = param.string_f_apply v in + param.string_value <- v + ) else - () + () end ;; (** This class is used to build a box for a boolean parameter.*) @@ -430,10 +430,10 @@ class bool_param_box param = method apply = let new_value = wchk#active in if new_value <> param.bool_value then - let _ = param.bool_f_apply new_value in - param.bool_value <- new_value + let _ = param.bool_f_apply new_value in + param.bool_value <- new_value else - () + () end ;; class modifiers_param_box param = @@ -461,10 +461,10 @@ class modifiers_param_box param = method apply = let new_value = !value in if new_value <> param.md_value then - let _ = param.md_f_apply new_value in - param.md_value <- new_value + let _ = param.md_f_apply new_value in + param.md_value <- new_value else - () + () end ;; (* (** This class is used to build a box for a parameter whose values are a list.*) @@ -728,20 +728,20 @@ let list ?(editable=true) ?help label (f_strings : 'a -> string list) v = List_param (fun () -> - new list_param_box - { - list_label = label ; - list_help = help ; - list_value = v ; - list_editable = editable ; - list_titles = titles; - list_eq = eq ; - list_strings = f_strings ; - list_color = color ; - list_f_edit = edit ; - list_f_add = add ; - list_f_apply = f ; - } + new list_param_box + { + list_label = label ; + list_help = help ; + list_value = v ; + list_editable = editable ; + list_titles = titles; + list_eq = eq ; + list_strings = f_strings ; + list_color = color ; + list_f_edit = edit ; + list_f_add = add ; + list_f_apply = f ; + } ) (** Create a strings param. *) @@ -818,10 +818,10 @@ let question_box ~title ~buttons ?(default=1) ?icon ?parent message = in ignore (b#connect#clicked ~callback: (fun () -> button_nb := n; window#destroy ())); - (* If it's the first button then give it the focus *) + (* If it's the first button then give it the focus *) if n = default then b#grab_default () else (); - iter_buttons (n+1) q + iter_buttons (n+1) q in iter_buttons 1 buttons; ignore (window#connect#destroy ~callback: GMain.Main.quit); diff --git a/ide/configwin_types.ml b/ide/configwin_types.ml index 4c66a6944e..711eccd08e 100644 --- a/ide/configwin_types.ml +++ b/ide/configwin_types.ml @@ -114,8 +114,8 @@ type configuration_structure = (** To indicate what button was pushed by the user when the window is closed. *) type return_button = Return_apply (** The user clicked on Apply at least once before - closing the window with Cancel or the window manager. *) + closing the window with Cancel or the window manager. *) | Return_ok (** The user closed the window with the ok button. *) | Return_cancel (** The user closed the window with the cancel - button or the window manager but never clicked - on the apply button.*) + button or the window manager but never clicked + on the apply button.*) diff --git a/ide/coq.ml b/ide/coq.ml index 889cc3be36..4d6ba55d76 100644 --- a/ide/coq.ml +++ b/ide/coq.ml @@ -56,7 +56,7 @@ let rec read_all_lines in_chan = let len = String.length arg in let arg = if len > 0 && arg.[len - 1] = '\r' then - String.sub arg 0 (len - 1) + String.sub arg 0 (len - 1) else arg in arg::(read_all_lines in_chan) @@ -135,7 +135,7 @@ and asks_for_coqtop args = match file with | Some _ -> let () = custom_coqtop := file in - filter_coq_opts args + filter_coq_opts args | None -> exit 0 exception WrongExitStatus of string @@ -597,8 +597,8 @@ struct let opts = Hashtbl.fold mkopt current_state [] in eval_call (Xmlprotocol.set_options opts) h (function - | Interface.Good () -> k () - | _ -> failwith "Cannot set options. Resetting coqtop") + | Interface.Good () -> k () + | _ -> failwith "Cannot set options. Resetting coqtop") end diff --git a/ide/coqOps.ml b/ide/coqOps.ml index d52f038f1f..89425bda56 100644 --- a/ide/coqOps.ml +++ b/ide/coqOps.ml @@ -280,7 +280,7 @@ object(self) List.exists (fun m -> Gobject.get_oid m = Gobject.get_oid (buffer#get_mark s.start)) marks in - try Doc.find document mem_marks + try Doc.find document mem_marks with Not_found -> aux iter#backward_char in aux iter in let ss = @@ -293,7 +293,7 @@ object(self) script#misc#set_tooltip_text ""; script#misc#set_has_tooltip true end; false - + method destroy () = feedback_timer.Ideutils.kill () @@ -323,7 +323,7 @@ object(self) method private get_start_of_input = buffer#get_iter_at_mark (`NAME "start_of_input") - + method private get_end_of_input = buffer#get_iter_at_mark (`NAME "stop_of_input") @@ -697,7 +697,7 @@ object(self) method private find_id until = try Doc.find_id document (fun id { start;stop } -> until (Some id) start stop) - with Not_found -> initial_state, Doc.focused document + with Not_found -> initial_state, Doc.focused document method private cleanup seg = if seg <> [] then begin @@ -758,7 +758,7 @@ object(self) (Doc.focused document && Doc.is_in_focus document safe_id)) in undo to_id unfocus_needed) - + method private backtrack_until ?move_insert until = self#backtrack_to_id ?move_insert (self#find_id until) @@ -782,7 +782,7 @@ object(self) method backtrack_last_phrase = messages#default_route#clear; - try + try let tgt = Doc.before_tip document in self#backtrack_to_id tgt with Not_found -> Coq.return (Coq.reset_coqtop _ct) diff --git a/ide/coqOps.mli b/ide/coqOps.mli index 1e8d87bb15..58d69c0aaa 100644 --- a/ide/coqOps.mli +++ b/ide/coqOps.mli @@ -32,7 +32,7 @@ object method handle_failure : handle_exn_rty -> unit task - + method destroy : unit -> unit end diff --git a/ide/coqide.ml b/ide/coqide.ml index 14cd87e7b5..fc30690544 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -166,7 +166,7 @@ let load_file ?(maycreate=false) f = | [] -> false | sn :: sessions -> match sn.fileops#filename with - | Some fn when is_f fn -> notebook#goto_page i; true + | Some fn when is_f fn -> notebook#goto_page i; true | _ -> search_f (i+1) sessions in if not (search_f 0 notebook#pages) then begin @@ -257,7 +257,7 @@ let crash_save exitcode = in try if try_export filename (sn.buffer#get_text ()) then - Minilib.log ("Saved "^filename) + Minilib.log ("Saved "^filename) else Minilib.log ("Could not save "^filename) with _ -> Minilib.log ("Could not save "^filename) in @@ -461,8 +461,8 @@ let compile sn = |Some f -> let args = Coq.get_arguments sn.coqtop in let cmd = cmd_coqc#get - ^ " " ^ String.concat " " args - ^ " " ^ (Filename.quote f) ^ " 2>&1" + ^ " " ^ String.concat " " args + ^ " " ^ (Filename.quote f) ^ " 2>&1" in let buf = Buffer.create 1024 in sn.messages#default_route#set (Pp.str ("Running: "^cmd)); @@ -1040,7 +1040,7 @@ let build_ui () = item "Preferences" ~accel:"<Primary>comma" ~stock:`PREFERENCES ~callback:(fun _ -> begin - try Preferences.configure ~apply:refresh_notebook_pos w + try Preferences.configure ~apply:refresh_notebook_pos w with e -> flash_info ("Editing preferences failed (" ^ Printexc.to_string e ^ ")") end; diff --git a/ide/coqide_ui.ml b/ide/coqide_ui.ml index 452808490d..f056af6703 100644 --- a/ide/coqide_ui.ml +++ b/ide/coqide_ui.ml @@ -7,14 +7,14 @@ let list_items menu li = let tactic_item = function |[] -> Buffer.create 1 |[s] -> let b = Buffer.create 16 in - let () = Buffer.add_string b ("<menuitem action='"^menu^" "^(no_under s)^"' />\n") in - b + let () = Buffer.add_string b ("<menuitem action='"^menu^" "^(no_under s)^"' />\n") in + b |s::_ as l -> let b = Buffer.create 50 in - let () = (Buffer.add_string b ("<menu action='"^menu^" "^(String.make 1 s.[0])^"'>\n")) in - let () = (List.iter - (fun x -> Buffer.add_string b ("<menuitem action='"^menu^" "^(no_under x)^"' />\n")) l) in - let () = Buffer.add_string b"</menu>\n" in - b in + let () = (Buffer.add_string b ("<menu action='"^menu^" "^(String.make 1 s.[0])^"'>\n")) in + let () = (List.iter + (fun x -> Buffer.add_string b ("<menuitem action='"^menu^" "^(no_under x)^"' />\n")) l) in + let () = Buffer.add_string b"</menu>\n" in + b in let () = List.iter (fun b -> Buffer.add_buffer res_buf (tactic_item b)) li in res_buf diff --git a/ide/document.ml b/ide/document.ml index cee490861d..b8e8182ab2 100644 --- a/ide/document.ml +++ b/ide/document.ml @@ -64,7 +64,7 @@ let tip = function | { stack = [] } -> raise Empty | { stack = { state_id = Some id }::_ } -> id | { stack = { state_id = None }::_ } -> invalid_arg "tip" - + let tip_data = function | { stack = [] } -> raise Empty | { stack = { data }::_ } -> data @@ -89,19 +89,19 @@ let focus d ~cond_top:c_start ~cond_bot:c_stop = else aux (x::a,s,b) grab xs | { state_id = Some id; data } as x :: xs -> if c_stop id data then List.rev a, List.rev (x::s), xs - else aux (a,x::s,b) grab xs + else aux (a,x::s,b) grab xs | _ -> assert false in let a, s, b = aux ([],[],[]) false d.stack in d.stack <- s; d.context <- Some (a, b) - + let unfocus = function | { context = None } -> invalid_arg "unfocus" | { context = Some (a,b); stack } as d -> assert(invariant stack); d.context <- None; d.stack <- a @ stack @ b - + let focused { context } = context <> None let to_lists = function @@ -117,17 +117,17 @@ let find d f = try List.find (flat f true) s with Not_found -> List.find (flat f false) b ).data - + let find_map d f = let a, s, b = to_lists d in - try CList.find_map (flat f false) a with Not_found -> - try CList.find_map (flat f true) s with Not_found -> + try CList.find_map (flat f false) a with Not_found -> + try CList.find_map (flat f true) s with Not_found -> CList.find_map (flat f false) b - + let is_empty = function | { stack = []; context = None } -> true | _ -> false - + let context d = let top, _, bot = to_lists d in let pair _ x y = try Option.get x, y with Option.IsNone -> assert false in diff --git a/ide/document.mli b/ide/document.mli index eea250bd50..c0cc848bd7 100644 --- a/ide/document.mli +++ b/ide/document.mli @@ -11,7 +11,7 @@ (* An 'a document is a structure to hold and manipulate list of sentences. Sentences are equipped with an id = Stateid.t and can carry arbitrary data ('a). - + When added (push) to the document, a sentence has no id, it has be manually assigned just afterward or the sentence has to be removed (pop) before any other sentence can be pushed. @@ -21,7 +21,7 @@ sentence in question, and it is simpler if the sentence is in the document. Only the functions pop, find, fold_all and find_map can be called on a document with a tip that has no id (and assign_tip_id of course). - + The document can be focused (non recursively) to a zone. After that some functions operate on the focused zone only. When unfocused the context (the part of the document out of focus) is restored. diff --git a/ide/ideutils.ml b/ide/ideutils.ml index 4b156065f3..1cf065cf25 100644 --- a/ide/ideutils.ml +++ b/ide/ideutils.ml @@ -18,8 +18,8 @@ let warn_image () = img#set_icon_size `DIALOG; img -let warning msg = - GToolbox.message_box ~title:"Warning" ~icon:(warn_image ())#coerce msg +let warning msg = + GToolbox.message_box ~title:"Warning" ~icon:(warn_image ())#coerce msg let cb = GData.clipboard Gdk.Atom.primary @@ -212,15 +212,15 @@ let try_export file_name s = try match encoding#get with |Eutf8 -> Minilib.log "UTF-8 is enforced" ; s |Elocale -> - let is_unicode,char_set = Glib.Convert.get_charset () in - if is_unicode then - (Minilib.log "Locale is UTF-8" ; s) - else - (Minilib.log ("Locale is "^char_set); - Glib.Convert.convert_with_fallback + let is_unicode,char_set = Glib.Convert.get_charset () in + if is_unicode then + (Minilib.log "Locale is UTF-8" ; s) + else + (Minilib.log ("Locale is "^char_set); + Glib.Convert.convert_with_fallback ~from_codeset:"UTF-8" ~to_codeset:char_set s) |Emanual enc -> - (Minilib.log ("Manual charset is "^ enc); + (Minilib.log ("Manual charset is "^ enc); Glib.Convert.convert_with_fallback ~from_codeset:"UTF-8" ~to_codeset:enc s) with e -> @@ -279,9 +279,9 @@ let select_file_for_open ~title ?(filter=true) ?parent ?filename () = match file_chooser#run () with | `OPEN -> begin - match file_chooser#filename with - | None -> None - | Some _ as f -> + match file_chooser#filename with + | None -> None + | Some _ as f -> project_path#set file_chooser#current_folder; f end | `DELETE_EVENT | `CANCEL -> None in @@ -365,12 +365,12 @@ let coqtop_path () = if Sys.file_exists new_prog || CString.equal Filename.(basename new_prog) new_prog then new_prog - else - let in_macos_bundle = - Filename.concat - (Filename.dirname new_prog) - (Filename.concat "../Resources/bin" (Filename.basename new_prog)) - in if Sys.file_exists in_macos_bundle then in_macos_bundle + else + let in_macos_bundle = + Filename.concat + (Filename.dirname new_prog) + (Filename.concat "../Resources/bin" (Filename.basename new_prog)) + in if Sys.file_exists in_macos_bundle then in_macos_bundle else "coqidetop.opt" with Not_found -> "coqidetop.opt" in file diff --git a/ide/microPG.ml b/ide/microPG.ml index 7d8fd44a75..9492f1a77f 100644 --- a/ide/microPG.ml +++ b/ide/microPG.ml @@ -153,7 +153,7 @@ let run key gui action status = else (b#place_cursor ~where; script#scroll_mark_onscreen `INSERT); status -let emacs = empty +let emacs = empty let emacs = insert emacs "Emacs" [] [ (* motion *) @@ -214,7 +214,7 @@ let emacs = insert emacs "Emacs" [] [ let k = if i#ends_line then begin b#delete ~start:i ~stop:i#forward_char; "\n" - end else begin + end else begin let k = b#get_text ~start:i ~stop:i#forward_to_line_end () in b#delete ~start:i ~stop:i#forward_to_line_end; k end in @@ -265,7 +265,7 @@ let emacs = insert emacs "Emacs" [mC,_x,"x"] [ mkE _f "f" "Open" (Action("File", "Open")); mkE ~mods:[] _u "u" "Undo" (Action("Edit", "Undo")); ] - + let pg = insert emacs "Proof General" [mC,_c,"c"] [ mkE _Return "RET" "Go to" (Action("Navigation", "Go to")); mkE _n "n" "Advance 1 sentence" (Action("Navigation", "Forward")); diff --git a/ide/preferences.ml b/ide/preferences.ml index 7b667027fc..4ee5669877 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -735,13 +735,13 @@ let configure ?(apply=(fun () -> ())) parent = "Goal (∃n : nat, n ≤ 0)∧(∀x,y,z, x∈y⋃z↔x∈y∨x∈z)."; box#pack ~expand:true w#coerce; ignore (w#misc#connect#realize - ~callback:(fun () -> w#set_font_name text_font#get)); + ~callback:(fun () -> w#set_font_name text_font#get)); custom ~label:"Fonts for text" box (fun () -> - let fd = w#font_name in - text_font#set fd) + let fd = w#font_name in + text_font#set fd) true in @@ -863,7 +863,7 @@ let configure ?(apply=(fun () -> ())) parent = let global_auto_revert_delay = string ~f:(fun s -> global_auto_revert_delay#set - (try int_of_string s with _ -> 10000)) + (try int_of_string s with _ -> 10000)) "Global auto revert delay (ms)" (string_of_int global_auto_revert_delay#get) in @@ -872,7 +872,7 @@ let configure ?(apply=(fun () -> ())) parent = let auto_save_delay = string ~f:(fun s -> auto_save_delay#set - (try int_of_string s with _ -> 10000)) + (try int_of_string s with _ -> 10000)) "Auto save delay (ms)" (string_of_int auto_save_delay#get) in @@ -891,8 +891,8 @@ let configure ?(apply=(fun () -> ())) parent = ~f:(fun s -> encoding#set (inputenc_of_string s)) ~new_allowed: true ("UTF-8"::"LOCALE":: match encoding#get with - |Emanual s -> [s] - |_ -> [] + |Emanual s -> [s] + |_ -> [] ) (string_of_inputenc encoding#get) in @@ -1018,26 +1018,26 @@ let configure ?(apply=(fun () -> ())) parent = (shame on Benjamin) *) let cmds = [Section("Fonts", Some `SELECT_FONT, - [config_font]); + [config_font]); Section("Colors", Some `SELECT_COLOR, [config_color; source_language; source_style]); Section("Tags", Some `SELECT_COLOR, [config_tags]); Section("Editor", Some `EDIT, [config_editor]); Section("Files", Some `DIRECTORY, - [global_auto_revert;global_auto_revert_delay; - auto_save; auto_save_delay; (* auto_save_name*) - encodings; line_ending; - ]); + [global_auto_revert;global_auto_revert_delay; + auto_save; auto_save_delay; (* auto_save_name*) + encodings; line_ending; + ]); Section("Project", Some (`STOCK "gtk-page-setup"), - [project_file_name;read_project; - ]); + [project_file_name;read_project; + ]); Section("Appearance", Some `PREFERENCES, [window_width; window_height]); Section("Externals", None, - [cmd_coqtop;cmd_coqc;cmd_make;cmd_coqmakefile; cmd_coqdoc; + [cmd_coqtop;cmd_coqc;cmd_make;cmd_coqmakefile; cmd_coqdoc; cmd_print;cmd_editor;cmd_browse]); Section("Shortcuts", Some `PREFERENCES, - [modifiers_valid; modifier_for_tactics; + [modifiers_valid; modifier_for_tactics; modifier_for_templates; modifier_for_display; modifier_for_navigation; modifier_for_queries (*; user_queries *)]); Section("Misc", Some `ADD, diff --git a/ide/protocol/xml_lexer.mli b/ide/protocol/xml_lexer.mli index e61cb055f7..920de9f9c3 100644 --- a/ide/protocol/xml_lexer.mli +++ b/ide/protocol/xml_lexer.mli @@ -18,26 +18,26 @@ *) type error = - | EUnterminatedComment - | EUnterminatedString - | EIdentExpected - | ECloseExpected - | ENodeExpected - | EAttributeNameExpected - | EAttributeValueExpected - | EUnterminatedEntity + | EUnterminatedComment + | EUnterminatedString + | EIdentExpected + | ECloseExpected + | ENodeExpected + | EAttributeNameExpected + | EAttributeValueExpected + | EUnterminatedEntity exception Error of error type token = - | Tag of string * (string * string) list * bool - | PCData of string - | Endtag of string - | Eof + | Tag of string * (string * string) list * bool + | PCData of string + | Endtag of string + | Eof type pos = int * int * int * int -val init : Lexing.lexbuf -> unit +val init : Lexing.lexbuf -> unit val close : unit -> unit val token : Lexing.lexbuf -> token val pos : Lexing.lexbuf -> pos diff --git a/ide/session.ml b/ide/session.ml index 2824530c43..547c9814ff 100644 --- a/ide/session.ml +++ b/ide/session.ml @@ -149,7 +149,7 @@ let set_buffer_handlers let rec aux old it = if it#is_start then None else if it#has_tag Tags.Script.processed then Some old - else if it#has_tag Tags.Script.error_bg then aux it it#backward_char + else if it#has_tag Tags.Script.error_bg then aux it it#backward_char else None in aux it it in let insert_cb it s = if String.length s = 0 then () else begin @@ -207,8 +207,8 @@ let set_buffer_handlers to a point indicated by coq. *) if !no_coq_action_required then begin let start, stop = get_start (), get_stop () in - List.iter (fun tag -> buffer#remove_tag tag ~start ~stop) - Tags.Script.ephemere; + List.iter (fun tag -> buffer#remove_tag tag ~start ~stop) + Tags.Script.ephemere; Sentence.tag_on_insert buffer end; end in @@ -301,7 +301,7 @@ let create_errpage (script : Wg_ScriptView.script_view) : errpage = script#buffer#place_cursor ~where; script#misc#grab_focus (); ignore (script#scroll_to_iter - ~use_align:false ~yalign:0.75 ~within_margin:0.25 where)) in + ~use_align:false ~yalign:0.75 ~within_margin:0.25 where)) in let tip = GMisc.label ~text:"Double click to jump to error line" () in let box = GPack.vbox ~homogeneous:false () in let () = box#pack ~expand:true table#coerce in @@ -313,10 +313,10 @@ let create_errpage (script : Wg_ScriptView.script_view) : errpage = method update errs = if !last_update = errs then () else begin - last_update := errs; - access (fun _ store -> store#clear ()); + last_update := errs; + access (fun _ store -> store#clear ()); !callback errs; - List.iter (fun (lno, msg) -> access (fun columns store -> + List.iter (fun (lno, msg) -> access (fun columns store -> let line = store#append () in store#set ~row:line ~column:(find_int_col "Line" columns) lno; store#set ~row:line ~column:(find_string_col "Error message" columns) msg)) @@ -333,8 +333,8 @@ let create_jobpage coqtop coqops : jobpage = (fun columns store tp vc -> let row = store#get_iter tp in let w = store#get ~row ~column:(find_string_col "Worker" columns) in - let info () = Minilib.log ("Coq busy, discarding query") in - Coq.try_grab coqtop (coqops#stop_worker w) info + let info () = Minilib.log ("Coq busy, discarding query") in + Coq.try_grab coqtop (coqops#stop_worker w) info ) in let tip = GMisc.label ~text:"Double click to interrupt worker" () in let box = GPack.vbox ~homogeneous:false () in @@ -347,10 +347,10 @@ let create_jobpage coqtop coqops : jobpage = method update jobs = if !last_update = jobs then () else begin - last_update := jobs; - access (fun _ store -> store#clear ()); + last_update := jobs; + access (fun _ store -> store#clear ()); !callback jobs; - CString.Map.iter (fun id job -> access (fun columns store -> + CString.Map.iter (fun id job -> access (fun columns store -> let column = find_string_col "Worker" columns in if job = "Dead" then store#foreach (fun _ row -> diff --git a/ide/wg_Command.ml b/ide/wg_Command.ml index f1a2fa4f2a..dcae3e38a5 100644 --- a/ide/wg_Command.ml +++ b/ide/wg_Command.ml @@ -93,9 +93,9 @@ object(self) combo, entry, ok_b in let r_bin = GBin.scrolled_window - ~vpolicy:`AUTOMATIC - ~hpolicy:`AUTOMATIC - ~packing:(vbox#pack ~fill:true ~expand:true) () in + ~vpolicy:`AUTOMATIC + ~hpolicy:`AUTOMATIC + ~packing:(vbox#pack ~fill:true ~expand:true) () in let result = Wg_MessageView.message_view () in router#register_route route_id result; r_bin#add_with_viewport (result :> GObj.widget); diff --git a/ide/wg_Find.ml b/ide/wg_Find.ml index db99bc0439..c0ece1ecdc 100644 --- a/ide/wg_Find.ml +++ b/ide/wg_Find.ml @@ -11,9 +11,9 @@ let b2c = Ideutils.byte_offset_to_char_offset class finder name (view : GText.view) = - + let widget = Wg_Detachable.detachable - ~title:(Printf.sprintf "Find & Replace (%s)" name) () in + ~title:(Printf.sprintf "Find & Replace (%s)" name) () in let replace_box = GPack.grid (* ~columns:4 ~rows:2 *) ~col_homogeneous:false ~row_homogeneous:false ~packing:widget#add () in let hb = GPack.hbox ~packing:(replace_box#attach @@ -75,7 +75,7 @@ class finder name (view : GText.view) = if use_regex#active then if use_nocase#active then Str.regexp_case_fold rex else Str.regexp rex - else + else if use_nocase#active then Str.regexp_string_case_fold rex else Str.regexp_string rex @@ -94,7 +94,7 @@ class finder name (view : GText.view) = Some(view#buffer#start_iter#forward_chars (b2c text i), view#buffer#start_iter#forward_chars (b2c text j)) with Not_found -> None - + method private forward_search starti = let text = starti#get_text ~stop:view#buffer#end_iter in let regexp = self#regex in diff --git a/ide/wg_ScriptView.ml b/ide/wg_ScriptView.ml index 181418d3d8..769ce61ee1 100644 --- a/ide/wg_ScriptView.ml +++ b/ide/wg_ScriptView.ml @@ -494,10 +494,10 @@ object (self) let proceed = if not b && i = 1 then iter#editable ~default:true && - iter#forward_line#editable ~default:true + iter#forward_line#editable ~default:true else if not b && i = -1 then iter#editable ~default:true && - iter#backward_line#editable ~default:true + iter#backward_line#editable ~default:true else false in if not proceed then GtkSignal.stop_emit () @@ -539,13 +539,13 @@ let script_view ct ?(source_buffer:GSourceView3.source_buffer option) ?draw_spa GtkSourceView3.SourceView.make_params [] ~cont:( GtkText.View.make_params ~cont:( GContainer.pack_container ~create: - (fun pl -> - let w = match source_buffer with + (fun pl -> + let w = match source_buffer with | None -> GtkSourceView3.SourceView.new_ () | Some buf -> GtkSourceView3.SourceView.new_with_buffer (Gobject.try_cast buf#as_buffer "GtkSourceBuffer") - in - let w = Gobject.unsafe_cast w in - Gobject.set_params (Gobject.try_cast w "GtkSourceView") pl; + in + let w = Gobject.unsafe_cast w in + Gobject.set_params (Gobject.try_cast w "GtkSourceView") pl; Gaux.may ~f:(GtkSourceView3.SourceView.set_draw_spaces w) draw_spaces; - ((new script_view w ct) : script_view)))) + ((new script_view w ct) : script_view)))) diff --git a/interp/constrexpr.ml b/interp/constrexpr.ml index 49b9149675..b96ef7c4e5 100644 --- a/interp/constrexpr.ml +++ b/interp/constrexpr.ml @@ -41,7 +41,7 @@ type binder_kind = | Default of Glob_term.binding_kind | Generalized of Glob_term.binding_kind * bool (** (Inner binding always Implicit) Outer bindings, typeclass-specific flag - for implicit generalization of superclasses *) + for implicit generalization of superclasses *) type abstraction_kind = AbsLambda | AbsPi @@ -80,8 +80,8 @@ type cases_pattern_expr_r = | CPatOr of cases_pattern_expr list | CPatNotation of notation * cases_pattern_notation_substitution * cases_pattern_expr list (** CPatNotation (_, n, l1 ,l2) represents - (notation n applied with substitution l1) - applied to arguments l2 *) + (notation n applied with substitution l1) + applied to arguments l2 *) | CPatPrim of prim_token | CPatRecord of (qualid * cases_pattern_expr) list | CPatDelimiters of string * cases_pattern_expr @@ -127,7 +127,7 @@ and constr_expr = constr_expr_r CAst.t and case_expr = constr_expr (* expression that is being matched *) * lname option (* as-clause *) - * cases_pattern_expr option (* in-clause *) + * cases_pattern_expr option (* in-clause *) and branch_expr = (cases_pattern_expr list list * constr_expr) CAst.t diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 0a1371413a..0c247e2660 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -303,8 +303,8 @@ let drop_implicits_in_patt cst nb_expl args = in let rec aux = function |[] -> None |(_,imps)::t -> match impls_fit [] (imps,args) with - |None -> aux t - |x -> x + |None -> aux t + |x -> x in if Int.equal nb_expl 0 then aux impl_data else @@ -327,7 +327,7 @@ let make_notation_gen loc ntn mknot mkprim destprim l bl = assert (bl=[]); mknot (loc,ntn,([mknot (loc,(InConstrEntrySomeLevel,"( _ )"),l,[])]),[]) | _ -> - match decompose_notation_key ntn, l with + match decompose_notation_key ntn, l with | (InConstrEntrySomeLevel,[Terminal "-"; Terminal x]), [] -> begin match NumTok.of_string x with | Some n -> mkprim (loc, Numeral (SMinus,n)) @@ -378,7 +378,7 @@ let rec extern_cases_pattern_in_scope (custom,scopes as allscopes) vars pat = match availability_of_prim_token p sc scopes with | None -> raise No_match | Some key -> - let loc = cases_pattern_loc pat in + let loc = cases_pattern_loc pat in insert_pat_coercion ?loc coercion (insert_pat_alias ?loc (insert_pat_delimiters ?loc (CAst.make ?loc @@ CPatPrim p) key) na) with No_match -> @@ -398,40 +398,40 @@ let rec extern_cases_pattern_in_scope (custom,scopes as allscopes) vars pat = let pat = match pat with | PatVar (Name id) -> CAst.make ?loc (CPatAtom (Some (qualid_of_ident ?loc id))) | PatVar (Anonymous) -> CAst.make ?loc (CPatAtom None) - | PatCstr(cstrsp,args,na) -> + | PatCstr(cstrsp,args,na) -> let args = List.map (extern_cases_pattern_in_scope allscopes vars) args in - let p = - try + let p = + try if !Flags.raw_print then raise Exit; - let projs = Recordops.lookup_projections (fst cstrsp) in - let rec ip projs args acc = - match projs, args with - | [], [] -> acc - | proj :: q, pat :: tail -> + let projs = Recordops.lookup_projections (fst cstrsp) in + let rec ip projs args acc = + match projs, args with + | [], [] -> acc + | proj :: q, pat :: tail -> let acc = match proj, pat with - | _, { CAst.v = CPatAtom None } -> - (* we don't want to have 'x := _' in our patterns *) + | _, { CAst.v = CPatAtom None } -> + (* we don't want to have 'x := _' in our patterns *) acc - | Some c, _ -> + | Some c, _ -> ((extern_reference ?loc Id.Set.empty (GlobRef.ConstRef c), pat) :: acc) | _ -> raise No_match in ip q tail acc - | _ -> assert false - in - CPatRecord(List.rev (ip projs args [])) - with - Not_found | No_match | Exit -> + | _ -> assert false + in + CPatRecord(List.rev (ip projs args [])) + with + Not_found | No_match | Exit -> let c = extern_reference Id.Set.empty (GlobRef.ConstructRef cstrsp) in if Constrintern.get_asymmetric_patterns () then - if pattern_printable_in_both_syntax cstrsp - then CPatCstr (c, None, args) - else CPatCstr (c, Some (add_patt_for_params (fst cstrsp) args), []) - else - let full_args = add_patt_for_params (fst cstrsp) args in + if pattern_printable_in_both_syntax cstrsp + then CPatCstr (c, None, args) + else CPatCstr (c, Some (add_patt_for_params (fst cstrsp) args), []) + else + let full_args = add_patt_for_params (fst cstrsp) args in match drop_implicits_in_patt (GlobRef.ConstructRef cstrsp) 0 full_args with - | Some true_args -> CPatCstr (c, None, true_args) - | None -> CPatCstr (c, Some full_args, []) + | Some true_args -> CPatCstr (c, None, true_args) + | None -> CPatCstr (c, Some full_args, []) in insert_pat_alias ?loc (CAst.make ?loc p) na in @@ -450,23 +450,23 @@ and apply_notation_to_pattern ?loc gr ((subst,substlist),(nb_to_drop,more_args)) | None -> raise No_match (* Uninterpretation is allowed in current context *) | Some (scopt,key) -> - let scopes' = Option.List.cons scopt scopes in - let l = + let scopes' = Option.List.cons scopt scopes in + let l = List.map (fun (c,(subentry,(scopt,scl))) -> extern_cases_pattern_in_scope (subentry,(scopt,scl@scopes')) vars c) - subst in - let ll = + subst in + let ll = List.map (fun (c,(subentry,(scopt,scl))) -> let subscope = (subentry,(scopt,scl@scopes')) in - List.map (extern_cases_pattern_in_scope subscope vars) c) - substlist in - let l2 = List.map (extern_cases_pattern_in_scope allscopes vars) more_args in + List.map (extern_cases_pattern_in_scope subscope vars) c) + substlist in + let l2 = List.map (extern_cases_pattern_in_scope allscopes vars) more_args in let l2' = if Constrintern.get_asymmetric_patterns () || not (List.is_empty ll) then l2 - else - match drop_implicits_in_patt gr nb_to_drop l2 with - |Some true_args -> true_args - |None -> raise No_match - in + else + match drop_implicits_in_patt gr nb_to_drop l2 with + |Some true_args -> true_args + |None -> raise No_match + in insert_pat_coercion coercion (insert_pat_delimiters ?loc (make_pat_notation ?loc ntn (l,ll) l2') key) @@ -482,10 +482,10 @@ and apply_notation_to_pattern ?loc gr ((subst,substlist),(nb_to_drop,more_args)) subst in let l2 = List.map (extern_cases_pattern_in_scope allscopes vars) more_args in let l2' = if Constrintern.get_asymmetric_patterns () then l2 - else - match drop_implicits_in_patt gr (nb_to_drop + List.length l1) l2 with - |Some true_args -> true_args - |None -> raise No_match + else + match drop_implicits_in_patt gr (nb_to_drop + List.length l1) l2 with + |Some true_args -> true_args + |None -> raise No_match in assert (List.is_empty substlist); insert_pat_coercion ?loc coercion (mkPat ?loc qid (List.rev_append l1 l2')) @@ -500,8 +500,8 @@ and extern_notation_pattern allscopes vars t = function let t = if na = Anonymous then t else DAst.make ?loc (PatCstr (cstr,args,Anonymous)) in let p = apply_notation_to_pattern ?loc (GlobRef.ConstructRef cstr) (match_notation_constr_cases_pattern t pat) allscopes vars keyrule in - insert_pat_alias ?loc p na - | PatVar Anonymous -> CAst.make ?loc @@ CPatAtom None + insert_pat_alias ?loc p na + | PatVar Anonymous -> CAst.make ?loc @@ CPatAtom None | PatVar (Name id) -> CAst.make ?loc @@ CPatAtom (Some (qualid_of_ident ?loc id)) with No_match -> extern_notation_pattern allscopes vars t rules @@ -532,8 +532,8 @@ let extern_ind_pattern_in_scope (custom,scopes as allscopes) vars ind args = let c = extern_reference vars (GlobRef.IndRef ind) in let args = List.map (extern_cases_pattern_in_scope allscopes vars) args in match drop_implicits_in_patt (GlobRef.IndRef ind) 0 args with - |Some true_args -> CAst.make @@ CPatCstr (c, None, true_args) - |None -> CAst.make @@ CPatCstr (c, Some args, []) + |Some true_args -> CAst.make @@ CPatCstr (c, None, true_args) + |None -> CAst.make @@ CPatCstr (c, Some args, []) let extern_cases_pattern vars p = extern_cases_pattern_in_scope (InConstrEntrySomeLevel,(None,[])) vars p @@ -554,8 +554,8 @@ let is_projection nargs = function | Some r when not !Flags.in_debugger && not !Flags.raw_print && !print_projections -> (try let n = Recordops.find_projection_nparams r + 1 in - if n <= nargs then Some n - else None + if n <= nargs then Some n + else None with Not_found -> None) | _ -> None @@ -581,23 +581,23 @@ let explicitize inctx impl (cf,f) args = !Flags.raw_print || (!print_implicits && !print_implicits_explicit_args) || (is_needed_for_correct_partial_application tail imp) || - (!print_implicits_defensive && - (not (is_inferable_implicit inctx n imp) || !Flags.beautify) && - is_significant_implicit (Lazy.force a)) - in + (!print_implicits_defensive && + (not (is_inferable_implicit inctx n imp) || !Flags.beautify) && + is_significant_implicit (Lazy.force a)) + in if visible then (Lazy.force a,Some (make @@ ExplByName (name_of_implicit imp))) :: tail - else - tail + else + tail | a::args, _::impl -> (Lazy.force a,None) :: exprec (q+1) (args,impl) | args, [] -> List.map (fun a -> (Lazy.force a,None)) args (*In case of polymorphism*) - | [], (imp :: _) when is_status_implicit imp && maximal_insertion_of imp -> + | [], (imp :: _) when is_status_implicit imp && maximal_insertion_of imp -> (* The non-explicit application cannot be parsed back with the same type *) raise Expl | [], _ -> [] in let ip = is_projection (List.length args) cf in - let expl () = + let expl () = match ip with | Some i -> (* Careful: It is possible to have declared implicits ending @@ -609,12 +609,12 @@ let explicitize inctx impl (cf,f) args = if is_impl then raise Expl else - let (args1,args2) = List.chop i args in + let (args1,args2) = List.chop i args in let (impl1,impl2) = try List.chop i impl with Failure _ -> impl, [] in - let args1 = exprec 1 (args1,impl1) in - let args2 = exprec (i+1) (args2,impl2) in - let ip = Some (List.length args1) in - CApp ((ip,f),args1@args2) + let args1 = exprec 1 (args1,impl1) in + let args2 = exprec (i+1) (args2,impl2) in + let ip = Some (List.length args1) in + CApp ((ip,f),args1@args2) | None -> let args = exprec 1 (args,impl) in if List.is_empty args then f.CAst.v else @@ -625,10 +625,10 @@ let explicitize inctx impl (cf,f) args = CApp (g,args'@args) | _ -> CApp ((None, f), args) in try expl () - with Expl -> + with Expl -> let f',us = match f with { CAst.v = CRef (f,us) } -> f,us | _ -> assert false in let ip = if !print_projections then ip else None in - CAppExpl ((ip, f', us), List.map Lazy.force args) + CAppExpl ((ip, f', us), List.map Lazy.force args) let is_start_implicit = function | imp :: _ -> is_status_implicit imp && maximal_insertion_of imp @@ -679,22 +679,22 @@ let rec remove_coercions inctx c = | Some (loc,r,pars,args) when not (!Flags.raw_print || !print_coercions) -> let nargs = List.length args in (try match Classops.hide_coercion r with - | Some n when (n - pars) < nargs && (inctx || (n - pars)+1 < nargs) -> - (* We skip a coercion *) - let l = List.skipn (n - pars) args in - let (a,l) = match l with a::l -> (a,l) | [] -> assert false in + | Some n when (n - pars) < nargs && (inctx || (n - pars)+1 < nargs) -> + (* We skip a coercion *) + let l = List.skipn (n - pars) args in + let (a,l) = match l with a::l -> (a,l) | [] -> assert false in (* Recursively remove the head coercions *) - let a' = remove_coercions true a in - (* Don't flatten App's in case of funclass so that - (atomic) notations on [a] work; should be compatible - since printer does not care whether App's are - collapsed or not and notations with an implicit - coercion using funclass either would have already - been confused with ordinary application or would have need + let a' = remove_coercions true a in + (* Don't flatten App's in case of funclass so that + (atomic) notations on [a] work; should be compatible + since printer does not care whether App's are + collapsed or not and notations with an implicit + coercion using funclass either would have already + been confused with ordinary application or would have need a surrounding context and the coercion to funclass would have been made explicit to match *) - if List.is_empty l then a' else DAst.make ?loc @@ GApp (a',l) - | _ -> c + if List.is_empty l then a' else DAst.make ?loc @@ GApp (a',l) + | _ -> c with Not_found -> c) | _ -> c @@ -841,58 +841,58 @@ let rec extern inctx scopes vars r = | GApp (f,args) -> (match DAst.get f with - | GRef (ref,us) -> - let subscopes = find_arguments_scope ref in + | GRef (ref,us) -> + let subscopes = find_arguments_scope ref in let args = fill_arg_scopes args subscopes scopes in - begin - try + begin + try if !Flags.raw_print then raise Exit; let cstrsp = match ref with GlobRef.ConstructRef c -> c | _ -> raise Not_found in - let struc = Recordops.lookup_structure (fst cstrsp) in + let struc = Recordops.lookup_structure (fst cstrsp) in if PrintingRecord.active (fst cstrsp) then () else if PrintingConstructor.active (fst cstrsp) then raise Exit else if not (get_record_print ()) then raise Exit; - let projs = struc.Recordops.s_PROJ in - let locals = struc.Recordops.s_PROJKIND in - let rec cut args n = - if Int.equal n 0 then args - else - match args with - | [] -> raise No_match - | _ :: t -> cut t (n - 1) in - let args = cut args struc.Recordops.s_EXPECTEDPARAM in - let rec ip projs locs args acc = - match projs with - | [] -> acc - | None :: q -> raise No_match - | Some c :: q -> - match locs with - | [] -> anomaly (Pp.str "projections corruption [Constrextern.extern].") + let projs = struc.Recordops.s_PROJ in + let locals = struc.Recordops.s_PROJKIND in + let rec cut args n = + if Int.equal n 0 then args + else + match args with + | [] -> raise No_match + | _ :: t -> cut t (n - 1) in + let args = cut args struc.Recordops.s_EXPECTEDPARAM in + let rec ip projs locs args acc = + match projs with + | [] -> acc + | None :: q -> raise No_match + | Some c :: q -> + match locs with + | [] -> anomaly (Pp.str "projections corruption [Constrextern.extern].") | { Recordops.pk_true_proj = false } :: locs' -> - (* we don't want to print locals *) - ip q locs' args acc + (* we don't want to print locals *) + ip q locs' args acc | { Recordops.pk_true_proj = true } :: locs' -> - match args with - | [] -> raise No_match - (* we give up since the constructor is not complete *) - | (arg, scopes) :: tail -> + match args with + | [] -> raise No_match + (* we give up since the constructor is not complete *) + | (arg, scopes) :: tail -> let head = extern true scopes vars arg in ip q locs' tail ((extern_reference ?loc Id.Set.empty (GlobRef.ConstRef c), head) :: acc) - in - CRecord (List.rev (ip projs locals args [])) - with - | Not_found | No_match | Exit -> + in + CRecord (List.rev (ip projs locals args [])) + with + | Not_found | No_match | Exit -> let args = extern_args (extern true) vars args in - extern_app inctx - (select_stronger_impargs (implicits_of_global ref)) + extern_app inctx + (select_stronger_impargs (implicits_of_global ref)) (Some ref,extern_reference ?loc vars ref) (extern_universes us) args - end + end - | _ -> - explicitize inctx [] (None,sub_extern false scopes vars f) + | _ -> + explicitize inctx [] (None,sub_extern false scopes vars f) (List.map (fun c -> lazy (sub_extern true scopes vars c)) args)) | GLetIn (na,b,t,c) -> @@ -911,7 +911,7 @@ let rec extern inctx scopes vars r = | GCases (sty,rtntypopt,tml,eqns) -> let vars' = List.fold_right (Name.fold_right Id.Set.add) - (cases_predicate_names tml) vars in + (cases_predicate_names tml) vars in let rtntypopt' = Option.map (extern_typ scopes vars') rtntypopt in let tml = List.map (fun (tm,(na,x)) -> let na' = match na, DAst.get tm with @@ -954,9 +954,9 @@ let rec extern inctx scopes vars r = | GRec (fk,idv,blv,tyv,bv) -> let vars' = Array.fold_right Id.Set.add idv vars in (match fk with - | GFix (nv,n) -> - let listdecl = - Array.mapi (fun i fi -> + | GFix (nv,n) -> + let listdecl = + Array.mapi (fun i fi -> let (bl,ty,def) = blv.(i), tyv.(i), bv.(i) in let bl = List.map (extended_glob_local_binder_of_decl ?loc) bl in let (assums,ids,bl) = extern_local_binder scopes vars bl in @@ -969,10 +969,10 @@ let rec extern inctx scopes vars r = in ((CAst.make fi), n, bl, extern_typ scopes vars0 ty, extern false scopes vars1 def)) idv - in + in CFix (CAst.(make ?loc idv.(n)), Array.to_list listdecl) - | GCoFix n -> - let listdecl = + | GCoFix n -> + let listdecl = Array.mapi (fun i fi -> let bl = List.map (extended_glob_local_binder_of_decl ?loc) blv.(i) in let (_,ids,bl) = extern_local_binder scopes vars bl in @@ -980,7 +980,7 @@ let rec extern inctx scopes vars r = let vars1 = List.fold_right (Name.fold_right Id.Set.add) ids vars' in ((CAst.make fi),bl,extern_typ scopes vars0 tyv.(i), sub_extern false scopes vars1 bv.(i))) idv - in + in CCoFix (CAst.(make ?loc idv.(n)),Array.to_list listdecl)) | GSort s -> CSort (extern_glob_sort s) @@ -1102,44 +1102,44 @@ and extern_notation (custom,scopes as allscopes) vars t = function let loc = Glob_ops.loc_of_glob_constr t in try if is_inactive_rule keyrule then raise No_match; - (* Adjusts to the number of arguments expected by the notation *) - let (t,args,argsscopes,argsimpls) = match DAst.get t ,n with - | GApp (f,args), Some n - when List.length args >= n -> - let args1, args2 = List.chop n args in + (* Adjusts to the number of arguments expected by the notation *) + let (t,args,argsscopes,argsimpls) = match DAst.get t ,n with + | GApp (f,args), Some n + when List.length args >= n -> + let args1, args2 = List.chop n args in let subscopes, impls = match DAst.get f with | GRef (ref,us) -> - let subscopes = - try List.skipn n (find_arguments_scope ref) + let subscopes = + try List.skipn n (find_arguments_scope ref) with Failure _ -> [] in - let impls = - let impls = - select_impargs_size - (List.length args) (implicits_of_global ref) in - try List.skipn n impls with Failure _ -> [] in + let impls = + let impls = + select_impargs_size + (List.length args) (implicits_of_global ref) in + try List.skipn n impls with Failure _ -> [] in subscopes,impls | _ -> [], [] in - (if Int.equal n 0 then f else DAst.make @@ GApp (f,args1)), - args2, subscopes, impls - | GApp (f, args), None -> + (if Int.equal n 0 then f else DAst.make @@ GApp (f,args1)), + args2, subscopes, impls + | GApp (f, args), None -> begin match DAst.get f with | GRef (ref,us) -> - let subscopes = find_arguments_scope ref in - let impls = - select_impargs_size - (List.length args) (implicits_of_global ref) in - f, args, subscopes, impls + let subscopes = find_arguments_scope ref in + let impls = + select_impargs_size + (List.length args) (implicits_of_global ref) in + f, args, subscopes, impls | _ -> t, [], [], [] end - | GRef (ref,us), Some 0 -> DAst.make @@ GApp (t,[]), [], [], [] + | GRef (ref,us), Some 0 -> DAst.make @@ GApp (t,[]), [], [], [] | _, None -> t, [], [], [] | _ -> raise No_match in - (* Try matching ... *) + (* Try matching ... *) let terms,termlists,binders,binderlists = match_notation_constr !print_universes t pat in - (* Try availability of interpretation ... *) + (* Try availability of interpretation ... *) let e = match keyrule with | NotationRule (sc,ntn) -> @@ -1152,12 +1152,12 @@ and extern_notation (custom,scopes as allscopes) vars t = function (* Uninterpretation is allowed in current context *) | Some (scopt,key) -> let scopes' = Option.List.cons scopt (snd scopes) in - let l = + let l = List.map (fun (c,(subentry,(scopt,scl))) -> - extern (* assuming no overloading: *) true + extern (* assuming no overloading: *) true (subentry,(scopt,scl@scopes')) vars c) terms in - let ll = + let ll = List.map (fun (c,(subentry,(scopt,scl))) -> List.map (extern true (subentry,(scopt,scl@scopes')) vars) c) termlists in @@ -1174,17 +1174,17 @@ and extern_notation (custom,scopes as allscopes) vars t = function match availability_of_entry_coercion custom InConstrEntrySomeLevel with | None -> raise No_match | Some coercion -> - let l = + let l = List.map (fun (c,(subentry,(scopt,scl))) -> extern true (subentry,(scopt,scl@snd scopes)) vars c, None) - terms in + terms in let a = CRef (Nametab.shortest_qualid_of_syndef ?loc vars kn,None) in insert_coercion coercion (CAst.make ?loc @@ if List.is_empty l then a else CApp ((None, CAst.make a),l)) in - if List.is_empty args then e - else + if List.is_empty args then e + else let args = fill_arg_scopes args argsscopes allscopes in - let args = extern_args (extern true) vars args in - CAst.make ?loc @@ explicitize false argsimpls (None,e) args + let args = extern_args (extern true) vars args in + CAst.make ?loc @@ explicitize false argsimpls (None,e) args with No_match -> extern_notation allscopes vars t rules @@ -1255,15 +1255,15 @@ let rec glob_of_pat avoid env sigma pat = DAst.make @@ match pat with GEvar (id,List.map (on_snd (glob_of_pat avoid env sigma)) l) | PRel n -> let id = try match lookup_name_of_rel n env with - | Name id -> id - | Anonymous -> - anomaly ~label:"glob_constr_of_pattern" (Pp.str "index to an anonymous variable.") + | Name id -> id + | Anonymous -> + anomaly ~label:"glob_constr_of_pattern" (Pp.str "index to an anonymous variable.") with Not_found -> Id.of_string ("_UNBOUND_REL_"^(string_of_int n)) in GVar id | PMeta None -> GHole (Evar_kinds.InternalHole, IntroAnonymous,None) | PMeta (Some n) -> GPatVar (Evar_kinds.FirstOrderPatVar n) | PProj (p,c) -> GApp (DAst.make @@ GRef (GlobRef.ConstRef (Projection.constant p),None), - [glob_of_pat avoid env sigma c]) + [glob_of_pat avoid env sigma c]) | PApp (f,args) -> GApp (glob_of_pat avoid env sigma f,Array.map_to_list (glob_of_pat avoid env sigma) args) | PSoApp (n,args) -> @@ -1290,19 +1290,19 @@ let rec glob_of_pat avoid env sigma pat = DAst.make @@ match pat with GLetTuple (nal,(Anonymous,None),glob_of_pat avoid env sigma tm,b) | PCase (info,p,tm,bl) -> let mat = match bl, info.cip_ind with - | [], _ -> [] - | _, Some ind -> - let bl' = List.map (fun (i,n,c) -> (i,n,glob_of_pat avoid env sigma c)) bl in - simple_cases_matrix_of_branches ind bl' - | _, None -> anomaly (Pp.str "PCase with some branches but unknown inductive.") + | [], _ -> [] + | _, Some ind -> + let bl' = List.map (fun (i,n,c) -> (i,n,glob_of_pat avoid env sigma c)) bl in + simple_cases_matrix_of_branches ind bl' + | _, None -> anomaly (Pp.str "PCase with some branches but unknown inductive.") in let mat = if info.cip_extensible then mat @ [any_any_branch] else mat in let indnames,rtn = match p, info.cip_ind, info.cip_ind_tags with - | PMeta None, _, _ -> (Anonymous,None),None - | _, Some ind, Some nargs -> - return_type_of_predicate ind nargs (glob_of_pat avoid env sigma p) - | _ -> anomaly (Pp.str "PCase with non-trivial predicate but unknown inductive.") + | PMeta None, _, _ -> (Anonymous,None),None + | _, Some ind, Some nargs -> + return_type_of_predicate ind nargs (glob_of_pat avoid env sigma p) + | _ -> anomaly (Pp.str "PCase with non-trivial predicate but unknown inductive.") in GCases (Constr.RegularStyle,rtn,[glob_of_pat avoid env sigma tm,indnames],mat) | PFix ((ln,i),(lna,tl,bl)) -> diff --git a/interp/constrextern.mli b/interp/constrextern.mli index 7b8b93377b..e22dd2be86 100644 --- a/interp/constrextern.mli +++ b/interp/constrextern.mli @@ -32,7 +32,7 @@ val extern_closed_glob : ?lax:bool -> bool -> env -> Evd.evar_map -> closed_glob (** If [b=true] in [extern_constr b env c] then the variables in the first level of quantification clashing with the variables in [env] are renamed. - ~lax is for debug printing, when the constr might not be well typed in + ~lax is for debug printing, when the constr might not be well typed in env, sigma *) diff --git a/interp/constrintern.ml b/interp/constrintern.ml index f2cb4ae5c7..57e2214293 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -279,7 +279,7 @@ let error_inconsistent_scope ?loc id scopes1 scopes2 = pr_scope_stack scopes1) let error_expect_binder_notation_type ?loc id = - user_err ?loc + user_err ?loc (Id.print id ++ str " is expected to occur in binding position in the right-hand side.") @@ -299,7 +299,7 @@ let set_var_scope ?loc id istermvar (tmp_scope,subscopes as scopes) ntnvars = in match typ with | Notation_term.NtnInternTypeOnlyBinder -> - if istermvar then error_expect_binder_notation_type ?loc id + if istermvar then error_expect_binder_notation_type ?loc id | Notation_term.NtnInternTypeAny -> () with Not_found -> (* Not in a notation *) @@ -319,8 +319,8 @@ let mkGLambda ?loc (na,bk,t) body = DAst.make ?loc @@ GLambda (na, bk, t, body) (* Utilities for binders *) let build_impls = function |Implicit -> (function - |Name id -> Some (id, Impargs.Manual, (true,true)) - |Anonymous -> Some (Id.of_string "_", Impargs.Manual, (true,true))) + |Name id -> Some (id, Impargs.Manual, (true,true)) + |Anonymous -> Some (Id.of_string "_", Impargs.Manual, (true,true))) |Explicit -> fun _ -> None let impls_type_list ?(args = []) = @@ -335,7 +335,7 @@ let impls_term_list ?(args = []) = | GRec (fix_kind, nas, args, tys, bds) -> let nb = match fix_kind with |GFix (_, n) -> n | GCoFix n -> n in let acc' = List.fold_left (fun a (na, bk, _, _) -> (build_impls bk na)::a) acc args.(nb) in - aux acc' bds.(nb) + aux acc' bds.(nb) |_ -> (Variable,[],List.append args (List.rev acc),[]) in aux [] @@ -351,9 +351,9 @@ let rec check_capture ty = let open CAst in function let locate_if_hole ?loc na c = match DAst.get c with | GHole (_,naming,arg) -> (try match na with - | Name id -> glob_constr_of_notation_constr ?loc - (Reserve.find_reserved_type id) - | Anonymous -> raise Not_found + | Name id -> glob_constr_of_notation_constr ?loc + (Reserve.find_reserved_type id) + | Anonymous -> raise Not_found with Not_found -> DAst.make ?loc @@ GHole (Evar_kinds.BinderType na, naming, arg)) | _ -> c @@ -416,13 +416,13 @@ let intern_generalized_binder intern_type ntnvars let na = match na with | Anonymous -> let name = - let id = - match ty with + let id = + match ty with | { v = CApp ((_, { v = CRef (qid,_) } ), _) } when qualid_is_ident qid -> qualid_basename qid - | _ -> default_non_dependent_ident - in Implicit_quantifiers.make_fresh ids' (Global.env ()) id - in Name name + | _ -> default_non_dependent_ident + in Implicit_quantifiers.make_fresh ids' (Global.env ()) id + in Name name | _ -> na in (push_name_env ntnvars (impls_type_list ty')(*?*) env' (make ?loc na)), (make ?loc (na,b',ty')) :: List.rev bl @@ -437,7 +437,7 @@ let intern_assumption intern ntnvars env nal bk ty = (fun (env, bl) ({loc;v=na} as locna) -> (push_name_env ntnvars impls env locna, (make ?loc (na,k,locate_if_hole ?loc na ty))::bl)) - (env, []) nal + (env, []) nal | Generalized (b',t) -> let env, b = intern_generalized_binder intern_type ntnvars env (List.hd nal) b' t ty in env, b @@ -501,9 +501,9 @@ let intern_generalization intern env ntnvars loc bk ak c = let env', c' = let abs = let pi = match ak with - | Some AbsPi -> true + | Some AbsPi -> true | Some _ -> false - | None -> + | None -> match Notation.current_type_scope_name () with | Some type_scope -> let is_type_scope = match env.tmp_scope with @@ -514,18 +514,18 @@ let intern_generalization intern env ntnvars loc bk ak c = String.List.mem type_scope env.scopes | None -> false in - if pi then + if pi then (fun {loc=loc';v=id} acc -> DAst.make ?loc:(Loc.merge_opt loc' loc) @@ GProd (Name id, bk, DAst.make ?loc:loc' @@ GHole (Evar_kinds.BinderType (Name id), IntroAnonymous, None), acc)) - else + else (fun {loc=loc';v=id} acc -> DAst.make ?loc:(Loc.merge_opt loc' loc) @@ GLambda (Name id, bk, DAst.make ?loc:loc' @@ GHole (Evar_kinds.BinderType (Name id), IntroAnonymous, None), acc)) in List.fold_right (fun ({loc;v=id} as lid) (env, acc) -> let env' = push_name_env ntnvars (Variable,[],[],[]) env CAst.(make @@ Name id) in - (env', abs lid acc)) fvs (env,c) + (env', abs lid acc)) fvs (env,c) in c' let rec expand_binders ?loc mk bl c = @@ -708,7 +708,7 @@ let instantiate_notation_constr loc intern intern_pat ntnvars subst infos c = with Not_found -> try let (bl,(scopt,subscopes)) = Id.Map.find x binderlists in - let env,bl' = List.fold_left (intern_local_binder_aux intern ntnvars) (env,[]) bl in + let env,bl' = List.fold_left (intern_local_binder_aux intern ntnvars) (env,[]) bl in terms_of_binders (if revert then bl' else List.rev bl'),(None,[]) with Not_found -> anomaly (Pp.str "Inconsistent substitution of recursive notation.") in @@ -970,10 +970,10 @@ let find_appl_head_data c = begin match DAst.get r with | GRef (ref,_) when l != [] -> let n = List.length l in - let impls = implicits_of_global ref in + let impls = implicits_of_global ref in let scopes = find_arguments_scope ref in - c, List.map (drop_first_implicits n) impls, - List.skipn_at_least n scopes,[] + c, List.map (drop_first_implicits n) impls, + List.skipn_at_least n scopes,[] | _ -> c,[],[],[] end | _ -> c,[],[],[] @@ -1084,8 +1084,8 @@ let intern_applied_reference ~isproj intern env namedctx (_, ntnvars as lvar) us try let r, realref, args2 = intern_qualid ~no_secvar:true qid intern env ntnvars us args in check_applied_projection isproj realref qid; - let x, imp, scopes, l = find_appl_head_data r in - (x,imp,scopes,l), args2 + let x, imp, scopes, l = find_appl_head_data r in + (x,imp,scopes,l), args2 with Not_found -> (* Extra allowance for non globalizing functions *) if !interning_grammar || env.unb then @@ -1169,9 +1169,9 @@ let loc_of_lhs lhs = let check_linearity lhs ids = match has_duplicate ids with | Some id -> - raise (InternalizationError (loc_of_lhs lhs,NonLinearPattern id)) + raise (InternalizationError (loc_of_lhs lhs,NonLinearPattern id)) | None -> - () + () (* Match the number of pattern against the number of matched args *) let check_number_of_pattern loc n l = @@ -1247,9 +1247,9 @@ let add_implicits_check_length fail nargs nargs_with_letin impls_st len_pl1 pl2 let remaining_args = List.fold_left (fun i x -> if is_status_implicit x then i else succ i) in let rec aux i = function |[],l -> let args_len = List.length l + List.length impl_list + len_pl1 in - ((if Int.equal args_len nargs then false - else Int.equal args_len nargs_with_letin || (fst (fail (nargs - List.length impl_list + i)))) - ,l) + ((if Int.equal args_len nargs then false + else Int.equal args_len nargs_with_letin || (fst (fail (nargs - List.length impl_list + i)))) + ,l) |imp::q as il,[] -> if is_status_implicit imp && maximal_insertion_of imp then let (b,out) = aux i (q,[]) in (b,(DAst.make @@ RCPatAtom None)::out) else fail (remaining_args (len_pl1+i) il) @@ -1489,7 +1489,7 @@ let product_of_cases_patterns aliases idspl = (* Cartesian prod of the or-pats for the nth arg and the tail args *) List.flatten ( List.map (fun (subst,p) -> - List.map (fun (subst',ptail) -> (merge_subst subst subst',p::ptail)) ptaill) pl))) + List.map (fun (subst',ptail) -> (merge_subst subst subst',p::ptail)) ptaill) pl))) idspl (aliases.alias_ids,[aliases.alias_map,[]]) let rec subst_pat_iterator y t = DAst.(map (function @@ -1497,7 +1497,7 @@ let rec subst_pat_iterator y t = DAst.(map (function begin match id with Some ({v=x},_) when Id.equal x y -> DAst.get t | _ -> p end | RCPatCstr (id,l1,l2) -> RCPatCstr (id,List.map (subst_pat_iterator y t) l1, - List.map (subst_pat_iterator y t) l2) + List.map (subst_pat_iterator y t) l2) | RCPatAlias (p,a) -> RCPatAlias (subst_pat_iterator y t p,a) | RCPatOr pl -> RCPatOr (List.map (subst_pat_iterator y t) pl))) @@ -1550,34 +1550,34 @@ let drop_notations_pattern looked_for genv = | SynDef sp -> let filter (vars,a) = try match a with - | NRef g -> + | NRef g -> (* Convention: do not deactivate implicit arguments and scopes for further arguments *) - test_kind top g; - let () = assert (List.is_empty vars) in - let (_,argscs) = find_remaining_scopes [] pats g in - Some (g, [], List.map2 (in_pat_sc scopes) argscs pats) - | NApp (NRef g,[]) -> (* special case: Syndef for @Cstr, this deactivates *) - test_kind top g; + test_kind top g; + let () = assert (List.is_empty vars) in + let (_,argscs) = find_remaining_scopes [] pats g in + Some (g, [], List.map2 (in_pat_sc scopes) argscs pats) + | NApp (NRef g,[]) -> (* special case: Syndef for @Cstr, this deactivates *) + test_kind top g; let () = assert (List.is_empty vars) in - Some (g, List.map (in_pat false scopes) pats, []) - | NApp (NRef g,args) -> + Some (g, List.map (in_pat false scopes) pats, []) + | NApp (NRef g,args) -> (* Convention: do not deactivate implicit arguments and scopes for further arguments *) - test_kind top g; - let nvars = List.length vars in + test_kind top g; + let nvars = List.length vars in if List.length pats < nvars then error_not_enough_arguments ?loc:qid.loc; - let pats1,pats2 = List.chop nvars pats in - let subst = make_subst vars pats1 in + let pats1,pats2 = List.chop nvars pats in + let subst = make_subst vars pats1 in let idspl1 = List.map (in_not false qid.loc scopes (subst, Id.Map.empty) []) args in - let (_,argscs) = find_remaining_scopes pats1 pats2 g in - Some (g, idspl1, List.map2 (in_pat_sc scopes) argscs pats2) + let (_,argscs) = find_remaining_scopes pats1 pats2 g in + Some (g, idspl1, List.map2 (in_pat_sc scopes) argscs pats2) | _ -> raise Not_found with Not_found -> None in Syntax_def.search_filtered_syntactic_definition filter sp | TrueGlobal g -> - test_kind top g; + test_kind top g; Dumpglob.add_glob ?loc:qid.loc g; - let (_,argscs) = find_remaining_scopes [] pats g in - Some (g,[],List.map2 (fun x -> in_pat false (x,snd scopes)) argscs pats) + let (_,argscs) = find_remaining_scopes [] pats g in + Some (g,[],List.map2 (fun x -> in_pat false (x,snd scopes)) argscs pats) with Not_found -> None and in_pat top scopes pt = let open CAst in @@ -1588,25 +1588,25 @@ let drop_notations_pattern looked_for genv = let sorted_fields = sort_fields ~complete:false loc l (fun _idx fieldname constructor -> CAst.make ?loc @@ CPatAtom None) in begin match sorted_fields with - | None -> DAst.make ?loc @@ RCPatAtom None - | Some (n, head, pl) -> + | None -> DAst.make ?loc @@ RCPatAtom None + | Some (n, head, pl) -> let pl = if get_asymmetric_patterns () then pl else let pars = List.make n (CAst.make ?loc @@ CPatAtom None) in List.rev_append pars pl in - match drop_syndef top scopes head pl with - | Some (a,b,c) -> DAst.make ?loc @@ RCPatCstr(a, b, c) - | None -> raise (InternalizationError (loc,NotAConstructor head)) + match drop_syndef top scopes head pl with + | Some (a,b,c) -> DAst.make ?loc @@ RCPatCstr(a, b, c) + | None -> raise (InternalizationError (loc,NotAConstructor head)) end | CPatCstr (head, None, pl) -> begin - match drop_syndef top scopes head pl with - | Some (a,b,c) -> DAst.make ?loc @@ RCPatCstr(a, b, c) - | None -> raise (InternalizationError (loc,NotAConstructor head)) + match drop_syndef top scopes head pl with + | Some (a,b,c) -> DAst.make ?loc @@ RCPatCstr(a, b, c) + | None -> raise (InternalizationError (loc,NotAConstructor head)) end | CPatCstr (qid, Some expl_pl, pl) -> let g = try Nametab.locate qid - with Not_found -> + with Not_found -> raise (InternalizationError (loc,NotAConstructor qid)) in if expl_pl == [] then (* Convention: (@r) deactivates all further implicit arguments and scopes *) @@ -1635,8 +1635,8 @@ let drop_notations_pattern looked_for genv = rcp_of_glob scopes pat | CPatAtom (Some id) -> begin - match drop_syndef top scopes id [] with - | Some (a,b,c) -> DAst.make ?loc @@ RCPatCstr (a, b, c) + match drop_syndef top scopes id [] with + | Some (a,b,c) -> DAst.make ?loc @@ RCPatCstr (a, b, c) | None -> DAst.make ?loc @@ RCPatAtom (Some ((make ?loc @@ find_pattern_variable id),scopes)) end | CPatAtom None -> DAst.make ?loc @@ RCPatAtom None @@ -1659,14 +1659,14 @@ let drop_notations_pattern looked_for genv = | NVar id -> let () = assert (List.is_empty args) in begin - (* subst remembers the delimiters stack in the interpretation *) - (* of the notations *) - try - let (a,(scopt,subscopes)) = Id.Map.find id subst in - in_pat top (scopt,subscopes@snd scopes) a - with Not_found -> + (* subst remembers the delimiters stack in the interpretation *) + (* of the notations *) + try + let (a,(scopt,subscopes)) = Id.Map.find id subst in + in_pat top (scopt,subscopes@snd scopes) a + with Not_found -> if Id.equal id ldots_var then DAst.make ?loc @@ RCPatAtom (Some ((make ?loc id),scopes)) else - anomaly (str "Unbound pattern notation variable: " ++ Id.print id ++ str ".") + anomaly (str "Unbound pattern notation variable: " ++ Id.print id ++ str ".") end | NRef g -> ensure_kind top loc g; @@ -1679,13 +1679,13 @@ let drop_notations_pattern looked_for genv = let pl = add_local_defs_and_check_length loc genv g pl args in DAst.make ?loc @@ RCPatCstr (g, pl @ List.map (in_pat false scopes) args, []) | NList (x,y,iter,terminator,revert) -> - if not (List.is_empty args) then user_err ?loc + if not (List.is_empty args) then user_err ?loc (strbrk "Application of arguments to a recursive notation not supported in patterns."); (try (* All elements of the list are in scopes (scopt,subscopes) *) - let (l,(scopt,subscopes)) = Id.Map.find x substlist in + let (l,(scopt,subscopes)) = Id.Map.find x substlist in let termin = in_not top loc scopes fullsubst [] terminator in - List.fold_right (fun a t -> + List.fold_right (fun a t -> let nsubst = Id.Map.add y (a, (scopt, subscopes)) subst in let u = in_not false loc scopes (nsubst, substlist) [] iter in subst_pat_iterator ldots_var t u) @@ -1713,15 +1713,15 @@ let rec intern_pat genv ntnvars aliases pat = | RCPatCstr (head, expl_pl, pl) -> if get_asymmetric_patterns () then let len = if List.is_empty expl_pl then Some (List.length pl) else None in - let c,idslpl1 = find_constructor loc len head in - let with_letin = - check_constructor_length genv loc c (List.length idslpl1 + List.length expl_pl) pl in - intern_cstr_with_all_args loc c with_letin idslpl1 (expl_pl@pl) + let c,idslpl1 = find_constructor loc len head in + let with_letin = + check_constructor_length genv loc c (List.length idslpl1 + List.length expl_pl) pl in + intern_cstr_with_all_args loc c with_letin idslpl1 (expl_pl@pl) else - let c,idslpl1 = find_constructor loc None head in - let with_letin, pl2 = - add_implicits_check_constructor_length genv loc c (List.length idslpl1 + List.length expl_pl) pl in - intern_cstr_with_all_args loc c with_letin idslpl1 (expl_pl@pl2) + let c,idslpl1 = find_constructor loc None head in + let with_letin, pl2 = + add_implicits_check_constructor_length genv loc c (List.length idslpl1 + List.length expl_pl) pl in + intern_cstr_with_all_args loc c with_letin idslpl1 (expl_pl@pl2) | RCPatAtom (Some ({loc;v=id},scopes)) -> let aliases = merge_aliases aliases (make ?loc @@ Name id) in set_var_scope ?loc id false scopes ntnvars; @@ -1756,7 +1756,7 @@ let intern_ind_pattern genv ntnvars scopes pat = | RCPatCstr (head, expl_pl, pl) -> let c = (function GlobRef.IndRef ind -> ind | _ -> error_bad_inductive_type ?loc) head in let with_letin, pl2 = add_implicits_check_ind_length genv loc c - (List.length expl_pl) pl in + (List.length expl_pl) pl in let idslpl = List.map (intern_pat genv ntnvars empty_alias) (expl_pl@pl2) in (with_letin, match product_of_cases_patterns empty_alias idslpl with @@ -1775,7 +1775,7 @@ let merge_impargs l args = List.fold_right (fun a l -> match a with | (_, Some {v=ExplByName id as x}) when - List.exists (test x) args -> l + List.exists (test x) args -> l | _ -> a::l) l args @@ -1807,30 +1807,30 @@ let extract_explicit_arg imps args = match e with | None -> (eargs,a::rargs) | Some {loc;v=pos} -> - let id = match pos with - | ExplByName id -> - if not (exists_implicit_name id imps) then - user_err ?loc - (str "Wrong argument name: " ++ Id.print id ++ str "."); - if Id.Map.mem id eargs then - user_err ?loc (str "Argument name " ++ Id.print id - ++ str " occurs more than once."); - id - | ExplByPos (p,_id) -> - let id = - try - let imp = List.nth imps (p-1) in - if not (is_status_implicit imp) then failwith "imp"; - name_of_implicit imp - with Failure _ (* "nth" | "imp" *) -> - user_err ?loc - (str"Wrong argument position: " ++ int p ++ str ".") - in - if Id.Map.mem id eargs then - user_err ?loc (str"Argument at position " ++ int p ++ - str " is mentioned more than once."); - id in - (Id.Map.add id (loc, a) eargs, rargs) + let id = match pos with + | ExplByName id -> + if not (exists_implicit_name id imps) then + user_err ?loc + (str "Wrong argument name: " ++ Id.print id ++ str "."); + if Id.Map.mem id eargs then + user_err ?loc (str "Argument name " ++ Id.print id + ++ str " occurs more than once."); + id + | ExplByPos (p,_id) -> + let id = + try + let imp = List.nth imps (p-1) in + if not (is_status_implicit imp) then failwith "imp"; + name_of_implicit imp + with Failure _ (* "nth" | "imp" *) -> + user_err ?loc + (str"Wrong argument position: " ++ int p ++ str ".") + in + if Id.Map.mem id eargs then + user_err ?loc (str"Argument at position " ++ int p ++ + str " is mentioned more than once."); + id in + (Id.Map.add id (loc, a) eargs, rargs) in aux args (**********************************************************************) @@ -1839,11 +1839,11 @@ let extract_explicit_arg imps args = let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = let rec intern env = CAst.with_loc_val (fun ?loc -> function | CRef (ref,us) -> - let (c,imp,subscopes,l),_ = + let (c,imp,subscopes,l),_ = intern_applied_reference ~isproj:None intern env (Environ.named_context_val globalenv) lvar us [] ref - in - apply_impargs c env imp subscopes l loc + in + apply_impargs c env imp subscopes l loc | CFix ({ CAst.loc = locid; v = iddef}, dl) -> let lf = List.map (fun ({CAst.v = id},_,_,_,_) -> id) dl in @@ -1890,11 +1890,11 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = | CCoFix ({ CAst.loc = locid; v = iddef }, dl) -> let lf = List.map (fun ({CAst.v = id},_,_,_) -> id) dl in let dl = Array.of_list dl in - let n = + let n = try List.index0 Id.equal iddef lf with Not_found -> - raise (InternalizationError (locid,UnboundFixName (true,iddef))) - in + raise (InternalizationError (locid,UnboundFixName (true,iddef))) + in let idl_tmp = Array.map (fun ({ CAst.loc; v = id },bl,ty,_) -> let (env',rbl) = List.fold_left intern_local_binder (env,[]) bl in @@ -1910,8 +1910,8 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = (* We add the binders common to body and type to the environment *) let env_body = restore_binders_impargs env_rec bl_impls in (b,c,intern {env_body with tmp_scope = None} bd)) dl idl_tmp in - DAst.make ?loc @@ - GRec (GCoFix n, + DAst.make ?loc @@ + GRec (GCoFix n, Array.of_list lf, Array.map (fun (bl,_,_) -> bl) idl, Array.map (fun (_,ty,_) -> ty) idl, @@ -1925,9 +1925,9 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = let (env',bl) = List.fold_left intern_local_binder (reset_tmp_scope env,[]) bl in expand_binders ?loc mkGLambda bl (intern env' c2) | CLetIn (na,c1,t,c2) -> - let inc1 = intern (reset_tmp_scope env) c1 in - let int = Option.map (intern_type env) t in - DAst.make ?loc @@ + let inc1 = intern (reset_tmp_scope env) c1 in + let int = Option.map (intern_type env) t in + DAst.make ?loc @@ GLetIn (na.CAst.v, inc1, int, intern (push_name_env ntnvars (impls_term_list inc1) env na) c2) | CNotation ((InConstrEntrySomeLevel,"- _"), ([a],[],[],[])) when is_non_zero a -> @@ -1939,16 +1939,16 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = | CGeneralization (b,a,c) -> intern_generalization intern env ntnvars loc b a c | CPrim p -> - fst (Notation.interp_prim_token ?loc p (env.tmp_scope,env.scopes)) + fst (Notation.interp_prim_token ?loc p (env.tmp_scope,env.scopes)) | CDelimiters (key, e) -> - intern {env with tmp_scope = None; - scopes = find_delimiters_scope ?loc key :: env.scopes} e + intern {env with tmp_scope = None; + scopes = find_delimiters_scope ?loc key :: env.scopes} e | CAppExpl ((isproj,ref,us), args) -> let (f,_,args_scopes,_),args = - let args = List.map (fun a -> (a,None)) args in + let args = List.map (fun a -> (a,None)) args in intern_applied_reference ~isproj intern env (Environ.named_context_val globalenv) lvar us args ref - in + in (* Rem: GApp(_,f,[]) stands for @f *) if args = [] then DAst.make ?loc @@ GApp (f,[]) else smart_gapp f loc (intern_args env args_scopes (List.map fst args)) @@ -1960,24 +1960,24 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = isproj',f,args'@args (* Don't compact "(f args') args" to resolve implicits separately *) | _ -> isproj,f,args in - let (c,impargs,args_scopes,l),args = + let (c,impargs,args_scopes,l),args = match f.CAst.v with - | CRef (ref,us) -> + | CRef (ref,us) -> intern_applied_reference ~isproj intern env (Environ.named_context_val globalenv) lvar us args ref | CNotation (ntn,([],[],[],[])) -> assert (Option.is_empty isproj); let c = intern_notation intern env ntnvars loc ntn ([],[],[],[]) in let x, impl, scopes, l = find_appl_head_data c in - (x,impl,scopes,l), args + (x,impl,scopes,l), args | _ -> assert (Option.is_empty isproj); (intern env f,[],[],[]), args in apply_impargs c env impargs args_scopes - (merge_impargs l args) loc + (merge_impargs l args) loc | CRecord fs -> let st = Evar_kinds.Define (not (Program.get_proofs_transparency ())) in let fields = - sort_fields ~complete:true loc fs + sort_fields ~complete:true loc fs (fun _idx fieldname constructorname -> let open Evar_kinds in let fieldinfo : Evar_kinds.record_field = @@ -1990,13 +1990,13 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = }) , IntroAnonymous, None)) in begin - match fields with - | None -> user_err ?loc ~hdr:"intern" (str"No constructor inference.") - | Some (n, constrname, args) -> + match fields with + | None -> user_err ?loc ~hdr:"intern" (str"No constructor inference.") + | Some (n, constrname, args) -> let pars = List.make n (CAst.make ?loc @@ CHole (None, IntroAnonymous, None)) in let app = CAst.make ?loc @@ CAppExpl ((None, constrname,None), List.rev_append pars args) in - intern env app - end + intern env app + end | CCases (sty, rtnpo, tms, eqns) -> let as_in_vars = List.fold_left (fun acc (_,na,inb) -> (Option.fold_left (fun acc { CAst.v = y } -> Name.fold_right Id.Set.add y acc) acc na)) @@ -2014,25 +2014,25 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = tms ([],Id.Set.empty,Id.Map.empty,[]) in let env' = Id.Set.fold (fun var bli -> push_name_env ntnvars (Variable,[],[],[]) bli (CAst.make @@ Name var)) - (Id.Set.union ex_ids as_in_vars) (reset_hidden_inductive_implicit_test env) in + (Id.Set.union ex_ids as_in_vars) (reset_hidden_inductive_implicit_test env) in (* PatVars before a real pattern do not need to be matched *) let stripped_match_from_in = let rec aux = function - | [] -> [] - | (_, c) :: q when is_patvar c -> aux q - | l -> l - in aux match_from_in in + | [] -> [] + | (_, c) :: q when is_patvar c -> aux q + | l -> l + in aux match_from_in in let rtnpo = Option.map (replace_vars_constr_expr aliases) rtnpo in let rtnpo = match stripped_match_from_in with - | [] -> Option.map (intern_type env') rtnpo (* Only PatVar in "in" clauses *) - | l -> + | [] -> Option.map (intern_type env') rtnpo (* Only PatVar in "in" clauses *) + | l -> (* Build a return predicate by expansion of the patterns of the "in" clause *) let thevars, thepats = List.split l in let sub_rtn = (* Some (GSort (Loc.ghost,GType None)) *) None in let sub_tms = List.map (fun id -> (DAst.make @@ GVar id),(Name id,None)) thevars (* "match v1,..,vn" *) in let main_sub_eqn = CAst.make @@ ([],thepats, (* "|p1,..,pn" *) - Option.cata (intern_type env') + Option.cata (intern_type env') (DAst.make ?loc @@ GHole(Evar_kinds.CasesType false,IntroAnonymous,None)) rtnpo) (* "=> P" if there were a return predicate P, and "=> _" otherwise *) in let catch_all_sub_eqn = @@ -2040,19 +2040,19 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = [CAst.make @@ ([],List.make (List.length thepats) (DAst.make @@ PatVar Anonymous), (* "|_,..,_" *) DAst.make @@ GHole(Evar_kinds.ImpossibleCase,IntroAnonymous,None))] (* "=> _" *) in Some (DAst.make @@ GCases(RegularStyle,sub_rtn,sub_tms,main_sub_eqn::catch_all_sub_eqn)) - in + in let eqns' = List.map (intern_eqn (List.length tms) env) eqns in - DAst.make ?loc @@ - GCases (sty, rtnpo, tms, List.flatten eqns') + DAst.make ?loc @@ + GCases (sty, rtnpo, tms, List.flatten eqns') | CLetTuple (nal, (na,po), b, c) -> - let env' = reset_tmp_scope env in - (* "in" is None so no match to add *) + let env' = reset_tmp_scope env in + (* "in" is None so no match to add *) let ((b',(na',_)),_,_) = intern_case_item env' Id.Set.empty (b,na,None) in let p' = Option.map (fun u -> - let env'' = push_name_env ntnvars (Variable,[],[],[]) (reset_hidden_inductive_implicit_test env') + let env'' = push_name_env ntnvars (Variable,[],[],[]) (reset_hidden_inductive_implicit_test env') (CAst.make na') in - intern_type env'' u) po in - DAst.make ?loc @@ + intern_type env'' u) po in + DAst.make ?loc @@ GLetTuple (List.map (fun { CAst.v } -> v) nal, (na', p'), b', intern (List.fold_left (push_name_env ntnvars (Variable,[],[],[])) (reset_hidden_inductive_implicit_test env) nal) c) | CIf (c, (na,po), b1, b2) -> @@ -2061,8 +2061,8 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = let p' = Option.map (fun p -> let env'' = push_name_env ntnvars (Variable,[],[],[]) (reset_hidden_inductive_implicit_test env) (CAst.make na') in - intern_type env'' p) po in - DAst.make ?loc @@ + intern_type env'' p) po in + DAst.make ?loc @@ GIf (c', (na', p'), intern env b1, intern env b2) | CHole (k, naming, solve) -> let k = match k with @@ -2099,28 +2099,28 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = let (_, glb) = Genintern.generic_intern ist gen in Some glb in - DAst.make ?loc @@ - GHole (k, naming, solve) + DAst.make ?loc @@ + GHole (k, naming, solve) (* Parsing pattern variables *) | CPatVar n when pattern_mode -> - DAst.make ?loc @@ - GPatVar (Evar_kinds.SecondOrderPatVar n) + DAst.make ?loc @@ + GPatVar (Evar_kinds.SecondOrderPatVar n) | CEvar (n, []) when pattern_mode -> - DAst.make ?loc @@ - GPatVar (Evar_kinds.FirstOrderPatVar n) + DAst.make ?loc @@ + GPatVar (Evar_kinds.FirstOrderPatVar n) (* end *) (* Parsing existential variables *) | CEvar (n, l) -> - DAst.make ?loc @@ - GEvar (n, List.map (on_snd (intern env)) l) + DAst.make ?loc @@ + GEvar (n, List.map (on_snd (intern env)) l) | CPatVar _ -> raise (InternalizationError (loc,IllegalMetavariable)) (* end *) | CSort s -> - DAst.make ?loc @@ - GSort s + DAst.make ?loc @@ + GSort s | CCast (c1, c2) -> - DAst.make ?loc @@ + DAst.make ?loc @@ GCast (intern env c1, map_cast_type (intern_type env) c2) ) and intern_type env = intern (set_type_scope env) @@ -2172,26 +2172,26 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = | Some t -> let with_letin,(ind,ind_ids,alias_subst,l) = intern_ind_pattern globalenv ntnvars (None,env.scopes) t in - let (mib,mip) = Inductive.lookup_mind_specif globalenv ind in - let nparams = (List.length (mib.Declarations.mind_params_ctxt)) in - (* for "in Vect n", we answer (["n","n"],[(loc,"n")]) - - for "in Vect (S n)", we answer ((match over "m", relevant branch is "S - n"), abstract over "m") = ([("m","S n")],[(loc,"m")]) where "m" is - generated from the canonical name of the inductive and outside of - {forbidden_names_for_gen} *) - let (match_to_do,nal) = - let rec canonize_args case_rel_ctxt arg_pats forbidden_names match_acc var_acc = - let add_name l = function + let (mib,mip) = Inductive.lookup_mind_specif globalenv ind in + let nparams = (List.length (mib.Declarations.mind_params_ctxt)) in + (* for "in Vect n", we answer (["n","n"],[(loc,"n")]) + + for "in Vect (S n)", we answer ((match over "m", relevant branch is "S + n"), abstract over "m") = ([("m","S n")],[(loc,"m")]) where "m" is + generated from the canonical name of the inductive and outside of + {forbidden_names_for_gen} *) + let (match_to_do,nal) = + let rec canonize_args case_rel_ctxt arg_pats forbidden_names match_acc var_acc = + let add_name l = function | { CAst.v = Anonymous } -> l | { CAst.loc; v = (Name y as x) } -> (y, DAst.make ?loc @@ PatVar x) :: l in - match case_rel_ctxt,arg_pats with - (* LetIn in the rel_context *) - | LocalDef _ :: t, l when not with_letin -> + match case_rel_ctxt,arg_pats with + (* LetIn in the rel_context *) + | LocalDef _ :: t, l when not with_letin -> canonize_args t l forbidden_names match_acc ((CAst.make Anonymous)::var_acc) - | [],[] -> - (add_name match_acc na, var_acc) - | (LocalAssum (cano_name,ty) | LocalDef (cano_name,_,ty)) :: t, c::tt -> + | [],[] -> + (add_name match_acc na, var_acc) + | (LocalAssum (cano_name,ty) | LocalDef (cano_name,_,ty)) :: t, c::tt -> begin match DAst.get c with | PatVar x -> let loc = c.CAst.loc in @@ -2203,10 +2203,10 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = canonize_args t tt (Id.Set.add fresh forbidden_names) ((fresh,c)::match_acc) ((CAst.make ?loc:(cases_pattern_loc c) @@ Name fresh)::var_acc) end - | _ -> assert false in - let _,args_rel = - List.chop nparams (List.rev mip.Declarations.mind_arity_ctxt) in - canonize_args args_rel l forbidden_names_for_gen [] [] in + | _ -> assert false in + let _,args_rel = + List.chop nparams (List.rev mip.Declarations.mind_arity_ctxt) in + canonize_args args_rel l forbidden_names_for_gen [] [] in (Id.Set.of_list (List.map (fun id -> id.CAst.v) ind_ids),alias_subst,match_to_do), Some (CAst.make ?loc:(cases_pattern_expr_loc t) (ind,List.rev_map (fun x -> x.v) nal)) | None -> @@ -2223,33 +2223,33 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = let (enva,subscopes') = apply_scope_env env subscopes in match (impl,rargs) with | (imp::impl', rargs) when is_status_implicit imp -> - begin try - let id = name_of_implicit imp in - let (_,a) = Id.Map.find id eargs in - let eargs' = Id.Map.remove id eargs in - intern enva a :: aux (n+1) impl' subscopes' eargs' rargs - with Not_found -> - if List.is_empty rargs && Id.Map.is_empty eargs && not (maximal_insertion_of imp) then + begin try + let id = name_of_implicit imp in + let (_,a) = Id.Map.find id eargs in + let eargs' = Id.Map.remove id eargs in + intern enva a :: aux (n+1) impl' subscopes' eargs' rargs + with Not_found -> + if List.is_empty rargs && Id.Map.is_empty eargs && not (maximal_insertion_of imp) then (* Less regular arguments than expected: complete *) (* with implicit arguments if maximal insertion is set *) - [] - else + [] + else (DAst.map_from_loc (fun ?loc (a,b,c) -> GHole(a,b,c)) (set_hole_implicit (n,get_implicit_name n l) (force_inference_of imp) c) ) :: aux (n+1) impl' subscopes' eargs rargs - end + end | (imp::impl', a::rargs') -> - intern enva a :: aux (n+1) impl' subscopes' eargs rargs' + intern enva a :: aux (n+1) impl' subscopes' eargs rargs' | (imp::impl', []) -> - if not (Id.Map.is_empty eargs) then - (let (id,(loc,_)) = Id.Map.choose eargs in + if not (Id.Map.is_empty eargs) then + (let (id,(loc,_)) = Id.Map.choose eargs in user_err ?loc (str "Not enough non implicit \ - arguments to accept the argument bound to " ++ - Id.print id ++ str".")); - [] + arguments to accept the argument bound to " ++ + Id.print id ++ str".")); + [] | ([], rargs) -> - assert (Id.Map.is_empty eargs); - intern_args env subscopes rargs + assert (Id.Map.is_empty eargs); + intern_args env subscopes rargs in aux 1 l subscopes eargs rargs and apply_impargs c env imp subscopes l loc = @@ -2276,8 +2276,8 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = intern env c with InternalizationError (loc,e) -> - user_err ?loc ~hdr:"internalize" - (explain_internalization_error e) + user_err ?loc ~hdr:"internalize" + (explain_internalization_error e) (**************************************************************************) (* Functions to translate constr_expr into glob_constr *) @@ -2304,8 +2304,8 @@ let intern_gen kind env sigma c = let tmp_scope = scope_of_type_kind sigma kind in internalize env {ids = extract_ids env; unb = false; - tmp_scope = tmp_scope; scopes = []; - impls = impls} + tmp_scope = tmp_scope; scopes = []; + impls = impls} pattern_mode (ltacvars, Id.Map.empty) c let intern_constr env sigma c = intern_gen WithoutTypeConstraint env sigma c @@ -2315,7 +2315,7 @@ let intern_pattern globalenv patt = intern_cases_pattern globalenv Id.Map.empty (None,[]) empty_alias patt with InternalizationError (loc,e) -> - user_err ?loc ~hdr:"internalize" (explain_internalization_error e) + user_err ?loc ~hdr:"internalize" (explain_internalization_error e) (*********************************************************************) @@ -2427,11 +2427,11 @@ let intern_context env impl_env binders = try let lvar = (empty_ltac_sign, Id.Map.empty) in let lenv, bl = List.fold_left - (fun (lenv, bl) b -> + (fun (lenv, bl) b -> let (env, bl) = intern_local_binder_aux (my_intern_constr env lvar) Id.Map.empty (lenv, bl) b in - (env, bl)) - ({ids = extract_ids env; unb = false; - tmp_scope = None; scopes = []; impls = impl_env}, []) binders in + (env, bl)) + ({ids = extract_ids env; unb = false; + tmp_scope = None; scopes = []; impls = impl_env}, []) binders in (lenv.impls, List.map glob_local_binder_of_extended bl) with InternalizationError (loc,e) -> user_err ?loc ~hdr:"internalize" (explain_internalization_error e) @@ -2443,20 +2443,20 @@ let interp_glob_context_evars ?(program_mode=false) env sigma k bl = List.fold_left (fun (env,sigma,params,n,impls) (na, k, b, t) -> let t' = - if Option.is_empty b then locate_if_hole ?loc:(loc_of_glob_constr t) na t - else t + if Option.is_empty b then locate_if_hole ?loc:(loc_of_glob_constr t) na t + else t in let sigma, t = understand_tcc ~flags env sigma ~expected_type:IsType t' in - match b with + match b with None -> let r = Retyping.relevance_of_type env sigma t in let d = LocalAssum (make_annot na r,t) in let impls = if k == Implicit then CAst.make (Some (na,true)) :: impls else CAst.make None :: impls - in + in (push_rel d env, sigma, d::params, succ n, impls) - | Some b -> + | Some b -> let sigma, c = understand_tcc ~flags env sigma ~expected_type:(OfType t) b in let r = Retyping.relevance_of_type env sigma t in let d = LocalDef (make_annot na r, c, t) in diff --git a/interp/constrintern.mli b/interp/constrintern.mli index 2e7b832e55..8cce7cd9af 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -150,7 +150,7 @@ val interp_reference : ltac_sign -> qualid -> glob_constr (** Interpret binders *) -val interp_binder : env -> evar_map -> Name.t -> constr_expr -> +val interp_binder : env -> evar_map -> Name.t -> constr_expr -> types Evd.in_evar_universe_context val interp_binder_evars : env -> evar_map -> Name.t -> constr_expr -> evar_map * types @@ -162,7 +162,7 @@ val interp_context_evars : env -> evar_map -> local_binder_expr list -> evar_map * (internalization_env * ((env * rel_context) * Impargs.manual_implicits)) -(** Locating references of constructions, possibly via a syntactic definition +(** Locating references of constructions, possibly via a syntactic definition (these functions do not modify the glob file) *) val locate_reference : Libnames.qualid -> GlobRef.t diff --git a/interp/dumpglob.ml b/interp/dumpglob.ml index 41d1da9694..25a87d5f94 100644 --- a/interp/dumpglob.ml +++ b/interp/dumpglob.ml @@ -112,18 +112,18 @@ let type_of_global_ref gr = | VarRef v -> "var" ^ type_of_logical_kind (Decls.variable_kind v) | IndRef ind -> - let (mib,oib) = Inductive.lookup_mind_specif (Global.env ()) ind in + let (mib,oib) = Inductive.lookup_mind_specif (Global.env ()) ind in if mib.Declarations.mind_record <> Declarations.NotRecord then begin match mib.Declarations.mind_finite with | Finite -> "indrec" | BiFinite -> "rec" - | CoFinite -> "corec" + | CoFinite -> "corec" end - else + else begin match mib.Declarations.mind_finite with | Finite -> "ind" | BiFinite -> "variant" - | CoFinite -> "coind" + | CoFinite -> "coind" end | ConstructRef _ -> "constr" @@ -150,7 +150,7 @@ let dump_ref ?loc filepath modpath ident ty = | _ -> Option.iter (fun 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) + bl el filepath modpath ident ty) ) loc let dump_reference ?loc modpath ident ty = @@ -193,13 +193,13 @@ let cook_notation (from,df) sc = (* Next token is a terminal *) set ntn !j '\''; incr j; while !i <= l && df.[!i] != ' ' do - if df.[!i] < ' ' then - let c = char_of_int (int_of_char 'A' + int_of_char df.[!i] - 1) in - (String.blit ("'^" ^ String.make 1 c) 0 ntn !j 3; j := !j+3; incr i) - else begin - if df.[!i] == '\'' then (set ntn !j '\''; incr j); - set ntn !j df.[!i]; incr j; incr i - end + if df.[!i] < ' ' then + let c = char_of_int (int_of_char 'A' + int_of_char df.[!i] - 1) in + (String.blit ("'^" ^ String.make 1 c) 0 ntn !j 3; j := !j+3; incr i) + else begin + if df.[!i] == '\'' then (set ntn !j '\''; incr j); + set ntn !j df.[!i]; incr j; incr i + end done; set ntn !j '\''; incr j end; diff --git a/interp/impargs.ml b/interp/impargs.ml index 0de4eb5fa1..2aa002ead1 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -163,7 +163,7 @@ let is_flexible_reference env sigma bound depth f = | Rel n -> (* since local definitions have been expanded *) false | Const (kn,_) -> let cb = Environ.lookup_constant kn env in - (match cb.const_body with Def _ -> true | _ -> false) + (match cb.const_body with Def _ -> true | _ -> false) | Var id -> env |> Environ.lookup_named id |> NamedDecl.is_local_def | Ind _ | Construct _ -> false @@ -183,19 +183,19 @@ let add_free_rels_until strict strongly_strict revpat bound env sigma m pos acc let c = if strongly_strict then hd else c in match kind sigma hd with | Rel n when (n < bound+depth) && (n >= depth) -> - let i = bound + depth - n - 1 in + let i = bound + depth - n - 1 in acc.(i) <- update pos rig acc.(i) | App (f,l) when revpat && is_reversible_pattern sigma bound depth f l -> let i = bound + depth - EConstr.destRel sigma f - 1 in - acc.(i) <- update pos rig acc.(i) + acc.(i) <- update pos rig acc.(i) | App (f,_) when rig && is_flexible_reference env sigma bound depth f -> - if strict then () else + if strict then () else iter_with_full_binders sigma push_lift (frec false) ed c | Proj (p, _) when rig -> if strict then () else iter_with_full_binders sigma push_lift (frec false) ed c | Case _ when rig -> - if strict then () else + if strict then () else iter_with_full_binders sigma push_lift (frec false) ed c | Evar _ -> () | _ -> @@ -611,9 +611,9 @@ let check_inclusion l = (* Check strict inclusion *) let rec aux = function | n1::(n2::_ as nl) -> - if n1 <= n2 then - user_err Pp.(str "Sequences of implicit arguments must be of different lengths."); - aux nl + if n1 <= n2 then + user_err Pp.(str "Sequences of implicit arguments must be of different lengths."); + aux nl | _ -> () in aux (List.map snd l) @@ -621,7 +621,7 @@ let check_rigidity isrigid = if not isrigid then user_err (strbrk "Multiple sequences of implicit arguments available only for references that cannot be applied to an arbitrarily large number of arguments.") -let projection_implicits env p impls = +let projection_implicits env p impls = let npars = Projection.npars p in CList.skipn_at_least npars impls diff --git a/interp/impargs.mli b/interp/impargs.mli index 2751b9d40b..8fa69e818a 100644 --- a/interp/impargs.mli +++ b/interp/impargs.mli @@ -46,18 +46,18 @@ type argument_position = type implicit_explanation = | DepRigid of argument_position (** means that the implicit argument can be found by - unification along a rigid path (we do not print the arguments of - this kind if there is enough arguments to infer them) *) + unification along a rigid path (we do not print the arguments of + this kind if there is enough arguments to infer them) *) | DepFlex of argument_position (** means that the implicit argument can be found by unification along a collapsible path only (e.g. as x in (P x) where P is another - argument) (we do (defensively) print the arguments of this kind) *) + argument) (we do (defensively) print the arguments of this kind) *) | DepFlexAndRigid of (*flex*) argument_position * (*rig*) argument_position (** means that the least argument from which the implicit argument can be inferred is following a collapsible path - but there is a greater argument from where the implicit argument is - inferable following a rigid path (useful to know how to print a - partial application) *) + but there is a greater argument from where the implicit argument is + inferable following a rigid path (useful to know how to print a + partial application) *) | Manual (** means the argument has been explicitly set as implicit. *) @@ -68,8 +68,8 @@ type maximal_insertion = bool (** true = maximal contextual insertion *) type force_inference = bool (** true = always infer, never turn into evar/subgoal *) -type implicit_status = (Id.t * implicit_explanation * - (maximal_insertion * force_inference)) option +type implicit_status = (Id.t * implicit_explanation * + (maximal_insertion * force_inference)) option (** [None] = Not implicit *) type implicit_side_condition diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml index 455471a472..77a2c1c8e6 100644 --- a/interp/implicit_quantifiers.ml +++ b/interp/implicit_quantifiers.ml @@ -34,7 +34,7 @@ let declare_generalizable_ident table {CAst.loc;v=id} = " is not declarable as generalizable identifier: it must have no trailing digits, quote, or _")); if Id.Pred.mem id table then user_err ?loc ~hdr:"declare_generalizable_ident" - ((Id.print id++str" is already declared as a generalizable identifier")) + ((Id.print id++str" is already declared as a generalizable identifier")) else Id.Pred.add id table let add_generalizable gen table = @@ -78,7 +78,7 @@ let is_freevar ids env x = let ungeneralizable loc id = user_err ?loc ~hdr:"Generalization" - (str "Unbound and ungeneralizable variable " ++ Id.print id) + (str "Unbound and ungeneralizable variable " ++ Id.print id) let free_vars_of_constr_expr c ?(bound=Id.Set.empty) l = let found loc id bdvars l = @@ -102,16 +102,16 @@ let generalizable_vars_of_glob_constr ?(bound=Id.Set.empty) ?(allowed=Id.Set.emp let rec vars bound vs c = match DAst.get c with | GVar id -> let loc = c.CAst.loc in - if is_freevar bound (Global.env ()) id then + if is_freevar bound (Global.env ()) id then if List.exists (fun {CAst.v} -> Id.equal v id) vs then vs else CAst.(make ?loc id) :: vs - else vs + else vs | _ -> Glob_ops.fold_glob_constr_with_binders Id.Set.add vars bound vs c - in fun rt -> + in fun rt -> let vars = List.rev (vars bound [] rt) in List.iter (fun {CAst.loc;v=id} -> - if not (Id.Set.mem id allowed || find_generalizable_ident id) then - ungeneralizable loc id) vars; + if not (Id.Set.mem id allowed || find_generalizable_ident id) then + ungeneralizable loc id) vars; vars let rec make_fresh ids env x = @@ -131,10 +131,10 @@ let combine_params avoid applied needed = | Name id' -> Id.equal id id' | Anonymous -> false in - if not (List.exists is_id needed) then - user_err ?loc (str "Wrong argument name: " ++ Id.print id); - true - | _ -> false) applied + if not (List.exists is_id needed) then + user_err ?loc (str "Wrong argument name: " ++ Id.print id); + true + | _ -> false) applied in let named = List.map (fun x -> match x with (t, Some {CAst.loc;v=ExplByName id}) -> id, t | _ -> assert false) @@ -148,10 +148,10 @@ let combine_params avoid applied needed = | [], [] -> List.rev ids, avoid | app, (_, (LocalAssum ({binder_name=Name id}, _))) :: need when Id.List.mem_assoc id named -> - aux (Id.List.assoc id named :: ids) avoid app need + aux (Id.List.assoc id named :: ids) avoid app need | (x, None) :: app, (None, (LocalAssum ({binder_name=Name id}, _))) :: need -> - aux (x :: ids) avoid app need + aux (x :: ids) avoid app need | x :: app, (None, _) :: need -> aux (fst x :: ids) avoid app need @@ -161,7 +161,7 @@ let combine_params avoid applied needed = aux (t' :: ids) (Id.Set.add id' avoid) app need | (x,_) :: _, [] -> - user_err ?loc:(Constrexpr_ops.constr_loc x) (str "Typeclass does not expect more arguments") + user_err ?loc:(Constrexpr_ops.constr_loc x) (str "Typeclass does not expect more arguments") in aux [] avoid applied needed diff --git a/interp/notation.ml b/interp/notation.ml index c157cf43fb..efb826a76e 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -219,9 +219,9 @@ let declare_delimiters scope key = | Some oldkey when String.equal oldkey key -> () | Some oldkey -> (* FIXME: implement multikey scopes? *) - Flags.if_verbose Feedback.msg_info - (str "Overwriting previous delimiting key " ++ str oldkey ++ str " in scope " ++ str scope); - scope_map := String.Map.add scope newsc !scope_map + Flags.if_verbose Feedback.msg_info + (str "Overwriting previous delimiting key " ++ str oldkey ++ str " in scope " ++ str scope); + scope_map := String.Map.add scope newsc !scope_map end; try let oldscope = String.Map.find key !delimiters_map in @@ -1077,11 +1077,11 @@ let rec find_without_delimiters find (ntn_scope,ntn) = function | Some scope' when String.equal scope scope' -> Some (None,None) | _ -> - (* If the most recently open scope has a notation/numeral printer - but not the expected one then we need delimiters *) - if find scope then + (* If the most recently open scope has a notation/numeral printer + but not the expected one then we need delimiters *) + if find scope then find_with_delimiters ntn_scope - else + else find_without_delimiters find (ntn_scope,ntn) scopes end | SingleNotation ntn' :: scopes -> @@ -1646,7 +1646,7 @@ let decompose_notation_key (from,s) = if n>=len then List.rev dirs else let pos = try - String.index_from s n ' ' + String.index_from s n ' ' with Not_found -> len in let tok = @@ -1693,7 +1693,7 @@ let pr_named_scope prglob scope sc = ++ pr_scope_classes scope ++ NotationMap.fold (fun ntn { not_interp = (_, r); not_location = (_, df) } strm -> - pr_notation_info prglob df r ++ fnl () ++ strm) + pr_notation_info prglob df r ++ fnl () ++ strm) sc.notations (mt ()) let pr_scope prglob scope = pr_named_scope prglob scope (find_scope scope) @@ -1717,10 +1717,10 @@ let factorize_entries = function | [] -> [] | (ntn,c)::l -> let (ntn,l_of_ntn,rest) = - List.fold_left + List.fold_left (fun (a',l,rest) (a,c) -> if notation_eq a a' then (a',c::l,rest) else (a,[c],(a',l)::rest)) - (ntn,[c],[]) l in + (ntn,[c],[]) l in (ntn,l_of_ntn)::rest type symbol_token = WhiteSpace of int | String of string @@ -1807,7 +1807,7 @@ let error_ambiguous_notation ?loc _ntn = user_err ?loc (str "Ambiguous notation.") let error_notation_not_reference ?loc ntn = - user_err ?loc + user_err ?loc (str "Unable to interpret " ++ quote (str ntn) ++ str " as a reference.") @@ -1844,14 +1844,14 @@ let locate_notation prglob ntn scope = prlist_with_sep fnl (fun (ntn,l) -> let scope = find_default ntn scopes in prlist_with_sep fnl - (fun (sc,r,(_,df)) -> - hov 0 ( - pr_notation_info prglob df r ++ - (if String.equal sc default_scope then mt () + (fun (sc,r,(_,df)) -> + hov 0 ( + pr_notation_info prglob df r ++ + (if String.equal sc default_scope then mt () else (spc () ++ str ": " ++ str sc)) ++ - (if Option.equal String.equal (Some sc) scope + (if Option.equal String.equal (Some sc) scope then spc () ++ str "(default interpretation)" else mt ()))) - l) ntns + l) ntns let collect_notation_in_scope scope sc known = assert (not (String.equal scope default_scope)); @@ -1864,22 +1864,22 @@ let collect_notations stack = fst (List.fold_left (fun (all,knownntn as acc) -> function | Scope scope -> - if String.List.mem_assoc scope all then acc - else - let (l,knownntn) = - collect_notation_in_scope scope (find_scope scope) knownntn in - ((scope,l)::all,knownntn) + if String.List.mem_assoc scope all then acc + else + let (l,knownntn) = + collect_notation_in_scope scope (find_scope scope) knownntn in + ((scope,l)::all,knownntn) | SingleNotation ntn -> if List.mem_f notation_eq ntn knownntn then (all,knownntn) - else - let { not_interp = (_, r); not_location = (_, df) } = + else + let { not_interp = (_, r); not_location = (_, df) } = NotationMap.find ntn (find_scope default_scope).notations in - let all' = match all with - | (s,lonelyntn)::rest when String.equal s default_scope -> - (s,(df,r)::lonelyntn)::rest - | _ -> - (default_scope,[df,r])::all in - (all',ntn::knownntn)) + let all' = match all with + | (s,lonelyntn)::rest when String.equal s default_scope -> + (s,(df,r)::lonelyntn)::rest + | _ -> + (default_scope,[df,r])::all in + (all',ntn::knownntn)) ([],[]) stack) let pr_visible_in_scope prglob (scope,ntns) = diff --git a/interp/notation.mli b/interp/notation.mli index bd9b50977b..864e500d56 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -233,8 +233,8 @@ val uninterp_notations : 'a glob_constr_g -> notation_rule list val uninterp_cases_pattern_notations : 'a cases_pattern_g -> notation_rule list val uninterp_ind_pattern_notations : inductive -> notation_rule list -(** Test if a notation is available in the scopes - context [scopes]; if available, the result is not None; the first +(** Test if a notation is available in the scopes + context [scopes]; if available, the result is not None; the first argument is itself not None if a delimiters is needed *) val availability_of_notation : scope_name option * notation -> subscopes -> (scope_name option * delimiters option) option diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index 7e146754b2..ff2498386d 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -137,13 +137,13 @@ let rec subst_glob_vars l gc = DAst.map (function | GVar id as r -> (try DAst.get (Id.List.assoc id l) with Not_found -> r) | GProd (Name id,bk,t,c) -> let id = - try match DAst.get (Id.List.assoc id l) with GVar id' -> id' | _ -> id - with Not_found -> id in + try match DAst.get (Id.List.assoc id l) with GVar id' -> id' | _ -> id + with Not_found -> id in GProd (Name id,bk,subst_glob_vars l t,subst_glob_vars l c) | GLambda (Name id,bk,t,c) -> let id = - try match DAst.get (Id.List.assoc id l) with GVar id' -> id' | _ -> id - with Not_found -> id in + try match DAst.get (Id.List.assoc id l) with GVar id' -> id' | _ -> id + with Not_found -> id in GLambda (Name id,bk,subst_glob_vars l t,subst_glob_vars l c) | GHole (x,naming,arg) -> GHole (subst_binder_type_vars l x,naming,arg) | _ -> DAst.get (map_glob_constr (subst_glob_vars l) gc) (* assume: id is not binding *) @@ -190,10 +190,10 @@ let glob_constr_of_notation_constr_with_binders ?loc g f e nc = | Some (disjpat,_id) -> DAst.get (apply_cases_pattern_term ?loc disjpat (f e b) (f e' c))) | NCases (sty,rtntypopt,tml,eqnl) -> let e',tml' = List.fold_right (fun (tm,(na,t)) (e',tml') -> - let e',t' = match t with - | None -> e',None - | Some (ind,nal) -> - let e',nal' = List.fold_right (fun na (e',nal) -> + let e',t' = match t with + | None -> e',None + | Some (ind,nal) -> + let e',nal' = List.fold_right (fun na (e',nal) -> let e',na' = protect g e' na in e',na'::nal) nal (e',[]) in e',Some (CAst.make ?loc (ind,nal')) in @@ -216,7 +216,7 @@ let glob_constr_of_notation_constr_with_binders ?loc g f e nc = | NRec (fk,idl,dll,tl,bl) -> let e,dll = Array.fold_left_map (List.fold_left_map (fun e (na,oc,b) -> let e,na = protect g e na in - (e,(na,Explicit,Option.map (f e) oc,f e b)))) e dll in + (e,(na,Explicit,Option.map (f e) oc,f e b)))) e dll in let e',idl = Array.fold_left_map (to_id (protect g)) e idl in GRec (fk,idl,dll,Array.map (f e) tl,Array.map (f e') bl) | NCast (c,k) -> GCast (f e c,map_cast_type (f e) k) @@ -362,8 +362,8 @@ let compare_recursive_parts recvars found f f' (iterator,subc) = if aux iterator subc then match !diff with | None -> - let loc1 = loc_of_glob_constr iterator in - let loc2 = loc_of_glob_constr (Option.get !terminator) in + let loc1 = loc_of_glob_constr iterator in + let loc2 = loc_of_glob_constr (Option.get !terminator) in (* Here, we would need a loc made of several parts ... *) user_err ?loc:(subtract_loc loc1 loc2) (str "Both ends of the recursive pattern are the same.") @@ -400,15 +400,15 @@ let notation_constr_and_vars_of_glob_constr recvars a = | GApp (t, [_]) -> begin match DAst.get t with | GVar f when Id.equal f ldots_var -> - (* Fall on the second part of the recursive pattern w/o having - found the first part *) + (* Fall on the second part of the recursive pattern w/o having + found the first part *) let loc = t.CAst.loc in - user_err ?loc - (str "Cannot find where the recursive pattern starts.") + user_err ?loc + (str "Cannot find where the recursive pattern starts.") | _ -> aux' c end | _c -> - aux' c + aux' c and aux' x = DAst.with_val (function | GVar id -> if not (Id.equal id ldots_var) then add_id found id; NVar id | GApp (g,args) -> NApp (aux g, List.map aux args) @@ -419,8 +419,8 @@ let notation_constr_and_vars_of_glob_constr recvars a = let f {CAst.v=(idl,pat,rhs)} = List.iter (add_id found) idl; (pat,aux rhs) in NCases (sty,Option.map aux rtntypopt, List.map (fun (tm,(na,x)) -> - add_name found na; - Option.iter + add_name found na; + Option.iter (fun {CAst.v=(_,nl)} -> List.iter (add_name found) nl) x; (aux tm,(na,Option.map (fun {CAst.v=(ind,nal)} -> (ind,nal)) x))) tml, List.map f eqnl) @@ -434,9 +434,9 @@ let notation_constr_and_vars_of_glob_constr recvars a = | GRec (fk,idl,dll,tl,bl) -> Array.iter (add_id found) idl; let dll = Array.map (List.map (fun (na,bk,oc,b) -> - if bk != Explicit then - user_err Pp.(str "Binders marked as implicit not allowed in notations."); - add_name found na; (na,Option.map aux oc,aux b))) dll in + if bk != Explicit then + user_err Pp.(str "Binders marked as implicit not allowed in notations."); + add_name found na; (na,Option.map aux oc,aux b))) dll in NRec (fk,idl,dll,Array.map aux tl,Array.map aux bl) | GCast (c,k) -> NCast (aux c,map_cast_type aux k) | GSort s -> NSort s @@ -465,7 +465,7 @@ let check_variables_and_reversibility nenv let check_recvar x = if Id.List.mem x found then user_err (Id.print x ++ - strbrk " should only be used in the recursive part of a pattern.") in + strbrk " should only be used in the recursive part of a pattern.") in let check (x, y) = check_recvar x; check_recvar y in let () = List.iter check foundrec in let () = List.iter check foundrecbinding in @@ -476,7 +476,7 @@ let check_variables_and_reversibility nenv Id.List.mem_assoc_sym x foundrec || Id.List.mem_assoc_sym x foundrecbinding then - user_err Pp.(str + user_err Pp.(str (Id.to_string x ^ " should not be bound in a recursive pattern of the right-hand side.")) else injective := x :: !injective @@ -484,19 +484,19 @@ let check_variables_and_reversibility nenv let check_pair s x y where = if not (mem_recursive_pair (x,y) where) then user_err (strbrk "in the right-hand side, " ++ Id.print x ++ - str " and " ++ Id.print y ++ strbrk " should appear in " ++ str s ++ - str " position as part of a recursive pattern.") in + str " and " ++ Id.print y ++ strbrk " should appear in " ++ str s ++ + str " position as part of a recursive pattern.") in let check_type x typ = match typ with | NtnInternTypeAny -> - begin - try check_pair "term" x (Id.Map.find x recvars) foundrec - with Not_found -> check_bound x - end + begin + try check_pair "term" x (Id.Map.find x recvars) foundrec + with Not_found -> check_bound x + end | NtnInternTypeOnlyBinder -> - begin - try check_pair "binding" x (Id.Map.find x recvars) foundrecbinding - with Not_found -> check_bound x + begin + try check_pair "binding" x (Id.Map.find x recvars) foundrecbinding + with Not_found -> check_bound x end in Id.Map.iter check_type vars; List.rev !injective @@ -547,49 +547,49 @@ let rec subst_notation_constr subst bound raw = | NApp (r,rl) -> let r' = subst_notation_constr subst bound r and rl' = List.Smart.map (subst_notation_constr subst bound) rl in - if r' == r && rl' == rl then raw else - NApp(r',rl') + if r' == r && rl' == rl then raw else + NApp(r',rl') | NList (id1,id2,r1,r2,b) -> let r1' = subst_notation_constr subst bound r1 and r2' = subst_notation_constr subst bound r2 in - if r1' == r1 && r2' == r2 then raw else - NList (id1,id2,r1',r2',b) + if r1' == r1 && r2' == r2 then raw else + NList (id1,id2,r1',r2',b) | NLambda (n,r1,r2) -> let r1' = subst_notation_constr subst bound r1 and r2' = subst_notation_constr subst bound r2 in - if r1' == r1 && r2' == r2 then raw else - NLambda (n,r1',r2') + if r1' == r1 && r2' == r2 then raw else + NLambda (n,r1',r2') | NProd (n,r1,r2) -> let r1' = subst_notation_constr subst bound r1 and r2' = subst_notation_constr subst bound r2 in - if r1' == r1 && r2' == r2 then raw else - NProd (n,r1',r2') + if r1' == r1 && r2' == r2 then raw else + NProd (n,r1',r2') | NBinderList (id1,id2,r1,r2,b) -> let r1' = subst_notation_constr subst bound r1 and r2' = subst_notation_constr subst bound r2 in - if r1' == r1 && r2' == r2 then raw else + if r1' == r1 && r2' == r2 then raw else NBinderList (id1,id2,r1',r2',b) | NLetIn (n,r1,t,r2) -> let r1' = subst_notation_constr subst bound r1 in let t' = Option.Smart.map (subst_notation_constr subst bound) t in let r2' = subst_notation_constr subst bound r2 in - if r1' == r1 && t == t' && r2' == r2 then raw else - NLetIn (n,r1',t',r2') + if r1' == r1 && t == t' && r2' == r2 then raw else + NLetIn (n,r1',t',r2') | NCases (sty,rtntypopt,rl,branches) -> let rtntypopt' = Option.Smart.map (subst_notation_constr subst bound) rtntypopt and rl' = List.Smart.map (fun (a,(n,signopt) as x) -> - let a' = subst_notation_constr subst bound a in - let signopt' = Option.map (fun ((indkn,i),nal as z) -> - let indkn' = subst_mind subst indkn in - if indkn == indkn' then z else ((indkn',i),nal)) signopt in - if a' == a && signopt' == signopt then x else (a',(n,signopt'))) + let a' = subst_notation_constr subst bound a in + let signopt' = Option.map (fun ((indkn,i),nal as z) -> + let indkn' = subst_mind subst indkn in + if indkn == indkn' then z else ((indkn',i),nal)) signopt in + if a' == a && signopt' == signopt then x else (a',(n,signopt'))) rl and branches' = List.Smart.map (fun (cpl,r as branch) -> @@ -607,27 +607,27 @@ let rec subst_notation_constr subst bound raw = let po' = Option.Smart.map (subst_notation_constr subst bound) po and b' = subst_notation_constr subst bound b and c' = subst_notation_constr subst bound c in - if po' == po && b' == b && c' == c then raw else - NLetTuple (nal,(na,po'),b',c') + if po' == po && b' == b && c' == c then raw else + NLetTuple (nal,(na,po'),b',c') | NIf (c,(na,po),b1,b2) -> let po' = Option.Smart.map (subst_notation_constr subst bound) po and b1' = subst_notation_constr subst bound b1 and b2' = subst_notation_constr subst bound b2 and c' = subst_notation_constr subst bound c in - if po' == po && b1' == b1 && b2' == b2 && c' == c then raw else - NIf (c',(na,po'),b1',b2') + if po' == po && b1' == b1 && b2' == b2 && c' == c then raw else + NIf (c',(na,po'),b1',b2') | NRec (fk,idl,dll,tl,bl) -> let dll' = Array.Smart.map (List.Smart.map (fun (na,oc,b as x) -> let oc' = Option.Smart.map (subst_notation_constr subst bound) oc in - let b' = subst_notation_constr subst bound b in - if oc' == oc && b' == b then x else (na,oc',b'))) dll in + let b' = subst_notation_constr subst bound b in + if oc' == oc && b' == b then x else (na,oc',b'))) dll in let tl' = Array.Smart.map (subst_notation_constr subst bound) tl in let bl' = Array.Smart.map (subst_notation_constr subst bound) bl in if dll' == dll && tl' == tl && bl' == bl then raw else - NRec (fk,idl,dll',tl',bl') + NRec (fk,idl,dll',tl',bl') | NSort _ -> raw | NInt _ -> raw @@ -660,7 +660,7 @@ let abstract_return_type_context pi mklam tml rtno = Option.map (fun rtn -> let nal = List.flatten (List.map (fun (_,(na,t)) -> - match t with Some x -> (pi x)@[na] | None -> [na]) tml) in + match t with Some x -> (pi x)@[na] | None -> [na]) tml) in List.fold_right mklam nal rtn) rtno @@ -1131,11 +1131,11 @@ let rec match_ inner u alp metas sigma a1 a2 = | GApp (f1,l1), NApp (f2,l2) -> let n1 = List.length l1 and n2 = List.length l2 in let f1,l1,f2,l2 = - if n1 < n2 then - let l21,l22 = List.chop (n2-n1) l2 in f1,l1, NApp (f2,l21), l22 - else if n1 > n2 then - let l11,l12 = List.chop (n1-n2) l1 in DAst.make ?loc @@ GApp (f1,l11),l12, f2,l2 - else f1,l1, f2, l2 in + if n1 < n2 then + let l21,l22 = List.chop (n2-n1) l2 in f1,l1, NApp (f2,l21), l22 + else if n1 > n2 then + let l11,l12 = List.chop (n1-n2) l1 in DAst.make ?loc @@ GApp (f1,l11),l12, f2,l2 + else f1,l1, f2, l2 in let may_use_eta = does_not_come_from_already_eta_expanded_var f1 in List.fold_left2 (match_ may_use_eta u alp metas) (match_hd u alp metas sigma f1 f2) l1 l2 @@ -1154,8 +1154,8 @@ let rec match_ inner u alp metas sigma a1 a2 = let rtno1' = abstract_return_type_context_glob_constr tml1 rtno1 in let rtno2' = abstract_return_type_context_notation_constr tml2 rtno2 in let sigma = - try Option.fold_left2 (match_in u alp metas) sigma rtno1' rtno2' - with Option.Heterogeneous -> raise No_match + try Option.fold_left2 (match_in u alp metas) sigma rtno1' rtno2' + with Option.Heterogeneous -> raise No_match in let sigma = List.fold_left2 (fun s (tm1,_) (tm2,_) -> @@ -1173,24 +1173,24 @@ let rec match_ inner u alp metas sigma a1 a2 = let sigma = match_opt (match_binders u alp metas na1 na2) sigma to1 to2 in let sigma = match_in u alp metas sigma b1 b2 in let (alp,sigma) = - List.fold_left2 (match_names metas) (alp,sigma) nal1 nal2 in + List.fold_left2 (match_names metas) (alp,sigma) nal1 nal2 in match_in u alp metas sigma c1 c2 | GIf (a1,(na1,to1),b1,c1), NIf (a2,(na2,to2),b2,c2) -> let sigma = match_opt (match_binders u alp metas na1 na2) sigma to1 to2 in List.fold_left2 (match_in u alp metas) sigma [a1;b1;c1] [a2;b2;c2] | GRec (fk1,idl1,dll1,tl1,bl1), NRec (fk2,idl2,dll2,tl2,bl2) when match_fix_kind fk1 fk2 && Int.equal (Array.length idl1) (Array.length idl2) && - Array.for_all2 (fun l1 l2 -> Int.equal (List.length l1) (List.length l2)) dll1 dll2 - -> + Array.for_all2 (fun l1 l2 -> Int.equal (List.length l1) (List.length l2)) dll1 dll2 + -> let alp,sigma = Array.fold_left2 - (List.fold_left2 (fun (alp,sigma) (na1,_,oc1,b1) (na2,oc2,b2) -> - let sigma = - match_in u alp metas + (List.fold_left2 (fun (alp,sigma) (na1,_,oc1,b1) (na2,oc2,b2) -> + let sigma = + match_in u alp metas (match_opt (match_in u alp metas) sigma oc1 oc2) b1 b2 - in match_names metas (alp,sigma) na1 na2)) (alp,sigma) dll1 dll2 in + in match_names metas (alp,sigma) na1 na2)) (alp,sigma) dll1 dll2 in let sigma = Array.fold_left2 (match_in u alp metas) sigma tl1 tl2 in let alp,sigma = Array.fold_right2 (fun id1 id2 alsig -> - match_names metas alsig (Name id1) (Name id2)) idl1 idl2 (alp,sigma) in + match_names metas alsig (Name id1) (Name id2)) idl1 idl2 (alp,sigma) in Array.fold_left2 (match_in u alp metas) sigma bl1 bl2 | GCast(t1, c1), NCast(t2, c2) -> match_cast (match_in u alp metas) (match_in u alp metas sigma t1 t2) c1 c2 @@ -1351,9 +1351,9 @@ let rec match_cases_pattern metas (terms,termlists,(),() as sigma) a1 a2 = let le2 = List.length l2 in if Int.equal le2 0 (* Special case of a notation for a @Cstr *) || le2 > List.length l1 then - raise No_match + raise No_match else - let l1',more_args = Util.List.chop le2 l1 in + let l1',more_args = Util.List.chop le2 l1 in (List.fold_left2 (match_cases_pattern_no_more_args metas) sigma l1' l2),(le2,more_args) | r1, NList (x,y,iter,termin,revert) -> (match_cases_pattern_list (match_cases_pattern_no_more_args) @@ -1374,10 +1374,10 @@ let match_ind_pattern metas sigma ind pats a2 = let le2 = List.length l2 in if Int.equal le2 0 (* Special case of a notation for a @Cstr *) || le2 > List.length pats then - raise No_match + raise No_match else - let l1',more_args = Util.List.chop le2 pats in - (List.fold_left2 (match_cases_pattern_no_more_args metas) sigma l1' l2),(le2,more_args) + let l1',more_args = Util.List.chop le2 pats in + (List.fold_left2 (match_cases_pattern_no_more_args metas) sigma l1' l2),(le2,more_args) |_ -> raise No_match let reorder_canonically_substitution terms termlists metas = diff --git a/interp/notation_ops.mli b/interp/notation_ops.mli index 7919d0061f..f9de6b7d6b 100644 --- a/interp/notation_ops.mli +++ b/interp/notation_ops.mli @@ -20,7 +20,7 @@ val eq_notation_constr : Id.t list * Id.t list -> notation_constr -> notation_co val subst_interpretation : Mod_subst.substitution -> interpretation -> interpretation - + (** Name of the special identifier used to encode recursive notations *) val ldots_var : Id.t diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index 72585e5014..af08ea18c1 100644 --- a/kernel/cClosure.ml +++ b/kernel/cClosure.ml @@ -53,10 +53,10 @@ let reset () = let stop() = Feedback.msg_debug (str "[Reds: beta=" ++ int !beta ++ str" delta=" ++ int !delta ++ - str " eta=" ++ int !eta ++ str" zeta=" ++ int !zeta ++ str" evar=" ++ - int !evar ++ str" match=" ++ int !nb_match ++ str" fix=" ++ int !fix ++ + str " eta=" ++ int !eta ++ str" zeta=" ++ int !zeta ++ str" evar=" ++ + int !evar ++ str" match=" ++ int !nb_match ++ str" fix=" ++ int !fix ++ str " cofix=" ++ int !cofix ++ str" prune=" ++ int !prune ++ - str"]") + str"]") let incr_cnt red cnt = if red then begin @@ -119,7 +119,7 @@ module RedFlags : RedFlagsSig = struct type red_kind = BETA | DELTA | ETA | MATCH | FIX | COFIX | ZETA - | CONST of Constant.t | VAR of Id.t + | CONST of Constant.t | VAR of Id.t let fBETA = BETA let fDELTA = DELTA let fETA = ETA @@ -181,16 +181,16 @@ module RedFlags : RedFlagsSig = struct | ETA -> incr_cnt red.r_eta eta | CONST kn -> let c = is_transparent_constant red.r_const kn in - incr_cnt c delta + incr_cnt c delta | VAR id -> (* En attendant d'avoir des kn pour les Var *) let c = is_transparent_variable red.r_const id in - incr_cnt c delta + incr_cnt c delta | ZETA -> incr_cnt red.r_zeta zeta | MATCH -> incr_cnt red.r_match nb_match | FIX -> incr_cnt red.r_fix fix | COFIX -> incr_cnt red.r_cofix cofix | DELTA -> (* Used for Rel/Var defined in context *) - incr_cnt red.r_delta delta + incr_cnt red.r_delta delta let red_projection red p = if Projection.unfolded p then true @@ -824,10 +824,10 @@ let rec try_drop_parameters depth n = function reloc_rargs depth (append_stack aft s) | Zshift(k)::s -> try_drop_parameters (depth-k) n s | [] -> - if Int.equal n 0 then [] - else raise Not_found + if Int.equal n 0 then [] + else raise Not_found | (ZcaseT _ | Zproj _ | Zfix _ | Zupdate _ | Zprimitive _) :: _ -> assert false - (* strip_update_shift_app only produces Zapp and Zshift items *) + (* strip_update_shift_app only produces Zapp and Zshift items *) let drop_parameters depth n argstk = try try_drop_parameters depth n argstk @@ -852,7 +852,7 @@ let eta_expand_ind_stack env ind m s (f, s') = match Declareops.inductive_make_projections ind mib with | Some projs -> (* (Construct, pars1 .. parsm :: arg1...argn :: []) ~= (f, s') -> - arg1..argn ~= (proj1 t...projn t) where t = zip (f,s') *) + arg1..argn ~= (proj1 t...projn t) where t = zip (f,s') *) let pars = mib.Declarations.mind_nparams in let right = fapp_stack (f, s') in let (depth, args, _s) = strip_update_shift_app m s in @@ -869,8 +869,8 @@ let eta_expand_ind_stack env ind m s (f, s') = let rec project_nth_arg n = function | Zapp args :: s -> let q = Array.length args in - if n >= q then project_nth_arg (n - q) s - else (* n < q *) args.(n) + if n >= q then project_nth_arg (n - q) s + else (* n < q *) args.(n) | (ZcaseT _ | Zproj _ | Zfix _ | Zupdate _ | Zshift _ | Zprimitive _) :: _ | [] -> assert false (* After drop_parameters we have a purely applicative stack *) @@ -891,12 +891,12 @@ let contract_fix_vect fix = (bds.(i), (fun j -> { mark = mark Cstr (opt_of_rel nas.(j).binder_relevance); term = FFix (((reci,j),rdcl),env) }), - env, Array.length bds) + env, Array.length bds) | FCoFix ((i,(nas,_,bds as rdcl)),env) -> (bds.(i), (fun j -> { mark = mark Cstr (opt_of_rel nas.(j).binder_relevance); term = FCoFix ((j,rdcl),env) }), - env, Array.length bds) + env, Array.length bds) | _ -> assert false in (subs_cons(Array.init nfix make_body, env), thisbody) @@ -1347,11 +1347,11 @@ let rec zip_term zfun m stk = zip_term zfun (mkApp(m, Array.map zfun args)) s | ZcaseT(ci,p,br,e)::s -> let t = mkCase(ci, zfun (mk_clos e p), m, - Array.map (fun b -> zfun (mk_clos e b)) br) in + Array.map (fun b -> zfun (mk_clos e b)) br) in zip_term zfun t s | Zproj p::s -> let t = mkProj (Projection.make p true, m) in - zip_term zfun t s + zip_term zfun t s | Zfix(fx,par)::s -> let h = mkApp(zip_term zfun (zfun fx) par,[|m|]) in zip_term zfun h s diff --git a/kernel/cbytecodes.ml b/kernel/cbytecodes.ml index 009db05ea2..e33a4f1518 100644 --- a/kernel/cbytecodes.ml +++ b/kernel/cbytecodes.ml @@ -106,18 +106,18 @@ let rec pp_instr i = str "closure " ++ pp_lbl lbl ++ str ", " ++ int n | Kclosurerec(fv,init,lblt,lblb) -> h 1 (str "closurerec " ++ - int fv ++ str ", " ++ int init ++ - str " types = " ++ - prlist_with_sep spc pp_lbl (Array.to_list lblt) ++ - str " bodies = " ++ - prlist_with_sep spc pp_lbl (Array.to_list lblb)) + int fv ++ str ", " ++ int init ++ + str " types = " ++ + prlist_with_sep spc pp_lbl (Array.to_list lblt) ++ + str " bodies = " ++ + prlist_with_sep spc pp_lbl (Array.to_list lblb)) | Kclosurecofix (fv,init,lblt,lblb) -> h 1 (str "closurecofix " ++ - int fv ++ str ", " ++ int init ++ - str " types = " ++ - prlist_with_sep spc pp_lbl (Array.to_list lblt) ++ - str " bodies = " ++ - prlist_with_sep spc pp_lbl (Array.to_list lblb)) + int fv ++ str ", " ++ int init ++ + str " types = " ++ + prlist_with_sep spc pp_lbl (Array.to_list lblt) ++ + str " bodies = " ++ + prlist_with_sep spc pp_lbl (Array.to_list lblb)) | Kgetglobal idu -> str "getglobal " ++ Constant.print idu | Kconst sc -> str "const " ++ pp_struct_const sc @@ -126,12 +126,12 @@ let rec pp_instr i = | Kmakeprod -> str "makeprod" | Kmakeswitchblock(lblt,lbls,_,sz) -> str "makeswitchblock " ++ pp_lbl lblt ++ str ", " ++ - pp_lbl lbls ++ str ", " ++ int sz + pp_lbl lbls ++ str ", " ++ int sz | Kswitch(lblc,lblb) -> h 1 (str "switch " ++ - prlist_with_sep spc pp_lbl (Array.to_list lblc) ++ - str " | " ++ - prlist_with_sep spc pp_lbl (Array.to_list lblb)) + prlist_with_sep spc pp_lbl (Array.to_list lblc) ++ + str " | " ++ + prlist_with_sep spc pp_lbl (Array.to_list lblb)) | Kpushfields n -> str "pushfields " ++ int n | Kfield n -> str "field " ++ int n | Ksetfield n -> str "setfield " ++ int n @@ -153,8 +153,8 @@ and pp_bytecodes c = match c with | [] -> str "" | Klabel lbl :: c -> - str "L" ++ int lbl ++ str ":" ++ fnl () ++ - pp_bytecodes c + str "L" ++ int lbl ++ str ":" ++ fnl () ++ + pp_bytecodes c | Ksequence (l1, l2) :: c -> pp_bytecodes l1 ++ pp_bytecodes l2 ++ pp_bytecodes c | i :: c -> diff --git a/kernel/cbytecodes.mli b/kernel/cbytecodes.mli index 06b380ef89..d7ea6f13c2 100644 --- a/kernel/cbytecodes.mli +++ b/kernel/cbytecodes.mli @@ -46,7 +46,7 @@ type instruction = | Kconst of structured_constant | Kmakeblock of (* size: *) int * tag (** allocate an ocaml block. Index 0 ** is accu, all others are popped from - ** the top of the stack *) + ** the top of the stack *) | Kmakeprod | Kmakeswitchblock of Label.t * Label.t * annot_switch * int | Kswitch of Label.t array * Label.t array (** consts,blocks *) diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml index 13cc6f7ea4..985c692eea 100644 --- a/kernel/cbytegen.ml +++ b/kernel/cbytegen.ml @@ -292,9 +292,9 @@ let pos_rel i r sz = let env = !(r.in_env) in try Kenvacc(r.offset + find_at db env) with Not_found -> - let pos = env.size in - r.in_env := push_fv db env; - Kenvacc(r.offset + pos) + let pos = env.size in + r.in_env := push_fv db env; + Kenvacc(r.offset + pos) let pos_universe_var i r sz = (* Compilation of a universe variable can happen either at toplevel (the @@ -445,7 +445,7 @@ let nest_block tag arity cont = Kconst (Const_b0 (tag - Obj.last_non_constant_constructor_tag)) :: Kmakeblock(arity+1, Obj.last_non_constant_constructor_tag) :: cont -let code_makeblock ~stack_size ~arity ~tag cont = +let code_makeblock ~stack_size ~arity ~tag cont = if tag < Obj.last_non_constant_constructor_tag then Kmakeblock(arity, tag) :: cont else begin @@ -473,16 +473,16 @@ let comp_app comp_fun comp_arg cenv f args sz cont = match is_tailcall cont with | Some k -> comp_args comp_arg cenv args sz - (Kpush :: + (Kpush :: comp_fun cenv f (sz + nargs) - (Kappterm(nargs, k + nargs) :: (discard_dead_code cont))) + (Kappterm(nargs, k + nargs) :: (discard_dead_code cont))) | None -> if nargs <= 4 then comp_args comp_arg cenv args sz (Kpush :: (comp_fun cenv f (sz+nargs) (Kapply nargs :: cont))) else - let lbl,cont1 = label_code cont in - Kpush_retaddr lbl :: + let lbl,cont1 = label_code cont in + Kpush_retaddr lbl :: (comp_args comp_arg cenv args (sz + 3) (Kpush :: (comp_fun cenv f (sz+3+nargs) (Kapply nargs :: cont1)))) @@ -513,8 +513,8 @@ let rec get_alias env kn = | None -> kn | Some tps -> (match Cemitcodes.force tps with - | BCalias kn' -> get_alias env kn' - | _ -> kn) + | BCalias kn' -> get_alias env kn' + | _ -> kn) (* sz is the size of the local stack *) let rec compile_lam env cenv lam sz cont = @@ -609,24 +609,24 @@ let rec compile_lam env cenv lam sz cont = in let lbl,fcode = label_code fcode in lbl_types.(i) <- lbl; - fun_code := [Ksequence(fcode,!fun_code)] + fun_code := [Ksequence(fcode,!fun_code)] done; (* Compiling bodies *) for i = 0 to ndef - 1 do let params,body = decompose_Llam bodies.(i) in let arity = Array.length params in - let env_body = comp_env_fix ndef i arity rfv in + let env_body = comp_env_fix ndef i arity rfv in let cont1 = ensure_stack_capacity (compile_lam env env_body body arity) [Kreturn arity] in - let lbl = Label.create () in - lbl_bodies.(i) <- lbl; - let fcode = add_grabrec rec_args.(i) arity lbl cont1 in - fun_code := [Ksequence(fcode,!fun_code)] + let lbl = Label.create () in + lbl_bodies.(i) <- lbl; + let fcode = add_grabrec rec_args.(i) arity lbl cont1 in + fun_code := [Ksequence(fcode,!fun_code)] done; let fv = !rfv in compile_fv cenv fv.fv_rev sz - (Kclosurerec(fv.size,init,lbl_types,lbl_bodies) :: cont) + (Kclosurerec(fv.size,init,lbl_types,lbl_bodies) :: cont) | Lcofix(init, (_decl,types,bodies)) -> @@ -642,27 +642,27 @@ let rec compile_lam env cenv lam sz cont = in let lbl,fcode = label_code fcode in lbl_types.(i) <- lbl; - fun_code := [Ksequence(fcode,!fun_code)] + fun_code := [Ksequence(fcode,!fun_code)] done; (* Compiling bodies *) for i = 0 to ndef - 1 do let params,body = decompose_Llam bodies.(i) in let arity = Array.length params in - let env_body = comp_env_cofix ndef arity rfv in - let lbl = Label.create () in + let env_body = comp_env_cofix ndef arity rfv in + let lbl = Label.create () in let comp arity = (* 4 stack slots are needed to update the cofix when forced *) set_max_stack_size (arity + 4); compile_lam env env_body body (arity+1) (cont_cofix arity) in - let cont = ensure_stack_capacity comp arity in - lbl_bodies.(i) <- lbl; - fun_code := [Ksequence(add_grab (arity+1) lbl cont,!fun_code)]; + let cont = ensure_stack_capacity comp arity in + lbl_bodies.(i) <- lbl; + fun_code := [Ksequence(add_grab (arity+1) lbl cont,!fun_code)]; done; let fv = !rfv in set_max_stack_size (sz + fv.size + ndef + 2); compile_fv cenv fv.fv_rev sz - (Kclosurecofix(fv.size, init, lbl_types, lbl_bodies) :: cont) + (Kclosurecofix(fv.size, init, lbl_types, lbl_bodies) :: cont) | Lif(t, bt, bf) -> let branch, cont = make_branch cont in @@ -686,7 +686,7 @@ let rec compile_lam env cenv lam sz cont = let nblock = min nallblock (Obj.last_non_constant_constructor_tag + 1) in let lbl_blocks = Array.make nblock Label.no in let neblock = max 0 (nallblock - Obj.last_non_constant_constructor_tag) in - let lbl_eblocks = Array.make neblock Label.no in + let lbl_eblocks = Array.make neblock Label.no in let branch1, cont = make_branch cont in (* Compilation of the return type *) let fcode = @@ -708,7 +708,7 @@ let rec compile_lam env cenv lam sz cont = let c = ref cont in (* Perform the extra match if needed (too many block constructors) *) if neblock <> 0 then begin - let lbl_b, code_b = + let lbl_b, code_b = label_code ( Kpush :: Kfield 0 :: Kswitch(lbl_eblocks, [||]) :: !c) in lbl_blocks.(Obj.last_non_constant_constructor_tag) <- lbl_b; @@ -756,17 +756,17 @@ let rec compile_lam env cenv lam sz cont = (* Compiling branch for accumulators *) let lbl_accu, code_accu = set_max_stack_size (sz+3); - label_code(Kmakeswitchblock(lbl_typ,lbl_sw,annot,sz) :: branch :: !c) + label_code(Kmakeswitchblock(lbl_typ,lbl_sw,annot,sz) :: branch :: !c) in lbl_blocks.(0) <- lbl_accu; c := Klabel lbl_sw :: Kswitch(lbl_consts,lbl_blocks) :: code_accu; let code_sw = - match branch1 with + match branch1 with (* spiwack : branch1 can't be a lbl anymore it's a Branch instead - | Klabel lbl -> Kpush_retaddr lbl :: !c *) + | Klabel lbl -> Kpush_retaddr lbl :: !c *) | Kbranch lbl -> Kpush_retaddr lbl :: !c - | _ -> !c + | _ -> !c in compile_lam env cenv a sz code_sw @@ -885,13 +885,13 @@ let compile_constant_body ~fail_on_error env univs = function let body = Mod_subst.force_constr sb in let instance_size = Univ.AUContext.size (Declareops.universes_context univs) in match kind body with - | Const (kn',u) when is_univ_copy instance_size u -> - (* we use the canonical name of the constant*) - let con= Constant.make1 (Constant.canonical kn') in - Some (BCalias (get_alias env con)) - | _ -> + | Const (kn',u) when is_univ_copy instance_size u -> + (* we use the canonical name of the constant*) + let con= Constant.make1 (Constant.canonical kn') in + Some (BCalias (get_alias env con)) + | _ -> let res = compile ~fail_on_error ~universes:instance_size env body in - Option.map (fun x -> BCdefined (to_memory x)) res + Option.map (fun x -> BCdefined (to_memory x)) res (* Shortcut of the previous function used during module strengthening *) diff --git a/kernel/cbytegen.mli b/kernel/cbytegen.mli index 814902a554..38c1c45a85 100644 --- a/kernel/cbytegen.mli +++ b/kernel/cbytegen.mli @@ -16,7 +16,7 @@ open Environ (** Should only be used for monomorphic terms *) val compile : fail_on_error:bool -> - ?universes:int -> env -> constr -> (bytecodes * bytecodes * fv) option + ?universes:int -> env -> constr -> (bytecodes * bytecodes * fv) option (** init, fun, fv *) val compile_constant_body : fail_on_error:bool -> diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml index 5e82cef810..4e22421f56 100644 --- a/kernel/cemitcodes.ml +++ b/kernel/cemitcodes.ml @@ -64,14 +64,14 @@ type patches = { reloc_infos : (reloc_info * int array) array; } -let patch_char4 buff pos c1 c2 c3 c4 = +let patch_char4 buff pos c1 c2 c3 c4 = Bytes.unsafe_set buff pos c1; Bytes.unsafe_set buff (pos + 1) c2; Bytes.unsafe_set buff (pos + 2) c3; - Bytes.unsafe_set buff (pos + 3) c4 - + Bytes.unsafe_set buff (pos + 3) c4 + let patch1 buff pos n = - patch_char4 buff pos + patch_char4 buff pos (Char.unsafe_chr n) (Char.unsafe_chr (n asr 8)) (Char.unsafe_chr (n asr 16)) (Char.unsafe_chr (n asr 24)) @@ -116,9 +116,9 @@ let out_word env b1 b2 b3 b4 = if len <= Sys.max_string_length / 2 then 2 * len else - if len = Sys.max_string_length - then invalid_arg "String.create" (* Pas la bonne exception .... *) - else Sys.max_string_length in + if len = Sys.max_string_length + then invalid_arg "String.create" (* Pas la bonne exception .... *) + else Sys.max_string_length in let new_buffer = Bytes.create new_len in Bytes.blit env.out_buffer 0 new_buffer 0 len; env.out_buffer <- new_buffer @@ -359,9 +359,9 @@ let emit_instr env = function (* Emission of a current list and remaining lists of instructions. Include some peephole optimization. *) let rec emit env insns remaining = match insns with - | [] -> - (match remaining with - [] -> () + | [] -> + (match remaining with + [] -> () | (first::rest) -> emit env first rest) (* Peephole optimizations *) | Kpush :: Kacc n :: c -> diff --git a/kernel/constr.ml b/kernel/constr.ml index b60b2d6d04..15e5c512ed 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -16,7 +16,7 @@ (* Optimization of substitution functions by Chet Murthy *) (* Optimization of lifting functions by Bruno Barras, Mar 1997 *) (* Hash-consing by Bruno Barras in Feb 1998 *) -(* Restructuration of Coq of the type-checking kernel by Jean-Christophe +(* Restructuration of Coq of the type-checking kernel by Jean-Christophe Filliâtre, 1999 *) (* Abstraction of the syntax of terms and iterators by Hugo Herbelin, 2000 *) (* Cleaning and lightening of the kernel by Bruno Barras, Nov 2001 *) @@ -924,7 +924,7 @@ let equal n m = eq_constr 0 m n (* to avoid tracing a recursive fun *) let eq_constr_univs univs m n = if m == n then true - else + else let eq_universes _ _ = UGraph.check_eq_instances univs in let eq_sorts s1 s2 = s1 == s2 || UGraph.check_eq univs (Sorts.univ_of_sort s1) (Sorts.univ_of_sort s2) in let rec eq_constr' nargs m n = @@ -933,11 +933,11 @@ let eq_constr_univs univs m n = let leq_constr_univs univs m n = if m == n then true - else + else let eq_universes _ _ = UGraph.check_eq_instances univs in - let eq_sorts s1 s2 = s1 == s2 || + let eq_sorts s1 s2 = s1 == s2 || UGraph.check_eq univs (Sorts.univ_of_sort s1) (Sorts.univ_of_sort s2) in - let leq_sorts s1 s2 = s1 == s2 || + let leq_sorts s1 s2 = s1 == s2 || UGraph.check_leq univs (Sorts.univ_of_sort s1) (Sorts.univ_of_sort s2) in let rec eq_constr' nargs m n = m == n || compare_head_gen eq_universes eq_sorts eq_constr' nargs m n @@ -949,17 +949,17 @@ let leq_constr_univs univs m n = let eq_constr_univs_infer univs m n = if m == n then true, Constraint.empty - else + else let cstrs = ref Constraint.empty in let eq_universes _ _ = UGraph.check_eq_instances univs in - let eq_sorts s1 s2 = + let eq_sorts s1 s2 = if Sorts.equal s1 s2 then true else - let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in - if UGraph.check_eq univs u1 u2 then true - else - (cstrs := Univ.enforce_eq u1 u2 !cstrs; - true) + let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in + if UGraph.check_eq univs u1 u2 then true + else + (cstrs := Univ.enforce_eq u1 u2 !cstrs; + true) in let rec eq_constr' nargs m n = m == n || compare_head_gen eq_universes eq_sorts eq_constr' nargs m n @@ -969,23 +969,23 @@ let eq_constr_univs_infer univs m n = let leq_constr_univs_infer univs m n = if m == n then true, Constraint.empty - else + else let cstrs = ref Constraint.empty in let eq_universes _ _ l l' = UGraph.check_eq_instances univs l l' in - let eq_sorts s1 s2 = + let eq_sorts s1 s2 = if Sorts.equal s1 s2 then true else - let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in - if UGraph.check_eq univs u1 u2 then true - else (cstrs := Univ.enforce_eq u1 u2 !cstrs; - true) + let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in + if UGraph.check_eq univs u1 u2 then true + else (cstrs := Univ.enforce_eq u1 u2 !cstrs; + true) in - let leq_sorts s1 s2 = + let leq_sorts s1 s2 = if Sorts.equal s1 s2 then true - else - let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in - if UGraph.check_leq univs u1 u2 then true - else + else + let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in + if UGraph.check_leq univs u1 u2 then true + else (try let c, _ = UGraph.enforce_leq_alg u1 u2 univs in cstrs := Univ.Constraint.union c !cstrs; true @@ -1183,54 +1183,54 @@ let hashcons (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) = let rec hash_term t = match t with | Var i -> - (Var (sh_id i), combinesmall 1 (Id.hash i)) + (Var (sh_id i), combinesmall 1 (Id.hash i)) | Sort s -> - (Sort (sh_sort s), combinesmall 2 (Sorts.hash s)) + (Sort (sh_sort s), combinesmall 2 (Sorts.hash s)) | Cast (c, k, t) -> - let c, hc = sh_rec c in - let t, ht = sh_rec t in - (Cast (c, k, t), combinesmall 3 (combine3 hc (hash_cast_kind k) ht)) + let c, hc = sh_rec c in + let t, ht = sh_rec t in + (Cast (c, k, t), combinesmall 3 (combine3 hc (hash_cast_kind k) ht)) | Prod (na,t,c) -> - let t, ht = sh_rec t - and c, hc = sh_rec c in + let t, ht = sh_rec t + and c, hc = sh_rec c in (Prod (sh_na na, t, c), combinesmall 4 (combine3 (hash_annot Name.hash na) ht hc)) | Lambda (na,t,c) -> - let t, ht = sh_rec t - and c, hc = sh_rec c in + let t, ht = sh_rec t + and c, hc = sh_rec c in (Lambda (sh_na na, t, c), combinesmall 5 (combine3 (hash_annot Name.hash na) ht hc)) | LetIn (na,b,t,c) -> - let b, hb = sh_rec b in - let t, ht = sh_rec t in - let c, hc = sh_rec c in + let b, hb = sh_rec b in + let t, ht = sh_rec t in + let c, hc = sh_rec c in (LetIn (sh_na na, b, t, c), combinesmall 6 (combine4 (hash_annot Name.hash na) hb ht hc)) | App (c,l) -> - let c, hc = sh_rec c in - let l, hl = hash_term_array l in - (App (c,l), combinesmall 7 (combine hl hc)) + let c, hc = sh_rec c in + let l, hl = hash_term_array l in + (App (c,l), combinesmall 7 (combine hl hc)) | Evar (e,l) -> - let l, hl = hash_term_array l in - (Evar (e,l), combinesmall 8 (combine (Evar.hash e) hl)) + let l, hl = hash_term_array l in + (Evar (e,l), combinesmall 8 (combine (Evar.hash e) hl)) | Const (c,u) -> - let c' = sh_con c in - let u', hu = sh_instance u in - (Const (c', u'), combinesmall 9 (combine (Constant.SyntacticOrd.hash c) hu)) + let c' = sh_con c in + let u', hu = sh_instance u in + (Const (c', u'), combinesmall 9 (combine (Constant.SyntacticOrd.hash c) hu)) | Ind (ind,u) -> - let u', hu = sh_instance u in - (Ind (sh_ind ind, u'), - combinesmall 10 (combine (ind_syntactic_hash ind) hu)) + let u', hu = sh_instance u in + (Ind (sh_ind ind, u'), + combinesmall 10 (combine (ind_syntactic_hash ind) hu)) | Construct (c,u) -> - let u', hu = sh_instance u in - (Construct (sh_construct c, u'), - combinesmall 11 (combine (constructor_syntactic_hash c) hu)) + let u', hu = sh_instance u in + (Construct (sh_construct c, u'), + combinesmall 11 (combine (constructor_syntactic_hash c) hu)) | Case (ci,p,c,bl) -> - let p, hp = sh_rec p - and c, hc = sh_rec c in - let bl,hbl = hash_term_array bl in + let p, hp = sh_rec p + and c, hc = sh_rec c in + let bl,hbl = hash_term_array bl in let hbl = combine (combine hc hp) hbl in - (Case (sh_ci ci, p, c, bl), combinesmall 12 hbl) + (Case (sh_ci ci, p, c, bl), combinesmall 12 hbl) | Fix (ln,(lna,tl,bl)) -> let bl,hbl = hash_term_array bl in - let tl,htl = hash_term_array tl in + let tl,htl = hash_term_array tl in let () = Array.iteri (fun i x -> Array.unsafe_set lna i (sh_na x)) lna in let fold accu na = combine (hash_annot Name.hash na) accu in let hna = Array.fold_left fold 0 lna in @@ -1238,16 +1238,16 @@ let hashcons (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) = (Fix (ln,(lna,tl,bl)), combinesmall 13 h) | CoFix(ln,(lna,tl,bl)) -> let bl,hbl = hash_term_array bl in - let tl,htl = hash_term_array tl in + let tl,htl = hash_term_array tl in let () = Array.iteri (fun i x -> Array.unsafe_set lna i (sh_na x)) lna in let fold accu na = combine (hash_annot Name.hash na) accu in let hna = Array.fold_left fold 0 lna in let h = combine3 hna hbl htl in (CoFix (ln,(lna,tl,bl)), combinesmall 14 h) | Meta n -> - (t, combinesmall 15 n) + (t, combinesmall 15 n) | Rel n -> - (t, combinesmall 16 n) + (t, combinesmall 16 n) | Proj (p,c) -> let c, hc = sh_rec c in let p' = Projection.hcons p in diff --git a/kernel/constr.mli b/kernel/constr.mli index 4f8d682e42..d4af1149c2 100644 --- a/kernel/constr.mli +++ b/kernel/constr.mli @@ -140,13 +140,13 @@ val mkConstructUi : pinductive * int -> constr val mkRef : GlobRef.t Univ.puniverses -> constr (** Constructs a destructor of inductive type. - - [mkCase ci p c ac] stand for match [c] as [x] in [I args] return [p] with [ac] + + [mkCase ci p c ac] stand for match [c] as [x] in [I args] return [p] with [ac] presented as describe in [ci]. [p] structure is [fun args x -> "return clause"] - [ac]{^ ith} element is ith constructor case presented as + [ac]{^ ith} element is ith constructor case presented as {e lambda construct_args (without params). case_term } *) val mkCase : case_info * constr * constr * constr array -> constr @@ -188,10 +188,10 @@ val mkFix : fixpoint -> constr (** If [funnames = [|f1,.....fn|]] [typarray = [|t1,...tn|]] - [bodies = [b1,.....bn]] + [bodies = [b1,.....bn]] then [mkCoFix (i, (funnames, typarray, bodies))] constructs the ith function of the block - + [CoFixpoint f1 = b1 with f2 = b2 ... @@ -365,7 +365,7 @@ val equal : constr -> constr -> bool application grouping and the universe equalities in [u]. *) val eq_constr_univs : constr UGraph.check_function -(** [leq_constr_univs u a b] is [true] if [a] is convertible to [b] modulo +(** [leq_constr_univs u a b] is [true] if [a] is convertible to [b] modulo alpha, casts, application grouping and the universe inequalities in [u]. *) val leq_constr_univs : constr UGraph.check_function @@ -373,7 +373,7 @@ val leq_constr_univs : constr UGraph.check_function application grouping and the universe equalities in [u]. *) val eq_constr_univs_infer : UGraph.t -> constr -> constr -> bool Univ.constrained -(** [leq_constr_univs u a b] is [true] if [a] is convertible to [b] modulo +(** [leq_constr_univs u a b] is [true] if [a] is convertible to [b] modulo alpha, casts, application grouping and the universe inequalities in [u]. *) val leq_constr_univs_infer : UGraph.t -> constr -> constr -> bool Univ.constrained diff --git a/kernel/context.ml b/kernel/context.ml index 2ef750ad69..7e394da2ed 100644 --- a/kernel/context.ml +++ b/kernel/context.ml @@ -74,7 +74,7 @@ struct let get_value = function | LocalAssum _ -> None | LocalDef (_,v,_) -> Some v - + (** Return the type of the name bound by a given declaration. *) let get_type = function | LocalAssum (_,ty) diff --git a/kernel/conv_oracle.mli b/kernel/conv_oracle.mli index 918dc8c928..4887e70cdb 100644 --- a/kernel/conv_oracle.mli +++ b/kernel/conv_oracle.mli @@ -18,7 +18,7 @@ val empty : oracle If [oracle_order kn1 kn2] is true, then unfold kn1 first. Note: the oracle does not introduce incompleteness, it only tries to postpone unfolding of "opaque" constants. *) -val oracle_order : ('a -> Constant.t) -> oracle -> bool -> +val oracle_order : ('a -> Constant.t) -> oracle -> bool -> 'a tableKey -> 'a tableKey -> bool (** Priority for the expansion of constant in the conversion test. diff --git a/kernel/cooking.ml b/kernel/cooking.ml index fae06f7163..9d7387c7ad 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -91,25 +91,25 @@ let expmod_constr cache modlist c = let rec substrec c = match kind c with | Case (ci,p,t,br) -> - Constr.map substrec (mkCase (update_case_info ci modlist,p,t,br)) + Constr.map substrec (mkCase (update_case_info ci modlist,p,t,br)) | Ind (ind,u) -> - (try - share_univs (IndRef ind) u modlist - with - | Not_found -> Constr.map substrec c) + (try + share_univs (IndRef ind) u modlist + with + | Not_found -> Constr.map substrec c) | Construct (cstr,u) -> - (try - share_univs (ConstructRef cstr) u modlist - with - | Not_found -> Constr.map substrec c) + (try + share_univs (ConstructRef cstr) u modlist + with + | Not_found -> Constr.map substrec c) | Const (cst,u) -> - (try - share_univs (ConstRef cst) u modlist - with - | Not_found -> Constr.map substrec c) + (try + share_univs (ConstRef cst) u modlist + with + | Not_found -> Constr.map substrec c) | Proj (p, c') -> let map cst npars = diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml index cbffdc731e..978c2c9f57 100644 --- a/kernel/csymtable.ml +++ b/kernel/csymtable.ml @@ -135,12 +135,12 @@ let rec slot_for_getglobal env kn = match cb.const_body_code with | None -> set_global (val_of_constant kn) | Some code -> - match Cemitcodes.force code with - | BCdefined(code,pl,fv) -> + match Cemitcodes.force code with + | BCdefined(code,pl,fv) -> let v = eval_to_patch env (code,pl,fv) in set_global v - | BCalias kn' -> slot_for_getglobal env kn' - | BCconstant -> set_global (val_of_constant kn) + | BCalias kn' -> slot_for_getglobal env kn' + | BCconstant -> set_global (val_of_constant kn) in (*Pp.msgnl(str"value stored at: "++int pos);*) rk := Some (CEphemeron.create pos); diff --git a/kernel/declarations.ml b/kernel/declarations.ml index 44676c9da5..9fd10b32e6 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -25,7 +25,7 @@ type engagement = set_predicativity and constants hiding inductives are implicitly polymorphic when applied to parameters, on the universes appearing in the whnf of their parameters and their conclusion, in a template style. - + In truly universe polymorphic mode, we always use RegularArity. *) @@ -34,7 +34,7 @@ type template_arity = { template_level : Univ.Universe.t; } -type ('a, 'b) declaration_arity = +type ('a, 'b) declaration_arity = | RegularArity of 'a | TemplateArity of 'b diff --git a/kernel/declareops.ml b/kernel/declareops.ml index 7225671a1e..35185b6a5e 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -31,14 +31,14 @@ let safe_flags oracle = { (** {6 Arities } *) -let subst_decl_arity f g sub ar = +let subst_decl_arity f g sub ar = match ar with - | RegularArity x -> - let x' = f sub x in + | RegularArity x -> + let x' = f sub x in if x' == x then ar else RegularArity x' - | TemplateArity x -> - let x' = g sub x in + | TemplateArity x -> + let x' = g sub x in if x' == x then ar else TemplateArity x' @@ -197,7 +197,7 @@ let subst_wf_paths sub p = Rtree.Smart.map (subst_recarg sub) p let subst_regular_ind_arity sub s = let uar' = subst_mps sub s.mind_user_arity in - if uar' == s.mind_user_arity then s + if uar' == s.mind_user_arity then s else { mind_user_arity = uar'; mind_sort = s.mind_sort } let subst_template_ind_arity _sub s = s diff --git a/kernel/entries.ml b/kernel/entries.ml index 046ea86872..b50c3ebbc3 100644 --- a/kernel/entries.ml +++ b/kernel/entries.ml @@ -87,7 +87,7 @@ type 'a opaque_entry = { type inline = int option (* inlining level, None for no inlining *) -type parameter_entry = +type parameter_entry = Id.Set.t option * types in_universes_entry * inline type primitive_entry = { diff --git a/kernel/environ.ml b/kernel/environ.ml index 2bee2f7a8e..f04863386f 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -259,7 +259,7 @@ let set_oracle env o = let engagement env = env.env_stratification.env_engagement let typing_flags env = env.env_typing_flags -let is_impredicative_set env = +let is_impredicative_set env = match engagement env with | ImpredicativeSet -> true | _ -> false @@ -312,11 +312,11 @@ let fold_rel_context f env ~init = match match_rel_context_val env.env_rel_context with | None -> init | Some (rd, _, rc) -> - let env = - { env with - env_rel_context = rc; - env_nb_rel = env.env_nb_rel - 1 } in - f env rd (fold_right env) + let env = + { env with + env_rel_context = rc; + env_nb_rel = env.env_nb_rel - 1 } in + f env rd (fold_right env) in fold_right env (* Named context *) @@ -376,9 +376,9 @@ let fold_named_context f env ~init = match match_named_context_val env.env_named_context with | None -> init | Some (d, _v, rem) -> - let env = - reset_with_named_context rem env in - f env d (fold_right env) + let env = + reset_with_named_context rem env in + f env d (fold_right env) in fold_right env let fold_named_context_reverse f ~init env = @@ -390,7 +390,7 @@ let fold_named_context_reverse f ~init env = let map_universes f env = let s = env.env_stratification in { env with env_stratification = - { s with env_universes = f s.env_universes } } + { s with env_universes = f s.env_universes } } let add_constraints c env = if Univ.Constraint.is_empty c then env @@ -405,10 +405,10 @@ let push_constraints_to_env (_,univs) env = let add_universes ~lbound ~strict ctx g = let g = Array.fold_left (fun g v -> UGraph.add_universe ~lbound ~strict v g) - g (Univ.Instance.to_array (Univ.UContext.instance ctx)) + g (Univ.Instance.to_array (Univ.UContext.instance ctx)) in UGraph.merge_constraints (Univ.UContext.constraints ctx) g - + let push_context ?(strict=false) ctx env = map_universes (add_universes ~lbound:(universes_lbound env) ~strict ctx) env @@ -416,7 +416,7 @@ let add_universes_set ~lbound ~strict ctx g = let g = Univ.LSet.fold (* Be lenient, module typing reintroduces universes and constraints due to includes *) (fun v g -> try UGraph.add_universe ~lbound ~strict v g with UGraph.AlreadyDeclared -> g) - (Univ.ContextSet.levels ctx) g + (Univ.ContextSet.levels ctx) g in UGraph.merge_constraints (Univ.ContextSet.constraints ctx) g let push_context_set ?(strict=false) ctx env = @@ -514,8 +514,8 @@ let constant_value_and_type env (kn, u) = in b', subst_instance_constr u cb.const_type, cst -(* These functions should be called under the invariant that [env] - already contains the constraints corresponding to the constant +(* These functions should be called under the invariant that [env] + already contains the constraints corresponding to the constant application. *) (* constant_type gives the type of a constant *) @@ -526,9 +526,9 @@ let constant_type_in env (kn,u) = let constant_value_in env (kn,u) = let cb = lookup_constant kn env in match cb.const_body with - | Def l_body -> + | Def l_body -> let b = Mod_subst.force_constr l_body in - subst_instance_constr u b + subst_instance_constr u b | OpaqueDef _ -> raise (NotEvaluableConst Opaque) | Undef _ -> raise (NotEvaluableConst NoBody) | Primitive p -> raise (NotEvaluableConst (IsPrimitive p)) @@ -595,7 +595,7 @@ let template_checked_ind (mind,_i) env = (lookup_mind mind env).mind_typing_flags.check_template let template_polymorphic_ind (mind,i) env = - match (lookup_mind mind env).mind_packets.(i).mind_arity with + match (lookup_mind mind env).mind_packets.(i).mind_arity with | TemplateArity _ -> true | RegularArity _ -> false @@ -608,7 +608,7 @@ let template_polymorphic_variables (mind,i) env = let template_polymorphic_pind (ind,u) env = if not (Univ.Instance.is_empty u) then false else template_polymorphic_ind ind env - + let add_mind_key kn (_mind, _ as mind_key) env = let new_inds = Mindmap_env.add kn mind_key env.env_globals.Globals.inductives in let new_globals = @@ -749,11 +749,11 @@ let apply_to_hyp ctxt id f = let rec aux rtail ctxt = match match_named_context_val ctxt with | Some (d, v, ctxt) -> - if Id.equal (get_id d) id then + if Id.equal (get_id d) id then push_named_context_val_val (f ctxt.env_named_ctx d rtail) v ctxt - else - let ctxt' = aux (d::rtail) ctxt in - push_named_context_val_val d v ctxt' + else + let ctxt' = aux (d::rtail) ctxt in + push_named_context_val_val d v ctxt' | None -> raise Hyp_not_found in aux [] ctxt diff --git a/kernel/environ.mli b/kernel/environ.mli index 782ea1c666..257bd43083 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -127,7 +127,7 @@ val push_rel : Constr.rel_declaration -> env -> env val push_rel_context : Constr.rel_context -> env -> env val push_rec_types : rec_declaration -> env -> env -(** Looks up in the context of local vars referred by indice ([rel_context]) +(** Looks up in the context of local vars referred by indice ([rel_context]) raises [Not_found] if the index points out of the context *) val lookup_rel : int -> env -> Constr.rel_declaration val lookup_rel_val : int -> env -> lazy_val @@ -160,7 +160,7 @@ val push_named_context_val : -(** Looks up in the context of local vars referred by names ([named_context]) +(** Looks up in the context of local vars referred by names ([named_context]) raises [Not_found] if the Id.t is not found *) val lookup_named : variable -> env -> Constr.named_declaration @@ -200,7 +200,7 @@ val add_constant_key : Constant.t -> Opaqueproof.opaque constant_body -> link_in env -> env val lookup_constant_key : Constant.t -> env -> constant_key -(** Looks up in the context of global constant names +(** Looks up in the context of global constant names raises an anomaly if the required path is not found *) val lookup_constant : Constant.t -> env -> Opaqueproof.opaque constant_body val evaluable_constant : Constant.t -> env -> bool @@ -227,14 +227,14 @@ exception NotEvaluableConst of const_evaluation_result val constant_type : env -> Constant.t puniverses -> types constrained -val constant_value_and_type : env -> Constant.t puniverses -> +val constant_value_and_type : env -> Constant.t puniverses -> constr option * types * Univ.Constraint.t -(** The universe context associated to the constant, empty if not +(** The universe context associated to the constant, empty if not polymorphic *) val constant_context : env -> Constant.t -> Univ.AUContext.t -(* These functions should be called under the invariant that [env] - already contains the constraints corresponding to the constant +(* These functions should be called under the invariant that [env] + already contains the constraints corresponding to the constant application. *) val constant_value_in : env -> Constant.t puniverses -> constr val constant_type_in : env -> Constant.t puniverses -> types @@ -255,7 +255,7 @@ val lookup_mind_key : MutInd.t -> env -> mind_key val add_mind_key : MutInd.t -> mind_key -> env -> env val add_mind : MutInd.t -> mutual_inductive_body -> env -> env -(** Looks up in the context of global inductive names +(** Looks up in the context of global inductive names raises an anomaly if the required path is not found *) val lookup_mind : MutInd.t -> env -> mutual_inductive_body diff --git a/kernel/esubst.mli b/kernel/esubst.mli index 400f91d302..a1a5b5251a 100644 --- a/kernel/esubst.mli +++ b/kernel/esubst.mli @@ -11,7 +11,7 @@ (** Explicit substitutions *) (** {6 Explicit substitutions } *) -(** Explicit substitutions of type ['a]. +(** Explicit substitutions of type ['a]. - ESID(n) = %n END bounded identity - CONS([|t1..tn|],S) = (S.t1...tn) parallel substitution (beware of the order: indice 1 is substituted by tn) diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index aa3ef715db..750ac86908 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -74,18 +74,18 @@ let explain_ind_err id ntyp env nparamsctxt c err = let (_lparams,c') = mind_extract_params nparamsctxt c in match err with | LocalNonPos kt -> - raise (InductiveError (NonPos (env,c',mkRel (kt+nparamsctxt)))) + raise (InductiveError (NonPos (env,c',mkRel (kt+nparamsctxt)))) | LocalNotEnoughArgs kt -> - raise (InductiveError - (NotEnoughArgs (env,c',mkRel (kt+nparamsctxt)))) + raise (InductiveError + (NotEnoughArgs (env,c',mkRel (kt+nparamsctxt)))) | LocalNotConstructor (paramsctxt,nargs)-> let nparams = Context.Rel.nhyps paramsctxt in - raise (InductiveError - (NotConstructor (env,id,c',mkRel (ntyp+nparamsctxt), + raise (InductiveError + (NotConstructor (env,id,c',mkRel (ntyp+nparamsctxt), nparams,nargs))) | LocalNonPar (n,i,l) -> - raise (InductiveError - (NonPar (env,c',n,mkRel i,mkRel (l+nparamsctxt)))) + raise (InductiveError + (NonPar (env,c',n,mkRel i,mkRel (l+nparamsctxt)))) let failwith_non_pos n ntypes c = for k = n to n + ntypes - 1 do @@ -115,9 +115,9 @@ let check_correct_par (env,n,ntypes,_) paramdecls ind_index args = check param_index (paramdecl_index+1) paramdecls | _::paramdecls -> match kind (whd_all env params.(param_index)) with - | Rel w when Int.equal w paramdecl_index -> + | Rel w when Int.equal w paramdecl_index -> check (param_index-1) (paramdecl_index+1) paramdecls - | _ -> + | _ -> let paramdecl_index_in_env = paramdecl_index-n+nparamdecls+1 in let err = LocalNonPar (param_index+1, paramdecl_index_in_env, ind_index) in @@ -137,12 +137,12 @@ if Int.equal nmr 0 then 0 else let (lpar,_) = List.chop nmr largs in let rec find k index = function - ([],_) -> nmr - | (_,[]) -> assert false (* |paramsctxt|>=nmr *) - | (lp, LocalDef _ :: paramsctxt) -> find k (index-1) (lp,paramsctxt) - | (p::lp,_::paramsctxt) -> + ([],_) -> nmr + | (_,[]) -> assert false (* |paramsctxt|>=nmr *) + | (lp, LocalDef _ :: paramsctxt) -> find k (index-1) (lp,paramsctxt) + | (p::lp,_::paramsctxt) -> ( match kind (whd_all env p) with - | Rel w when Int.equal w index -> find (k+1) (index-1) (lp,paramsctxt) + | Rel w when Int.equal w index -> find (k+1) (index-1) (lp,paramsctxt) | _ -> k) in find 0 (n-1) (lpar,List.rev paramsctxt) @@ -177,7 +177,7 @@ let rec ienv_decompose_prod (env,_,_,_ as ienv) n c = match kind c' with Prod(na,a,b) -> let ienv' = ienv_push_var ienv (na,a,mk_norec) in - ienv_decompose_prod ienv' (n-1) b + ienv_decompose_prod ienv' (n-1) b | _ -> assert false let array_min nmr a = if Int.equal nmr 0 then 0 else @@ -205,36 +205,36 @@ let check_positivity_one ~chkpos recursive (env,_,ntypes,_ as ienv) paramsctxt ( let x,largs = decompose_app (whd_all env c) in match kind x with | Prod (na,b,d) -> - let () = assert (List.is_empty largs) in + let () = assert (List.is_empty largs) in (** If one of the inductives of the mutually inductive block occurs in the left-hand side of a product, then such an occurrence is a non-strictly-positive recursive call. Occurrences in the right-hand side of the product must be strictly positive.*) (match weaker_noccur_between env n ntypes b with - | None when chkpos -> + | None when chkpos -> failwith_non_pos_list n ntypes [b] | None -> check_pos (ienv_push_var ienv (na, b, mk_norec)) nmr d | Some b -> check_pos (ienv_push_var ienv (na, b, mk_norec)) nmr d) - | Rel k -> + | Rel k -> (try let (ra,rarg) = List.nth ra_env (k-1) in let largs = List.map (whd_all env) largs in - let nmr1 = - (match ra with + let nmr1 = + (match ra with Mrec _ -> compute_rec_par ienv paramsctxt nmr largs - | _ -> nmr) - in + | _ -> nmr) + in (** The case where one of the inductives of the mutually inductive block occurs as an argument of another is not known to be safe. So Coq rejects it. *) - if chkpos && + if chkpos && not (List.for_all (noccur_between n ntypes) largs) - then failwith_non_pos_list n ntypes largs - else (nmr1,rarg) + then failwith_non_pos_list n ntypes largs + else (nmr1,rarg) with Failure _ | Invalid_argument _ -> (nmr,mk_norec)) - | Ind ind_kn -> + | Ind ind_kn -> (** If one of the inductives of the mutually inductive block being defined appears in a parameter, then we have a nested inductive type. The positivity is then @@ -245,11 +245,11 @@ let check_positivity_one ~chkpos recursive (env,_,ntypes,_ as ienv) paramsctxt ( (** If an inductive of the mutually inductive block appears in any other way, then the positivy check gives up. *) - if not chkpos || + if not chkpos || (noccur_between n ntypes x && List.for_all (noccur_between n ntypes) largs) - then (nmr,mk_norec) - else failwith_non_pos_list n ntypes (x::largs) + then (nmr,mk_norec) + else failwith_non_pos_list n ntypes (x::largs) (** [check_positive_nested] handles the case of nested inductive calls, that is, when an inductive types from the mutually @@ -270,35 +270,35 @@ let check_positivity_one ~chkpos recursive (env,_,ntypes,_ as ienv) paramsctxt ( allowed to appear nested in the parameters of another inductive type. Not in the proper indices. *) if chkpos && not (List.for_all (noccur_between n ntypes) auxnonrecargs) then - failwith_non_pos_list n ntypes auxnonrecargs; + failwith_non_pos_list n ntypes auxnonrecargs; (* Nested mutual inductive types are not supported *) let auxntyp = mib.mind_ntypes in - if not (Int.equal auxntyp 1) then raise (IllFormedInd (LocalNonPos n)); - (* The nested inductive type with parameters removed *) - let auxlcvect = abstract_mind_lc auxntyp auxnrecpar mip.mind_nf_lc in - (* Extends the environment with a variable corresponding to - the inductive def *) - let (env',_,_,_ as ienv') = ienv_push_inductive ienv ((mi,u),auxrecparams) in - (* Parameters expressed in env' *) - let auxrecparams' = List.map (lift auxntyp) auxrecparams in - let irecargs_nmr = - (** Checks that the "nesting" inductive type is covariant in - the relevant parameters. In other words, that the - (nested) parameters which are instantiated with - inductives of the mutually inductive block occur - positively in the types of the nested constructors. *) - Array.map - (function c -> - let c' = hnf_prod_applist env' c auxrecparams' in - (* skip non-recursive parameters *) - let (ienv',c') = ienv_decompose_prod ienv' auxnnonrecpar c' in - check_constructors ienv' false nmr c') - auxlcvect - in - let irecargs = Array.map snd irecargs_nmr - and nmr' = array_min nmr irecargs_nmr - in - (nmr',(Rtree.mk_rec [|mk_paths (Imbr mi) irecargs|]).(0)) + if not (Int.equal auxntyp 1) then raise (IllFormedInd (LocalNonPos n)); + (* The nested inductive type with parameters removed *) + let auxlcvect = abstract_mind_lc auxntyp auxnrecpar mip.mind_nf_lc in + (* Extends the environment with a variable corresponding to + the inductive def *) + let (env',_,_,_ as ienv') = ienv_push_inductive ienv ((mi,u),auxrecparams) in + (* Parameters expressed in env' *) + let auxrecparams' = List.map (lift auxntyp) auxrecparams in + let irecargs_nmr = + (** Checks that the "nesting" inductive type is covariant in + the relevant parameters. In other words, that the + (nested) parameters which are instantiated with + inductives of the mutually inductive block occur + positively in the types of the nested constructors. *) + Array.map + (function c -> + let c' = hnf_prod_applist env' c auxrecparams' in + (* skip non-recursive parameters *) + let (ienv',c') = ienv_decompose_prod ienv' auxnnonrecpar c' in + check_constructors ienv' false nmr c') + auxlcvect + in + let irecargs = Array.map snd irecargs_nmr + and nmr' = array_min nmr irecargs_nmr + in + (nmr',(Rtree.mk_rec [|mk_paths (Imbr mi) irecargs|]).(0)) (** [check_constructors ienv check_head nmr c] checks the positivity condition in the type [c] of a constructor (i.e. that recursive @@ -311,11 +311,11 @@ let check_positivity_one ~chkpos recursive (env,_,ntypes,_ as ienv) paramsctxt ( and check_constructors ienv check_head nmr c = let rec check_constr_rec (env,n,ntypes,_ra_env as ienv) nmr lrec c = let x,largs = decompose_app (whd_all env c) in - match kind x with + match kind x with | Prod (na,b,d) -> - let () = assert (List.is_empty largs) in - if not recursive && not (noccur_between n ntypes b) then + let () = assert (List.is_empty largs) in + if not recursive && not (noccur_between n ntypes b) then raise (InductiveError Type_errors.BadEntry); let nmr',recarg = check_pos ienv nmr b in let ienv' = ienv_push_var ienv (na,b,mk_norec) in @@ -341,9 +341,9 @@ let check_positivity_one ~chkpos recursive (env,_,ntypes,_ as ienv) paramsctxt ( (fun id c -> let _,rawc = mind_extract_params nparamsctxt c in try - check_constructors ienv true nmr rawc + check_constructors ienv true nmr rawc with IllFormedInd err -> - explain_ind_err id (ntypes-i) env nparamsctxt c err) + explain_ind_err id (ntypes-i) env nparamsctxt c err) (Array.of_list lcnames) indlc in let irecargs = Array.map snd irecargs_nmr @@ -397,7 +397,7 @@ let rel_list n m = Array.to_list (rel_vect n m) (** From a rel context describing the constructor arguments, build an expansion function. - The term built is expecting to be substituted first by + The term built is expecting to be substituted first by a substitution of the form [params, x : ind params] *) let compute_projections (kn, i as ind) mib = let pkt = mib.mind_packets.(i) in @@ -444,10 +444,10 @@ let compute_projections (kn, i as ind) mib = let t = liftn 1 j t in (* from [params, x:I, field1,..,fieldj |- t(params,field1,..,fieldj)] to [params-wo-let, x:I |- t(params,proj1 x,..,projj x)] *) - let projty = substl letsubst t in + let projty = substl letsubst t in (* from [params, x:I, field1,..,fieldj |- t(field1,..,fieldj)] to [params, x:I |- t(proj1 x,..,projj x)] *) - let fterm = mkProj (Projection.make kn false, mkRel 1) in + let fterm = mkProj (Projection.make kn false, mkRel 1) in (i + 1, j + 1, lab :: labs, r :: rs, projty :: pbs, fterm :: letsubst) | Anonymous -> assert false (* checked by indTyping *) in @@ -469,7 +469,7 @@ let build_inductive env names prv univs variance paramsctxt kn isrecord isfinite let nf_lc = Array.map (fun (d, b) -> (d@paramsctxt, b)) splayed_lc in let consnrealdecls = Array.map (fun (d,_) -> Context.Rel.length d) - splayed_lc in + splayed_lc in let consnrealargs = Array.map (fun (d,_) -> Context.Rel.nhyps d) splayed_lc in @@ -481,14 +481,14 @@ let build_inductive env names prv univs variance paramsctxt kn isrecord isfinite let nconst, nblock = ref 0, ref 0 in let transf num = let arity = List.length (dest_subterms recarg).(num) in - if Int.equal arity 0 then - let p = (!nconst, 0) in - incr nconst; p - else - let p = (!nblock + 1, arity) in - incr nblock; p - (* les tag des constructeur constant commence a 0, - les tag des constructeur non constant a 1 (0 => accumulator) *) + if Int.equal arity 0 then + let p = (!nconst, 0) in + incr nconst; p + else + let p = (!nblock + 1, arity) in + incr nblock; p + (* les tag des constructeur constant commence a 0, + les tag des constructeur non constant a 1 (0 => accumulator) *) in let rtbl = Array.init (List.length cnames) transf in (* Build the inductive packet *) @@ -497,17 +497,17 @@ let build_inductive env names prv univs variance paramsctxt kn isrecord isfinite mind_arity_ctxt = indices @ paramsctxt; mind_nrealargs = Context.Rel.nhyps indices; mind_nrealdecls = Context.Rel.length indices; - mind_kelim = kelim; - mind_consnames = Array.of_list cnames; - mind_consnrealdecls = consnrealdecls; - mind_consnrealargs = consnrealargs; - mind_user_lc = lc; - mind_nf_lc = nf_lc; + mind_kelim = kelim; + mind_consnames = Array.of_list cnames; + mind_consnrealdecls = consnrealdecls; + mind_consnrealargs = consnrealargs; + mind_user_lc = lc; + mind_nf_lc = nf_lc; mind_recargs = recarg; mind_relevance; mind_nb_constant = !nconst; - mind_nb_args = !nblock; - mind_reloc_tbl = rtbl; + mind_nb_args = !nblock; + mind_reloc_tbl = rtbl; } in let packets = Array.map3 build_one_packet names inds recargs in let mib = diff --git a/kernel/inductive.ml b/kernel/inductive.ml index 2966acae45..ca4fea45c5 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -52,7 +52,7 @@ let find_coinductive env c = let inductive_params (mib,_) = mib.mind_nparams -let inductive_paramdecls (mib,u) = +let inductive_paramdecls (mib,u) = Vars.subst_instance_context u mib.mind_params_ctxt let instantiate_inductive_constraints mib u = @@ -81,9 +81,9 @@ let instantiate_params full t u args sign = match (decl, largs, kind ty) with | (LocalAssum _, a::args, Prod(_,_,t)) -> (args, a::subs, t) | (LocalDef (_,b,_), _, LetIn(_,_,_,t)) -> - (largs, (substl subs (subst_instance_constr u b))::subs, t) - | (_,[],_) -> if full then fail() else ([], subs, ty) - | _ -> fail ()) + (largs, (substl subs (subst_instance_constr u b))::subs, t) + | (_,[],_) -> if full then fail() else ([], subs, ty) + | _ -> fail ()) sign ~init:(args,[],t) in @@ -98,7 +98,7 @@ let full_inductive_instantiate mib u params sign = let full_constructor_instantiate ((mind,_),u,(mib,_),params) t = let inst_ind = constructor_instantiate mind u mib t in instantiate_params true inst_ind u params mib.mind_params_ctxt - + (************************************************************************) (************************************************************************) @@ -211,7 +211,7 @@ let type_of_inductive_gen ?(polyprop=true) env ((_,mip),u) paramtyps = then raise (SingletonInductiveBecomesProp mip.mind_typename); Term.mkArity (List.rev ctx,s) -let type_of_inductive env pind = +let type_of_inductive env pind = type_of_inductive_gen env pind [||] let constrained_type_of_inductive env ((mib,_mip),u as pind) = @@ -292,7 +292,7 @@ let get_instantiated_arity (_ind,u) (mib,mip) params = let elim_sort (_,mip) = mip.mind_kelim let is_private (mib,_) = mib.mind_private = Some true -let is_primitive_record (mib,_) = +let is_primitive_record (mib,_) = match mib.mind_record with | PrimRecord _ -> true | NotRecord | FakeRecord -> false @@ -325,20 +325,20 @@ let is_correct_arity env c pj ind specif params = (* The last Prod domain is the type of the scrutinee *) | Prod (na1,a1,a2), [] -> (* whnf of t was not needed here! *) let env' = push_rel (LocalAssum (na1,a1)) env in - let ksort = match kind (whd_all env' a2) with - | Sort s -> Sorts.family s - | _ -> raise (LocalArity None) in - let dep_ind = build_dependent_inductive ind specif params in - let _ = + let ksort = match kind (whd_all env' a2) with + | Sort s -> Sorts.family s + | _ -> raise (LocalArity None) in + let dep_ind = build_dependent_inductive ind specif params in + let _ = try conv env a1 dep_ind with NotConvertible -> raise (LocalArity None) in - check_allowed_sort ksort specif + check_allowed_sort ksort specif | _, (LocalDef _ as d)::ar' -> - srec (push_rel d env) (lift 1 pt') ar' + srec (push_rel d env) (lift 1 pt') ar' | _ -> - raise (LocalArity None) + raise (LocalArity None) in - try srec env pj.uj_type (List.rev arsign) + try srec env pj.uj_type (List.rev arsign) with LocalArity kinds -> error_elim_arity env ind c pj kinds @@ -517,10 +517,10 @@ let push_fix_renv renv (_,v,_ as recdef) = (* Definition and manipulation of the stack *) type stack_element = |SClosure of guard_env*constr |SArg of subterm_spec Lazy.t -let push_stack_closures renv l stack = +let push_stack_closures renv l stack = List.fold_right (fun h b -> (SClosure (renv,h))::b) l stack -let push_stack_args l stack = +let push_stack_args l stack = List.fold_right (fun h b -> (SArg h)::b) l stack (******************************) @@ -540,7 +540,7 @@ let match_inductive ind ra = [branches_specif renv c_spec ci] returns an array of x_s specs knowing c_spec. *) let branches_specif renv c_spec ci = - let car = + let car = (* We fetch the regular tree associated to the inductive of the match. This is just to get the number of constructors (and constructor arities) that fit the match branches without forcing c_spec. @@ -551,16 +551,16 @@ let branches_specif renv c_spec ci = Array.map List.length v in Array.mapi (fun i nca -> (* i+1-th cstructor has arity nca *) - let lvra = lazy - (match Lazy.force c_spec with - Subterm (_,t) when match_inductive ci.ci_ind (dest_recarg t) -> - let vra = Array.of_list (dest_subterms t).(i) in - assert (Int.equal nca (Array.length vra)); - Array.map spec_of_tree vra - | Dead_code -> Array.make nca Dead_code - | _ -> Array.make nca Not_subterm) in - List.init nca (fun j -> lazy (Lazy.force lvra).(j))) - car + let lvra = lazy + (match Lazy.force c_spec with + Subterm (_,t) when match_inductive ci.ci_ind (dest_recarg t) -> + let vra = Array.of_list (dest_subterms t).(i) in + assert (Int.equal nca (Array.length vra)); + Array.map spec_of_tree vra + | Dead_code -> Array.make nca Dead_code + | _ -> Array.make nca Not_subterm) in + List.init nca (fun j -> lazy (Lazy.force lvra).(j))) + car let check_inductive_codomain env p = let absctx, ar = dest_lam_assum env p in @@ -615,7 +615,7 @@ let abstract_mind_lc ntyps npars lc = else let make_abs = List.init ntyps - (function i -> lambda_implicit_lift npars (mkRel (i+1))) + (function i -> lambda_implicit_lift npars (mkRel (i+1))) in Array.map (substl make_abs) lc @@ -639,9 +639,9 @@ let get_recargs_approx env tree ind args = (* When the inferred tree allows it, we consider that we have a potential nested inductive type *) begin match dest_recarg tree with - | Imbr kn' | Mrec kn' when eq_ind (fst ind_kn) kn' -> - build_recargs_nested ienv tree (ind_kn, largs) - | _ -> mk_norec + | Imbr kn' | Mrec kn' when eq_ind (fst ind_kn) kn' -> + build_recargs_nested ienv tree (ind_kn, largs) + | _ -> mk_norec end | _err -> mk_norec @@ -656,7 +656,7 @@ let get_recargs_approx env tree ind args = let (lpar,_) = List.chop auxnpar largs in let auxntyp = mib.mind_ntypes in (* Extends the environment with a variable corresponding to - the inductive def *) + the inductive def *) let (env',_ as ienv') = ienv_push_inductive ienv ((mind,u),lpar) in (* Parameters expressed in env' *) let lpar' = List.map (lift auxntyp) lpar in @@ -672,11 +672,11 @@ let get_recargs_approx env tree ind args = let auxlcvect = abstract_mind_lc auxntyp auxnpar specif.mind_nf_lc in let paths = Array.mapi (fun k c -> - let c' = hnf_prod_applist env' c lpar' in - (* skip non-recursive parameters *) - let (ienv',c') = ienv_decompose_prod ienv' nonrecpar c' in - build_recargs_constructors ienv' trees.(j).(k) c') - auxlcvect + let c' = hnf_prod_applist env' c lpar' in + (* skip non-recursive parameters *) + let (ienv',c') = ienv_decompose_prod ienv' nonrecpar c' in + build_recargs_constructors ienv' trees.(j).(k) c') + auxlcvect in mk_paths (Imbr (mind,j)) paths in @@ -686,10 +686,10 @@ let get_recargs_approx env tree ind args = and build_recargs_constructors ienv trees c = let rec recargs_constr_rec (env,_ra_env as ienv) trees lrec c = let x,largs = decompose_app (whd_all env c) in - match kind x with + match kind x with | Prod (na,b,d) -> - let () = assert (List.is_empty largs) in + let () = assert (List.is_empty largs) in let recarg = build_recargs ienv (List.hd trees) b in let ienv' = ienv_push_var ienv (na,b,mk_norec) in recargs_constr_rec ienv' (List.tl trees) (recarg::lrec) d @@ -718,12 +718,12 @@ let restrict_spec env spec p = match kind i with | Ind i -> begin match spec with - | Dead_code -> spec - | Subterm(st,tree) -> - let recargs = get_recargs_approx env tree i args in - let recargs = inter_wf_paths tree recargs in - Subterm(st,recargs) - | _ -> assert false + | Dead_code -> spec + | Subterm(st,tree) -> + let recargs = get_recargs_approx env tree i args in + let recargs = inter_wf_paths tree recargs in + Subterm(st,recargs) + | _ -> assert false end | _ -> Not_subterm @@ -741,25 +741,25 @@ let rec subterm_specif renv stack t = | Case (ci,p,c,lbr) -> let stack' = push_stack_closures renv l stack in let cases_spec = - branches_specif renv (lazy_subterm_specif renv [] c) ci + branches_specif renv (lazy_subterm_specif renv [] c) ci in let stl = - Array.mapi (fun i br' -> - let stack_br = push_stack_args (cases_spec.(i)) stack' in - subterm_specif renv stack_br br') - lbr in + Array.mapi (fun i br' -> + let stack_br = push_stack_args (cases_spec.(i)) stack' in + subterm_specif renv stack_br br') + lbr in let spec = subterm_spec_glb stl in restrict_spec renv.env spec p | Fix ((recindxs,i),(_,typarray,bodies as recdef)) -> (* when proving that the fixpoint f(x)=e is less than n, it is enough - to prove that e is less than n assuming f is less than n - furthermore when f is applied to a term which is strictly less than - n, one may assume that x itself is strictly less than n + to prove that e is less than n assuming f is less than n + furthermore when f is applied to a term which is strictly less than + n, one may assume that x itself is strictly less than n *) if not (check_inductive_codomain renv.env typarray.(i)) then Not_subterm - else - let (ctxt,clfix) = dest_prod renv.env typarray.(i) in + else + let (ctxt,clfix) = dest_prod renv.env typarray.(i) in let oind = let env' = push_rel_context ctxt renv.env in try Some(fst(find_inductive env' clfix)) @@ -767,39 +767,39 @@ let rec subterm_specif renv stack t = (match oind with None -> Not_subterm (* happens if fix is polymorphic *) | Some (ind, _) -> - let nbfix = Array.length typarray in - let recargs = lookup_subterms renv.env ind in - (* pushing the fixpoints *) - let renv' = push_fix_renv renv recdef in - let renv' = + let nbfix = Array.length typarray in + let recargs = lookup_subterms renv.env ind in + (* pushing the fixpoints *) + let renv' = push_fix_renv renv recdef in + let renv' = (* Why Strict here ? To be general, it could also be - Large... *) + Large... *) assign_var_spec renv' - (nbfix-i, lazy (Subterm(Strict,recargs))) in - let decrArg = recindxs.(i) in - let theBody = bodies.(i) in - let nbOfAbst = decrArg+1 in - let sign,strippedBody = Term.decompose_lam_n_assum nbOfAbst theBody in - (* pushing the fix parameters *) - let stack' = push_stack_closures renv l stack in - let renv'' = push_ctxt_renv renv' sign in - let renv'' = + (nbfix-i, lazy (Subterm(Strict,recargs))) in + let decrArg = recindxs.(i) in + let theBody = bodies.(i) in + let nbOfAbst = decrArg+1 in + let sign,strippedBody = Term.decompose_lam_n_assum nbOfAbst theBody in + (* pushing the fix parameters *) + let stack' = push_stack_closures renv l stack in + let renv'' = push_ctxt_renv renv' sign in + let renv'' = if List.length stack' < nbOfAbst then renv'' else - let decrArg = List.nth stack' decrArg in + let decrArg = List.nth stack' decrArg in let arg_spec = stack_element_specif decrArg in - assign_var_spec renv'' (1, arg_spec) in - subterm_specif renv'' [] strippedBody) + assign_var_spec renv'' (1, arg_spec) in + subterm_specif renv'' [] strippedBody) | Lambda (x,a,b) -> let () = assert (List.is_empty l) in let spec,stack' = extract_stack stack in - subterm_specif (push_var renv (x,a,spec)) stack' b + subterm_specif (push_var renv (x,a,spec)) stack' b (* Metas and evars are considered OK *) | (Meta _|Evar _) -> Dead_code - | Proj (p, c) -> + | Proj (p, c) -> let subt = subterm_specif renv stack c in (match subt with | Subterm (_s, wf) -> @@ -850,7 +850,7 @@ let error_illegal_rec_call renv fx (arg_renv,arg) = (1,[],[]) renv.genv in raise (FixGuardError (renv.env, RecursionOnIllegalTerm(fx,(arg_renv.env, arg), - le_vars,lt_vars))) + le_vars,lt_vars))) let error_partial_apply renv fx = raise (FixGuardError (renv.env,NotEnoughArgumentsForFixCall fx)) @@ -870,7 +870,7 @@ let filter_stack_domain env p stack = let env = push_rel_context ctx env in let ty, args = decompose_app (whd_all env a) in let elt = match kind ty with - | Ind ind -> + | Ind ind -> let spec' = stack_element_specif elt in (match (Lazy.force spec') with | Not_subterm | Dead_code -> elt @@ -894,8 +894,8 @@ let judgment_of_fixpoint (_, types, bodies) = let check_one_fix renv recpos trees def = let nfi = Array.length recpos in - (* Checks if [t] only make valid recursive calls - [stack] is the list of constructor's argument specification and + (* Checks if [t] only make valid recursive calls + [stack] is the list of constructor's argument specification and arguments that will be applied after reduction. example u in t where we have (match .. with |.. => t end) u *) let rec check_rec_call renv stack t = @@ -906,24 +906,24 @@ let check_one_fix renv recpos trees def = match kind f with | Rel p -> (* Test if [p] is a fixpoint (recursive call) *) - if renv.rel_min <= p && p < renv.rel_min+nfi then + if renv.rel_min <= p && p < renv.rel_min+nfi then begin List.iter (check_rec_call renv []) l; (* the position of the invoked fixpoint: *) - let glob = renv.rel_min+nfi-1-p in + let glob = renv.rel_min+nfi-1-p in (* the decreasing arg of the rec call: *) - let np = recpos.(glob) in - let stack' = push_stack_closures renv l stack in + let np = recpos.(glob) in + let stack' = push_stack_closures renv l stack in if List.length stack' <= np then error_partial_apply renv glob else - (* Retrieve the expected tree for the argument *) + (* Retrieve the expected tree for the argument *) (* Check the decreasing arg is smaller *) let z = List.nth stack' np in - if not (check_is_subterm (stack_element_specif z) trees.(glob)) then + if not (check_is_subterm (stack_element_specif z) trees.(glob)) then begin match z with - |SClosure (z,z') -> error_illegal_rec_call renv glob (z,z') - |SArg _ -> error_partial_apply renv glob - end + |SClosure (z,z') -> error_illegal_rec_call renv glob (z,z') + |SArg _ -> error_partial_apply renv glob + end end else begin @@ -935,7 +935,7 @@ let check_one_fix renv recpos trees def = with FixGuardError _ -> check_rec_call renv stack (Term.applist(lift p c,l)) end - + | Case (ci,p,c_0,lrest) -> begin try List.iter (check_rec_call renv []) (c_0::p::l); @@ -1012,15 +1012,15 @@ let check_one_fix renv recpos trees def = if evaluable_constant kn renv.env then try List.iter (check_rec_call renv []) l with (FixGuardError _ ) -> - let value = (Term.applist(constant_value_in renv.env cu, l)) in - check_rec_call renv stack value - else List.iter (check_rec_call renv []) l + let value = (Term.applist(constant_value_in renv.env cu, l)) in + check_rec_call renv stack value + else List.iter (check_rec_call renv []) l | Lambda (x,a,b) -> let () = assert (List.is_empty l) in - check_rec_call renv [] a ; + check_rec_call renv [] a ; let spec, stack' = extract_stack stack in - check_rec_call (push_var renv (x,a,spec)) stack' b + check_rec_call (push_var renv (x,a,spec)) stack' b | Prod (x,a,b) -> let () = assert (List.is_empty l && List.is_empty stack) in @@ -1029,9 +1029,9 @@ let check_one_fix renv recpos trees def = | CoFix (_i,(_,typarray,bodies as recdef)) -> List.iter (check_rec_call renv []) l; - Array.iter (check_rec_call renv []) typarray; - let renv' = push_fix_renv renv recdef in - Array.iter (check_rec_call renv' []) bodies + Array.iter (check_rec_call renv []) typarray; + let renv' = push_fix_renv renv recdef in + Array.iter (check_rec_call renv' []) bodies | (Ind _ | Construct _) -> List.iter (check_rec_call renv []) l @@ -1061,8 +1061,8 @@ let check_one_fix renv recpos trees def = List.iter (check_rec_call renv []) l | LocalDef (_,c,_) -> try List.iter (check_rec_call renv []) l - with (FixGuardError _) -> - check_rec_call renv stack (Term.applist(c,l)) + with (FixGuardError _) -> + check_rec_call renv stack (Term.applist(c,l)) end | Sort _ | Int _ | Float _ -> @@ -1079,11 +1079,11 @@ let check_one_fix renv recpos trees def = else match kind (whd_all renv.env body) with | Lambda (x,a,b) -> - check_rec_call renv [] a; + check_rec_call renv [] a; let renv' = push_var_renv renv (x,a) in check_nested_fix_body illformed renv' (decr-1) recArgsDecrArg b | _ -> illformed () - + in check_rec_call renv [] def @@ -1107,19 +1107,19 @@ let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) = let rec check_occur env n def = match kind (whd_all env def) with | Lambda (x,a,b) -> - if noccur_with_meta n nbfix a then + if noccur_with_meta n nbfix a then let env' = push_rel (LocalAssum (x,a)) env in if Int.equal n (k + 1) then (* get the inductive type of the fixpoint *) let (mind, _) = try find_inductive env a with Not_found -> - raise_err env i (RecursionNotOnInductiveType a) in + raise_err env i (RecursionNotOnInductiveType a) in let mib,_ = lookup_mind_specif env (out_punivs mind) in if mib.mind_finite != Finite then raise_err env i (RecursionNotOnInductiveType a); (mind, (env', b)) - else check_occur env' (n+1) b + else check_occur env' (n+1) b else anomaly ~label:"check_one_fix" (Pp.str "Bad occurrence of recursive call.") | _ -> raise_err env i NotEnoughAbstractionInFixBody in @@ -1155,7 +1155,7 @@ let check_fix env ((nvect,_),(names,_,bodies as recdef) as fix) = try check_one_fix renv nvect trees body with FixGuardError (fixenv,err) -> error_ill_formed_rec_body fixenv err names i - (push_rec_types recdef env) (judgment_of_fixpoint recdef) + (push_rec_types recdef env) (judgment_of_fixpoint recdef) done else () @@ -1179,22 +1179,22 @@ let rec codomain_is_coind env c = | Prod (x,a,b) -> codomain_is_coind (push_rel (LocalAssum (x,a)) env) b | _ -> - (try find_coinductive env b + (try find_coinductive env b with Not_found -> - raise (CoFixGuardError (env, CodomainNotInductiveType b))) + raise (CoFixGuardError (env, CodomainNotInductiveType b))) let check_one_cofix env nbfix def deftype = let rec check_rec_call env alreadygrd n tree vlra t = if not (noccur_with_meta n nbfix t) then let c,args = decompose_app (whd_all env t) in match kind c with - | Rel p when n <= p && p < n+nbfix -> - (* recursive call: must be guarded and no nested recursive + | Rel p when n <= p && p < n+nbfix -> + (* recursive call: must be guarded and no nested recursive call allowed *) if not alreadygrd then - raise (CoFixGuardError (env,UnguardedRecursiveCall t)) + raise (CoFixGuardError (env,UnguardedRecursiveCall t)) else if not(List.for_all (noccur_with_meta n nbfix) args) then - raise (CoFixGuardError (env,NestedRecursiveOccurrences)) + raise (CoFixGuardError (env,NestedRecursiveOccurrences)) | Construct ((_,i as cstr_kn),_u) -> let lra = vlra.(i-1) in let mI = inductive_of_constructor cstr_kn in @@ -1206,59 +1206,59 @@ let check_one_cofix env nbfix def deftype = if noccur_with_meta n nbfix t then process_args_of_constr (lr, lrar) else raise (CoFixGuardError - (env,RecCallInNonRecArgOfConstructor t)) + (env,RecCallInNonRecArgOfConstructor t)) else begin check_rec_call env true n rar (dest_subterms rar) t; process_args_of_constr (lr, lrar) - end + end | [],_ -> () | _ -> anomaly_ill_typed () in process_args_of_constr (realargs, lra) | Lambda (x,a,b) -> - let () = assert (List.is_empty args) in + let () = assert (List.is_empty args) in if noccur_with_meta n nbfix a then let env' = push_rel (LocalAssum (x,a)) env in check_rec_call env' alreadygrd (n+1) tree vlra b else - raise (CoFixGuardError (env,RecCallInTypeOfAbstraction a)) + raise (CoFixGuardError (env,RecCallInTypeOfAbstraction a)) | CoFix (_j,(_,varit,vdefs as recdef)) -> if List.for_all (noccur_with_meta n nbfix) args then - if Array.for_all (noccur_with_meta n nbfix) varit then - let nbfix = Array.length vdefs in - let env' = push_rec_types recdef env in - (Array.iter (check_rec_call env' alreadygrd (n+nbfix) tree vlra) vdefs; - List.iter (check_rec_call env alreadygrd n tree vlra) args) + if Array.for_all (noccur_with_meta n nbfix) varit then + let nbfix = Array.length vdefs in + let env' = push_rec_types recdef env in + (Array.iter (check_rec_call env' alreadygrd (n+nbfix) tree vlra) vdefs; + List.iter (check_rec_call env alreadygrd n tree vlra) args) else - raise (CoFixGuardError (env,RecCallInTypeOfDef c)) - else - raise (CoFixGuardError (env,UnguardedRecursiveCall c)) - - | Case (_,p,tm,vrest) -> - begin - let tree = match restrict_spec env (Subterm (Strict, tree)) p with - | Dead_code -> assert false - | Subterm (_, tree') -> tree' - | _ -> raise (CoFixGuardError (env, ReturnPredicateNotCoInductive c)) - in + raise (CoFixGuardError (env,RecCallInTypeOfDef c)) + else + raise (CoFixGuardError (env,UnguardedRecursiveCall c)) + + | Case (_,p,tm,vrest) -> + begin + let tree = match restrict_spec env (Subterm (Strict, tree)) p with + | Dead_code -> assert false + | Subterm (_, tree') -> tree' + | _ -> raise (CoFixGuardError (env, ReturnPredicateNotCoInductive c)) + in if (noccur_with_meta n nbfix p) then - if (noccur_with_meta n nbfix tm) then - if (List.for_all (noccur_with_meta n nbfix) args) then - let vlra = dest_subterms tree in - Array.iter (check_rec_call env alreadygrd n tree vlra) vrest - else - raise (CoFixGuardError (env,RecCallInCaseFun c)) - else - raise (CoFixGuardError (env,RecCallInCaseArg c)) + if (noccur_with_meta n nbfix tm) then + if (List.for_all (noccur_with_meta n nbfix) args) then + let vlra = dest_subterms tree in + Array.iter (check_rec_call env alreadygrd n tree vlra) vrest + else + raise (CoFixGuardError (env,RecCallInCaseFun c)) + else + raise (CoFixGuardError (env,RecCallInCaseArg c)) else - raise (CoFixGuardError (env,RecCallInCasePred c)) - end + raise (CoFixGuardError (env,RecCallInCasePred c)) + end - | Meta _ -> () + | Meta _ -> () | Evar _ -> - List.iter (check_rec_call env alreadygrd n tree vlra) args + List.iter (check_rec_call env alreadygrd n tree vlra) args | Rel _ | Var _ | Sort _ | Cast _ | Prod _ | LetIn _ | App _ | Const _ | Ind _ | Fix _ | Proj _ | Int _ | Float _ -> raise (CoFixGuardError (env,NotGuardedForm t)) in @@ -1279,7 +1279,7 @@ let check_cofix env (_bodynum,(names,types,bodies as recdef)) = try check_one_cofix fixenv nbfix bodies.(i) types.(i) with CoFixGuardError (errenv,err) -> error_ill_formed_rec_body errenv err names i - fixenv (judgment_of_fixpoint recdef) + fixenv (judgment_of_fixpoint recdef) done else () diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml index c5ea32e157..1cf34977c5 100644 --- a/kernel/mod_subst.ml +++ b/kernel/mod_subst.ml @@ -114,7 +114,7 @@ let debug_pr_delta resolve = let debug_pr_subst sub = let l = list_contents sub in let f (s1,(s2,s3)) = hov 2 (str s1 ++ spc () ++ str "|-> " ++ str s2 ++ - spc () ++ str "[" ++ str s3 ++ str "]") + spc () ++ str "[" ++ str s3 ++ str "]") in str "{" ++ hov 2 (prlist_with_sep pr_comma f l) ++ str "}" @@ -156,8 +156,8 @@ let mp_of_delta resolve mp = let find_prefix resolve mp = let rec sub_mp = function | MPdot(mp,l) as mp_sup -> - (try Deltamap.find_mp mp_sup resolve - with Not_found -> MPdot(sub_mp mp,l)) + (try Deltamap.find_mp mp_sup resolve + with Not_found -> MPdot(sub_mp mp,l)) | p -> Deltamap.find_mp p resolve in try sub_mp mp with Not_found -> mp @@ -207,9 +207,9 @@ let inline_of_delta inline resolver = | None -> [] | Some inl_lev -> let extract kn hint l = - match hint with - | Inline (lev,_) -> if lev <= inl_lev then (lev,kn)::l else l - | _ -> l + match hint with + | Inline (lev,_) -> if lev <= inl_lev then (lev,kn)::l else l + | _ -> l in Deltamap.fold_kn extract resolver [] @@ -230,12 +230,12 @@ let subst_mp0 sub mp = (* 's like subst *) match mp with | MPfile _ | MPbound _ -> Umap.find mp sub | MPdot (mp1,l) as mp2 -> - begin + begin try Umap.find mp2 sub - with Not_found -> - let mp1',resolve = aux mp1 in - MPdot (mp1',l),resolve - end + with Not_found -> + let mp1',resolve = aux mp1 in + MPdot (mp1',l),resolve + end in try Some (aux mp) with Not_found -> None @@ -317,7 +317,7 @@ let subst_con sub cst = let subst_pcon sub (con,u as pcon) = try let con', _can = subst_con0 sub con in - con',u + con',u with No_subst -> pcon let subst_constant sub con = @@ -353,71 +353,71 @@ let rec map_kn f f' c = let func = map_kn f f' in match kind c with | Const kn -> (try f' kn with No_subst -> c) - | Proj (p,t) -> + | Proj (p,t) -> let p' = Projection.map f p in - let t' = func t in - if p' == p && t' == t then c - else mkProj (p', t') + let t' = func t in + if p' == p && t' == t then c + else mkProj (p', t') | Ind ((kn,i),u) -> - let kn' = f kn in - if kn'==kn then c else mkIndU ((kn',i),u) + let kn' = f kn in + if kn'==kn then c else mkIndU ((kn',i),u) | Construct (((kn,i),j),u) -> - let kn' = f kn in - if kn'==kn then c else mkConstructU (((kn',i),j),u) + let kn' = f kn in + if kn'==kn then c else mkConstructU (((kn',i),j),u) | Case (ci,p,ct,l) -> - let ci_ind = + let ci_ind = let (kn,i) = ci.ci_ind in - let kn' = f kn in - if kn'==kn then ci.ci_ind else kn',i - in - let p' = func p in - let ct' = func ct in + let kn' = f kn in + if kn'==kn then ci.ci_ind else kn',i + in + let p' = func p in + let ct' = func ct in let l' = Array.Smart.map func l in - if (ci.ci_ind==ci_ind && p'==p - && l'==l && ct'==ct)then c - else - mkCase ({ci with ci_ind = ci_ind}, - p',ct', l') + if (ci.ci_ind==ci_ind && p'==p + && l'==l && ct'==ct)then c + else + mkCase ({ci with ci_ind = ci_ind}, + p',ct', l') | Cast (ct,k,t) -> - let ct' = func ct in - let t'= func t in - if (t'==t && ct'==ct) then c - else mkCast (ct', k, t') + let ct' = func ct in + let t'= func t in + if (t'==t && ct'==ct) then c + else mkCast (ct', k, t') | Prod (na,t,ct) -> - let ct' = func ct in - let t'= func t in - if (t'==t && ct'==ct) then c - else mkProd (na, t', ct') + let ct' = func ct in + let t'= func t in + if (t'==t && ct'==ct) then c + else mkProd (na, t', ct') | Lambda (na,t,ct) -> - let ct' = func ct in - let t'= func t in - if (t'==t && ct'==ct) then c - else mkLambda (na, t', ct') + let ct' = func ct in + let t'= func t in + if (t'==t && ct'==ct) then c + else mkLambda (na, t', ct') | LetIn (na,b,t,ct) -> - let ct' = func ct in - let t'= func t in - let b'= func b in - if (t'==t && ct'==ct && b==b') then c - else mkLetIn (na, b', t', ct') + let ct' = func ct in + let t'= func t in + let b'= func b in + if (t'==t && ct'==ct && b==b') then c + else mkLetIn (na, b', t', ct') | App (ct,l) -> - let ct' = func ct in + let ct' = func ct in let l' = Array.Smart.map func l in - if (ct'== ct && l'==l) then c - else mkApp (ct',l') + if (ct'== ct && l'==l) then c + else mkApp (ct',l') | Evar (e,l) -> let l' = Array.Smart.map func l in - if (l'==l) then c - else mkEvar (e,l') + if (l'==l) then c + else mkEvar (e,l') | Fix (ln,(lna,tl,bl)) -> let tl' = Array.Smart.map func tl in let bl' = Array.Smart.map func bl in - if (bl == bl'&& tl == tl') then c - else mkFix (ln,(lna,tl',bl')) + if (bl == bl'&& tl == tl') then c + else mkFix (ln,(lna,tl',bl')) | CoFix(ln,(lna,tl,bl)) -> let tl' = Array.Smart.map func tl in let bl' = Array.Smart.map func bl in - if (bl == bl'&& tl == tl') then c - else mkCoFix (ln,(lna,tl',bl')) + if (bl == bl'&& tl == tl') then c + else mkCoFix (ln,(lna,tl',bl')) | _ -> c let subst_mps sub c = @@ -434,9 +434,9 @@ let rec replace_mp_in_mp mpfrom mpto mp = match mp with | _ when ModPath.equal mp mpfrom -> mpto | MPdot (mp1,l) -> - let mp1' = replace_mp_in_mp mpfrom mpto mp1 in - if mp1 == mp1' then mp - else MPdot (mp1',l) + let mp1' = replace_mp_in_mp mpfrom mpto mp1 in + if mp1 == mp1' then mp + else MPdot (mp1',l) | _ -> mp let replace_mp_in_kn mpfrom mpto kn = @@ -459,7 +459,7 @@ let subset_prefixed_by mp resolver = match hint with | Inline _ -> rslv | Equiv _ -> - if mp_in_mp mp (KerName.modpath kn) then Deltamap.add_kn kn hint rslv else rslv + if mp_in_mp mp (KerName.modpath kn) then Deltamap.add_kn kn hint rslv else rslv in Deltamap.fold mp_prefix kn_prefix resolver empty_delta_resolver @@ -479,7 +479,7 @@ let subst_mp_delta sub mp mkey = let mp1 = find_prefix resolve mp' in let resolve1 = subset_prefixed_by mp1 resolve in (subst_dom_delta_resolver - (map_mp mp1 mkey empty_delta_resolver) resolve1),mp1 + (map_mp mp1 mkey empty_delta_resolver) resolve1),mp1 let gen_subst_delta_resolver dom subst resolver = let mp_apply_subst mkey mequ rslv = @@ -491,8 +491,8 @@ let gen_subst_delta_resolver dom subst resolver = let kkey' = if dom then subst_kn subst kkey else kkey in let hint' = match hint with | Equiv kequ -> - (try Equiv (subst_kn_delta subst kequ) - with Change_equiv_to_inline (lev,c) -> Inline (lev,Some c)) + (try Equiv (subst_kn_delta subst kequ) + with Change_equiv_to_inline (lev,c) -> Inline (lev,Some c)) | Inline (lev,Some t) -> Inline (lev,Some (Univ.map_univ_abstracted (subst_mps subst) t)) | Inline (_,None) -> hint in @@ -510,8 +510,8 @@ let update_delta_resolver resolver1 resolver2 = let kn_apply_rslv kkey hint1 rslv = let hint = match hint1 with | Equiv kequ -> - (try Equiv (solve_delta_kn resolver2 kequ) - with Change_equiv_to_inline (lev,c) -> Inline (lev, Some c)) + (try Equiv (solve_delta_kn resolver2 kequ) + with Change_equiv_to_inline (lev,c) -> Inline (lev, Some c)) | Inline (_,Some _) -> hint1 | Inline (_,None) -> (try Deltamap.find_kn kkey resolver2 with Not_found -> hint1) @@ -539,15 +539,15 @@ let join subst1 subst2 = let apply_subst mpk add (mp,resolve) res = let mp',resolve' = match subst_mp0 subst2 mp with - | None -> mp, None - | Some (mp',resolve') -> mp', Some resolve' in + | None -> mp, None + | Some (mp',resolve') -> mp', Some resolve' in let resolve'' = match resolve' with | Some res -> - add_delta_resolver - (subst_dom_codom_delta_resolver subst2 resolve) res - | None -> - subst_codom_delta_resolver subst2 resolve + add_delta_resolver + (subst_dom_codom_delta_resolver subst2 resolve) res + | None -> + subst_codom_delta_resolver subst2 resolve in let prefixed_subst = substition_prefixed_by mpk mp' subst2 in Umap.join prefixed_subst (add (mp',resolve'') res) diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index ccc218771a..c1ac8b1a3e 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -174,10 +174,10 @@ let rec check_with_mod env struc (idl,mp1) mp equiv = let mtb_old = module_type_of_module old in let chk_cst = Subtyping.check_subtypes env' mtb_mp1 mtb_old in Univ.ContextSet.add_constraints chk_cst old.mod_constraints - | Algebraic (NoFunctor (MEident(mp'))) -> - check_modpath_equiv env' mp1 mp'; - old.mod_constraints - | _ -> error_generative_module_expected lab + | Algebraic (NoFunctor (MEident(mp'))) -> + check_modpath_equiv env' mp1 mp'; + old.mod_constraints + | _ -> error_generative_module_expected lab in let mp' = MPdot (mp,lab) in let new_mb = strengthen_and_subst_mb mb_mp1 mp' false in @@ -198,28 +198,28 @@ let rec check_with_mod env struc (idl,mp1) mp equiv = let mp' = MPdot (mp,lab) in let old = match spec with | SFBmodule msb -> msb - | _ -> error_not_a_module (Label.to_string lab) + | _ -> error_not_a_module (Label.to_string lab) in begin match old.mod_expr with | Abstract -> let struc = destr_nofunctor old.mod_type in - let struc',equiv',cst = + let struc',equiv',cst = check_with_mod env' struc (idl,mp1) mp' old.mod_delta in - let new_mb = + let new_mb = { old with mod_type = NoFunctor struc'; mod_type_alg = None; mod_delta = equiv' } in - let new_equiv = add_delta_resolver equiv equiv' in - let id_subst = map_mp mp' mp' equiv' in + let new_equiv = add_delta_resolver equiv equiv' in + let id_subst = map_mp mp' mp' equiv' in let new_after = subst_structure id_subst after in - before@(lab,SFBmodule new_mb)::new_after, new_equiv, cst + before@(lab,SFBmodule new_mb)::new_after, new_equiv, cst | Algebraic (NoFunctor (MEident mp0)) -> - let mpnew = rebuild_mp mp0 idl in - check_modpath_equiv env' mpnew mp; - before@(lab,spec)::after, equiv, Univ.ContextSet.empty + let mpnew = rebuild_mp mp0 idl in + check_modpath_equiv env' mpnew mp; + before@(lab,spec)::after, equiv, Univ.ContextSet.empty | _ -> error_generative_module_expected lab end with diff --git a/kernel/modops.ml b/kernel/modops.ml index 4808ed14e4..2b141cc6a7 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -286,10 +286,10 @@ let rec add_structure mp sign resolver linkinfo env = Environ.add_constant_key c cb linkinfo env |SFBmind mib -> let mind = mind_of_delta_kn resolver (KerName.make mp l) in - let mib = - if mib.mind_private != None then - { mib with mind_private = Some true } - else mib + let mib = + if mib.mind_private != None then + { mib with mind_private = Some true } + else mib in Environ.add_mind_key mind (mib,ref linkinfo) env |SFBmodule mb -> add_module mb linkinfo env (* adds components as well *) @@ -329,7 +329,7 @@ let strengthen_const mp_from l cb resolver = let u = Univ.make_abstract_instance (Declareops.constant_polymorphic_context cb) in { cb with const_body = Def (Mod_subst.from_val (mkConstU (con,u))); - const_body_code = Some (Cemitcodes.from_val (Cbytegen.compile_alias con)) } + const_body_code = Some (Cemitcodes.from_val (Cbytegen.compile_alias con)) } let rec strengthen_mod mp_from mp_to mb = if mp_in_delta mb.mod_mp mb.mod_delta then mb @@ -341,7 +341,7 @@ let rec strengthen_mod mp_from mp_to mb = mod_type = NoFunctor struc'; mod_delta = add_mp_delta_resolver mp_from mp_to - (add_delta_resolver mb.mod_delta reso) } + (add_delta_resolver mb.mod_delta reso) } |MoreFunctor _ -> mb and strengthen_sig mp_from struc mp_to reso = match struc with @@ -374,7 +374,7 @@ let strengthen mtb mp = mod_type = NoFunctor struc'; mod_delta = add_delta_resolver mtb.mod_delta - (add_mp_delta_resolver mtb.mod_mp mp reso') } + (add_mp_delta_resolver mtb.mod_mp mp reso') } |MoreFunctor _ -> mtb let inline_delta_resolver env inl mp mbid mtb delta = @@ -382,21 +382,21 @@ let inline_delta_resolver env inl mp mbid mtb delta = let rec make_inline delta = function | [] -> delta | (lev,kn)::r -> - let kn = replace_mp_in_kn (MPbound mbid) mp kn in - let con = constant_of_delta_kn delta kn in - try - let constant = lookup_constant con env in - let l = make_inline delta r in - match constant.const_body with + let kn = replace_mp_in_kn (MPbound mbid) mp kn in + let con = constant_of_delta_kn delta kn in + try + let constant = lookup_constant con env in + let l = make_inline delta r in + match constant.const_body with | Undef _ | OpaqueDef _ | Primitive _ -> l - | Def body -> - let constr = Mod_subst.force_constr body in + | Def body -> + let constr = Mod_subst.force_constr body in let ctx = Declareops.constant_polymorphic_context constant in let constr = Univ.{univ_abstracted_value=constr; univ_abstracted_binder=ctx} in add_inline_delta_resolver kn (lev, Some constr) l - with Not_found -> - error_no_such_label_sub (Constant.label con) - (ModPath.to_string (Constant.modpath con)) + with Not_found -> + error_no_such_label_sub (Constant.label con) + (ModPath.to_string (Constant.modpath con)) in make_inline delta constants @@ -407,14 +407,14 @@ let rec strengthen_and_subst_mod mb subst mp_from mp_to = if mb_is_an_alias then subst_module subst do_delta_dom mb else let reso',struc' = - strengthen_and_subst_struct struc subst - mp_from mp_to false false mb.mod_delta + strengthen_and_subst_struct struc subst + mp_from mp_to false false mb.mod_delta in { mb with - mod_mp = mp_to; - mod_expr = Algebraic (NoFunctor (MEident mp_from)); - mod_type = NoFunctor struc'; - mod_delta = add_mp_delta_resolver mp_to mp_from reso' } + mod_mp = mp_to; + mod_expr = Algebraic (NoFunctor (MEident mp_from)); + mod_type = NoFunctor struc'; + mod_delta = add_mp_delta_resolver mp_to mp_from reso' } |MoreFunctor _ -> let subst = add_mp mb.mod_mp mp_to empty_delta_resolver subst in subst_module subst do_delta_dom mb @@ -429,55 +429,55 @@ and strengthen_and_subst_struct str subst mp_from mp_to alias incl reso = else strengthen_const mp_from l cb' reso in let item' = if cb' == cb then item else (l, SFBconst cb') in - let reso',rest' = - strengthen_and_subst_struct rest subst mp_from mp_to alias incl reso + let reso',rest' = + strengthen_and_subst_struct rest subst mp_from mp_to alias incl reso in let str' = if rest' == rest && item' == item then str else item' :: rest' in - if incl then + if incl then (* If we are performing an inclusion we need to add the fact that the constant mp_to.l is \Delta-equivalent to reso(mp_from.l) *) let kn_from = KerName.make mp_from l in let kn_to = KerName.make mp_to l in let old_name = kn_of_delta reso kn_from in - add_kn_delta_resolver kn_to old_name reso', str' - else - (* In this case the fact that the constant mp_to.l is - \Delta-equivalent to resolver(mp_from.l) is already known - because reso' contains mp_to maps to reso(mp_from) *) - reso', str' + add_kn_delta_resolver kn_to old_name reso', str' + else + (* In this case the fact that the constant mp_to.l is + \Delta-equivalent to resolver(mp_from.l) is already known + because reso' contains mp_to maps to reso(mp_from) *) + reso', str' | (l,SFBmind mib) as item :: rest -> let mib' = subst_mind_body subst mib in let item' = if mib' == mib then item else (l, SFBmind mib') in - let reso',rest' = - strengthen_and_subst_struct rest subst mp_from mp_to alias incl reso + let reso',rest' = + strengthen_and_subst_struct rest subst mp_from mp_to alias incl reso in let str' = if rest' == rest && item' == item then str else item' :: rest' in - (* Same as constant *) - if incl then + (* Same as constant *) + if incl then let kn_from = KerName.make mp_from l in let kn_to = KerName.make mp_to l in - let old_name = kn_of_delta reso kn_from in + let old_name = kn_of_delta reso kn_from in add_kn_delta_resolver kn_to old_name reso', str' - else + else reso', str' | (l,SFBmodule mb) as item :: rest -> - let mp_from' = MPdot (mp_from,l) in - let mp_to' = MPdot (mp_to,l) in - let mb' = if alias then - subst_module subst do_delta_dom mb - else - strengthen_and_subst_mod mb subst mp_from' mp_to' - in + let mp_from' = MPdot (mp_from,l) in + let mp_to' = MPdot (mp_to,l) in + let mb' = if alias then + subst_module subst do_delta_dom mb + else + strengthen_and_subst_mod mb subst mp_from' mp_to' + in let item' = if mb' == mb then item else (l, SFBmodule mb') in - let reso',rest' = - strengthen_and_subst_struct rest subst mp_from mp_to alias incl reso + let reso',rest' = + strengthen_and_subst_struct rest subst mp_from mp_to alias incl reso in let str' = if rest' == rest && item' == item then str @@ -487,27 +487,27 @@ and strengthen_and_subst_struct str subst mp_from mp_to alias incl reso = on names, hence we add the fact that the functor can only be equivalent to itself. If we adopt an applicative semantic for functor this should be changed.*) - if is_functor mb'.mod_type then + if is_functor mb'.mod_type then add_mp_delta_resolver mp_to' mp_to' reso', str' - else + else add_delta_resolver reso' mb'.mod_delta, str' | (l,SFBmodtype mty) as item :: rest -> - let mp_from' = MPdot (mp_from,l) in - let mp_to' = MPdot(mp_to,l) in - let subst' = add_mp mp_from' mp_to' empty_delta_resolver subst in - let mty' = subst_modtype subst' - (fun resolver _ -> subst_dom_codom_delta_resolver subst' resolver) + let mp_from' = MPdot (mp_from,l) in + let mp_to' = MPdot(mp_to,l) in + let subst' = add_mp mp_from' mp_to' empty_delta_resolver subst in + let mty' = subst_modtype subst' + (fun resolver _ -> subst_dom_codom_delta_resolver subst' resolver) mty in let item' = if mty' == mty then item else (l, SFBmodtype mty') in - let reso',rest' = + let reso',rest' = strengthen_and_subst_struct rest subst mp_from mp_to alias incl reso in let str' = if rest' == rest && item' == item then str else item' :: rest' in - add_mp_delta_resolver mp_to' mp_to' reso', str' + add_mp_delta_resolver mp_to' mp_to' reso', str' (** Let P be a module path when we write: @@ -525,12 +525,12 @@ let strengthen_and_subst_mb mb mp include_b = match mb.mod_type with let subst_resolver = map_mp mb.mod_mp mp empty_delta_resolver in let new_resolver = add_mp_delta_resolver mp mp_alias - (subst_dom_delta_resolver subst_resolver mb.mod_delta) + (subst_dom_delta_resolver subst_resolver mb.mod_delta) in let subst = map_mp mb.mod_mp mp new_resolver in let reso',struc' = strengthen_and_subst_struct struc subst - mb.mod_mp mp mb_is_an_alias include_b mb.mod_delta + mb.mod_mp mp mb_is_an_alias include_b mb.mod_delta in { mb with mod_mp = mp; @@ -538,7 +538,7 @@ let strengthen_and_subst_mb mb mp include_b = match mb.mod_type with mod_expr = Algebraic (NoFunctor (MEident mb.mod_mp)); mod_delta = if include_b then reso' - else add_delta_resolver new_resolver reso' } + else add_delta_resolver new_resolver reso' } |MoreFunctor _ -> let subst = map_mp mb.mod_mp mp empty_delta_resolver in subst_module subst do_delta_dom_codom mb diff --git a/kernel/names.ml b/kernel/names.ml index b755ff0e08..148cc352f1 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -83,7 +83,7 @@ end module Name = struct type t = Anonymous (** anonymous identifier *) - | Name of Id.t (** non-anonymous identifier *) + | Name of Id.t (** non-anonymous identifier *) let mk_name id = Name id @@ -333,7 +333,7 @@ module ModPath = struct module Self_Hashcons = struct type t = module_path type u = (DirPath.t -> DirPath.t) * (MBId.t -> MBId.t) * - (string -> string) + (string -> string) let rec hashcons (hdir,huniqid,hstr as hfuns) = function | MPfile dir -> MPfile (hdir dir) | MPbound m -> MPbound (huniqid m) @@ -727,8 +727,8 @@ type 'a tableKey = | RelKey of Int.t type inv_rel_key = int (* index in the [rel_context] part of environment - starting by the end, {\em inverse} - of de Bruijn indice *) + starting by the end, {\em inverse} + of de Bruijn indice *) let eq_table_key f ik1 ik2 = if ik1 == ik2 then true diff --git a/kernel/names.mli b/kernel/names.mli index 0c92a2f2bc..d43038d2f0 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -81,7 +81,7 @@ end module Name : sig type t = Anonymous (** anonymous identifier *) - | Name of Id.t (** non-anonymous identifier *) + | Name of Id.t (** non-anonymous identifier *) val mk_name : Id.t -> t (** constructor *) @@ -534,8 +534,8 @@ type 'a tableKey = | RelKey of Int.t type inv_rel_key = int (** index in the [rel_context] part of environment - starting by the end, {e inverse} - of de Bruijn indice *) + starting by the end, {e inverse} + of de Bruijn indice *) val eq_table_key : ('a -> 'a -> bool) -> 'a tableKey -> 'a tableKey -> bool val eq_constant_key : Constant.t -> Constant.t -> bool diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index 63dc49ba57..ec3f15176b 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -34,9 +34,9 @@ let eq_lname ln1 ln2 = let dummy_lname = { lname = Anonymous; luid = -1 } -module LNord = - struct - type t = lname +module LNord = + struct + type t = lname let compare l1 l2 = l1.luid - l2.luid end module LNmap = Map.Make(LNord) @@ -44,12 +44,12 @@ module LNset = Set.Make(LNord) let lname_ctr = ref (-1) -let fresh_lname n = +let fresh_lname n = incr lname_ctr; { lname = n; luid = !lname_ctr } (** Global names **) -type gname = +type gname = | Gind of string * inductive (* prefix, inductive name *) | Gconstant of string * Constant.t (* prefix, constant name *) | Gproj of string * inductive * int (* prefix, inductive, index (start from 0) *) @@ -117,7 +117,7 @@ let fresh_gcase l = let pred_ctr = ref (-1) -let fresh_gpred l = +let fresh_gpred l = incr pred_ctr; Gpred (l,!pred_ctr) @@ -252,7 +252,7 @@ type primitive = | Mk_ind | Mk_const | Mk_sw - | Mk_fix of rec_pos * int + | Mk_fix of rec_pos * int | Mk_cofix of int | Mk_rel of int | Mk_var of Id.t @@ -357,10 +357,10 @@ let primitive_hash = function | MLnot -> 41 type mllambda = - | MLlocal of lname - | MLglobal of gname + | MLlocal of lname + | MLglobal of gname | MLprimitive of primitive - | MLlam of lname array * mllambda + | MLlam of lname array * mllambda | MLletrec of (lname * lname array * mllambda) array * mllambda | MLlet of lname * mllambda * mllambda | MLapp of mllambda * mllambda array @@ -578,25 +578,25 @@ let fv_lam l = let rec aux l bind fv = match l with | MLlocal l -> - if LNset.mem l bind then fv else LNset.add l fv + if LNset.mem l bind then fv else LNset.add l fv | MLglobal _ | MLprimitive _ | MLint _ | MLuint _ | MLfloat _ -> fv | MLlam (ln,body) -> - let bind = Array.fold_right LNset.add ln bind in - aux body bind fv + let bind = Array.fold_right LNset.add ln bind in + aux body bind fv | MLletrec(bodies,def) -> - let bind = - Array.fold_right (fun (id,_,_) b -> LNset.add id b) bodies bind in - let fv_body (_,ln,body) fv = - let bind = Array.fold_right LNset.add ln bind in - aux body bind fv in - Array.fold_right fv_body bodies (aux def bind fv) + let bind = + Array.fold_right (fun (id,_,_) b -> LNset.add id b) bodies bind in + let fv_body (_,ln,body) fv = + let bind = Array.fold_right LNset.add ln bind in + aux body bind fv in + Array.fold_right fv_body bodies (aux def bind fv) | MLlet(l,def,body) -> - aux body (LNset.add l bind) (aux def bind fv) + aux body (LNset.add l bind) (aux def bind fv) | MLapp(f,args) -> - let fv_arg arg fv = aux arg bind fv in - Array.fold_right fv_arg args (aux f bind fv) + let fv_arg arg fv = aux arg bind fv in + Array.fold_right fv_arg args (aux f bind fv) | MLif(t,b1,b2) -> - aux t bind (aux b1 bind (aux b2 bind fv)) + aux t bind (aux b1 bind (aux b2 bind fv)) | MLmatch(_,a,p,bs) -> let fv = aux a bind (aux p bind fv) in let fv_bs (cargs, body) fv = @@ -614,7 +614,7 @@ let fv_lam l = Array.fold_right fv_bs bs fv (* argument, accu branch, branches *) | MLconstruct (_,_,_,p) -> - Array.fold_right (fun a fv -> aux a bind fv) p fv + Array.fold_right (fun a fv -> aux a bind fv) p fv | MLsetref(_,l) -> aux l bind fv | MLsequence(l1,l2) -> aux l1 bind (aux l2 bind fv) | MLarray arr -> Array.fold_right (fun a fv -> aux a bind fv) arr fv @@ -624,7 +624,7 @@ let fv_lam l = let mkMLlam params body = - if Array.is_empty params then body + if Array.is_empty params then body else match body with | MLlam (params', body) -> MLlam(Array.append params params', body) @@ -655,10 +655,10 @@ let decompose_MLlam c = (*s Global declaration *) type global = (* | Gtblname of gname * Id.t array *) - | Gtblnorm of gname * lname array * mllambda array + | Gtblnorm of gname * lname array * mllambda array | Gtblfixtype of gname * lname array * mllambda array | Glet of gname * mllambda - | Gletcase of + | Gletcase of gname * lname array * annot_sw * mllambda * mllambda * mllam_branches | Gopen of string | Gtype of inductive * (tag * int) array @@ -720,7 +720,7 @@ let hash_global g = in combinesmall 6 (combine (ind_hash ind) (Array.fold_left hash_aux 0 arr)) | Gcomment s -> combinesmall 7 (String.hash s) - + let global_stack = ref ([] : global list) module HashedTypeGlobal = struct @@ -776,27 +776,27 @@ let empty_env univ = env_univ = univ } -let push_rel env id = +let push_rel env id = let local = fresh_lname id.binder_name in - local, { env with - env_rel = MLlocal local :: env.env_rel; - env_bound = env.env_bound + 1 - } + local, { env with + env_rel = MLlocal local :: env.env_rel; + env_bound = env.env_bound + 1 + } let push_rels env ids = - let lnames, env_rel = + let lnames, env_rel = Array.fold_left (fun (names,env_rel) id -> let local = fresh_lname id.binder_name in (local::names, MLlocal local::env_rel)) ([],env.env_rel) ids in - Array.of_list (List.rev lnames), { env with - env_rel = env_rel; - env_bound = env.env_bound + Array.length ids - } + Array.of_list (List.rev lnames), { env with + env_rel = env_rel; + env_bound = env.env_bound + Array.length ids + } let get_rel env id i = if i <= env.env_bound then List.nth env.env_rel (i-1) - else + else let i = i - env.env_bound in try Int.List.assoc i !(env.env_urel) with Not_found -> @@ -816,19 +816,19 @@ let fresh_univ () = (*s Traduction of lambda to mllambda *) -let get_prod_name codom = +let get_prod_name codom = match codom with | MLlam(ids,_) -> ids.(0).lname | _ -> assert false -let get_lname (_,l) = +let get_lname (_,l) = match l with | MLlocal id -> id | _ -> invalid_arg "Nativecode.get_lname" (* Collects free variables from env in an array of local names *) -let fv_params env = - let fvn, fvr = !(env.env_named), !(env.env_urel) in +let fv_params env = + let fvn, fvr = !(env.env_named), !(env.env_urel) in let size = List.length fvn + List.length fvr in let start,params = match env.env_univ with | None -> 0, Array.make size dummy_lname @@ -852,7 +852,7 @@ let fv_params env = params end -let generalize_fv env body = +let generalize_fv env body = mkMLlam (fv_params env) body let empty_args = [||] @@ -864,22 +864,22 @@ let fv_args env fvn fvr = | Some u -> 1, let t = Array.make (size + 1) (MLint 0) in t.(0) <- MLlocal u; t in if Array.is_empty args then empty_args - else + else begin let fvn = ref fvn in let i = ref start in while not (List.is_empty !fvn) do - args.(!i) <- get_var env (fst (List.hd !fvn)); - fvn := List.tl !fvn; - incr i + args.(!i) <- get_var env (fst (List.hd !fvn)); + fvn := List.tl !fvn; + incr i done; let fvr = ref fvr in while not (List.is_empty !fvr) do - let (k,_ as kml) = List.hd !fvr in - let n = get_lname kml in - args.(!i) <- get_rel env n.lname k; - fvr := List.tl !fvr; - incr i + let (k,_ as kml) = List.hd !fvr in + let n = get_lname kml in + args.(!i) <- get_rel env n.lname k; + fvr := List.tl !fvr; + incr i done; args end @@ -1120,14 +1120,14 @@ let ml_of_instance instance u = let decl,cond,paux = extract_prim (ml_of_lam env l) t in compile_prim decl cond paux | Lcase (annot,p,a,bs) -> - (* let predicate_uid fv_pred = compilation of p - let rec case_uid fv a_uid = + (* let predicate_uid fv_pred = compilation of p + let rec case_uid fv a_uid = match a_uid with | Accu _ => mk_sw (predicate_uid fv_pred) (case_uid fv) a_uid - | Ci argsi => compilation of branches + | Ci argsi => compilation of branches compile case = case_uid fv (compilation of a) *) (* Compilation of the predicate *) - (* Remark: if we do not want to compile the predicate we + (* Remark: if we do not want to compile the predicate we should a least compute the fv, then store the lambda representation of the predicate (not the mllambda) *) let env_p = empty_env env.env_univ in @@ -1159,10 +1159,10 @@ let ml_of_instance instance u = (* remark : the call to fv_args does not add free variables in env_c *) let i = push_symbol (SymbMatch annot) in let accu = - MLapp(MLprimitive Mk_sw, - [| get_match_code i; MLapp (MLprimitive Cast_accu, [|la_uid|]); - pred; - cn_fv |]) in + MLapp(MLprimitive Mk_sw, + [| get_match_code i; MLapp (MLprimitive Cast_accu, [|la_uid|]); + pred; + cn_fv |]) in (* let body = MLlam([|a_uid|], MLmatch(annot, la_uid, accu, bs)) in let case = generalize_fv env_c body in *) let cn = push_global_case cn (Array.append (fv_params env_c) [|a_uid|]) @@ -1171,26 +1171,26 @@ let ml_of_instance instance u = (* Final result *) let arg = ml_of_lam env l a in let force = - if annot.asw_finite then arg + if annot.asw_finite then arg else mkForceCofix annot.asw_prefix annot.asw_ind arg in mkMLapp (MLapp (MLglobal cn, fv_args env fvn fvr)) [|force|] - | Lif(t,bt,bf) -> + | Lif(t,bt,bf) -> MLif(ml_of_lam env l t, ml_of_lam env l bt, ml_of_lam env l bf) | Lfix ((rec_pos, inds, start), (ids, tt, tb)) -> - (* let type_f fvt = [| type fix |] + (* let type_f fvt = [| type fix |] let norm_f1 fv f1 .. fn params1 = body1 - .. + .. let norm_fn fv f1 .. fn paramsn = bodyn - let norm fv f1 .. fn = - [|norm_f1 fv f1 .. fn; ..; norm_fn fv f1 .. fn|] - compile fix = - let rec f1 params1 = + let norm fv f1 .. fn = + [|norm_f1 fv f1 .. fn; ..; norm_fn fv f1 .. fn|] + compile fix = + let rec f1 params1 = if is_accu rec_pos.(1) then mk_fix (type_f fvt) (norm fv) params1 - else norm_f1 fv f1 .. fn params1 - and .. and fn paramsn = - if is_accu rec_pos.(n) then mk_fix (type_f fvt) (norm fv) paramsn + else norm_f1 fv f1 .. fn params1 + and .. and fn paramsn = + if is_accu rec_pos.(n) then mk_fix (type_f fvt) (norm fv) paramsn else norm_fn fv f1 .. fv paramsn in - start + start *) (* Compilation of type *) let env_t = empty_env env.env_univ in @@ -1214,7 +1214,7 @@ let ml_of_instance instance u = in let ml_of_fix i body = let varsi, bodyi = decompose_Llam_Llet body in - let paramsi,letsi,envi = + let paramsi,letsi,envi = Array.fold_left mk_lam_or_let ([],[],env_n) varsi in let paramsi,letsi = @@ -1232,32 +1232,32 @@ let ml_of_instance instance u = let fv_args' = Array.map (fun id -> MLlocal id) fv_params in let norm_params = Array.append fv_params lf in let t_norm_f = Array.mapi (fun i body -> - push_global_let (t_norm_f.(i)) (mkMLlam norm_params body)) tnorm in + push_global_let (t_norm_f.(i)) (mkMLlam norm_params body)) tnorm in let norm = fresh_gnormtbl l in - let norm = push_global_norm norm fv_params + let norm = push_global_norm norm fv_params (Array.map (fun g -> mkMLapp (MLglobal g) fv_args') t_norm_f) in (* Compilation of fix *) - let fv_args = fv_args env fvn fvr in + let fv_args = fv_args env fvn fvr in let lf, _env = push_rels env ids in let lf_args = Array.map (fun id -> MLlocal id) lf in let mk_norm = MLapp(MLglobal norm, fv_args) in - let mkrec i lname = - let paramsi = t_params.(i) in - let reci = MLlocal (paramsi.(rec_pos.(i))) in - let pargsi = Array.map (fun id -> MLlocal id) paramsi in + let mkrec i lname = + let paramsi = t_params.(i) in + let reci = MLlocal (paramsi.(rec_pos.(i))) in + let pargsi = Array.map (fun id -> MLlocal id) paramsi in let (prefix, ind) = inds.(i) in - let body = + let body = MLif(MLisaccu (prefix, ind, reci), - mkMLapp - (MLapp(MLprimitive (Mk_fix(rec_pos,i)), - [|mk_type; mk_norm|])) - pargsi, - MLapp(MLglobal t_norm_f.(i), - Array.concat [fv_args;lf_args;pargsi])) - in - (lname, paramsi, body) in + mkMLapp + (MLapp(MLprimitive (Mk_fix(rec_pos,i)), + [|mk_type; mk_norm|])) + pargsi, + MLapp(MLglobal t_norm_f.(i), + Array.concat [fv_args;lf_args;pargsi])) + in + (lname, paramsi, body) in MLletrec(Array.mapi mkrec lf, lf_args.(start)) - | Lcofix (start, (ids, tt, tb)) -> + | Lcofix (start, (ids, tt, tb)) -> (* Compilation of type *) let env_t = empty_env env.env_univ in let ml_t = Array.map (ml_of_lam env_t l) tt in @@ -1266,7 +1266,7 @@ let ml_of_instance instance u = let gft = fresh_gfixtype l in let gft = push_global_fixtype gft params_t ml_t in let mk_type = MLapp(MLglobal gft, args_t) in - (* Compilation of norm_i *) + (* Compilation of norm_i *) let ndef = Array.length ids in let lf,env_n = push_rels (empty_env env.env_univ) ids in let t_params = Array.make ndef [||] in @@ -1284,46 +1284,46 @@ let ml_of_instance instance u = let fv_args' = Array.map (fun id -> MLlocal id) fv_params in let norm_params = Array.append fv_params lf in let t_norm_f = Array.mapi (fun i body -> - push_global_let (t_norm_f.(i)) (mkMLlam norm_params body)) tnorm in + push_global_let (t_norm_f.(i)) (mkMLlam norm_params body)) tnorm in let norm = fresh_gnormtbl l in let norm = push_global_norm norm fv_params (Array.map (fun g -> mkMLapp (MLglobal g) fv_args') t_norm_f) in (* Compilation of fix *) - let fv_args = fv_args env fvn fvr in + let fv_args = fv_args env fvn fvr in let mk_norm = MLapp(MLglobal norm, fv_args) in let lnorm = fresh_lname Anonymous in let ltype = fresh_lname Anonymous in let lf, _env = push_rels env ids in let lf_args = Array.map (fun id -> MLlocal id) lf in let upd i _lname cont = - let paramsi = t_params.(i) in - let pargsi = Array.map (fun id -> MLlocal id) paramsi in - let uniti = fresh_lname Anonymous in - let body = - MLlam(Array.append paramsi [|uniti|], - MLapp(MLglobal t_norm_f.(i), - Array.concat [fv_args;lf_args;pargsi])) in - MLsequence(MLapp(MLprimitive Upd_cofix, [|lf_args.(i);body|]), - cont) in + let paramsi = t_params.(i) in + let pargsi = Array.map (fun id -> MLlocal id) paramsi in + let uniti = fresh_lname Anonymous in + let body = + MLlam(Array.append paramsi [|uniti|], + MLapp(MLglobal t_norm_f.(i), + Array.concat [fv_args;lf_args;pargsi])) in + MLsequence(MLapp(MLprimitive Upd_cofix, [|lf_args.(i);body|]), + cont) in let upd = Array.fold_right_i upd lf lf_args.(start) in let mk_let i lname cont = - MLlet(lname, - MLapp(MLprimitive(Mk_cofix i),[| MLlocal ltype; MLlocal lnorm|]), - cont) in - let init = Array.fold_right_i mk_let lf upd in + MLlet(lname, + MLapp(MLprimitive(Mk_cofix i),[| MLlocal ltype; MLlocal lnorm|]), + cont) in + let init = Array.fold_right_i mk_let lf upd in MLlet(lnorm, mk_norm, MLlet(ltype, mk_type, init)) - (* - let mkrec i lname = - let paramsi = t_params.(i) in - let pargsi = Array.map (fun id -> MLlocal id) paramsi in - let uniti = fresh_lname Anonymous in - let body = - MLapp( MLprimitive(Mk_cofix i), - [|mk_type;mk_norm; - MLlam([|uniti|], - MLapp(MLglobal t_norm_f.(i), - Array.concat [fv_args;lf_args;pargsi]))|]) in - (lname, paramsi, body) in + (* + let mkrec i lname = + let paramsi = t_params.(i) in + let pargsi = Array.map (fun id -> MLlocal id) paramsi in + let uniti = fresh_lname Anonymous in + let body = + MLapp( MLprimitive(Mk_cofix i), + [|mk_type;mk_norm; + MLlam([|uniti|], + MLapp(MLglobal t_norm_f.(i), + Array.concat [fv_args;lf_args;pargsi]))|]) in + (lname, paramsi, body) in MLletrec(Array.mapi mkrec lf, lf_args.(start)) *) | Lint tag -> MLapp(MLprimitive Mk_int, [|MLint tag|]) @@ -1356,11 +1356,11 @@ let mllambda_of_lambda univ auxdefs l t = let fv_rel = !(env.env_urel) in let fv_named = !(env.env_named) in (* build the free variables *) - let get_lname (_,t) = + let get_lname (_,t) = match t with | MLlocal x -> x | _ -> assert false in - let params = + let params = List.append (List.map get_lname fv_rel) (List.map get_lname fv_named) in if List.is_empty params then (!global_stack, ([],[]), ml) @@ -1372,13 +1372,13 @@ let mllambda_of_lambda univ auxdefs l t = (** Optimization of match and fix *) -let can_subst l = +let can_subst l = match l with | MLlocal _ | MLint _ | MLuint _ | MLglobal _ -> true | _ -> false let subst s l = - if LNmap.is_empty s then l + if LNmap.is_empty s then l else let rec aux l = match l with @@ -1386,16 +1386,16 @@ let subst s l = | MLglobal _ | MLprimitive _ | MLint _ | MLuint _ | MLfloat _ -> l | MLlam(params,body) -> MLlam(params, aux body) | MLletrec(defs,body) -> - let arec (f,params,body) = (f,params,aux body) in - MLletrec(Array.map arec defs, aux body) + let arec (f,params,body) = (f,params,aux body) in + MLletrec(Array.map arec defs, aux body) | MLlet(id,def,body) -> MLlet(id,aux def, aux body) | MLapp(f,args) -> MLapp(aux f, Array.map aux args) | MLif(t,b1,b2) -> MLif(aux t, aux b1, aux b2) | MLmatch(annot,a,accu,bs) -> - let auxb (cargs,body) = (cargs,aux body) in - MLmatch(annot,a,aux accu, Array.map auxb bs) + let auxb (cargs,body) = (cargs,aux body) in + MLmatch(annot,a,aux accu, Array.map auxb bs) | MLconstruct(prefix,c,tag,args) -> MLconstruct(prefix,c,tag,Array.map aux args) - | MLsetref(s,l1) -> MLsetref(s,aux l1) + | MLsetref(s,l1) -> MLsetref(s,aux l1) | MLsequence(l1,l2) -> MLsequence(aux l1, aux l2) | MLarray arr -> MLarray (Array.map aux arr) | MLisaccu (s, ind, l) -> MLisaccu (s, ind, aux l) @@ -1418,24 +1418,24 @@ let subst_norm params args s = let subst_case params args s = let len = Array.length params in - assert (len > 0 && - Int.equal (Array.length args) len && - let r = ref true and i = ref 0 in - (* we test all arguments excepted the last *) - while !i < len - 1 && !r do r := can_subst args.(!i); incr i done; - !r); + assert (len > 0 && + Int.equal (Array.length args) len && + let r = ref true and i = ref 0 in + (* we test all arguments excepted the last *) + while !i < len - 1 && !r do r := can_subst args.(!i); incr i done; + !r); let s = ref s in for i = 0 to len - 2 do s := add_subst params.(i) args.(i) !s done; !s, params.(len-1), args.(len-1) - + let empty_gdef = Int.Map.empty, Int.Map.empty let get_norm (gnorm, _) i = Int.Map.find i gnorm let get_case (_, gcase) i = Int.Map.find i gcase -let all_lam n bs = - let f (_, l) = +let all_lam n bs = + let f (_, l) = match l with | MLlam(params, _) -> Int.equal (Array.length params) n | _ -> false in @@ -1444,68 +1444,68 @@ let all_lam n bs = let commutative_cut annot a accu bs args = let mkb (c,b) = match b with - | MLlam(params, body) -> + | MLlam(params, body) -> (c, Array.fold_left2 (fun body x v -> MLlet(x,v,body)) body params args) | _ -> assert false in MLmatch(annot, a, mkMLapp accu args, Array.map mkb bs) -let optimize gdef l = +let optimize gdef l = let rec optimize s l = match l with | MLlocal id -> (try LNmap.find id s with Not_found -> l) | MLglobal _ | MLprimitive _ | MLint _ | MLuint _ | MLfloat _ -> l - | MLlam(params,body) -> - MLlam(params, optimize s body) + | MLlam(params,body) -> + MLlam(params, optimize s body) | MLletrec(decls,body) -> - let opt_rec (f,params,body) = (f,params,optimize s body ) in - MLletrec(Array.map opt_rec decls, optimize s body) + let opt_rec (f,params,body) = (f,params,optimize s body ) in + MLletrec(Array.map opt_rec decls, optimize s body) | MLlet(id,def,body) -> - let def = optimize s def in - if can_subst def then optimize (add_subst id def s) body - else MLlet(id,def,optimize s body) + let def = optimize s def in + if can_subst def then optimize (add_subst id def s) body + else MLlet(id,def,optimize s body) | MLapp(f, args) -> - let args = Array.map (optimize s) args in - begin match f with - | MLglobal (Gnorm (_,i)) -> - (try - let params,body = get_norm gdef i in - let s = subst_norm params args s in - optimize s body - with Not_found -> MLapp(optimize s f, args)) - | MLglobal (Gcase (_,i)) -> - (try - let params,body = get_case gdef i in - let s, id, arg = subst_case params args s in - if can_subst arg then optimize (add_subst id arg s) body - else MLlet(id, arg, optimize s body) - with Not_found -> MLapp(optimize s f, args)) - | _ -> + let args = Array.map (optimize s) args in + begin match f with + | MLglobal (Gnorm (_,i)) -> + (try + let params,body = get_norm gdef i in + let s = subst_norm params args s in + optimize s body + with Not_found -> MLapp(optimize s f, args)) + | MLglobal (Gcase (_,i)) -> + (try + let params,body = get_case gdef i in + let s, id, arg = subst_case params args s in + if can_subst arg then optimize (add_subst id arg s) body + else MLlet(id, arg, optimize s body) + with Not_found -> MLapp(optimize s f, args)) + | _ -> let f = optimize s f in match f with | MLmatch (annot,a,accu,bs) -> - if all_lam (Array.length args) bs then - commutative_cut annot a accu bs args + if all_lam (Array.length args) bs then + commutative_cut annot a accu bs args else MLapp(f, args) | _ -> MLapp(f, args) - end + end | MLif(t,b1,b2) -> (* This optimization is critical: it applies to all fixpoints that start by matching on their recursive argument *) - let t = optimize s t in - let b1 = optimize s b1 in - let b2 = optimize s b2 in - begin match t, b2 with + let t = optimize s t in + let b1 = optimize s b1 in + let b2 = optimize s b2 in + begin match t, b2 with | MLisaccu (_, _, l1), MLmatch(annot, l2, _, bs) - when eq_mllambda l1 l2 -> MLmatch(annot, l1, b1, bs) + when eq_mllambda l1 l2 -> MLmatch(annot, l1, b1, bs) | _, _ -> MLif(t, b1, b2) - end + end | MLmatch(annot,a,accu,bs) -> - let opt_b (cargs,body) = (cargs,optimize s body) in - MLmatch(annot, optimize s a, subst s accu, Array.map opt_b bs) + let opt_b (cargs,body) = (cargs,optimize s body) in + MLmatch(annot, optimize s a, subst s accu, Array.map opt_b bs) | MLconstruct(prefix,c,tag,args) -> MLconstruct(prefix,c,tag,Array.map (optimize s) args) - | MLsetref(r,l) -> MLsetref(r, optimize s l) + | MLsetref(r,l) -> MLsetref(r, optimize s l) | MLsequence(l1,l2) -> MLsequence(optimize s l1, optimize s l2) | MLarray arr -> MLarray (Array.map (optimize s) arr) | MLisaccu (pf, ind, l) -> MLisaccu (pf, ind, optimize s l) @@ -1516,15 +1516,15 @@ let optimize_stk stk = let add_global gdef g = match g with | Glet (Gnorm (_,i), body) -> - let (gnorm, gcase) = gdef in - (Int.Map.add i (decompose_MLlam body) gnorm, gcase) + let (gnorm, gcase) = gdef in + (Int.Map.add i (decompose_MLlam body) gnorm, gcase) | Gletcase(Gcase (_,i), params, annot,a,accu,bs) -> - let (gnorm,gcase) = gdef in - (gnorm, Int.Map.add i (params,MLmatch(annot,a,accu,bs)) gcase) + let (gnorm,gcase) = gdef in + (gnorm, Int.Map.add i (params,MLmatch(annot,a,accu,bs)) gcase) | Gletcase _ -> assert false | _ -> gdef in let gdef = List.fold_left add_global empty_gdef stk in - let optimize_global g = + let optimize_global g = match g with | Glet(Gconstant (prefix, c), body) -> Glet(Gconstant (prefix, c), optimize gdef body) @@ -1596,7 +1596,7 @@ let string_of_gname g = | Gnorm (l,i) -> Format.sprintf "norm_%s_%i" (string_of_label_def l) i | Ginternal s -> Format.sprintf "%s" s - | Gnormtbl (l,i) -> + | Gnormtbl (l,i) -> Format.sprintf "normtbl_%s_%i" (string_of_label_def l) i | Grel i -> Format.sprintf "rel_%i" i @@ -1633,19 +1633,19 @@ let pp_mllam fmt l = | MLglobal g -> Format.fprintf fmt "@[%a@]" pp_gname g | MLprimitive p -> Format.fprintf fmt "@[%a@]" pp_primitive p | MLlam(ids,body) -> - Format.fprintf fmt "@[(fun%a@ ->@\n %a)@]" - pp_ldecls ids pp_mllam body + Format.fprintf fmt "@[(fun%a@ ->@\n %a)@]" + pp_ldecls ids pp_mllam body | MLletrec(defs, body) -> - Format.fprintf fmt "@[%a@ in@\n%a@]" pp_letrec defs - pp_mllam body + Format.fprintf fmt "@[%a@ in@\n%a@]" pp_letrec defs + pp_mllam body | MLlet(id,def,body) -> - Format.fprintf fmt "@[(let@ %a@ =@\n %a@ in@\n%a)@]" + Format.fprintf fmt "@[(let@ %a@ =@\n %a@ in@\n%a)@]" pp_lname id pp_mllam def pp_mllam body | MLapp(f, args) -> - Format.fprintf fmt "@[%a@ %a@]" pp_mllam f (pp_args true) args + Format.fprintf fmt "@[%a@ %a@]" pp_mllam f (pp_args true) args | MLif(t,l1,l2) -> - Format.fprintf fmt "@[(if %a then@\n %a@\nelse@\n %a)@]" - pp_mllam t pp_mllam l1 pp_mllam l2 + Format.fprintf fmt "@[(if %a then@\n %a@\nelse@\n %a)@]" + pp_mllam t pp_mllam l1 pp_mllam l2 | MLmatch (annot, c, accu_br, br) -> let ind = annot.asw_ind in let prefix = annot.asw_prefix in @@ -1655,22 +1655,22 @@ let pp_mllam fmt l = pp_mllam c accu pp_mllam accu_br (pp_branches prefix ind) br | MLconstruct(prefix,ind,tag,args) -> - Format.fprintf fmt "@[(Obj.magic (%s%a) : Nativevalues.t)@]" + Format.fprintf fmt "@[(Obj.magic (%s%a) : Nativevalues.t)@]" (string_of_construct prefix ~constant:false ind tag) pp_cargs args | MLint i -> pp_int fmt i | MLuint i -> Format.fprintf fmt "(%s)" (Uint63.compile i) | MLfloat f -> Format.fprintf fmt "(%s)" (Float64.compile f) | MLsetref (s, body) -> - Format.fprintf fmt "@[%s@ :=@\n %a@]" s pp_mllam body + Format.fprintf fmt "@[%s@ :=@\n %a@]" s pp_mllam body | MLsequence(l1,l2) -> - Format.fprintf fmt "@[%a;@\n%a@]" pp_mllam l1 pp_mllam l2 + Format.fprintf fmt "@[%a;@\n%a@]" pp_mllam l1 pp_mllam l2 | MLarray arr -> let len = Array.length arr in Format.fprintf fmt "@[[|"; if 0 < len then begin - for i = 0 to len - 2 do + for i = 0 to len - 2 do Format.fprintf fmt "%a;" pp_mllam arr.(i) - done; + done; pp_mllam fmt arr.(len-1) end; Format.fprintf fmt "|]@]" @@ -1684,8 +1684,8 @@ let pp_mllam fmt l = let len = Array.length defs in let pp_one_rec (fn, argsn, body) = Format.fprintf fmt "%a%a =@\n %a" - pp_lname fn - pp_ldecls argsn pp_mllam body in + pp_lname fn + pp_ldecls argsn pp_mllam body in Format.fprintf fmt "@[let rec "; pp_one_rec defs.(0); for i = 1 to len - 1 do @@ -1697,9 +1697,9 @@ let pp_mllam fmt l = match l with | MLprimitive (Mk_prod | Mk_sort) (* FIXME: why this special case? *) | MLlam _ | MLletrec _ | MLlet _ | MLapp _ | MLif _ -> - Format.fprintf fmt "(%a)" pp_mllam l + Format.fprintf fmt "(%a)" pp_mllam l | MLconstruct(_,_,_,args) when Array.length args > 0 -> - Format.fprintf fmt "(%a)" pp_mllam l + Format.fprintf fmt "(%a)" pp_mllam l | _ -> pp_mllam fmt l and pp_args sep fmt args = @@ -1708,7 +1708,7 @@ let pp_mllam fmt l = if len > 0 then begin Format.fprintf fmt "%a" pp_blam args.(0); for i = 1 to len - 1 do - Format.fprintf fmt "%s%a" sep pp_blam args.(i) + Format.fprintf fmt "%s%a" sep pp_blam args.(i) done end @@ -1719,7 +1719,7 @@ let pp_mllam fmt l = | 1 -> Format.fprintf fmt " %a" pp_blam args.(0) | _ -> Format.fprintf fmt "(%a)" (pp_args false) args - and pp_cparam fmt param = + and pp_cparam fmt param = match param with | Some l -> pp_mllam fmt (MLlocal l) | None -> Format.fprintf fmt "_" @@ -1729,13 +1729,13 @@ let pp_mllam fmt l = match len with | 0 -> () | 1 -> Format.fprintf fmt " %a" pp_cparam params.(0) - | _ -> - let aux fmt params = - Format.fprintf fmt "%a" pp_cparam params.(0); - for i = 1 to len - 1 do - Format.fprintf fmt ",%a" pp_cparam params.(i) - done in - Format.fprintf fmt "(%a)" aux params + | _ -> + let aux fmt params = + Format.fprintf fmt "%a" pp_cparam params.(0); + for i = 1 to len - 1 do + Format.fprintf fmt ",%a" pp_cparam params.(i) + done in + Format.fprintf fmt "(%a)" aux params and pp_branches prefix ind fmt bs = let pp_branch (cargs,body) = @@ -1757,19 +1757,19 @@ let pp_mllam fmt l = Array.iter pp_branch bs and pp_primitive fmt = function - | Mk_prod -> Format.fprintf fmt "mk_prod_accu" + | Mk_prod -> Format.fprintf fmt "mk_prod_accu" | Mk_sort -> Format.fprintf fmt "mk_sort_accu" | Mk_ind -> Format.fprintf fmt "mk_ind_accu" | Mk_const -> Format.fprintf fmt "mk_constant_accu" | Mk_sw -> Format.fprintf fmt "mk_sw_accu" - | Mk_fix(rec_pos,start) -> - let pp_rec_pos fmt rec_pos = - Format.fprintf fmt "@[[| %i" rec_pos.(0); - for i = 1 to Array.length rec_pos - 1 do - Format.fprintf fmt "; %i" rec_pos.(i) - done; - Format.fprintf fmt " |]@]" in - Format.fprintf fmt "mk_fix_accu %a %i" pp_rec_pos rec_pos start + | Mk_fix(rec_pos,start) -> + let pp_rec_pos fmt rec_pos = + Format.fprintf fmt "@[[| %i" rec_pos.(0); + for i = 1 to Array.length rec_pos - 1 do + Format.fprintf fmt "; %i" rec_pos.(i) + done; + Format.fprintf fmt " |]@]" in + Format.fprintf fmt "mk_fix_accu %a %i" pp_rec_pos rec_pos start | Mk_cofix(start) -> Format.fprintf fmt "mk_cofix_accu %i" start | Mk_rel i -> Format.fprintf fmt "mk_rel_accu %i" i | Mk_var id -> @@ -1810,7 +1810,7 @@ let pp_mllam fmt l = pp_mllam (MLglobal (Gconstant (prefix,c))) in Format.fprintf fmt "@[%a@]" pp_mllam l - + let pp_array fmt t = let len = Array.length t in Format.fprintf fmt "@[[|"; @@ -1820,14 +1820,14 @@ let pp_array fmt t = if len > 0 then Format.fprintf fmt "%a" pp_mllam t.(len - 1); Format.fprintf fmt "|]@]" - + let pp_global fmt g = match g with | Glet (gn, c) -> let ids, c = decompose_MLlam c in - Format.fprintf fmt "@[let %a%a =@\n %a@]@\n@." pp_gname gn - pp_ldecls ids - pp_mllam c + Format.fprintf fmt "@[let %a%a =@\n %a@]@\n@." pp_gname gn + pp_ldecls ids + pp_mllam c | Gopen s -> Format.fprintf fmt "@[open %s@]@." s | Gtype (ind, lar) -> @@ -1850,15 +1850,15 @@ let pp_global fmt g = Format.fprintf fmt "@[type ind_%s =@\n%a@]@\n@." (string_of_ind ind) pp_const_sigs lar | Gtblfixtype (g, params, t) -> Format.fprintf fmt "@[let %a %a =@\n %a@]@\n@." pp_gname g - pp_ldecls params pp_array t + pp_ldecls params pp_array t | Gtblnorm (g, params, t) -> Format.fprintf fmt "@[let %a %a =@\n %a@]@\n@." pp_gname g - pp_ldecls params pp_array t + pp_ldecls params pp_array t | Gletcase(gn,params,annot,a,accu,bs) -> Format.fprintf fmt "@[(* Hash = %i *)@\nlet rec %a %a =@\n %a@]@\n@." (hash_global g) - pp_gname gn pp_ldecls params - pp_mllam (MLmatch(annot,a,accu,bs)) + pp_gname gn pp_ldecls params + pp_mllam (MLmatch(annot,a,accu,bs)) | Gcomment s -> Format.fprintf fmt "@[(* %s *)@]@." s @@ -1930,10 +1930,10 @@ let compile_constant env sigma prefix ~interactive con cb = in let l = Constant.label con in let auxdefs,code = - if no_univs then compile_with_fv env sigma None [] (Some l) code - else - let univ = fresh_univ () in - let (auxdefs,code) = compile_with_fv env sigma (Some univ) [] (Some l) code in + if no_univs then compile_with_fv env sigma None [] (Some l) code + else + let univ = fresh_univ () in + let (auxdefs,code) = compile_with_fv env sigma (Some univ) [] (Some l) code in (auxdefs,mkMLlam [|univ|] code) in if !Flags.debug then Feedback.msg_debug (Pp.str "Generated mllambda code"); @@ -1942,18 +1942,18 @@ let compile_constant env sigma prefix ~interactive con cb = in if !Flags.debug then Feedback.msg_debug (Pp.str "Optimized mllambda code"); code, name - | _ -> + | _ -> let i = push_symbol (SymbConst con) in - let args = - if no_univs then [|get_const_code i; MLarray [||]|] - else [|get_const_code i|] - in - (* - let t = mkMLlam [|univ|] (mkMLapp (MLprimitive Mk_const) - *) + let args = + if no_univs then [|get_const_code i; MLarray [||]|] + else [|get_const_code i|] + in + (* + let t = mkMLlam [|univ|] (mkMLapp (MLprimitive Mk_const) + *) [Glet(Gconstant ("", con), mkMLapp (MLprimitive Mk_const) args)], - if interactive then LinkedInteractive prefix - else Linked prefix + if interactive then LinkedInteractive prefix + else Linked prefix end module StringOrd = struct type t = string let compare = String.compare end @@ -1989,9 +1989,9 @@ let compile_mind mb mind stack = let name = Gind ("", ind) in let accu = let args = - if Int.equal (Univ.AUContext.size u) 0 then - [|get_ind_code j; MLarray [||]|] - else [|get_ind_code j|] + if Int.equal (Univ.AUContext.size u) 0 then + [|get_ind_code j; MLarray [||]|] + else [|get_ind_code j|] in Glet(name, MLapp (MLprimitive Mk_ind, args)) in @@ -2079,7 +2079,7 @@ let compile_deps env sigma prefix ~interactive init t = | _ -> init in let code, name = - compile_constant env sigma prefix ~interactive c cb + compile_constant env sigma prefix ~interactive c cb in let comp_stack = code@comp_stack in let const_updates = Cmap_env.add c (nameref, name) const_updates in diff --git a/kernel/nativeconv.ml b/kernel/nativeconv.ml index ef610ce7e9..c3710cb0d6 100644 --- a/kernel/nativeconv.ml +++ b/kernel/nativeconv.ml @@ -23,41 +23,41 @@ let rec conv_val env pb lvl v1 v2 cu = else match kind_of_value v1, kind_of_value v2 with | Vfun f1, Vfun f2 -> - let v = mk_rel_accu lvl in - conv_val env CONV (lvl+1) (f1 v) (f2 v) cu + let v = mk_rel_accu lvl in + conv_val env CONV (lvl+1) (f1 v) (f2 v) cu | Vfun _f1, _ -> - conv_val env CONV lvl v1 (fun x -> v2 x) cu + conv_val env CONV lvl v1 (fun x -> v2 x) cu | _, Vfun _f2 -> - conv_val env CONV lvl (fun x -> v1 x) v2 cu + conv_val env CONV lvl (fun x -> v1 x) v2 cu | Vaccu k1, Vaccu k2 -> - conv_accu env pb lvl k1 k2 cu - | Vconst i1, Vconst i2 -> - if Int.equal i1 i2 then cu else raise NotConvertible + conv_accu env pb lvl k1 k2 cu + | Vconst i1, Vconst i2 -> + if Int.equal i1 i2 then cu else raise NotConvertible | Vint64 i1, Vint64 i2 -> if Int64.equal i1 i2 then cu else raise NotConvertible | Vfloat64 f1, Vfloat64 f2 -> if Float64.(equal (of_float f1) (of_float f2)) then cu else raise NotConvertible | Vblock b1, Vblock b2 -> - let n1 = block_size b1 in + let n1 = block_size b1 in let n2 = block_size b2 in - if not (Int.equal (block_tag b1) (block_tag b2)) || not (Int.equal n1 n2) then - raise NotConvertible; - let rec aux lvl max b1 b2 i cu = - if Int.equal i max then - conv_val env CONV lvl (block_field b1 i) (block_field b2 i) cu - else - let cu = conv_val env CONV lvl (block_field b1 i) (block_field b2 i) cu in - aux lvl max b1 b2 (i+1) cu - in - aux lvl (n1-1) b1 b2 0 cu + if not (Int.equal (block_tag b1) (block_tag b2)) || not (Int.equal n1 n2) then + raise NotConvertible; + let rec aux lvl max b1 b2 i cu = + if Int.equal i max then + conv_val env CONV lvl (block_field b1 i) (block_field b2 i) cu + else + let cu = conv_val env CONV lvl (block_field b1 i) (block_field b2 i) cu in + aux lvl max b1 b2 (i+1) cu + in + aux lvl (n1-1) b1 b2 0 cu | (Vaccu _ | Vconst _ | Vint64 _ | Vfloat64 _ | Vblock _), _ -> raise NotConvertible and conv_accu env pb lvl k1 k2 cu = let n1 = accu_nargs k1 in let n2 = accu_nargs k2 in if not (Int.equal n1 n2) then raise NotConvertible; - if Int.equal n1 0 then + if Int.equal n1 0 then conv_atom env pb lvl (atom_of_accu k1) (atom_of_accu k2) cu else let cu = conv_atom env pb lvl (atom_of_accu k1) (atom_of_accu k2) cu in @@ -73,48 +73,48 @@ and conv_atom env pb lvl a1 a2 cu = if Evar.equal ev1 ev2 then Array.fold_right2 (conv_val env CONV lvl) args1 args2 cu else raise NotConvertible - | Arel i1, Arel i2 -> - if Int.equal i1 i2 then cu else raise NotConvertible + | Arel i1, Arel i2 -> + if Int.equal i1 i2 then cu else raise NotConvertible | Aind (ind1,u1), Aind (ind2,u2) -> if eq_ind ind1 ind2 then convert_instances ~flex:false u1 u2 cu else raise NotConvertible | Aconstant (c1,u1), Aconstant (c2,u2) -> if Constant.equal c1 c2 then convert_instances ~flex:true u1 u2 cu else raise NotConvertible - | Asort s1, Asort s2 -> + | Asort s1, Asort s2 -> sort_cmp_universes env pb s1 s2 cu | Avar id1, Avar id2 -> - if Id.equal id1 id2 then cu else raise NotConvertible + if Id.equal id1 id2 then cu else raise NotConvertible | Acase(a1,ac1,p1,bs1), Acase(a2,ac2,p2,bs2) -> - if not (eq_ind a1.asw_ind a2.asw_ind) then raise NotConvertible; - let cu = conv_accu env CONV lvl ac1 ac2 cu in - let tbl = a1.asw_reloc in - let len = Array.length tbl in - if Int.equal len 0 then conv_val env CONV lvl p1 p2 cu - else begin - let cu = conv_val env CONV lvl p1 p2 cu in - let max = len - 1 in - let rec aux i cu = - let tag,arity = tbl.(i) in - let ci = - if Int.equal arity 0 then mk_const tag - else mk_block tag (mk_rels_accu lvl arity) in - let bi1 = bs1 ci and bi2 = bs2 ci in - if Int.equal i max then conv_val env CONV (lvl + arity) bi1 bi2 cu - else aux (i+1) (conv_val env CONV (lvl + arity) bi1 bi2 cu) in - aux 0 cu - end + if not (eq_ind a1.asw_ind a2.asw_ind) then raise NotConvertible; + let cu = conv_accu env CONV lvl ac1 ac2 cu in + let tbl = a1.asw_reloc in + let len = Array.length tbl in + if Int.equal len 0 then conv_val env CONV lvl p1 p2 cu + else begin + let cu = conv_val env CONV lvl p1 p2 cu in + let max = len - 1 in + let rec aux i cu = + let tag,arity = tbl.(i) in + let ci = + if Int.equal arity 0 then mk_const tag + else mk_block tag (mk_rels_accu lvl arity) in + let bi1 = bs1 ci and bi2 = bs2 ci in + if Int.equal i max then conv_val env CONV (lvl + arity) bi1 bi2 cu + else aux (i+1) (conv_val env CONV (lvl + arity) bi1 bi2 cu) in + aux 0 cu + end | Afix(t1,f1,rp1,s1), Afix(t2,f2,rp2,s2) -> - if not (Int.equal s1 s2) || not (Array.equal Int.equal rp1 rp2) then raise NotConvertible; - if f1 == f2 then cu - else conv_fix env lvl t1 f1 t2 f2 cu + if not (Int.equal s1 s2) || not (Array.equal Int.equal rp1 rp2) then raise NotConvertible; + if f1 == f2 then cu + else conv_fix env lvl t1 f1 t2 f2 cu | (Acofix(t1,f1,s1,_) | Acofixe(t1,f1,s1,_)), (Acofix(t2,f2,s2,_) | Acofixe(t2,f2,s2,_)) -> - if not (Int.equal s1 s2) then raise NotConvertible; - if f1 == f2 then cu - else - if not (Int.equal (Array.length f1) (Array.length f2)) then raise NotConvertible - else conv_fix env lvl t1 f1 t2 f2 cu + if not (Int.equal s1 s2) then raise NotConvertible; + if f1 == f2 then cu + else + if not (Int.equal (Array.length f1) (Array.length f2)) then raise NotConvertible + else conv_fix env lvl t1 f1 t2 f2 cu | Aprod(_,d1,_c1), Aprod(_,d2,_c2) -> let cu = conv_val env CONV lvl d1 d2 cu in let v = mk_rel_accu lvl in diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index 7a4e62cdfe..ad71557a65 100644 --- a/kernel/nativelambda.ml +++ b/kernel/nativelambda.ml @@ -73,7 +73,7 @@ let mkLapp f args = let mkLlam ids body = if Array.is_empty ids then body - else + else match body with | Llam(ids', body) -> Llam(Array.append ids ids', body) | _ -> Llam(ids, body) @@ -99,7 +99,7 @@ let decompose_Llam_Llet lam = (*s Operators on substitution *) let subst_id = subs_id 0 -let lift = subs_lift +let lift = subs_lift let liftn = subs_liftn let cons v subst = subs_cons([|v|], subst) let shift subst = subs_shft (1, subst) @@ -125,7 +125,7 @@ let map_lam_with_binders g f n lam = match lam with | Lrel _ | Lvar _ | Lconst _ | Lproj _ | Lval _ | Lsort _ | Lind _ | Luint _ | Llazy | Lforce | Lmeta _ | Lint _ | Lfloat _ -> lam - | Lprod(dom,codom) -> + | Lprod(dom,codom) -> let dom' = f n dom in let codom' = f n codom in if dom == dom' && codom == codom' then lam else Lprod(dom',codom') @@ -189,10 +189,10 @@ let map_lam_with_binders g f n lam = if args == args' then lam else Levar (evk, args') (*s Lift and substitution *) - + let rec lam_exlift el lam = match lam with - | Lrel(id,i) -> + | Lrel(id,i) -> let i' = reloc_rel i el in if i == i' then lam else Lrel(id,i') | _ -> map_lam_with_binders el_liftn lam_exlift el lam @@ -204,9 +204,9 @@ let lam_lift k lam = let lam_subst_rel lam id n subst = match expand_rel n subst with | Inl(k,v) -> lam_lift k v - | Inr(n',_) -> + | Inr(n',_) -> if n == n' then lam - else Lrel(id, n') + else Lrel(id, n') let rec lam_exsubst subst lam = match lam with @@ -214,11 +214,11 @@ let rec lam_exsubst subst lam = | _ -> map_lam_with_binders liftn lam_exsubst subst lam let lam_subst_args subst args = - if is_subs_id subst then args + if is_subs_id subst then args else Array.Smart.map (lam_exsubst subst) args - + (** Simplification of lambda expression *) - + (* [simplify subst lam] simplify the expression [lam_subst subst lam] *) (* that is : *) (* - Reduce [let] is the definition can be substituted i.e: *) @@ -227,11 +227,11 @@ let lam_subst_args subst args = (* - a structured constant *) (* - a function *) (* - Transform beta redex into [let] expression *) -(* - Move arguments under [let] *) +(* - Move arguments under [let] *) (* Invariant : Terms in [subst] are already simplified and can be *) (* substituted *) - -let can_subst lam = + +let can_subst lam = match lam with | Lrel _ | Lvar _ | Lconst _ | Lproj _ | Lval _ | Lsort _ | Lind _ | Llam _ | Lmeta _ | Levar _ -> true @@ -247,27 +247,27 @@ let merge_if t bt bf = let (idsf,bodyf) = decompose_Llam bf in let nt = Array.length idst in let nf = Array.length idsf in - let common,idst,idsf = - if Int.equal nt nf then idst, [||], [||] + let common,idst,idsf = + if Int.equal nt nf then idst, [||], [||] else if nt < nf then idst,[||], Array.sub idsf nt (nf - nt) else idsf, Array.sub idst nf (nt - nf), [||] in Llam(common, - Lif(lam_lift (Array.length common) t, - mkLlam idst bodyt, - mkLlam idsf bodyf)) + Lif(lam_lift (Array.length common) t, + mkLlam idst bodyt, + mkLlam idsf bodyf)) let rec simplify subst lam = match lam with - | Lrel(id,i) -> lam_subst_rel lam id i subst + | Lrel(id,i) -> lam_subst_rel lam id i subst | Llet(id,def,body) -> let def' = simplify subst def in if can_subst def' then simplify (cons def' subst) body - else - let body' = simplify (lift subst) body in - if def == def' && body == body' then lam - else Llet(id,def',body') + else + let body' = simplify (lift subst) body in + if def == def' && body == body' then lam + else Llet(id,def',body') | Lapp(f,args) -> begin match simplify_app subst f subst args with @@ -280,9 +280,9 @@ let rec simplify subst lam = let bt' = simplify subst bt in let bf' = simplify subst bf in if can_merge_if bt' bf' then merge_if t' bt' bf' - else - if t == t' && bt == bt' && bf == bf' then lam - else Lif(t',bt',bf') + else + if t == t' && bt == bt' && bf == bf' then lam + else Lif(t',bt',bf') | _ -> map_lam_with_binders liftn simplify subst lam and simplify_app substf f substa args = @@ -290,9 +290,9 @@ and simplify_app substf f substa args = | Lrel(id, i) -> begin match lam_subst_rel f id i substf with | Llam(ids, body) -> - reduce_lapp - subst_id (Array.to_list ids) body - substa (Array.to_list args) + reduce_lapp + subst_id (Array.to_list ids) body + substa (Array.to_list args) | f' -> mkLapp f' (simplify_args substa args) end | Llam(ids, body) -> @@ -300,16 +300,16 @@ and simplify_app substf f substa args = | Llet(id, def, body) -> let def' = simplify substf def in if can_subst def' then - simplify_app (cons def' substf) body substa args - else - Llet(id, def', simplify_app (lift substf) body (shift substa) args) + simplify_app (cons def' substf) body substa args + else + Llet(id, def', simplify_app (lift substf) body (shift substa) args) | Lapp(f, args') -> - let args = Array.append - (lam_subst_args substf args') (lam_subst_args substa args) in + let args = Array.append + (lam_subst_args substf args') (lam_subst_args substa args) in simplify_app substf f subst_id args (* TODO | Lproj -> simplify if the argument is known or a known global *) | _ -> mkLapp (simplify substf f) (simplify_args substa args) - + and simplify_args subst args = Array.Smart.map (simplify subst) args and reduce_lapp substf lids body substa largs = @@ -317,12 +317,12 @@ and reduce_lapp substf lids body substa largs = | id::lids, a::largs -> let a = simplify substa a in if can_subst a then - reduce_lapp (cons a substf) lids body substa largs + reduce_lapp (cons a substf) lids body substa largs else - let body = reduce_lapp (lift substf) lids body (shift substa) largs in - Llet(id, a, body) + let body = reduce_lapp (lift substf) lids body (shift substa) largs in + Llet(id, a, body) | [], [] -> simplify substf body - | _::_, _ -> + | _::_, _ -> Llam(Array.of_list lids, simplify (liftn (List.length lids) substf) body) | [], _::_ -> simplify_app substf body substa (Array.of_list largs) @@ -345,8 +345,8 @@ let get_value lc = let make_args start _end = Array.init (start - _end + 1) (fun i -> Lrel (Anonymous, start - i)) - -(* Translation of constructors *) + +(* Translation of constructors *) let expand_constructor prefix ind tag nparams arity = let anon = Context.make_annot Anonymous Sorts.Relevant in (* TODO relevance *) let ids = Array.make (nparams + arity) anon in @@ -405,7 +405,7 @@ let lambda_of_prim env kn op args = (*i Global environment *) -let get_names decl = +let get_names decl = let decl = Array.of_list decl in Array.map fst decl @@ -428,14 +428,14 @@ module Cache = let get_construct_info cache env c : constructor_info = try ConstrTable.find cache c with Not_found -> - let ((mind,j), i) = c in + let ((mind,j), i) = c in let oib = lookup_mind mind env in - let oip = oib.mind_packets.(j) in - let tag,arity = oip.mind_reloc_tbl.(i-1) in - let nparams = oib.mind_nparams in - let r = (tag, nparams, arity) in + let oip = oib.mind_packets.(j) in + let tag,arity = oip.mind_reloc_tbl.(i-1) in + let nparams = oib.mind_nparams in + let r = (tag, nparams, arity) in ConstrTable.add cache c r; - r + r end let is_lazy t = @@ -618,24 +618,24 @@ and lambda_of_app cache env sigma f args = let args = lambda_of_args cache env sigma nparams args in makeblock env ind tag 0 arity args else makeblock env ind tag (nparams - nargs) arity empty_args - | _ -> + | _ -> let f = lambda_of_constr cache env sigma f in let args = lambda_of_args cache env sigma 0 args in mkLapp f args - + and lambda_of_args cache env sigma start args = let nargs = Array.length args in if start < nargs then - Array.init (nargs - start) + Array.init (nargs - start) (fun i -> lambda_of_constr cache env sigma args.(start + i)) else empty_args let optimize lam = let lam = simplify subst_id lam in -(* if Flags.vm_draw_opt () then - (msgerrnl (str "Simplify = \n" ++ pp_lam lam);flush_all()); +(* if Flags.vm_draw_opt () then + (msgerrnl (str "Simplify = \n" ++ pp_lam lam);flush_all()); let lam = remove_let subst_id lam in - if Flags.vm_draw_opt () then + if Flags.vm_draw_opt () then (msgerrnl (str "Remove let = \n" ++ pp_lam lam);flush_all()); *) lam @@ -643,8 +643,8 @@ let lambda_of_constr env sigma c = let cache = Cache.ConstrTable.create 91 in let lam = lambda_of_constr cache env sigma c in (* if Flags.vm_draw_opt () then begin - (msgerrnl (str "Constr = \n" ++ pr_constr c);flush_all()); - (msgerrnl (str "Lambda = \n" ++ pp_lam lam);flush_all()); + (msgerrnl (str "Constr = \n" ++ pr_constr c);flush_all()); + (msgerrnl (str "Lambda = \n" ++ pp_lam lam);flush_all()); end; *) optimize lam diff --git a/kernel/nativelibrary.ml b/kernel/nativelibrary.ml index 1dbab6c690..7f46d4e173 100644 --- a/kernel/nativelibrary.ml +++ b/kernel/nativelibrary.ml @@ -30,29 +30,29 @@ and translate_field prefix mp env acc (l,x) = let con = Constant.make2 mp l in (if !Flags.debug then let msg = Printf.sprintf "Compiling constant %s..." (Constant.to_string con) in - Feedback.msg_debug (Pp.str msg)); + Feedback.msg_debug (Pp.str msg)); compile_constant_field env prefix con acc cb | SFBmind mb -> (if !Flags.debug then - let id = mb.mind_packets.(0).mind_typename in - let msg = Printf.sprintf "Compiling inductive %s..." (Id.to_string id) in - Feedback.msg_debug (Pp.str msg)); + let id = mb.mind_packets.(0).mind_typename in + let msg = Printf.sprintf "Compiling inductive %s..." (Id.to_string id) in + Feedback.msg_debug (Pp.str msg)); compile_mind_field mp l acc mb | SFBmodule md -> let mp = md.mod_mp in (if !Flags.debug then - let msg = - Printf.sprintf "Compiling module %s..." (ModPath.to_string mp) - in - Feedback.msg_debug (Pp.str msg)); + let msg = + Printf.sprintf "Compiling module %s..." (ModPath.to_string mp) + in + Feedback.msg_debug (Pp.str msg)); translate_mod prefix mp env md.mod_type acc | SFBmodtype mdtyp -> let mp = mdtyp.mod_mp in (if !Flags.debug then - let msg = - Printf.sprintf "Compiling module type %s..." (ModPath.to_string mp) - in - Feedback.msg_debug (Pp.str msg)); + let msg = + Printf.sprintf "Compiling module type %s..." (ModPath.to_string mp) + in + Feedback.msg_debug (Pp.str msg)); translate_mod prefix mp env mdtyp.mod_type acc let dump_library mp dp env mod_expr = diff --git a/kernel/nativevalues.ml b/kernel/nativevalues.ml index e4a8344eaf..891b4bf8f7 100644 --- a/kernel/nativevalues.ml +++ b/kernel/nativevalues.ml @@ -17,11 +17,11 @@ open Constr the native compiler *) type t = t -> t - + type accumulator (* = t (* a block [0:code;atom;arguments] *) *) type tag = int - + type arity = int type reloc_table = (tag * arity) array @@ -50,7 +50,7 @@ type rec_pos = int array let eq_rec_pos = Array.equal Int.equal -type atom = +type atom = | Arel of int | Aconstant of pconstant | Aind of pinductive @@ -109,13 +109,13 @@ let mk_accu (a : atom) : t = let get_accu (k : accumulator) = (Obj.magic k : Obj.t -> accu_val) ret_accu -let mk_rel_accu i = +let mk_rel_accu i = mk_accu (Arel i) -let rel_tbl_size = 100 +let rel_tbl_size = 100 let rel_tbl = Array.init rel_tbl_size mk_rel_accu -let mk_rel_accu i = +let mk_rel_accu i = if i < rel_tbl_size then rel_tbl.(i) else mk_rel_accu i @@ -125,10 +125,10 @@ let mk_rels_accu lvl len = let napply (f:t) (args: t array) = Array.fold_left (fun f a -> f a) f args -let mk_constant_accu kn u = +let mk_constant_accu kn u = mk_accu (Aconstant (kn,Univ.Instance.of_array u)) -let mk_ind_accu ind u = +let mk_ind_accu ind u = mk_accu (Aind (ind,Univ.Instance.of_array u)) let mk_sort_accu s u = @@ -140,10 +140,10 @@ let mk_sort_accu s u = let s = Sorts.sort_of_univ (Univ.subst_instance_universe u s) in mk_accu (Asort s) -let mk_var_accu id = +let mk_var_accu id = mk_accu (Avar id) -let mk_sw_accu annot c p ac = +let mk_sw_accu annot c p ac = mk_accu (Acase(annot,c,p,ac)) let mk_prod_accu s dom codom = @@ -155,7 +155,7 @@ let mk_meta_accu mv ty = let mk_evar_accu ev args = mk_accu (Aevar (ev, args)) -let mk_proj_accu kn c = +let mk_proj_accu kn c = mk_accu (Aproj (kn,c)) let atom_of_accu (k:accumulator) = @@ -183,8 +183,8 @@ let upd_cofix (cofix :t) (cofix_fun : t) = | Acofix (typ,norm,pos,_) -> set_atom_of_accu (Obj.magic cofix) (Acofix(typ,norm,pos,cofix_fun)) | _ -> assert false - -let force_cofix (cofix : t) = + +let force_cofix (cofix : t) = let accu = (Obj.magic cofix : accumulator) in let atom = atom_of_accu accu in match atom with @@ -235,7 +235,7 @@ let block_size (b:block) = let block_field (b:block) i = (Obj.magic (Obj.field (Obj.magic b) i) : t) -let block_tag (b:block) = +let block_tag (b:block) = Obj.tag (Obj.magic b) type kind_of_value = @@ -258,7 +258,7 @@ let kind_of_value (v:t) = else if Int.equal tag Obj.double_tag then Vfloat64 (Obj.magic v) else if (tag < Obj.lazy_tag) then Vblock (Obj.magic v) else - (* assert (tag = Obj.closure_tag || tag = Obj.infix_tag); + (* assert (tag = Obj.closure_tag || tag = Obj.infix_tag); or ??? what is 1002*) Vfun v @@ -296,7 +296,7 @@ let no_check_add x y = [@@ocaml.inline always] let add accu x y = - if is_int x && is_int y then no_check_add x y + if is_int x && is_int y then no_check_add x y else accu x y let no_check_sub x y = @@ -320,7 +320,7 @@ let no_check_div x y = [@@ocaml.inline always] let div accu x y = - if is_int x && is_int y then no_check_div x y + if is_int x && is_int y then no_check_div x y else accu x y let no_check_rem x y = @@ -372,12 +372,12 @@ let l_or accu x y = else accu x y [@@@ocaml.warning "-37"] -type coq_carry = +type coq_carry = | Caccu of t | C0 of t | C1 of t -type coq_pair = +type coq_pair = | Paccu of t | PPair of t * t @@ -404,7 +404,7 @@ let subc accu x y = else accu x y let no_check_addCarryC x y = - let s = + let s = Uint63.add (Uint63.add (to_uint x) (to_uint y)) (Uint63.of_int 1) in mkCarry (Uint63.le s (to_uint x)) s @@ -412,10 +412,10 @@ let no_check_addCarryC x y = let addCarryC accu x y = if is_int x && is_int y then no_check_addCarryC x y - else accu x y + else accu x y let no_check_subCarryC x y = - let s = + let s = Uint63.sub (Uint63.sub (to_uint x) (to_uint y)) (Uint63.of_int 1) in mkCarry (Uint63.le (to_uint x) (to_uint y)) s @@ -423,7 +423,7 @@ let no_check_subCarryC x y = let subCarryC accu x y = if is_int x && is_int y then no_check_subCarryC x y - else accu x y + else accu x y let of_pair (x, y) = (Obj.magic (PPair(mk_uint x, mk_uint y)):t) @@ -472,7 +472,7 @@ type coq_bool = type coq_cmp = | CmpAccu of t - | CmpEq + | CmpEq | CmpLt | CmpGt diff --git a/kernel/nativevalues.mli b/kernel/nativevalues.mli index 815ef3e98e..420249117d 100644 --- a/kernel/nativevalues.mli +++ b/kernel/nativevalues.mli @@ -36,7 +36,7 @@ val eq_annot_sw : annot_sw -> annot_sw -> bool val hash_annot_sw : annot_sw -> int type sort_annot = string * int - + type rec_pos = int array val eq_rec_pos : rec_pos -> rec_pos -> bool @@ -47,8 +47,8 @@ type atom = | Aind of pinductive | Asort of Sorts.t | Avar of Id.t - | Acase of annot_sw * accumulator * t * (t -> t) - | Afix of t array * t array * rec_pos * int + | Acase of annot_sw * accumulator * t * (t -> t) + | Afix of t array * t array * rec_pos * int | Acofix of t array * t array * int * t | Acofixe of t array * t array * int * t | Aprod of Name.t * t * (t -> t) @@ -89,7 +89,7 @@ val mk_meta_accu : metavariable -> t val mk_evar_accu : Evar.t -> t array -> t val mk_proj_accu : (inductive * int) -> accumulator -> t val upd_cofix : t -> t -> unit -val force_cofix : t -> t +val force_cofix : t -> t val mk_const : tag -> t val mk_block : tag -> t array -> t @@ -117,9 +117,9 @@ val cast_accu : t -> accumulator [@@ocaml.inline always] (* Functions over block: i.e constructors *) - + type block - + val block_size : block -> int val block_field : block -> int -> t val block_tag : block -> int @@ -178,7 +178,7 @@ val addMulDiv : t -> t -> t -> t -> t val eq : t -> t -> t -> t val lt : t -> t -> t -> t val le : t -> t -> t -> t -val compare : t -> t -> t -> t +val compare : t -> t -> t -> t val print : t -> t diff --git a/kernel/opaqueproof.ml b/kernel/opaqueproof.ml index f0b706e4f5..774bdc92fb 100644 --- a/kernel/opaqueproof.ml +++ b/kernel/opaqueproof.ml @@ -13,7 +13,7 @@ open Univ open Constr open Mod_subst -type work_list = (Instance.t * Id.t array) Cmap.t * +type work_list = (Instance.t * Id.t array) Cmap.t * (Instance.t * Id.t array) Mindmap.t type cooking_info = { diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 0cc7692fcf..f2cb9a8aec 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -209,7 +209,7 @@ type conv_pb = let is_cumul = function CUMUL -> true | CONV -> false -type 'a universe_compare = +type 'a universe_compare = { (* Might raise NotConvertible *) compare_sorts : env -> conv_pb -> Sorts.t -> Sorts.t -> 'a -> 'a; compare_instances: flex:bool -> Univ.Instance.t -> Univ.Instance.t -> 'a -> 'a; @@ -281,9 +281,9 @@ let conv_table_key infos k1 k2 cuniv = match k1, k2 with | ConstKey (cst, u), ConstKey (cst', u') when Constant.equal cst cst' -> if Univ.Instance.equal u u' then cuniv - else - let flex = evaluable_constant cst (info_env infos) - && RedFlags.red_set (info_flags infos) (RedFlags.fCONST cst) + else + let flex = evaluable_constant cst (info_env infos) + && RedFlags.red_set (info_flags infos) (RedFlags.fCONST cst) in convert_instances ~flex u u' cuniv | VarKey id, VarKey id' when Id.equal id id' -> cuniv | RelKey n, RelKey n' when Int.equal n n' -> cuniv @@ -351,16 +351,16 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = match (fterm_of hd1, fterm_of hd2) with (* case of leaves *) | (FAtom a1, FAtom a2) -> - (match kind a1, kind a2 with - | (Sort s1, Sort s2) -> - if not (is_empty_stack v1 && is_empty_stack v2) then - anomaly (Pp.str "conversion was given ill-typed terms (Sort)."); + (match kind a1, kind a2 with + | (Sort s1, Sort s2) -> + if not (is_empty_stack v1 && is_empty_stack v2) then + anomaly (Pp.str "conversion was given ill-typed terms (Sort)."); sort_cmp_universes (info_env infos.cnv_inf) cv_pb s1 s2 cuniv - | (Meta n, Meta m) -> + | (Meta n, Meta m) -> if Int.equal n m then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else raise NotConvertible - | _ -> raise NotConvertible) + | _ -> raise NotConvertible) | (FEvar ((ev1,args1),env1), FEvar ((ev2,args2),env2)) -> if Evar.equal ev1 ev2 then let el1 = el_stack lft1 v1 in @@ -405,8 +405,8 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = | (FProj (p1,c1), FProj (p2, c2)) -> (* Projections: prefer unfolding to first-order unification, - which will happen naturally if the terms c1, c2 are not in constructor - form *) + which will happen naturally if the terms c1, c2 are not in constructor + form *) (match unfold_projection infos.cnv_inf p1 with | Some s1 -> eqappr cv_pb l2r infos (lft1, (c1, (s1 :: v1))) appr2 cuniv @@ -422,7 +422,7 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = let u1 = ccnv CONV l2r infos el1 el2 c1 c2 cuniv in convert_stacks l2r infos lft1 lft2 v1 v2 u1 else (* Two projections in WHNF: unfold *) - raise NotConvertible) + raise NotConvertible) | (FProj (p1,c1), t2) -> begin match unfold_projection infos.cnv_inf p1 with @@ -471,8 +471,8 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = | (FProd (x1, c1, c2, e), FProd (_, c'1, c'2, e')) -> if not (is_empty_stack v1 && is_empty_stack v2) then - anomaly (Pp.str "conversion was given ill-typed terms (FProd)."); - (* Luo's system *) + anomaly (Pp.str "conversion was given ill-typed terms (FProd)."); + (* Luo's system *) let el1 = el_stack lft1 v1 in let el2 = el_stack lft2 v2 in let cuniv = ccnv CONV l2r infos el1 el2 c1 c'1 cuniv in @@ -493,8 +493,8 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = let () = match v2 with | [] -> () | _ -> - anomaly (Pp.str "conversion was given unreduced term (FLambda).") - in + anomaly (Pp.str "conversion was given unreduced term (FLambda).") + in let (x2,_ty2,bd2) = destFLambda mk_clos hd2 in let infos = push_relevance infos x2 in eqappr CONV l2r infos @@ -569,26 +569,26 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = let cuniv = convert_constructors (mind, snd ind1, j1) nargs u1 u2 cuniv in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else raise NotConvertible - + (* Eta expansion of records *) | (FConstruct ((ind1,_j1),_u1), _) -> (try - let v1, v2 = + let v1, v2 = eta_expand_ind_stack (info_env infos.cnv_inf) ind1 hd1 v1 (snd appr2) in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv with Not_found -> raise NotConvertible) | (_, FConstruct ((ind2,_j2),_u2)) -> (try - let v2, v1 = + let v2, v1 = eta_expand_ind_stack (info_env infos.cnv_inf) ind2 hd2 v2 (snd appr1) in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv with Not_found -> raise NotConvertible) | (FFix (((op1, i1),(na1,tys1,cl1)),e1), FFix(((op2, i2),(_,tys2,cl2)),e2)) -> if Int.equal i1 i2 && Array.equal Int.equal op1 op2 - then - let n = Array.length cl1 in + then + let n = Array.length cl1 in let fty1 = Array.map (mk_clos e1) tys1 in let fty2 = Array.map (mk_clos e2) tys2 in let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in @@ -607,7 +607,7 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = | (FCoFix ((op1,(na1,tys1,cl1)),e1), FCoFix((op2,(_,tys2,cl2)),e2)) -> if Int.equal op1 op2 then - let n = Array.length cl1 in + let n = Array.length cl1 in let fty1 = Array.map (mk_clos e1) tys1 in let fty2 = Array.map (mk_clos e2) tys2 in let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in @@ -712,10 +712,10 @@ let clos_gen_conv trans cv_pb l2r evars env univs t1 t2 = ccnv cv_pb l2r infos el_id el_id (inject t1) (inject t2) univs -let check_eq univs u u' = +let check_eq univs u u' = if not (UGraph.check_eq univs u u') then raise NotConvertible -let check_leq univs u u' = +let check_leq univs u u' = if not (UGraph.check_leq univs u u') then raise NotConvertible let check_sort_cmp_universes env pb s0 s1 univs = @@ -787,7 +787,7 @@ let infer_cmp_universes env pb s0 s1 univs = let infer_convert_instances ~flex u u' (univs,cstrs) = let cstrs' = - if flex then + if flex then if UGraph.check_eq_instances univs u u' then cstrs else raise NotConvertible else Univ.enforce_eq_instances u u' cstrs @@ -803,14 +803,14 @@ let inferred_universes : (UGraph.t * Univ.Constraint.t) universe_compare = compare_cumul_instances = infer_inductive_instances; } let gen_conv cv_pb l2r reds env evars univs t1 t2 = - let b = - if cv_pb = CUMUL then leq_constr_univs univs t1 t2 + let b = + if cv_pb = CUMUL then leq_constr_univs univs t1 t2 else eq_constr_univs univs t1 t2 in if b then () - else + else let _ = clos_gen_conv reds cv_pb l2r evars env (univs, checked_universes) t1 t2 in - () + () (* Profiling *) let gen_conv cv_pb ?(l2r=false) ?(reds=TransparentState.full) env ?(evars=(fun _->None), universes env) = @@ -825,8 +825,8 @@ let conv = gen_conv CONV let conv_leq = gen_conv CUMUL let generic_conv cv_pb ~l2r evars reds env univs t1 t2 = - let (s, _) = - clos_gen_conv reds cv_pb l2r evars env univs t1 t2 + let (s, _) = + clos_gen_conv reds cv_pb l2r evars env univs t1 t2 in s let infer_conv_universes cv_pb l2r evars reds env univs t1 t2 = @@ -838,21 +838,21 @@ let infer_conv_universes cv_pb l2r evars reds env univs t1 t2 = else let univs = ((univs, Univ.Constraint.empty), inferred_universes) in let ((_,cstrs), _) = clos_gen_conv reds cv_pb l2r evars env univs t1 t2 in - cstrs + cstrs (* Profiling *) -let infer_conv_universes = - if Flags.profile then +let infer_conv_universes = + if Flags.profile then let infer_conv_universes_key = CProfile.declare_profile "infer_conv_universes" in CProfile.profile8 infer_conv_universes_key infer_conv_universes else infer_conv_universes let infer_conv ?(l2r=false) ?(evars=fun _ -> None) ?(ts=TransparentState.full) - env univs t1 t2 = + env univs t1 t2 = infer_conv_universes CONV l2r evars ts env univs t1 t2 let infer_conv_leq ?(l2r=false) ?(evars=fun _ -> None) ?(ts=TransparentState.full) - env univs t1 t2 = + env univs t1 t2 = infer_conv_universes CUMUL l2r evars ts env univs t1 t2 let default_conv cv_pb ?l2r:_ env t1 t2 = @@ -923,7 +923,7 @@ let dest_prod env = match kind t with | Prod (n,a,c0) -> let d = LocalAssum (n,a) in - decrec (push_rel d env) (Context.Rel.add d m) c0 + decrec (push_rel d env) (Context.Rel.add d m) c0 | _ -> m,t in decrec env Context.Rel.empty @@ -946,14 +946,14 @@ let dest_prod_assum env = match kind rty with | Prod (x,t,c) -> let d = LocalAssum (x,t) in - prodec_rec (push_rel d env) (Context.Rel.add d l) c + prodec_rec (push_rel d env) (Context.Rel.add d l) c | LetIn (x,b,t,c) -> let d = LocalDef (x,b,t) in - prodec_rec (push_rel d env) (Context.Rel.add d l) c + prodec_rec (push_rel d env) (Context.Rel.add d l) c | _ -> let rty' = whd_all env rty in - if Constr.equal rty' rty then l, rty - else prodec_rec env l rty' + if Constr.equal rty' rty then l, rty + else prodec_rec env l rty' in prodec_rec env Context.Rel.empty @@ -963,10 +963,10 @@ let dest_lam_assum env = match kind rty with | Lambda (x,t,c) -> let d = LocalAssum (x,t) in - lamec_rec (push_rel d env) (Context.Rel.add d l) c + lamec_rec (push_rel d env) (Context.Rel.add d l) c | LetIn (x,b,t,c) -> let d = LocalDef (x,b,t) in - lamec_rec (push_rel d env) (Context.Rel.add d l) c + lamec_rec (push_rel d env) (Context.Rel.add d l) c | _ -> l,rty in lamec_rec env Context.Rel.empty diff --git a/kernel/reduction.mli b/kernel/reduction.mli index ab34d3a6dc..ecd6b89388 100644 --- a/kernel/reduction.mli +++ b/kernel/reduction.mli @@ -29,7 +29,7 @@ val nf_betaiota : env -> constr -> constr exception NotConvertible type 'a kernel_conversion_function = env -> 'a -> 'a -> unit -type 'a extended_conversion_function = +type 'a extended_conversion_function = ?l2r:bool -> ?reds:TransparentState.t -> env -> ?evars:((existential->constr option) * UGraph.t) -> 'a -> 'a -> unit @@ -75,9 +75,9 @@ val conv_leq : types extended_conversion_function (** These conversion functions are used by module subtyping, which needs to infer universe constraints inside the kernel *) -val infer_conv : ?l2r:bool -> ?evars:(existential->constr option) -> +val infer_conv : ?l2r:bool -> ?evars:(existential->constr option) -> ?ts:TransparentState.t -> constr infer_conversion_function -val infer_conv_leq : ?l2r:bool -> ?evars:(existential->constr option) -> +val infer_conv_leq : ?l2r:bool -> ?evars:(existential->constr option) -> ?ts:TransparentState.t -> types infer_conversion_function (** Depending on the universe state functions, this might raise diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index d3cffd1546..06f5aae047 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -341,7 +341,7 @@ let push_context_set poly cst senv = let add_constraints cst senv = match cst with - | Later fc -> + | Later fc -> {senv with future_cst = fc :: senv.future_cst} | Now cst -> push_context_set false cst senv @@ -360,7 +360,7 @@ let join_safe_environment ?(except=Future.UUIDSet.empty) e = else add_constraints (Now (Future.join fc)) e) {e with future_cst = []} e.future_cst -let is_joined_environment e = List.is_empty e.future_cst +let is_joined_environment e = List.is_empty e.future_cst (** {6 Various checks } *) @@ -493,7 +493,7 @@ let globalize_constant_universes cb = [cstrs] | Polymorphic _ -> [] - + let globalize_mind_universes mb = match mb.mind_universes with | Monomorphic ctx -> @@ -1185,11 +1185,11 @@ let add_include me is_module inl senv = | MoreFunctor(mbid,mtb,str) -> let cst_sub = Subtyping.check_subtypes senv.env mb mtb in let senv = - add_constraints + add_constraints (Now (Univ.ContextSet.add_constraints cst_sub Univ.ContextSet.empty)) - senv in + senv in let mpsup_delta = - Modops.inline_delta_resolver senv.env inl mp_sup mbid mtb mb.mod_delta + Modops.inline_delta_resolver senv.env inl mp_sup mbid mtb mb.mod_delta in let subst = Mod_subst.map_mbid mbid mp_sup mpsup_delta in let resolver = Mod_subst.subst_codom_delta_resolver subst resolver in @@ -1291,8 +1291,8 @@ let import lib cst vodigest senv = let mp = MPfile lib.comp_name in let mb = lib.comp_mod in let env = Environ.push_context_set ~strict:true - (Univ.ContextSet.union mb.mod_constraints cst) - senv.env + (Univ.ContextSet.union mb.mod_constraints cst) + senv.env in let env = let linkinfo = Nativecode.link_info_of_dirpath lib.comp_name in diff --git a/kernel/sorts.ml b/kernel/sorts.ml index b8bebb659b..01ee91d108 100644 --- a/kernel/sorts.ml +++ b/kernel/sorts.ml @@ -111,9 +111,9 @@ module Hsorts = type u = Universe.t -> Universe.t let hashcons huniv = function - | Type u as c -> - let u' = huniv u in - if u' == u then c else Type u' + | Type u as c -> + let u' = huniv u in + if u' == u then c else Type u' | s -> s let eq s1 s2 = match (s1,s2) with | Prop, Prop | Set, Set -> true diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index d22ec3b7ca..0a654adf7f 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -84,11 +84,11 @@ let make_labmap mp list = let check_conv_error error why cst poly f env a1 a2 = - try + try let cst' = f env (Environ.universes env) a1 a2 in - if poly then - if Constraint.is_empty cst' then cst - else error (IncompatiblePolymorphism (env, a1, a2)) + if poly then + if Constraint.is_empty cst' then cst + else error (IncompatiblePolymorphism (env, a1, a2)) else Constraint.union cst cst' with NotConvertible -> error why | Univ.UniverseInconsistency e -> error (IncompatibleUniverses e) @@ -116,7 +116,7 @@ let check_variance error v1 v2 = (* for now we do not allow reorderings *) -let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2= +let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2= let kn1 = KerName.make mp1 l in let kn2 = KerName.make mp2 l in let error why = error_signature_mismatch l spec2 why in @@ -153,7 +153,7 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2 let ty1 = type_of_inductive env ((mib1, p1), inst) in let ty2 = type_of_inductive env ((mib2, p2), inst) in let cst = check_inductive_type cst p2.mind_typename ty1 ty2 in - cst + cst in let mind = MutInd.make1 kn1 in let check_cons_types _i cst p1 p2 = @@ -170,7 +170,7 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2 check (fun mib -> mib.mind_ntypes) Int.equal (fun x -> InductiveNumbersFieldExpected x); assert (List.is_empty mib1.mind_hyps && List.is_empty mib2.mind_hyps); assert (Array.length mib1.mind_packets >= 1 - && Array.length mib2.mind_packets >= 1); + && Array.length mib2.mind_packets >= 1); (* Check that the expected numbers of uniform parameters are the same *) (* No need to check the contexts of parameters: it is checked *) @@ -217,7 +217,7 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2 in cst - + let check_constant cst env l info1 cb2 spec2 subst1 subst2 = let error why = error_signature_mismatch l spec2 why in let check_conv cst poly f = check_conv_error error cst poly f in @@ -238,21 +238,21 @@ let check_constant cst env l info1 cb2 spec2 subst1 subst2 = let typ2 = cb2.const_type in let cst = check_type poly cst env typ1 typ2 in (* Now we check the bodies: - - A transparent constant can only be implemented by a compatible - transparent constant. + - A transparent constant can only be implemented by a compatible + transparent constant. - In the signature, an opaque is handled just as a parameter: anything of the right type can implement it, even if bodies differ. *) (match cb2.const_body with | Primitive _ | Undef _ | OpaqueDef _ -> cst - | Def lc2 -> - (match cb1.const_body with + | Def lc2 -> + (match cb1.const_body with | Primitive _ | Undef _ | OpaqueDef _ -> error NotConvertibleBodyField - | Def lc1 -> - (* NB: cb1 might have been strengthened and appear as transparent. - Anyway [check_conv] will handle that afterwards. *) - let c1 = Mod_subst.force_constr lc1 in - let c2 = Mod_subst.force_constr lc2 in + | Def lc1 -> + (* NB: cb1 might have been strengthened and appear as transparent. + Anyway [check_conv] will handle that afterwards. *) + let c1 = Mod_subst.force_constr lc1 in + let c2 = Mod_subst.force_constr lc2 in check_conv NotConvertibleBodyField cst poly (infer_conv ?l2r:None ?evars:None ?ts:None) env c1 c2)) | IndType ((_kn,_i),_mind1) -> CErrors.user_err Pp.(str @@ @@ -272,31 +272,31 @@ let rec check_modules cst env msb1 msb2 subst1 subst2 = let mty2 = module_type_of_module msb2 in check_modtypes cst env mty1 mty2 subst1 subst2 false -and check_signatures cst env mp1 sig1 mp2 sig2 subst1 subst2 reso1 reso2= +and check_signatures cst env mp1 sig1 mp2 sig2 subst1 subst2 reso1 reso2= let map1 = make_labmap mp1 sig1 in let check_one_body cst (l,spec2) = match spec2 with - | SFBconst cb2 -> + | SFBconst cb2 -> check_constant cst env l (get_obj mp1 map1 l) - cb2 spec2 subst1 subst2 - | SFBmind mib2 -> - check_inductive cst env mp1 l (get_obj mp1 map1 l) - mp2 mib2 spec2 subst1 subst2 reso1 reso2 - | SFBmodule msb2 -> - begin match get_mod mp1 map1 l with - | Module msb -> check_modules cst env msb msb2 subst1 subst2 - | _ -> error_signature_mismatch l spec2 ModuleFieldExpected - end - | SFBmodtype mtb2 -> - let mtb1 = match get_mod mp1 map1 l with - | Modtype mtb -> mtb - | _ -> error_signature_mismatch l spec2 ModuleTypeFieldExpected - in - let env = + cb2 spec2 subst1 subst2 + | SFBmind mib2 -> + check_inductive cst env mp1 l (get_obj mp1 map1 l) + mp2 mib2 spec2 subst1 subst2 reso1 reso2 + | SFBmodule msb2 -> + begin match get_mod mp1 map1 l with + | Module msb -> check_modules cst env msb msb2 subst1 subst2 + | _ -> error_signature_mismatch l spec2 ModuleFieldExpected + end + | SFBmodtype mtb2 -> + let mtb1 = match get_mod mp1 map1 l with + | Modtype mtb -> mtb + | _ -> error_signature_mismatch l spec2 ModuleTypeFieldExpected + in + let env = add_module_type mtb2.mod_mp mtb2 - (add_module_type mtb1.mod_mp mtb1 env) + (add_module_type mtb1.mod_mp mtb1 env) in - check_modtypes cst env mtb1 mtb2 subst1 subst2 true + check_modtypes cst env mtb1 mtb2 subst1 subst2 true in List.fold_left check_one_body cst sig2 @@ -307,40 +307,40 @@ and check_modtypes cst env mtb1 mtb2 subst1 subst2 equiv = match str1,str2 with |NoFunctor list1, NoFunctor list2 -> - if equiv then - let subst2 = add_mp mtb2.mod_mp mtb1.mod_mp mtb1.mod_delta subst2 in + if equiv then + let subst2 = add_mp mtb2.mod_mp mtb1.mod_mp mtb1.mod_delta subst2 in let cst1 = check_signatures cst env - mtb1.mod_mp list1 mtb2.mod_mp list2 subst1 subst2 - mtb1.mod_delta mtb2.mod_delta + mtb1.mod_mp list1 mtb2.mod_mp list2 subst1 subst2 + mtb1.mod_delta mtb2.mod_delta in let cst2 = check_signatures cst env - mtb2.mod_mp list2 mtb1.mod_mp list1 subst2 subst1 - mtb2.mod_delta mtb1.mod_delta - in - Univ.Constraint.union cst1 cst2 - else - check_signatures cst env - mtb1.mod_mp list1 mtb2.mod_mp list2 subst1 subst2 - mtb1.mod_delta mtb2.mod_delta + mtb2.mod_mp list2 mtb1.mod_mp list1 subst2 subst1 + mtb2.mod_delta mtb1.mod_delta + in + Univ.Constraint.union cst1 cst2 + else + check_signatures cst env + mtb1.mod_mp list1 mtb2.mod_mp list2 subst1 subst2 + mtb1.mod_delta mtb2.mod_delta |MoreFunctor (arg_id1,arg_t1,body_t1), MoreFunctor (arg_id2,arg_t2,body_t2) -> let mp2 = MPbound arg_id2 in - let subst1 = join (map_mbid arg_id1 mp2 arg_t2.mod_delta) subst1 in - let cst = check_modtypes cst env arg_t2 arg_t1 subst2 subst1 equiv in + let subst1 = join (map_mbid arg_id1 mp2 arg_t2.mod_delta) subst1 in + let cst = check_modtypes cst env arg_t2 arg_t1 subst2 subst1 equiv in (* contravariant *) - let env = add_module_type mp2 arg_t2 env in - let env = + let env = add_module_type mp2 arg_t2 env in + let env = if Modops.is_functor body_t1 then env else add_module {mod_mp = mtb1.mod_mp; - mod_expr = Abstract; - mod_type = subst_signature subst1 body_t1; - mod_type_alg = None; - mod_constraints = mtb1.mod_constraints; - mod_retroknowledge = ModBodyRK []; - mod_delta = mtb1.mod_delta} env - in - check_structure cst env body_t1 body_t2 equiv subst1 subst2 + mod_expr = Abstract; + mod_type = subst_signature subst1 body_t1; + mod_type_alg = None; + mod_constraints = mtb1.mod_constraints; + mod_retroknowledge = ModBodyRK []; + mod_delta = mtb1.mod_delta} env + in + check_structure cst env body_t1 body_t2 equiv subst1 subst2 | _ , _ -> error_incompatible_modtypes mtb1 mtb2 in check_structure cst env mtb1.mod_type mtb2.mod_type equiv subst1 subst2 diff --git a/kernel/term.ml b/kernel/term.ml index 7343507838..87678b911e 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -380,7 +380,7 @@ let kind_of_type t = match kind t with | Prod (na,t,c) -> ProdType (na, t, c) | LetIn (na,b,t,c) -> LetInType (na, b, t, c) | App (c,l) -> AtomicType (c, l) - | (Rel _ | Meta _ | Var _ | Evar _ | Const _ + | (Rel _ | Meta _ | Var _ | Evar _ | Const _ | Proj _ | Case _ | Fix _ | CoFix _ | Ind _) -> AtomicType (t,[||]) | (Lambda _ | Construct _ | Int _ | Float _) -> failwith "Not a type" diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index f85b3db413..faa601e277 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -138,7 +138,7 @@ let infer_declaration env (dcl : constant_entry) = in let def = Vars.subst_univs_level_constr usubst j.uj_val in let def = Def (Mod_subst.from_val def) in - feedback_completion_typecheck feedback_id; + feedback_completion_typecheck feedback_id; { Cooking.cook_body = def; cook_type = typ; @@ -243,7 +243,7 @@ let build_constant_declaration env result = in let univs = result.cook_universes in let hyps = List.filter (fun d -> Id.Set.mem (NamedDecl.get_id d) hyps) (Environ.named_context env) in - let tps = + let tps = let res = Cbytegen.compile_constant_body ~fail_on_error:false env univs def in Option.map Cemitcodes.from_val res in diff --git a/kernel/typeops.ml b/kernel/typeops.ml index 1cc40a6707..c74bfd0688 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -39,7 +39,7 @@ let conv_leq_vecti env v1 v2 = v1 v2 -let check_constraints cst env = +let check_constraints cst env = if Environ.check_constraints cst env then () else error_unsatisfied_constraints env cst @@ -173,7 +173,7 @@ let type_of_abstraction _env name var ty = (* Type of an application. *) -let make_judgev c t = +let make_judgev c t = Array.map2 make_judge c t let rec check_empty_stack = function @@ -371,7 +371,7 @@ let check_cast env c ct k expected_type = let type_of_inductive_knowing_parameters env (ind,u as indu) args = let (mib,_mip) as spec = lookup_mind_specif env ind in check_hyps_inclusion env mkIndU indu mib.mind_hyps; - let t,cst = Inductive.constrained_type_of_inductive_knowing_parameters + let t,cst = Inductive.constrained_type_of_inductive_knowing_parameters env (spec,u) args in check_constraints cst env; @@ -432,7 +432,7 @@ let type_of_projection env p c ct = assert(eq_ind (Projection.inductive p) ind); let ty = Vars.subst_instance_constr u pty in substl (c :: CList.rev args) ty - + (* Fixpoints. *) @@ -503,7 +503,7 @@ let rec execute env cstr = | Const c -> cstr, type_of_constant env c - + | Proj (p, c) -> let c', ct = execute env c in let cstr = if c == c' then cstr else mkProj (p,c') in @@ -513,14 +513,14 @@ let rec execute env cstr = | App (f,args) -> let args', argst = execute_array env args in let f', ft = - match kind f with - | Ind ind when Environ.template_polymorphic_pind ind env -> - let args = Array.map (fun t -> lazy t) argst in + match kind f with + | Ind ind when Environ.template_polymorphic_pind ind env -> + let args = Array.map (fun t -> lazy t) argst in f, type_of_inductive_knowing_parameters env ind args - | _ -> - (* No template polymorphism *) + | _ -> + (* No template polymorphism *) execute env f - in + in let cstr = if f == f' && args == args' then cstr else mkApp (f',args') in cstr, type_of_apply env f' ft args' argst @@ -582,7 +582,7 @@ let rec execute env cstr = let fix = (vni,recdef') in mkFix fix, fix in check_fix env fix; cstr, fix_ty - + | CoFix (i,recdef as cofix) -> let (fix_ty,recdef') = execute_recdef env recdef i in let cstr, cofix = if recdef == recdef' then cstr, cofix else @@ -596,10 +596,10 @@ let rec execute env cstr = (* Partial proofs: unsupported by the kernel *) | Meta _ -> - anomaly (Pp.str "the kernel does not support metavariables.") + anomaly (Pp.str "the kernel does not support metavariables.") | Evar _ -> - anomaly (Pp.str "the kernel does not support existential variables.") + anomaly (Pp.str "the kernel does not support existential variables.") and execute_is_type env constr = let c, t = execute env constr in @@ -632,7 +632,7 @@ let infer env constr = let constr, t = execute env constr in make_judge constr t -let infer = +let infer = if Flags.profile then let infer_key = CProfile.declare_profile "Fast_infer" in CProfile.profile2 infer_key (fun b c -> infer b c) diff --git a/kernel/univ.ml b/kernel/univ.ml index 14d6bfabf1..0029ff96d5 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -133,11 +133,11 @@ module Level = struct | Var of int (** Embed levels with their hash value *) - type t = { + type t = { hash : int; data : RawLevel.t } - let equal x y = + let equal x y = x == y || Int.equal x.hash y.hash && RawLevel.equal x.data y.data let hash x = x.hash @@ -166,14 +166,14 @@ module Level = struct let prop = make Prop let sprop = make SProp - let is_small x = + let is_small x = match data x with | Level _ -> false | Var _ -> false | SProp -> true | Prop -> true | Set -> true - + let is_prop x = match data x with | Prop -> true @@ -192,8 +192,8 @@ module Level = struct let compare u v = if u == v then 0 else RawLevel.compare (data u) (data v) - - let to_string x = + + let to_string x = match data x with | SProp -> "SProp" | Prop -> "Prop" @@ -211,7 +211,7 @@ module Level = struct let vars = Array.init 20 (fun i -> make (Var i)) - let var n = + let var n = if n < 20 then vars.(n) else make (Var n) let var_index u = @@ -227,7 +227,7 @@ module Level = struct end (** Level maps *) -module LMap = struct +module LMap = struct module M = HMap.Make (Level) include M @@ -242,8 +242,8 @@ module LMap = struct | _, _ -> Some r) l r let diff ext orig = - fold (fun u v acc -> - if mem u orig then acc + fold (fun u v acc -> + if mem u orig then acc else add u v acc) ext empty @@ -288,22 +288,22 @@ module Universe = struct (* Invariants: non empty, sorted and without duplicates *) - module Expr = + module Expr = struct type t = Level.t * int (* Hashing of expressions *) - module ExprHash = + module ExprHash = struct type t = Level.t * int type u = Level.t -> Level.t - let hashcons hdir (b,n as x) = - let b' = hdir b in - if b' == b then x else (b',n) + let hashcons hdir (b,n as x) = + let b' = hdir b in + if b' == b then x else (b',n) let eq l1 l2 = - l1 == l2 || + l1 == l2 || match l1,l2 with - | (b,n), (b',n') -> b == b' && n == n' + | (b,n), (b',n') -> b == b' && n == n' let hash (x, n) = n + Level.hash x @@ -318,10 +318,10 @@ struct let compare u v = if u == v then 0 - else - let (x, n) = u and (x', n') = v in - if Int.equal n n' then Level.compare x x' - else n - n' + else + let (x, n) = u and (x', n') = v in + if Int.equal n n' then Level.compare x x' + else n - n' let sprop = hcons (Level.sprop, 0) let prop = hcons (Level.prop, 0) @@ -334,29 +334,29 @@ struct let equal x y = x == y || (let (u,n) = x and (v,n') = y in - Int.equal n n' && Level.equal u v) + Int.equal n n' && Level.equal u v) let hash = ExprHash.hash let leq (u,n) (v,n') = let cmp = Level.compare u v in - if Int.equal cmp 0 then n <= n' - else if n <= n' then + if Int.equal cmp 0 then n <= n' + else if n <= n' then (Level.is_prop u && not (Level.is_sprop v)) - else false + else false let successor (u,n) = if Level.is_small u then type1 else (u, n + 1) - let addn k (u,n as x) = - if k = 0 then x + let addn k (u,n as x) = + if k = 0 then x else if Level.is_small u then - (Level.set,n+k) + (Level.set,n+k) else (u,n+k) type super_result = - SuperSame of bool + SuperSame of bool (* The level expressions are in cumulativity relation. boolean indicates if left is smaller than right? *) | SuperDiff of int @@ -370,7 +370,7 @@ struct let super (u,n) (v,n') = let cmp = Level.compare u v in if Int.equal cmp 0 then SuperSame (n < n') - else + else let open RawLevel in match Level.data u, n, Level.data v, n' with | SProp, _, SProp, _ | Prop, _, Prop, _ -> SuperSame (n < n') @@ -387,7 +387,7 @@ struct let pr x = str(to_string x) - let pr_with f (v, n) = + let pr_with f (v, n) = if Int.equal n 0 then f v else f v ++ str"+" ++ int n @@ -398,15 +398,15 @@ struct let level = function | (v,0) -> Some v | _ -> None - + let get_level (v,_n) = v - let map f (v, n as x) = - let v' = f v in - if v' == v then x - else if Level.is_prop v' && n != 0 then - (Level.set, n) - else (v', n) + let map f (v, n as x) = + let v' = f v in + if v' == v then x + else if Level.is_prop v' && n != 0 then + (Level.set, n) + else (v', n) end @@ -432,16 +432,16 @@ struct let pr l = match l with | [u] -> Expr.pr u - | _ -> + | _ -> str "max(" ++ hov 0 - (prlist_with_sep pr_comma Expr.pr l) ++ + (prlist_with_sep pr_comma Expr.pr l) ++ str ")" let pr_with f l = match l with | [u] -> Expr.pr_with f u - | _ -> + | _ -> str "max(" ++ hov 0 - (prlist_with_sep pr_comma (Expr.pr_with f) l) ++ + (prlist_with_sep pr_comma (Expr.pr_with f) l) ++ str ")" let is_level l = match l with @@ -456,10 +456,10 @@ struct | [l] -> Expr.level l | _ -> None - let levels l = + let levels l = List.fold_left (fun acc x -> LSet.add (Expr.get_level x) acc) LSet.empty l - let is_small u = + let is_small u = match u with | [l] -> Expr.is_small l | _ -> false @@ -474,7 +474,7 @@ struct let type0 = tip Expr.set (* When typing [Prop] and [Set], there is no constraint on the level, - hence the definition of [type1_univ], the type of [Prop] *) + hence the definition of [type1_univ], the type of [Prop] *) let type1 = tip Expr.type1 let is_sprop x = equal sprop x @@ -483,7 +483,7 @@ struct (* Returns the formal universe that lies just above the universe variable u. Used to type the sort u. *) - let super l = + let super l = if is_small l then type1 else List.Smart.map (fun x -> Expr.successor x) l @@ -498,26 +498,26 @@ struct | h1 :: t1, h2 :: t2 -> let open Expr in (match super h1 h2 with - | SuperSame true (* h1 < h2 *) -> merge_univs t1 l2 - | SuperSame false -> merge_univs l1 t2 - | SuperDiff c -> + | SuperSame true (* h1 < h2 *) -> merge_univs t1 l2 + | SuperSame false -> merge_univs l1 t2 + | SuperDiff c -> if c <= 0 (* h1 < h2 is name order *) - then cons h1 (merge_univs t1 l2) - else cons h2 (merge_univs l1 t2)) + then cons h1 (merge_univs t1 l2) + else cons h2 (merge_univs l1 t2)) let sort u = - let rec aux a l = + let rec aux a l = match l with | b :: l' -> - let open Expr in + let open Expr in (match super a b with - | SuperSame false -> aux a l' - | SuperSame true -> l - | SuperDiff c -> - if c <= 0 then cons a l - else cons b (aux a l')) + | SuperSame false -> aux a l' + | SuperSame true -> l + | SuperDiff c -> + if c <= 0 then cons a l + else cons b (aux a l')) | [] -> cons a l - in + in List.fold_right (fun a acc -> aux a acc) u [] (* Returns the formal universe that is greater than the universes u and v. @@ -578,11 +578,11 @@ exception UniverseInconsistency of univ_inconsistency let error_inconsistency o u v p = raise (UniverseInconsistency (o,make u,make v,p)) -(* Constraints and sets of constraints. *) +(* Constraints and sets of constraints. *) type univ_constraint = Level.t * constraint_type * Level.t -let pr_constraint_type op = +let pr_constraint_type op = let op_str = match op with | Lt -> " < " | Le -> " <= " @@ -601,8 +601,8 @@ struct else Level.compare v v' end -module Constraint = -struct +module Constraint = +struct module S = Set.Make(UConstraintOrd) include S @@ -626,7 +626,7 @@ module Hconstraint = type u = universe_level -> universe_level let hashcons hul (l1,k,l2) = (hul l1, k, hul l2) let eq (l1,k,l2) (l1',k',l2') = - l1 == l1' && k == k' && l2 == l2' + l1 == l1' && k == k' && l2 == l2' let hash = Hashtbl.hash end) @@ -636,11 +636,11 @@ module Hconstraints = type t = constraints type u = univ_constraint -> univ_constraint let hashcons huc s = - Constraint.fold (fun x -> Constraint.add (huc x)) s Constraint.empty + Constraint.fold (fun x -> Constraint.add (huc x)) s Constraint.empty let eq s s' = - List.for_all2eq (==) - (Constraint.elements s) - (Constraint.elements s') + List.for_all2eq (==) + (Constraint.elements s) + (Constraint.elements s') let hash = Hashtbl.hash end) @@ -659,7 +659,7 @@ type 'a constraint_function = 'a -> 'a -> constraints -> constraints let enforce_eq_level u v c = (* We discard trivial constraints like u=u *) - if Level.equal u v then c + if Level.equal u v then c else if Level.apart u v then error_inconsistency Eq u v None else Constraint.add (u,Eq,v) c @@ -680,24 +680,24 @@ let constraint_add_leq v u c = if Expr.equal v u then c else match v, u with - | (x,n), (y,m) -> + | (x,n), (y,m) -> let j = m - n in if j = -1 (* n = m+1, v+1 <= u <-> v < u *) then - Constraint.add (x,Lt,y) c + Constraint.add (x,Lt,y) c else if j <= -1 (* n = m+k, v+k <= u <-> v+(k-1) < u *) then - if Level.equal x y then (* u+(k+1) <= u *) - raise (UniverseInconsistency (Le, Universe.tip v, Universe.tip u, None)) - else anomaly (Pp.str"Unable to handle arbitrary u+k <= v constraints.") + if Level.equal x y then (* u+(k+1) <= u *) + raise (UniverseInconsistency (Le, Universe.tip v, Universe.tip u, None)) + else anomaly (Pp.str"Unable to handle arbitrary u+k <= v constraints.") else if j = 0 then - Constraint.add (x,Le,y) c + Constraint.add (x,Le,y) c else (* j >= 1 *) (* m = n + k, u <= v+k *) - if Level.equal x y then c (* u <= u+k, trivial *) - else if Level.is_small x then c (* Prop,Set <= u+S k, trivial *) + if Level.equal x y then c (* u <= u+k, trivial *) + else if Level.is_small x then c (* Prop,Set <= u+S k, trivial *) else Constraint.add (x,Le,y) c (* u <= v implies u <= v+k *) - + let check_univ_leq_one u v = Universe.exists (Expr.leq u) v -let check_univ_leq u v = +let check_univ_leq u v = Universe.for_all (fun u -> check_univ_leq_one u v) u let enforce_leq u v c = @@ -721,7 +721,7 @@ let enforce_leq_level u v c = let univ_level_mem u v = List.exists (fun (l, n) -> Int.equal n 0 && Level.equal u l) v -let univ_level_rem u v min = +let univ_level_rem u v min = match Universe.level v with | Some u' -> if Level.equal u u' then min else v | None -> List.filter (fun (l, n) -> not (Int.equal n 0 && Level.equal u l)) v @@ -794,7 +794,7 @@ module Instance : sig val empty : t val is_empty : t -> bool - + val of_array : Level.t array -> t val to_array : t -> Level.t array @@ -808,10 +808,10 @@ module Instance : sig val share : t -> t * int val subst_fn : universe_level_subst_fn -> t -> t - + val pr : (Level.t -> Pp.t) -> ?variance:Variance.t array -> t -> Pp.t val levels : t -> LSet.t -end = +end = struct type t = Level.t array @@ -822,53 +822,53 @@ struct type nonrec t = t type u = Level.t -> Level.t - let hashcons huniv a = + let hashcons huniv a = let len = Array.length a in - if Int.equal len 0 then empty - else begin - for i = 0 to len - 1 do - let x = Array.unsafe_get a i in - let x' = huniv x in - if x == x' then () - else Array.unsafe_set a i x' - done; - a - end + if Int.equal len 0 then empty + else begin + for i = 0 to len - 1 do + let x = Array.unsafe_get a i in + let x' = huniv x in + if x == x' then () + else Array.unsafe_set a i x' + done; + a + end let eq t1 t2 = t1 == t2 || - (Int.equal (Array.length t1) (Array.length t2) && - let rec aux i = - (Int.equal i (Array.length t1)) || (t1.(i) == t2.(i) && aux (i + 1)) - in aux 0) - - let hash a = + (Int.equal (Array.length t1) (Array.length t2) && + let rec aux i = + (Int.equal i (Array.length t1)) || (t1.(i) == t2.(i) && aux (i + 1)) + in aux 0) + + let hash a = let accu = ref 0 in - for i = 0 to Array.length a - 1 do - let l = Array.unsafe_get a i in - let h = Level.hash l in - accu := Hashset.Combine.combine !accu h; - done; - (* [h] must be positive. *) - let h = !accu land 0x3FFFFFFF in - h + for i = 0 to Array.length a - 1 do + let l = Array.unsafe_get a i in + let h = Level.hash l in + accu := Hashset.Combine.combine !accu h; + done; + (* [h] must be positive. *) + let h = !accu land 0x3FFFFFFF in + h end module HInstance = Hashcons.Make(HInstancestruct) let hcons = Hashcons.simple_hcons HInstance.generate HInstance.hcons Level.hcons - + let hash = HInstancestruct.hash - + let share a = (hcons a, hash a) - + let empty = hcons [||] let is_empty x = Int.equal (Array.length x) 0 let append x y = if Array.length x = 0 then y - else if Array.length y = 0 then x + else if Array.length y = 0 then x else Array.append x y let of_array a = @@ -879,7 +879,7 @@ struct let length a = Array.length a - let subst_fn fn t = + let subst_fn fn t = let t' = CArray.Smart.map fn t in if t' == t then t else of_array t' @@ -892,20 +892,20 @@ struct in prvecti_with_sep spc ppu - let equal t u = + let equal t u = t == u || (Array.is_empty t && Array.is_empty u) || - (CArray.for_all2 Level.equal t u - (* Necessary as universe instances might come from different modules and - unmarshalling doesn't preserve sharing *)) + (CArray.for_all2 Level.equal t u + (* Necessary as universe instances might come from different modules and + unmarshalling doesn't preserve sharing *)) end -let enforce_eq_instances x y = +let enforce_eq_instances x y = let ax = Instance.to_array x and ay = Instance.to_array y in if Array.length ax != Array.length ay then anomaly (Pp.(++) (Pp.str "Invalid argument: enforce_eq_instances called with") - (Pp.str " instances of different lengths.")); + (Pp.str " instances of different lengths.")); CArray.fold_right2 enforce_eq_level ax ay let enforce_eq_variance_instances = Variance.eq_constraints @@ -913,10 +913,10 @@ let enforce_leq_variance_instances = Variance.leq_constraints let subst_instance_level s l = match l.Level.data with - | Level.Var n -> s.(n) + | Level.Var n -> s.(n) | _ -> l -let subst_instance_instance s i = +let subst_instance_instance s i = Array.Smart.map (fun l -> subst_instance_level s l) i let subst_instance_universe s u = @@ -932,9 +932,9 @@ let subst_instance_constraint s (u,d,v as c) = else (u',d,v') let subst_instance_constraints s csts = - Constraint.fold + Constraint.fold (fun c csts -> Constraint.add (subst_instance_constraint s c) csts) - csts Constraint.empty + csts Constraint.empty type 'a puniverses = 'a * Instance.t let out_punivs (x, _y) = x @@ -1017,7 +1017,7 @@ let map_univ_abstracted f {univ_abstracted_value;univ_abstracted_binder} = let hcons_abstract_universe_context = AUContext.hcons (** A set of universes with universe constraints. - We linearize the set to a list after typechecking. + We linearize the set to a list after typechecking. Beware, representation could change. *) @@ -1030,7 +1030,7 @@ struct let equal (univs, cst as x) (univs', cst' as y) = x == y || (LSet.equal univs univs' && Constraint.equal cst cst') - + let of_set s = (s, Constraint.empty) let singleton l = of_set (LSet.singleton l) let of_instance i = of_set (Instance.levels i) @@ -1059,7 +1059,7 @@ struct let univs = Array.fold_left fold univs v in (univs, cst) - let sort_levels a = + let sort_levels a = Array.sort Level.compare a; a let to_context (ctx, cst) = @@ -1112,17 +1112,17 @@ let subst_univs_level_instance subst i = let i' = Instance.subst_fn (subst_univs_level_level subst) i in if i == i' then i else i' - + let subst_univs_level_constraint subst (u,d,v) = - let u' = subst_univs_level_level subst u + let u' = subst_univs_level_level subst u and v' = subst_univs_level_level subst v in if d != Lt && Level.equal u' v' then None else Some (u',d,v') let subst_univs_level_constraints subst csts = - Constraint.fold + Constraint.fold (fun c -> Option.fold_right Constraint.add (subst_univs_level_constraint subst c)) - csts Constraint.empty + csts Constraint.empty let subst_univs_level_abstract_universe_context subst (inst, csts) = inst, subst_univs_level_constraints subst csts @@ -1136,41 +1136,41 @@ let subst_univs_expr_opt fn (l,n) = Universe.addn n (fn l) let subst_univs_universe fn ul = - let subst, nosubst = - List.fold_right (fun u (subst,nosubst) -> + let subst, nosubst = + List.fold_right (fun u (subst,nosubst) -> try let a' = subst_univs_expr_opt fn u in - (a' :: subst, nosubst) + (a' :: subst, nosubst) with Not_found -> (subst, u :: nosubst)) ul ([], []) - in + in if CList.is_empty subst then ul - else - let substs = - List.fold_left Universe.merge_univs Universe.empty subst + else + let substs = + List.fold_left Universe.merge_univs Universe.empty subst in - List.fold_left (fun acc u -> Universe.merge_univs acc (Universe.tip u)) - substs nosubst + List.fold_left (fun acc u -> Universe.merge_univs acc (Universe.tip u)) + substs nosubst -let make_instance_subst i = +let make_instance_subst i = let arr = Instance.to_array i in Array.fold_left_i (fun i acc l -> LMap.add l (Level.var i) acc) LMap.empty arr -let make_inverse_instance_subst i = +let make_inverse_instance_subst i = let arr = Instance.to_array i in Array.fold_left_i (fun i acc l -> LMap.add (Level.var i) l acc) LMap.empty arr -let make_abstract_instance (ctx, _) = +let make_abstract_instance (ctx, _) = Array.init (Array.length ctx) (fun i -> Level.var i) let abstract_universes nas ctx = let instance = UContext.instance ctx in let () = assert (Int.equal (Array.length nas) (Instance.length instance)) in let subst = make_instance_subst instance in - let cstrs = subst_univs_level_constraints subst + let cstrs = subst_univs_level_constraints subst (UContext.constraints ctx) in let ctx = (nas, cstrs) in @@ -1200,28 +1200,28 @@ let pr_abstract_universe_context = AUContext.pr let pr_universe_context_set = ContextSet.pr -let pr_universe_subst = +let pr_universe_subst = LMap.pr (fun u -> str" := " ++ Universe.pr u ++ spc ()) -let pr_universe_level_subst = +let pr_universe_level_subst = LMap.pr (fun u -> str" := " ++ Level.pr u ++ spc ()) -module Huniverse_set = +module Huniverse_set = Hashcons.Make( struct type t = universe_set type u = universe_level -> universe_level let hashcons huc s = - LSet.fold (fun x -> LSet.add (huc x)) s LSet.empty + LSet.fold (fun x -> LSet.add (huc x)) s LSet.empty let eq s s' = - LSet.equal s s' + LSet.equal s s' let hash = Hashtbl.hash end) -let hcons_universe_set = +let hcons_universe_set = Hashcons.simple_hcons Huniverse_set.generate Huniverse_set.hcons Level.hcons -let hcons_universe_context_set (v, c) = +let hcons_universe_context_set (v, c) = (hcons_universe_set v, hcons_constraints c) let hcons_univ x = Universe.hcons x @@ -1229,7 +1229,7 @@ let hcons_univ x = Universe.hcons x let explain_universe_inconsistency prl (o,u,v,p : univ_inconsistency) = let pr_uni = Universe.pr_with prl in let pr_rel = function - | Eq -> str"=" | Lt -> str"<" | Le -> str"<=" + | Eq -> str"=" | Lt -> str"<" | Le -> str"<=" in let reason = match p with | None -> mt() diff --git a/kernel/vars.ml b/kernel/vars.ml index dd187387d4..c2775a6896 100644 --- a/kernel/vars.ml +++ b/kernel/vars.ml @@ -164,7 +164,7 @@ let subst_of_rel_context_instance sign l = match sign, l with | LocalAssum _ :: sign', a::args' -> aux (a::subst) sign' args' | LocalDef (_,c,_)::sign', args' -> - aux (substl subst c :: subst) sign' args' + aux (substl subst c :: subst) sign' args' | [], [] -> subst | _ -> CErrors.anomaly (Pp.str "Instance and signature do not match.") in aux [] (List.rev sign) l @@ -228,41 +228,41 @@ open Constr let subst_univs_level_constr subst c = if Univ.is_empty_level_subst subst then c - else + else let f = Univ.Instance.subst_fn (Univ.subst_univs_level_level subst) in let changed = ref false in - let rec aux t = + let rec aux t = match kind t with - | Const (c, u) -> - if Univ.Instance.is_empty u then t - else - let u' = f u in - if u' == u then t - else (changed := true; mkConstU (c, u')) + | Const (c, u) -> + if Univ.Instance.is_empty u then t + else + let u' = f u in + if u' == u then t + else (changed := true; mkConstU (c, u')) | Ind (i, u) -> - if Univ.Instance.is_empty u then t - else - let u' = f u in - if u' == u then t - else (changed := true; mkIndU (i, u')) + if Univ.Instance.is_empty u then t + else + let u' = f u in + if u' == u then t + else (changed := true; mkIndU (i, u')) | Construct (c, u) -> - if Univ.Instance.is_empty u then t - else - let u' = f u in - if u' == u then t - else (changed := true; mkConstructU (c, u')) - | Sort (Sorts.Type u) -> + if Univ.Instance.is_empty u then t + else + let u' = f u in + if u' == u then t + else (changed := true; mkConstructU (c, u')) + | Sort (Sorts.Type u) -> let u' = Univ.subst_univs_level_universe subst u in - if u' == u then t else - (changed := true; mkSort (Sorts.sort_of_univ u')) + if u' == u then t else + (changed := true; mkSort (Sorts.sort_of_univ u')) | _ -> Constr.map aux t in let c' = aux c in if !changed then c' else c -let subst_univs_level_context s = +let subst_univs_level_context s = Context.Rel.map (subst_univs_level_constr s) - + let subst_instance_constr subst c = if Univ.Instance.is_empty subst then c else @@ -303,7 +303,7 @@ let univ_instantiate_constr u c = (* let substkey = CProfile.declare_profile "subst_instance_constr";; *) (* let subst_instance_constr inst c = CProfile.profile2 substkey subst_instance_constr inst c;; *) -let subst_instance_context s ctx = +let subst_instance_context s ctx = if Univ.Instance.is_empty s then ctx else Context.Rel.map (fun x -> subst_instance_constr s x) ctx diff --git a/kernel/vconv.ml b/kernel/vconv.ml index 5d36ad54a2..3563407f7e 100644 --- a/kernel/vconv.ml +++ b/kernel/vconv.ml @@ -65,11 +65,11 @@ and conv_whd env pb k whd1 whd2 cu = let tag1 = btag b1 and tag2 = btag b2 in let sz = bsize b1 in if Int.equal tag1 tag2 && Int.equal sz (bsize b2) then - let rcu = ref cu in - for i = 0 to sz - 1 do - rcu := conv_val env CONV k (bfield b1 i) (bfield b2 i) !rcu - done; - !rcu + let rcu = ref cu in + for i = 0 to sz - 1 do + rcu := conv_val env CONV k (bfield b1 i) (bfield b2 i) !rcu + done; + !rcu else raise NotConvertible | Vint64 i1, Vint64 i2 -> if Int64.equal i1 i2 then cu else raise NotConvertible @@ -105,12 +105,12 @@ and conv_atom env pb k a1 stk1 a2 stk2 cu = let u2 = Univ.Instance.of_array u2 in let cu = convert_instances ~flex:false u1 u2 cu in conv_arguments env ~from:ulen k args1 args2 - (conv_stack env k stk1' stk2' cu) + (conv_stack env k stk1' stk2' cu) | _, _ -> assert false (* Should not happen if problem is well typed *) else raise NotConvertible | Aid ik1, Aid ik2 -> if Vmvalues.eq_id_key ik1 ik2 && compare_stack stk1 stk2 then - conv_stack env k stk1 stk2 cu + conv_stack env k stk1 stk2 cu else raise NotConvertible | Asort s1, Asort s2 -> sort_cmp_universes env pb s1 s2 cu @@ -123,17 +123,17 @@ and conv_stack env k stk1 stk2 cu = conv_stack env k stk1 stk2 (conv_arguments env k args1 args2 cu) | Zfix(f1,args1) :: stk1, Zfix(f2,args2) :: stk2 -> conv_stack env k stk1 stk2 - (conv_arguments env k args1 args2 (conv_fix env k f1 f2 cu)) + (conv_arguments env k args1 args2 (conv_fix env k f1 f2 cu)) | Zswitch sw1 :: stk1, Zswitch sw2 :: stk2 -> if check_switch sw1 sw2 then - let vt1,vt2 = type_of_switch sw1, type_of_switch sw2 in - let rcu = ref (conv_val env CONV k vt1 vt2 cu) in - let b1, b2 = branch_of_switch k sw1, branch_of_switch k sw2 in - for i = 0 to Array.length b1 - 1 do - rcu := - conv_val env CONV (k + fst b1.(i)) (snd b1.(i)) (snd b2.(i)) !rcu - done; - conv_stack env k stk1 stk2 !rcu + let vt1,vt2 = type_of_switch sw1, type_of_switch sw2 in + let rcu = ref (conv_val env CONV k vt1 vt2 cu) in + let b1, b2 = branch_of_switch k sw1, branch_of_switch k sw2 in + for i = 0 to Array.length b1 - 1 do + rcu := + conv_val env CONV (k + fst b1.(i)) (snd b1.(i)) (snd b2.(i)) !rcu + done; + conv_stack env k stk1 stk2 !rcu else raise NotConvertible | Zproj p1 :: stk1, Zproj p2 :: stk2 -> if Projection.Repr.equal p1 p2 then conv_stack env k stk1 stk2 cu @@ -174,7 +174,7 @@ and conv_arguments env ?from:(from=0) k args1 args2 cu = if Int.equal n (nargs args2) then let rcu = ref cu in for i = from to n - 1 do - rcu := conv_val env CONV k (arg args1 i) (arg args2 i) !rcu + rcu := conv_val env CONV k (arg args1 i) (arg args2 i) !rcu done; !rcu else raise NotConvertible diff --git a/kernel/vm.ml b/kernel/vm.ml index 5f08720f77..ee3e7a9913 100644 --- a/kernel/vm.ml +++ b/kernel/vm.ml @@ -21,8 +21,8 @@ let popstop_code i = else begin popstop_tbl := - Array.init (i+10) - (fun j -> if j < len then !popstop_tbl.(j) else mkPopStopCode j); + Array.init (i+10) + (fun j -> if j < len then !popstop_tbl.(j) else mkPopStopCode j); !popstop_tbl.(i) end @@ -143,25 +143,25 @@ let rec apply_stack a stk v = | Zapp args :: stk -> apply_stack (apply_arguments (fun_of_val a) args) stk v | Zproj kn :: stk -> apply_stack (val_of_proj kn a) stk v | Zfix(f,args) :: stk -> - let a,stk = - match stk with - | Zapp args' :: stk -> - push_ra stop; - push_arguments args'; - push_val a; - push_arguments args; - let a = + let a,stk = + match stk with + | Zapp args' :: stk -> + push_ra stop; + push_arguments args'; + push_val a; + push_arguments args; + let a = interprete (fix_code f) (fix_val f) (fix_env f) - (nargs args+ nargs args') in - a, stk - | _ -> - push_ra stop; - push_val a; - push_arguments args; - let a = + (nargs args+ nargs args') in + a, stk + | _ -> + push_ra stop; + push_val a; + push_arguments args; + let a = interprete (fix_code f) (fix_val f) (fix_env f) - (nargs args) in - a, stk in + (nargs args) in + a, stk in apply_stack a stk v | Zswitch sw :: stk -> apply_stack (apply_switch sw a) stk v @@ -172,7 +172,7 @@ let apply_whd k whd = | Vprod _ | Vconstr_const _ | Vconstr_block _ | Vint64 _ | Vfloat64 _ -> assert false | Vfun f -> reduce_fun k f - | Vfix(f, None) -> + | Vfix(f, None) -> push_ra stop; push_val v; interprete (fix_code f) (fix_val f) (fix_env f) 0 diff --git a/lib/cProfile.ml b/lib/cProfile.ml index 323a14c6f0..34656ef4d5 100644 --- a/lib/cProfile.ml +++ b/lib/cProfile.ml @@ -134,7 +134,7 @@ let merge_profile filename (curr_table, curr_outside, curr_total as new_data) = begin (try let c = - open_out_gen + open_out_gen [Open_creat;Open_wronly;Open_trunc;Open_binary] 0o644 filename in output_binary_int c magic; output_value c updated_data; @@ -246,7 +246,7 @@ let time_overhead_A_D () = p.intcount <- p.intcount + e.intcount - intcount0 + 1; p.immcount <- p.immcount + 1; if not (p==e) then - (match !dummy_stack with [] -> assert false | _::s -> stack := s); + (match !dummy_stack with [] -> assert false | _::s -> stack := s); dummy_last_alloc := get_alloc () done; let after = get_time () in @@ -328,30 +328,30 @@ let close_profile print = let t = get_time () in match !stack with | [outside] -> - outside.tottime <- outside.tottime + t; - outside.owntime <- outside.owntime + t; - ajoute_ownalloc outside dw; - ajoute_totalloc outside dw; - let ov_bc = time_overhead_B_C () (* B+C overhead *) in - let ov_ad = time_overhead_A_D () (* A+D overhead *) in - let adjust (n,e) = (n, adjust_time ov_bc ov_ad e) in - let adjtable = List.map adjust !prof_table in - let adjoutside = adjust_time ov_bc ov_ad outside in - let totalloc = !last_alloc -. !init_alloc in - let total = create_record () in - total.tottime <- outside.tottime; - total.totalloc <- totalloc; - (* We compute estimations of overhead, put into "own" fields *) - total.owntime <- outside.tottime - adjoutside.tottime; - total.ownalloc <- totalloc -. outside.totalloc; - let current_data = (adjtable, adjoutside, total) in - let updated_data = - match !recording_file with - | "" -> current_data - | name -> merge_profile !recording_file current_data - in - if print then format_profile updated_data; - init_profile () + outside.tottime <- outside.tottime + t; + outside.owntime <- outside.owntime + t; + ajoute_ownalloc outside dw; + ajoute_totalloc outside dw; + let ov_bc = time_overhead_B_C () (* B+C overhead *) in + let ov_ad = time_overhead_A_D () (* A+D overhead *) in + let adjust (n,e) = (n, adjust_time ov_bc ov_ad e) in + let adjtable = List.map adjust !prof_table in + let adjoutside = adjust_time ov_bc ov_ad outside in + let totalloc = !last_alloc -. !init_alloc in + let total = create_record () in + total.tottime <- outside.tottime; + total.totalloc <- totalloc; + (* We compute estimations of overhead, put into "own" fields *) + total.owntime <- outside.tottime - adjoutside.tottime; + total.ownalloc <- totalloc -. outside.totalloc; + let current_data = (adjtable, adjoutside, total) in + let updated_data = + match !recording_file with + | "" -> current_data + | name -> merge_profile !recording_file current_data + in + if print then format_profile updated_data; + init_profile () | _ -> failwith "Inconsistency" end diff --git a/lib/cProfile.mli b/lib/cProfile.mli index 6f8639226d..50dd6bec34 100644 --- a/lib/cProfile.mli +++ b/lib/cProfile.mli @@ -111,11 +111,11 @@ val profile8 : (** Some utilities to compute the logical and physical sizes and depth of ML objects *) -(** Print logical size (in words) and depth of its argument +(** Print logical size (in words) and depth of its argument This function does not disturb the heap *) val print_logical_stats : 'a -> unit -(** Print physical size, logical size (in words) and depth of its argument +(** Print physical size, logical size (in words) and depth of its argument This function allocates itself a lot (the same order of magnitude as the physical size of its argument) *) val print_stats : 'a -> unit diff --git a/lib/cWarnings.ml b/lib/cWarnings.ml index 7612e8c340..0f2c083042 100644 --- a/lib/cWarnings.ml +++ b/lib/cWarnings.ml @@ -34,7 +34,7 @@ let add_warning_in_category ~name ~category = let set_warning_status ~name status = try - let w = Hashtbl.find warnings name in + let w = Hashtbl.find warnings name in Hashtbl.replace warnings name { w with status = status } with Not_found -> () diff --git a/lib/envars.ml b/lib/envars.ml index 440df08782..67759d0a3e 100644 --- a/lib/envars.ml +++ b/lib/envars.ml @@ -29,8 +29,8 @@ let home ~warn = getenv_else "HOME" (fun () -> try (Sys.getenv "HOMEDRIVE")^(Sys.getenv "HOMEPATH") with Not_found -> getenv_else "USERPROFILE" (fun () -> - warn ("Cannot determine user home directory, using '.' ."); - Filename.current_dir_name)) + warn ("Cannot determine user home directory, using '.' ."); + Filename.current_dir_name)) let path_to_list p = let sep = if String.equal Sys.os_type "Win32" then ';' else ':' in @@ -46,20 +46,20 @@ let expand_path_macros ~warn s = let l = String.length s in if Int.equal i l then s else match s.[i] with - | '$' -> - let n = expand_atom s (i+1) in - let v = safe_getenv warn (String.sub s (i+1) (n-i-1)) in - let s = (String.sub s 0 i)^v^(String.sub s n (l-n)) in - expand_macros s (i + String.length v) - | '~' when Int.equal i 0 -> - let n = expand_atom s (i+1) in - let v = - if Int.equal n (i + 1) then home ~warn - else (Unix.getpwnam (String.sub s (i+1) (n-i-1))).Unix.pw_dir - in - let s = v^(String.sub s n (l-n)) in - expand_macros s (String.length v) - | c -> expand_macros s (i+1) + | '$' -> + let n = expand_atom s (i+1) in + let v = safe_getenv warn (String.sub s (i+1) (n-i-1)) in + let s = (String.sub s 0 i)^v^(String.sub s n (l-n)) in + expand_macros s (i + String.length v) + | '~' when Int.equal i 0 -> + let n = expand_atom s (i+1) in + let v = + if Int.equal n (i + 1) then home ~warn + else (Unix.getpwnam (String.sub s (i+1) (n-i-1))).Unix.pw_dir + in + let s = v^(String.sub s n (l-n)) in + expand_macros s (String.length v) + | c -> expand_macros s (i+1) in expand_macros s 0 (** {1 Paths} *) @@ -172,7 +172,7 @@ let xdg_dirs ~warn = (* Print the configuration information *) let print_config ?(prefix_var_name="") f coq_src_subdirs = - let open Printf in + let open Printf in fprintf f "%sLOCAL=%s\n" prefix_var_name (if Coq_config.local then "1" else "0"); fprintf f "%sCOQLIB=%s/\n" prefix_var_name (coqlib ()); fprintf f "%sDOCDIR=%s/\n" prefix_var_name (docdir ()); diff --git a/lib/envars.mli b/lib/envars.mli index db904d419d..9f65ef8557 100644 --- a/lib/envars.mli +++ b/lib/envars.mli @@ -8,20 +8,20 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -(** This file provides a high-level interface to the environment variables +(** This file provides a high-level interface to the environment variables needed by Coq to run (such as coqlib). The values of these variables - may come from different sources (shell environment variables, + may come from different sources (shell environment variables, command line options, options set at the time Coq was build). *) -(** [expand_path_macros warn s] substitutes environment variables +(** [expand_path_macros warn s] substitutes environment variables in a string by their values. This function also takes care of - substituting path of the form '~X' by an absolute path. + substituting path of the form '~X' by an absolute path. Use [warn] as a message displayer. *) val expand_path_macros : warn:(string -> unit) -> string -> string (** [home warn] returns the root of the user directory, depending - on the OS. This information is usually stored in the $HOME - environment variable on POSIX shells. If no such variable + on the OS. This information is usually stored in the $HOME + environment variable on POSIX shells. If no such variable exists, then other common names are tried (HOMEDRIVE, HOMEPATH, USERPROFILE). If all of them fail, [warn] is called. *) val home : warn:(string -> unit) -> string @@ -47,14 +47,14 @@ val set_user_coqlib : string -> unit (** [coqbin] is the name of the current executable. *) val coqbin : string -(** [coqroot] is the path to [coqbin]. +(** [coqroot] is the path to [coqbin]. The following value only makes sense when executables are running from - source tree (e.g. during build or in local mode). + source tree (e.g. during build or in local mode). *) val coqroot : string -(** [coqpath] is the standard path to coq. - Notice that coqpath is stored in reverse order, since that is +(** [coqpath] is the standard path to coq. + Notice that coqpath is stored in reverse order, since that is the order it gets added to the search path. *) val coqpath : string list diff --git a/lib/explore.ml b/lib/explore.ml index e30dd7e809..42d48fbc1b 100644 --- a/lib/explore.ml +++ b/lib/explore.ml @@ -48,7 +48,7 @@ module Make = functor(S : SearchProblem) -> struct | [] -> raise Not_found | [s] -> explore (i::p) s | s :: l -> - try explore (i::p) s with Not_found -> explore_many (succ i) p l + try explore (i::p) s with Not_found -> explore_many (succ i) p l in explore [1] s @@ -82,11 +82,11 @@ module Make = functor(S : SearchProblem) -> struct enqueue 1 p q' (S.branching s) and enqueue i p q = function | [] -> - explore q + explore q | s :: l -> - let ps = i::p in - msg_with_position ps (S.pp s); - if S.success s then s else enqueue (succ i) p (push (ps,s) q) l + let ps = i::p in + msg_with_position ps (S.pp s); + if S.success s then s else enqueue (succ i) p (push (ps,s) q) l in enqueue 1 [] empty [s] @@ -265,7 +265,7 @@ let prlist_sep_lastsep no_empty sep_thunk lastsep_thunk elem l = | h::t -> h ++ sep ++ insert_seps t in insert_seps filtered_elems - + let prlist_strict pr l = prlist_sep_lastsep true mt mt pr l (* [prlist_with_sep sep pr [a ; ... ; c]] outputs [pr a ++ sep() ++ ... ++ sep() ++ pr c] *) diff --git a/lib/pp.mli b/lib/pp.mli index b97e74132c..7bb66b0135 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -149,8 +149,8 @@ val prlist_strict : ('a -> t) -> 'a list -> t val prlist_with_sep : (unit -> t) -> ('a -> t) -> 'a list -> t (** [prlist_with_sep sep pr [a ; ... ; c]] outputs - [pr a ++ sep () ++ ... ++ sep () ++ pr c]. - where the thunk sep is memoized, rather than being called each place + [pr a ++ sep () ++ ... ++ sep () ++ pr c]. + where the thunk sep is memoized, rather than being called each place its result is used. *) diff --git a/lib/spawn.ml b/lib/spawn.ml index ea0cef54f6..046829802b 100644 --- a/lib/spawn.ml +++ b/lib/spawn.ml @@ -209,8 +209,8 @@ let spawn ?(prefer_sock=prefer_sock) ?(env=Unix.environment ()) p, cout let rec wait p = - (* On windows kill is not reliable, so wait may never return. *) - if Sys.os_type = "Unix" then + (* On windows kill is not reliable, so wait may never return. *) + if Sys.os_type = "Unix" then try snd (Unix.waitpid [] p.pid) with | Unix.Unix_error (Unix.EINTR, _, _) -> wait p @@ -254,8 +254,8 @@ let kill ({ pid = unixpid; oob_req; oob_resp; cin; cout; alive } as p) = with e -> prerr_endline ("kill: "^Printexc.to_string e) end let rec wait p = - (* On windows kill is not reliable, so wait may never return. *) - if Sys.os_type = "Unix" then + (* On windows kill is not reliable, so wait may never return. *) + if Sys.os_type = "Unix" then try snd (Unix.waitpid [] p.pid) with | Unix.Unix_error (Unix.EINTR, _, _) -> wait p diff --git a/lib/spawn.mli b/lib/spawn.mli index 5321436ab0..03613fc4ec 100644 --- a/lib/spawn.mli +++ b/lib/spawn.mli @@ -27,7 +27,7 @@ module type Control = sig val kill : handle -> unit val wait : handle -> Unix.process_status val unixpid : handle -> int - + (* What is used in debug messages *) val uid : handle -> string @@ -54,7 +54,7 @@ module Async(ML : MainLoopModel) : sig (* If the returned value is false the callback is never called again and * the process is killed *) type callback = ML.condition list -> read_all:(unit -> string) -> bool - + val spawn : ?prefer_sock:bool -> ?env:string array -> string -> string array -> callback -> process * out_channel @@ -65,7 +65,7 @@ end (* spawn a process and read its output synchronously *) module Sync () : sig type process - + val spawn : ?prefer_sock:bool -> ?env:string array -> string -> string array -> process * in_channel * out_channel diff --git a/lib/system.ml b/lib/system.ml index 8c333ec267..2d68fd2fdf 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -29,9 +29,9 @@ let all_subdirs ~unix_path:root = let rec traverse path rel = let f = function | FileDir (path,f) -> - let newrel = rel @ [f] in - add path newrel; - traverse path newrel + let newrel = rel @ [f] in + add path newrel; + traverse path newrel | _ -> () in process_directory f path in @@ -133,7 +133,7 @@ let find_file_in_path ?(warn=true) paths filename = root, filename else CErrors.user_err ~hdr:"System.find_file_in_path" - (hov 0 (str "Can't find file" ++ spc () ++ str filename)) + (hov 0 (str "Can't find file" ++ spc () ++ str filename)) else (* the name is considered to be the transcription as a relative physical name of a logical name, so we deal with it as a name @@ -141,8 +141,8 @@ let find_file_in_path ?(warn=true) paths filename = try where_in_path ~warn paths filename with Not_found -> CErrors.user_err ~hdr:"System.find_file_in_path" - (hov 0 (str "Can't find file" ++ spc () ++ str filename ++ spc () ++ - str "on loadpath")) + (hov 0 (str "Can't find file" ++ spc () ++ str filename ++ spc () ++ + str "on loadpath")) let is_in_path lpath filename = try ignore (where_in_path ~warn:false lpath filename); true diff --git a/lib/util.ml b/lib/util.ml index 61678f7669..e2447b005e 100644 --- a/lib/util.ml +++ b/lib/util.ml @@ -97,7 +97,7 @@ let matrix_transpose mat = let identity x = x (** Left-to-right function composition: - + [f1 %> f2] is [fun x -> f2 (f1 x)]. [f1 %> f2 %> f3] is [fun x -> f3 (f2 (f1 x))]. diff --git a/lib/util.mli b/lib/util.mli index b6347126e0..2f1a03a19c 100644 --- a/lib/util.mli +++ b/lib/util.mli @@ -94,7 +94,7 @@ val matrix_transpose : 'a list list -> 'a list list val identity : 'a -> 'a (** Left-to-right function composition: - + [f1 %> f2] is [fun x -> f2 (f1 x)]. [f1 %> f2 %> f3] is [fun x -> f3 (f2 (f1 x))]. diff --git a/library/coqlib.ml b/library/coqlib.ml index 11d053624c..00ea8b8489 100644 --- a/library/coqlib.ml +++ b/library/coqlib.ml @@ -89,15 +89,15 @@ let gen_reference_in_modules locstr dirs s = match these with | [x] -> x | [] -> - anomaly ~label:locstr (str "cannot find " ++ str s ++ - str " in module" ++ str (if List.length dirs > 1 then "s " else " ") ++ + anomaly ~label:locstr (str "cannot find " ++ str s ++ + str " in module" ++ str (if List.length dirs > 1 then "s " else " ") ++ prlist_with_sep pr_comma DirPath.print dirs ++ str ".") | l -> anomaly ~label:locstr - (str "ambiguous name " ++ str s ++ str " can represent " ++ - prlist_with_sep pr_comma - (fun x -> Libnames.pr_path (Nametab.path_of_global x)) l ++ - str " in module" ++ str (if List.length dirs > 1 then "s " else " ") ++ + (str "ambiguous name " ++ str s ++ str " can represent " ++ + prlist_with_sep pr_comma + (fun x -> Libnames.pr_path (Nametab.path_of_global x)) l ++ + str " in module" ++ str (if List.length dirs > 1 then "s " else " ") ++ prlist_with_sep pr_comma DirPath.print dirs ++ str ".") (* For tactics/commands requiring vernacular libraries *) diff --git a/library/coqlib.mli b/library/coqlib.mli index ab8b18c4fb..10805416d1 100644 --- a/library/coqlib.mli +++ b/library/coqlib.mli @@ -210,9 +210,9 @@ val build_coq_f_equal2 : GlobRef.t delayed type coq_inversion_data = { inv_eq : GlobRef.t; (** : forall params, args -> Prop *) inv_ind : GlobRef.t; (** : forall params P (H : P params) args, eq params args - -> P args *) + -> P args *) inv_congr: GlobRef.t (** : forall params B (f:t->B) args, eq params args -> - f params = f args *) + f params = f args *) } val build_coq_inversion_eq_data : coq_inversion_data delayed diff --git a/library/global.ml b/library/global.ml index 98d3e9cb1f..d4262683bb 100644 --- a/library/global.ml +++ b/library/global.ml @@ -201,10 +201,10 @@ let is_type_in_type r = is_type_in_type (env ()) r let current_modpath () = Safe_typing.current_modpath (safe_env ()) -let current_dirpath () = +let current_dirpath () = Safe_typing.current_dirpath (safe_env ()) -let with_global f = +let with_global f = let (a, ctx) = f (env ()) (current_dirpath ()) in push_context_set false ctx; a diff --git a/library/global.mli b/library/global.mli index 0570ad0102..db0f87df7e 100644 --- a/library/global.mli +++ b/library/global.mli @@ -105,7 +105,7 @@ val lookup_named : variable -> Constr.named_declaration val lookup_constant : Constant.t -> Opaqueproof.opaque Declarations.constant_body val lookup_inductive : inductive -> Declarations.mutual_inductive_body * Declarations.one_inductive_body -val lookup_pinductive : Constr.pinductive -> +val lookup_pinductive : Constr.pinductive -> Declarations.mutual_inductive_body * Declarations.one_inductive_body val lookup_mind : MutInd.t -> Declarations.mutual_inductive_body val lookup_module : ModPath.t -> Declarations.module_body diff --git a/library/globnames.mli b/library/globnames.mli index fc0de96e36..48cbb11b66 100644 --- a/library/globnames.mli +++ b/library/globnames.mli @@ -37,7 +37,7 @@ val subst_constructor : substitution -> constructor -> constructor val subst_global : substitution -> GlobRef.t -> GlobRef.t * constr Univ.univ_abstracted option val subst_global_reference : substitution -> GlobRef.t -> GlobRef.t -(** This constr is not safe to be typechecked, universe polymorphism is not +(** This constr is not safe to be typechecked, universe polymorphism is not handled here: just use for printing *) val printable_constr_of_global : GlobRef.t -> constr @@ -60,6 +60,6 @@ module ExtRefOrdered : sig val hash : t -> int end -type global_reference_or_constr = +type global_reference_or_constr = | IsGlobal of GlobRef.t | IsConstr of constr diff --git a/library/goptions.ml b/library/goptions.ml index 0973944fb5..6e53bed349 100644 --- a/library/goptions.ml +++ b/library/goptions.ml @@ -52,12 +52,12 @@ type 'a table_of_A = { module MakeTable = functor (A : sig - type t + type t type key module Set : CSig.SetS with type elt = t val table : (string * key table_of_A) list ref val encode : Environ.env -> key -> t - val subst : substitution -> t -> t + val subst : substitution -> t -> t val printer : t -> Pp.t val key : option_name val title : string @@ -83,30 +83,30 @@ module MakeTable = | GOadd -> t := MySet.add p !t | GOrmv -> t := MySet.remove p !t in let load_options i o = if Int.equal i 1 then cache_options o in - let subst_options (subst,(f,p as obj)) = - let p' = A.subst subst p in - if p' == p then obj else - (f,p') - in + let subst_options (subst,(f,p as obj)) = + let p' = A.subst subst p in + if p' == p then obj else + (f,p') + in let inGo : option_mark * A.t -> obj = Libobject.declare_object {(Libobject.default_object nick) with Libobject.load_function = load_options; - Libobject.open_function = load_options; - Libobject.cache_function = cache_options; - Libobject.subst_function = subst_options; - Libobject.classify_function = (fun x -> Substitute x)} - in + Libobject.open_function = load_options; + Libobject.cache_function = cache_options; + Libobject.subst_function = subst_options; + Libobject.classify_function = (fun x -> Substitute x)} + in ((fun c -> Lib.add_anonymous_leaf (inGo (GOadd, c))), (fun c -> Lib.add_anonymous_leaf (inGo (GOrmv, c)))) let print_table table_name printer table = Feedback.msg_notice (str table_name ++ - (hov 0 - (if MySet.is_empty table then str " None" ++ fnl () + (hov 0 + (if MySet.is_empty table then str " None" ++ fnl () else MySet.fold - (fun a b -> spc () ++ printer a ++ b) - table (mt ()) ++ str "." ++ fnl ()))) + (fun a b -> spc () ++ printer a ++ b) + table (mt ()) ++ str "." ++ fnl ()))) let table_of_A = { add = (fun env x -> add_option (A.encode env x)); diff --git a/library/lib.ml b/library/lib.ml index 630c860a61..c3c480aee4 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -52,7 +52,7 @@ let subst_atomic_objects subst seg = let subst_one = fun (id,obj as node) -> let obj' = subst_object (subst,obj) in if obj' == obj then node else - (id, obj') + (id, obj') in List.Smart.map subst_one seg @@ -296,15 +296,15 @@ let start_modtype = start_mod true None let error_still_opened string oname = let id = basename (fst oname) in - user_err + user_err (str "The " ++ str string ++ str " " ++ Id.print id ++ str " is still opened.") let end_mod is_type = let oname,fs = try match find_entry_p is_opening_node with | oname,OpenedModule (ty,_,_,fs) -> - if ty == is_type then oname, fs - else error_still_opened (module_kind ty) oname + if ty == is_type then oname, fs + else error_still_opened (module_kind ty) oname | oname,OpenedSection _ -> error_still_opened "section" oname | _ -> assert false with Not_found -> user_err (Pp.str "No opened modules.") @@ -359,7 +359,7 @@ let end_compilation_checks dir = match !lib_state.comp_name with | None -> anomaly (Pp.str "There should be a module name...") | Some m -> - if not (Names.DirPath.equal m dir) then anomaly + if not (Names.DirPath.equal m dir) then anomaly (str "The current open module has name" ++ spc () ++ DirPath.print m ++ spc () ++ str "and not" ++ spc () ++ DirPath.print m ++ str "."); in diff --git a/library/libnames.ml b/library/libnames.ml index 485f8837e8..126841c9a5 100644 --- a/library/libnames.ml +++ b/library/libnames.ml @@ -62,7 +62,7 @@ let parse_dir s = if n >= len then dirs else let pos = try - String.index_from s n '.' + String.index_from s n '.' with Not_found -> len in if Int.equal pos n then user_err Pp.(str @@ s ^ " is an invalid path."); diff --git a/library/libobject.ml b/library/libobject.ml index 932f065f73..a632a426fd 100644 --- a/library/libobject.ml +++ b/library/libobject.ml @@ -113,12 +113,12 @@ let declare_object_full odecl = and rebuild lobj = infun (odecl.rebuild_function (outfun lobj)) in Hashtbl.add cache_tab na { dyn_cache_function = cacher; - dyn_load_function = loader; + dyn_load_function = loader; dyn_open_function = opener; - dyn_subst_function = substituter; - dyn_classify_function = classifier; - dyn_discharge_function = discharge; - dyn_rebuild_function = rebuild }; + dyn_subst_function = substituter; + dyn_classify_function = classifier; + dyn_discharge_function = discharge; + dyn_rebuild_function = rebuild }; (infun,outfun) let declare_object odecl = fst (declare_object_full odecl) @@ -144,7 +144,7 @@ let load_object i ((_,lobj) as node) = let open_object i ((_,lobj) as node) = apply_dyn_fun (fun d -> d.dyn_open_function i node) lobj -let subst_object ((_,lobj) as node) = +let subst_object ((_,lobj) as node) = apply_dyn_fun (fun d -> d.dyn_subst_function node) lobj let classify_object lobj = diff --git a/library/nametab.ml b/library/nametab.ml index 8626ee1c59..283da5936c 100644 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -128,7 +128,7 @@ struct (* Dictionaries of short names *) type nametree = { path : path_status; - map : nametree ModIdmap.t } + map : nametree ModIdmap.t } let mktree p m = { path=p; map=m } let empty_tree = mktree Nothing ModIdmap.empty @@ -149,34 +149,34 @@ struct let ptab = modify () empty_tree in ModIdmap.add modid ptab tree.map in - let this = + let this = if level <= 0 then - match tree.path with - | Absolute (n,_) -> - (* This is an absolute name, we must keep it - otherwise it may become unaccessible forever *) + match tree.path with + | Absolute (n,_) -> + (* This is an absolute name, we must keep it + otherwise it may become unaccessible forever *) warn_masking_absolute n; tree.path - | Nothing - | Relative _ -> Relative (uname,o) + | Nothing + | Relative _ -> Relative (uname,o) else tree.path - in - mktree this map + in + mktree this map | [] -> - match tree.path with - | Absolute (uname',o') -> - if E.equal o' o then begin - assert (U.equal uname uname'); - tree - (* we are putting the same thing for the second time :) *) - end - else - (* This is an absolute name, we must keep it otherwise it may - become unaccessible forever *) - (* But ours is also absolute! This is an error! *) - user_err Pp.(str @@ "Cannot mask the absolute name \"" + match tree.path with + | Absolute (uname',o') -> + if E.equal o' o then begin + assert (U.equal uname uname'); + tree + (* we are putting the same thing for the second time :) *) + end + else + (* This is an absolute name, we must keep it otherwise it may + become unaccessible forever *) + (* But ours is also absolute! This is an error! *) + user_err Pp.(str @@ "Cannot mask the absolute name \"" ^ U.to_string uname' ^ "\"!") - | Nothing - | Relative _ -> mktree (Absolute (uname,o)) tree.map + | Nothing + | Relative _ -> mktree (Absolute (uname,o)) tree.map let rec push_exactly uname o level tree = function | [] -> @@ -241,7 +241,7 @@ let user_name qid tab = let find uname tab = let id,l = U.repr uname in match search (Id.Map.find id tab) l with - Absolute (_,o) -> o + Absolute (_,o) -> o | _ -> raise Not_found let exists uname tab = @@ -260,9 +260,9 @@ let shortest_qualid ?loc ctx uname tab = | Absolute (u,_) | Relative (u,_) when U.equal u uname && not (is_empty && hidden) -> List.rev pos | _ -> - match dir with - [] -> raise Not_found - | id::dir -> find_uname (id::pos) dir (ModIdmap.find id tree.map) + match dir with + [] -> raise Not_found + | id::dir -> find_uname (id::pos) dir (ModIdmap.find id tree.map) in let ptab = Id.Map.find id tab in let found_dir = find_uname [] dir ptab in @@ -385,25 +385,25 @@ let the_univrevtab = Summary.ref ~name:"univrevtab" (UnivIdMap.empty : univrevta let push_xref visibility sp xref = match visibility with | Until _ -> - the_ccitab := ExtRefTab.push visibility sp xref !the_ccitab; - the_globrevtab := Globrevtab.add xref sp !the_globrevtab + the_ccitab := ExtRefTab.push visibility sp xref !the_ccitab; + the_globrevtab := Globrevtab.add xref sp !the_globrevtab | _ -> - begin - if ExtRefTab.exists sp !the_ccitab then + begin + if ExtRefTab.exists sp !the_ccitab then let open GlobRef in - match ExtRefTab.find sp !the_ccitab with - | TrueGlobal( ConstRef _) | TrueGlobal( IndRef _) | - TrueGlobal( ConstructRef _) as xref -> - the_ccitab := ExtRefTab.push visibility sp xref !the_ccitab; - | _ -> - the_ccitab := ExtRefTab.push visibility sp xref !the_ccitab; - else - the_ccitab := ExtRefTab.push visibility sp xref !the_ccitab; - end + match ExtRefTab.find sp !the_ccitab with + | TrueGlobal( ConstRef _) | TrueGlobal( IndRef _) | + TrueGlobal( ConstructRef _) as xref -> + the_ccitab := ExtRefTab.push visibility sp xref !the_ccitab; + | _ -> + the_ccitab := ExtRefTab.push visibility sp xref !the_ccitab; + else + the_ccitab := ExtRefTab.push visibility sp xref !the_ccitab; + end let push_cci visibility sp ref = push_xref visibility sp (TrueGlobal ref) - + (* This is for Syntactic Definitions *) let push_syndef visibility sp kn = push_xref visibility sp (SynDef kn) diff --git a/library/nametab.mli b/library/nametab.mli index 55458fe2c6..d603bd51e2 100644 --- a/library/nametab.mli +++ b/library/nametab.mli @@ -100,7 +100,7 @@ val error_global_not_found : qualid -> 'a object is loaded inside a module -- or - for a precise suffix, when the module containing (the module containing ...) the object is opened (imported) - + *) type visibility = Until of int | Exactly of int diff --git a/parsing/cLexer.ml b/parsing/cLexer.ml index 7f0d768d3f..4611d64665 100644 --- a/parsing/cLexer.ml +++ b/parsing/cLexer.ml @@ -195,14 +195,14 @@ let lookup_utf8_tail loc c cs = match Stream.npeek 3 cs with | [_;c2;c3] -> check_utf8_trailing_byte loc cs c2; - check_utf8_trailing_byte loc cs c3; + check_utf8_trailing_byte loc cs c3; 3, (c1 land 0x0F) lsl 12 + (Char.code c2 land 0x3F) lsl 6 + (Char.code c3 land 0x3F) | _ -> error_utf8 loc cs else match Stream.npeek 4 cs with | [_;c2;c3;c4] -> check_utf8_trailing_byte loc cs c2; - check_utf8_trailing_byte loc cs c3; + check_utf8_trailing_byte loc cs c3; check_utf8_trailing_byte loc cs c4; 4, (c1 land 0x07) lsl 18 + (Char.code c2 land 0x3F) lsl 12 + (Char.code c3 land 0x3F) lsl 6 + (Char.code c4 land 0x3F) @@ -833,7 +833,7 @@ let func next_token ?loc cs = Stream.from (fun i -> let (tok, loc) = next_token !cur_loc cs in - cur_loc := after loc; + cur_loc := after loc; loct_add loct i loc; Some tok) in (ts, loct_func loct) diff --git a/parsing/g_constr.mlg b/parsing/g_constr.mlg index 1cd36d2135..af1e973261 100644 --- a/parsing/g_constr.mlg +++ b/parsing/g_constr.mlg @@ -60,12 +60,12 @@ let lpar_id_coloneq = match stream_nth 0 strm with | KEYWORD "(" -> (match stream_nth 1 strm with - | IDENT s -> + | IDENT s -> (match stream_nth 2 strm with | KEYWORD ":=" -> stream_njunk 3 strm; Names.Id.of_string s - | _ -> err ()) + | _ -> err ()) | _ -> err ()) | _ -> err ()) @@ -73,23 +73,23 @@ let ensure_fixannot = Pcoq.Entry.of_parser "check_fixannot" (fun _ strm -> match stream_nth 0 strm with - | KEYWORD "{" -> - (match stream_nth 1 strm with + | KEYWORD "{" -> + (match stream_nth 1 strm with | IDENT ("wf"|"struct"|"measure") -> () - | _ -> err ()) - | _ -> err ()) + | _ -> err ()) + | _ -> err ()) let name_colon = Pcoq.Entry.of_parser "name_colon" (fun _ strm -> match stream_nth 0 strm with - | IDENT s -> + | IDENT s -> (match stream_nth 1 strm with | KEYWORD ":" -> stream_njunk 2 strm; Name (Names.Id.of_string s) | _ -> err ()) - | KEYWORD "_" -> + | KEYWORD "_" -> (match stream_nth 1 strm with | KEYWORD ":" -> stream_njunk 2 strm; @@ -186,7 +186,7 @@ GRAMMAR EXTEND Gram | "8" [ ] | "1" LEFTA [ c = operconstr; ".("; f = global; args = LIST0 appl_arg; ")" -> - { CAst.make ~loc @@ CApp((Some (List.length args+1), CAst.make @@ CRef (f,None)),args@[c,None]) } + { CAst.make ~loc @@ CApp((Some (List.length args+1), CAst.make @@ CRef (f,None)),args@[c,None]) } | c = operconstr; ".("; "@"; f = global; args = LIST0 (operconstr LEVEL "9"); ")" -> { CAst.make ~loc @@ CAppExpl((Some (List.length args+1),f,None),args@[c]) } @@ -453,7 +453,7 @@ GRAMMAR EXTEND Gram typeclass_constraint: [ [ "!" ; c = operconstr LEVEL "200" -> { (CAst.make ~loc Anonymous), true, c } | "{"; id = name; "}"; ":" ; expl = [ "!" -> { true } | -> { false } ] ; c = operconstr LEVEL "200" -> - { id, expl, c } + { id, expl, c } | iid = name_colon ; expl = [ "!" -> { true } | -> { false } ] ; c = operconstr LEVEL "200" -> { (CAst.make ~loc iid), expl, c } | c = operconstr LEVEL "200" -> diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml index 615e9cd140..ec9f9a39e0 100644 --- a/plugins/btauto/refl_btauto.ml +++ b/plugins/btauto/refl_btauto.ml @@ -54,10 +54,10 @@ module Env = struct type t = (int ConstrHashtbl.t * int ref) let add (tbl, off) (t : Constr.t) = - try ConstrHashtbl.find tbl t + try ConstrHashtbl.find tbl t with - | Not_found -> - let i = !off in + | Not_found -> + let i = !off in let () = ConstrHashtbl.add tbl t i in let () = incr off in i @@ -159,7 +159,7 @@ module Btauto = struct | Bool.Xorb (b1, b2) -> lapp f_xor [|convert b1; convert b2|] | Bool.Ifb (b1, b2, b3) -> lapp f_ifb [|convert b1; convert b2; convert b3|] - let convert_env env : Constr.t = + let convert_env env : Constr.t = CoqList.of_list (Lazy.force Bool.typ) env let reify env t = lapp eval [|convert_env env; convert t|] diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index 6f8fe8959c..500f464ea7 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -56,7 +56,7 @@ module ST=struct module IntPairTable = Hashtbl.Make(IntPair) type t = {toterm: int IntPairTable.t; - tosign: (int * int) IntTable.t} + tosign: (int * int) IntTable.t} let empty () = {toterm=IntPairTable.create init_size; @@ -64,19 +64,19 @@ module ST=struct let enter t sign st= if IntPairTable.mem st.toterm sign then - anomaly ~label:"enter" (Pp.str "signature already entered.") + anomaly ~label:"enter" (Pp.str "signature already entered.") else - IntPairTable.replace st.toterm sign t; - IntTable.replace st.tosign t sign + IntPairTable.replace st.toterm sign t; + IntTable.replace st.tosign t sign let query sign st=IntPairTable.find st.toterm sign let delete st t= try let sign=IntTable.find st.tosign t in - IntPairTable.remove st.toterm sign; - IntTable.remove st.tosign t + IntPairTable.remove st.toterm sign; + IntTable.remove st.tosign t with - Not_found -> () + Not_found -> () let delete_set st s = Int.Set.iter (delete st) s @@ -199,7 +199,7 @@ type quant_eq = qe_rhs: ccpattern; qe_rhs_valid:patt_kind } - + let swap eq : equality = let swap_rule=match eq.rule with Congruence -> Congruence @@ -234,21 +234,21 @@ type node = module Constrhash = Hashtbl.Make (struct type t = constr - let equal = eq_constr_nounivs - let hash = Constr.hash + let equal = eq_constr_nounivs + let hash = Constr.hash end) module Typehash = Constrhash module Termhash = Hashtbl.Make (struct type t = term - let equal = term_equal - let hash = hash_term + let equal = term_equal + let hash = hash_term end) module Identhash = Hashtbl.Make (struct type t = Id.t - let equal = Id.equal - let hash = Id.hash + let equal = Id.equal + let hash = Id.hash end) type forest= @@ -293,7 +293,7 @@ let empty_forest() = axioms=Constrhash.create init_size; syms=Termhash.create init_size } - + let empty depth gls:state = { uf= empty_forest (); @@ -311,7 +311,7 @@ let empty depth gls:state = env=pf_env gls; sigma=project gls } - + let forest state = state.uf let compress_path uf i j = uf.map.(j).cpath<-i @@ -332,11 +332,11 @@ let get_constructors uf i= uf.map.(i).constructors let rec find_oldest_pac uf i pac= try PacMap.find pac (get_constructors uf i) with - Not_found -> - match uf.map.(i).clas with - Eqto (j,_) -> find_oldest_pac uf j pac + Not_found -> + match uf.map.(i).clas with + Eqto (j,_) -> find_oldest_pac uf j pac | Rep _ -> raise Not_found - + let get_constructor_info uf i= match uf.map.(i).term with @@ -397,11 +397,11 @@ let next uf= if Int.equal nsize uf.max_size then let newmax=uf.max_size * 3 / 2 + 1 in let newmap=Array.make newmax dummy_node in - begin - uf.max_size<-newmax; - Array.blit uf.map 0 newmap 0 size; - uf.map<-newmap - end + begin + uf.max_size<-newmax; + Array.blit uf.map 0 newmap 0 size; + uf.map<-newmap + end else (); uf.size<-nsize; size @@ -440,14 +440,14 @@ let rec canonize_name sigma c = let func c = canonize_name sigma (EConstr.of_constr c) in match Constr.kind c with | Const (kn,u) -> - let canon_const = Constant.make1 (Constant.canonical kn) in - (mkConstU (canon_const,u)) + let canon_const = Constant.make1 (Constant.canonical kn) in + (mkConstU (canon_const,u)) | Ind ((kn,i),u) -> - let canon_mind = MutInd.make1 (MutInd.canonical kn) in - (mkIndU ((canon_mind,i),u)) + let canon_mind = MutInd.make1 (MutInd.canonical kn) in + (mkIndU ((canon_mind,i),u)) | Construct (((kn,i),j),u) -> - let canon_mind = MutInd.make1 (MutInd.canonical kn) in - mkConstructU (((canon_mind,i),j),u) + let canon_mind = MutInd.make1 (MutInd.canonical kn) in + mkConstructU (((canon_mind,i),j),u) | Prod (na,t,ct) -> mkProd (na,func t, func ct) | Lambda (na,t,ct) -> @@ -457,9 +457,9 @@ let rec canonize_name sigma c = | App (ct,l) -> mkApp (func ct,Array.Smart.map func l) | Proj(p,c) -> - let p' = Projection.map (fun kn -> + let p' = Projection.map (fun kn -> MutInd.make1 (MutInd.canonical kn)) p in - (mkProj (p', func c)) + (mkProj (p', func c)) | _ -> c (* rebuild a term from a pattern and a substitution *) @@ -477,8 +477,8 @@ let rec inst_pattern subst = function subst.(pred i) | PApp (t, args) -> List.fold_right - (fun spat f -> Appli (f,inst_pattern subst spat)) - args t + (fun spat f -> Appli (f,inst_pattern subst spat)) + args t let pr_idx_term env sigma uf i = str "[" ++ int i ++ str ":=" ++ Printer.pr_econstr_env env sigma (EConstr.of_constr (constr_of_term (term uf i))) ++ str "]" @@ -489,62 +489,62 @@ let pr_term env sigma t = str "[" ++ let rec add_term state t= let uf=state.uf in try Termhash.find uf.syms t with - Not_found -> - let b=next uf in + Not_found -> + let b=next uf in let trm = constr_of_term t in let typ = Typing.unsafe_type_of state.env state.sigma (EConstr.of_constr trm) in let typ = canonize_name state.sigma typ in - let new_node= - match t with - Symb _ | Product (_,_) -> - let paf = - {fsym=b; - fnargs=0} in - Queue.add (b,Fmark paf) state.marks; - {clas= Rep (new_representative typ); - cpath= -1; - constructors=PacMap.empty; - vertex= Leaf; - term= t} - | Eps id -> - {clas= Rep (new_representative typ); - cpath= -1; - constructors=PacMap.empty; - vertex= Leaf; - term= t} - | Appli (t1,t2) -> - let i1=add_term state t1 and i2=add_term state t2 in - add_lfather uf (find uf i1) b; - add_rfather uf (find uf i2) b; - state.terms<-Int.Set.add b state.terms; - {clas= Rep (new_representative typ); - cpath= -1; - constructors=PacMap.empty; - vertex= Node(i1,i2); - term= t} - | Constructor cinfo -> - let paf = - {fsym=b; - fnargs=0} in - Queue.add (b,Fmark paf) state.marks; - let pac = - {cnode= b; - arity= cinfo.ci_arity; - args=[]} in - Queue.add (b,Cmark pac) state.marks; - {clas=Rep (new_representative typ); - cpath= -1; - constructors=PacMap.empty; - vertex=Leaf; - term=t} - in - uf.map.(b)<-new_node; - Termhash.add uf.syms t b; - Typehash.replace state.by_type typ - (Int.Set.add b - (try Typehash.find state.by_type typ with - Not_found -> Int.Set.empty)); - b + let new_node= + match t with + Symb _ | Product (_,_) -> + let paf = + {fsym=b; + fnargs=0} in + Queue.add (b,Fmark paf) state.marks; + {clas= Rep (new_representative typ); + cpath= -1; + constructors=PacMap.empty; + vertex= Leaf; + term= t} + | Eps id -> + {clas= Rep (new_representative typ); + cpath= -1; + constructors=PacMap.empty; + vertex= Leaf; + term= t} + | Appli (t1,t2) -> + let i1=add_term state t1 and i2=add_term state t2 in + add_lfather uf (find uf i1) b; + add_rfather uf (find uf i2) b; + state.terms<-Int.Set.add b state.terms; + {clas= Rep (new_representative typ); + cpath= -1; + constructors=PacMap.empty; + vertex= Node(i1,i2); + term= t} + | Constructor cinfo -> + let paf = + {fsym=b; + fnargs=0} in + Queue.add (b,Fmark paf) state.marks; + let pac = + {cnode= b; + arity= cinfo.ci_arity; + args=[]} in + Queue.add (b,Cmark pac) state.marks; + {clas=Rep (new_representative typ); + cpath= -1; + constructors=PacMap.empty; + vertex=Leaf; + term=t} + in + uf.map.(b)<-new_node; + Termhash.add uf.syms t b; + Typehash.replace state.by_type typ + (Int.Set.add b + (try Typehash.find state.by_type typ with + Not_found -> Int.Set.empty)); + b let add_equality state c s t= let i = add_term state s in @@ -573,7 +573,7 @@ let is_redundant state id args = let prev_args = Identhash.find_all state.q_history id in List.exists (fun old_args -> - Util.Array.for_all2 (fun i j -> Int.equal i (find state.uf j)) + Util.Array.for_all2 (fun i j -> Int.equal i (find state.uf j)) norm_args old_args) prev_args with Not_found -> false @@ -591,26 +591,26 @@ let add_inst state (inst,int_subst) = let args = Array.map constr_of_term subst in let _ = Array.rev args in (* highest deBruijn index first *) let prf= mkApp(prfhead,args) in - let s = inst_pattern subst inst.qe_lhs - and t = inst_pattern subst inst.qe_rhs in - state.changed<-true; - state.rew_depth<-pred state.rew_depth; - if inst.qe_pol then - begin - debug (fun () -> - (str "Adding new equality, depth="++ int state.rew_depth) ++ fnl () ++ + let s = inst_pattern subst inst.qe_lhs + and t = inst_pattern subst inst.qe_rhs in + state.changed<-true; + state.rew_depth<-pred state.rew_depth; + if inst.qe_pol then + begin + debug (fun () -> + (str "Adding new equality, depth="++ int state.rew_depth) ++ fnl () ++ (str " [" ++ Printer.pr_econstr_env state.env state.sigma (EConstr.of_constr prf) ++ str " : " ++ pr_term state.env state.sigma s ++ str " == " ++ pr_term state.env state.sigma t ++ str "]")); - add_equality state prf s t - end - else - begin - debug (fun () -> - (str "Adding new disequality, depth="++ int state.rew_depth) ++ fnl () ++ + add_equality state prf s t + end + else + begin + debug (fun () -> + (str "Adding new disequality, depth="++ int state.rew_depth) ++ fnl () ++ (str " [" ++ Printer.pr_econstr_env state.env state.sigma (EConstr.of_constr prf) ++ str " : " ++ pr_term state.env state.sigma s ++ str " <> " ++ pr_term state.env state.sigma t ++ str "]")); - add_disequality state (Hyp prf) s t - end + add_disequality state (Hyp prf) s t + end end let link uf i j eq = (* links i -> j *) @@ -643,8 +643,8 @@ let union state i1 i2 eq= link state.uf i1 i2 eq; Constrhash.replace state.by_type r1.class_type (Int.Set.remove i1 - (try Constrhash.find state.by_type r1.class_type with - Not_found -> Int.Set.empty)); + (try Constrhash.find state.by_type r1.class_type with + Not_found -> Int.Set.empty)); let f= Int.Set.union r1.fathers r2.fathers in r2.weight<-Int.Set.cardinal f; r2.fathers<-f; @@ -652,28 +652,28 @@ let union state i1 i2 eq= ST.delete_set state.sigtable r1.fathers; state.terms<-Int.Set.union state.terms r1.fathers; PacMap.iter - (fun pac b -> Queue.add (b,Cmark pac) state.marks) - state.uf.map.(i1).constructors; + (fun pac b -> Queue.add (b,Cmark pac) state.marks) + state.uf.map.(i1).constructors; PafMap.iter - (fun paf -> Int.Set.iter - (fun b -> Queue.add (b,Fmark paf) state.marks)) - r1.functions; + (fun paf -> Int.Set.iter + (fun b -> Queue.add (b,Fmark paf) state.marks)) + r1.functions; match r1.inductive_status,r2.inductive_status with - Unknown,_ -> () - | Partial pac,Unknown -> - r2.inductive_status<-Partial pac; - state.pa_classes<-Int.Set.remove i1 state.pa_classes; - state.pa_classes<-Int.Set.add i2 state.pa_classes - | Partial _ ,(Partial _ |Partial_applied) -> - state.pa_classes<-Int.Set.remove i1 state.pa_classes - | Partial_applied,Unknown -> - r2.inductive_status<-Partial_applied - | Partial_applied,Partial _ -> - state.pa_classes<-Int.Set.remove i2 state.pa_classes; - r2.inductive_status<-Partial_applied - | Total cpl,Unknown -> r2.inductive_status<-Total cpl; - | Total (i,pac),Total _ -> Queue.add (i,Cmark pac) state.marks - | _,_ -> () + Unknown,_ -> () + | Partial pac,Unknown -> + r2.inductive_status<-Partial pac; + state.pa_classes<-Int.Set.remove i1 state.pa_classes; + state.pa_classes<-Int.Set.add i2 state.pa_classes + | Partial _ ,(Partial _ |Partial_applied) -> + state.pa_classes<-Int.Set.remove i1 state.pa_classes + | Partial_applied,Unknown -> + r2.inductive_status<-Partial_applied + | Partial_applied,Partial _ -> + state.pa_classes<-Int.Set.remove i2 state.pa_classes; + r2.inductive_status<-Partial_applied + | Total cpl,Unknown -> r2.inductive_status<-Total cpl; + | Total (i,pac),Total _ -> Queue.add (i,Cmark pac) state.marks + | _,_ -> () let merge eq state = (* merge and no-merge *) debug @@ -684,9 +684,9 @@ let merge eq state = (* merge and no-merge *) and j=find uf eq.rhs in if not (Int.equal i j) then if (size uf i)<(size uf j) then - union state i j eq + union state i j eq else - union state j i (swap eq) + union state j i (swap eq) let update t state = (* update 1 and 2 *) debug @@ -696,10 +696,10 @@ let update t state = (* update 1 and 2 *) let rep = get_representative state.uf i in begin match rep.inductive_status with - Partial _ -> - rep.inductive_status <- Partial_applied; - state.pa_classes <- Int.Set.remove i state.pa_classes - | _ -> () + Partial _ -> + rep.inductive_status <- Partial_applied; + state.pa_classes <- Int.Set.remove i state.pa_classes + | _ -> () end; PacMap.iter (fun pac _ -> Queue.add (t,Cmark (append_pac v pac)) state.marks) @@ -709,9 +709,9 @@ let update t state = (* update 1 and 2 *) rep.functions; try let s = ST.query sign state.sigtable in - Queue.add {lhs=t;rhs=s;rule=Congruence} state.combine + Queue.add {lhs=t;rhs=s;rule=Congruence} state.combine with - Not_found -> ST.enter t sign state.sigtable + Not_found -> ST.enter t sign state.sigtable let process_function_mark t rep paf state = add_paf rep paf t; @@ -720,35 +720,35 @@ let process_function_mark t rep paf state = let process_constructor_mark t i rep pac state = add_pac state.uf.map.(i) pac t; match rep.inductive_status with - Total (s,opac) -> - if not (Int.equal pac.cnode opac.cnode) then (* Conflict *) - raise (Discriminable (s,opac,t,pac)) - else (* Match *) - let cinfo = get_constructor_info state.uf pac.cnode in - let rec f n oargs args= - if n > 0 then - match (oargs,args) with - s1::q1,s2::q2-> - Queue.add - {lhs=s1;rhs=s2;rule=Injection(s,opac,t,pac,n)} - state.combine; - f (n-1) q1 q2 - | _-> anomaly ~label:"add_pacs" - (Pp.str "weird error in injection subterms merge.") - in f cinfo.ci_nhyps opac.args pac.args + Total (s,opac) -> + if not (Int.equal pac.cnode opac.cnode) then (* Conflict *) + raise (Discriminable (s,opac,t,pac)) + else (* Match *) + let cinfo = get_constructor_info state.uf pac.cnode in + let rec f n oargs args= + if n > 0 then + match (oargs,args) with + s1::q1,s2::q2-> + Queue.add + {lhs=s1;rhs=s2;rule=Injection(s,opac,t,pac,n)} + state.combine; + f (n-1) q1 q2 + | _-> anomaly ~label:"add_pacs" + (Pp.str "weird error in injection subterms merge.") + in f cinfo.ci_nhyps opac.args pac.args | Partial_applied | Partial _ -> (* add_pac state.uf.map.(i) pac t; *) - state.terms<-Int.Set.union rep.lfathers state.terms + state.terms<-Int.Set.union rep.lfathers state.terms | Unknown -> - if Int.equal pac.arity 0 then - rep.inductive_status <- Total (t,pac) - else - begin - (* add_pac state.uf.map.(i) pac t; *) - state.terms<-Int.Set.union rep.lfathers state.terms; - rep.inductive_status <- Partial pac; - state.pa_classes<- Int.Set.add i state.pa_classes - end + if Int.equal pac.arity 0 then + rep.inductive_status <- Total (t,pac) + else + begin + (* add_pac state.uf.map.(i) pac t; *) + state.terms<-Int.Set.union rep.lfathers state.terms; + rep.inductive_status <- Partial pac; + state.pa_classes<- Int.Set.add i state.pa_classes + end let process_mark t m state = debug @@ -756,7 +756,7 @@ let process_mark t m state = let i=find state.uf t in let rep=get_representative state.uf i in match m with - Fmark paf -> process_function_mark t rep paf state + Fmark paf -> process_function_mark t rep paf state | Cmark pac -> process_constructor_mark t i rep pac state type explanation = @@ -783,20 +783,20 @@ let check_disequalities state = let one_step state = try let eq = Queue.take state.combine in - merge eq state; - true + merge eq state; + true with Queue.Empty -> try - let (t,m) = Queue.take state.marks in - process_mark t m state; - true + let (t,m) = Queue.take state.marks in + process_mark t m state; + true with Queue.Empty -> - try - let t = Int.Set.choose state.terms in - state.terms<-Int.Set.remove t state.terms; - update t state; - true - with Not_found -> false + try + let t = Int.Set.choose state.terms in + state.terms<-Int.Set.remove t state.terms; + update t state; + true + with Not_found -> false let __eps__ = Id.of_string "_eps_" @@ -810,21 +810,21 @@ let new_state_var typ state = let complete_one_class state i= match (get_representative state.uf i).inductive_status with Partial pac -> - let rec app t typ n = - if n<=0 then t else + let rec app t typ n = + if n<=0 then t else let _,etyp,rest= destProd typ in let id = new_state_var (EConstr.of_constr etyp) state in app (Appli(t,Eps id)) (substl [mkVar id] rest) (n-1) in let _c = Typing.unsafe_type_of state.env state.sigma - (EConstr.of_constr (constr_of_term (term state.uf pac.cnode))) in + (EConstr.of_constr (constr_of_term (term state.uf pac.cnode))) in let _c = EConstr.Unsafe.to_constr _c in - let _args = - List.map (fun i -> constr_of_term (term state.uf i)) - pac.args in + let _args = + List.map (fun i -> constr_of_term (term state.uf i)) + pac.args in let typ = Term.prod_applist _c (List.rev _args) in - let ct = app (term state.uf i) typ pac.arity in - state.uf.epsilons <- pac :: state.uf.epsilons; - ignore (add_term state ct) + let ct = app (term state.uf i) typ pac.arity in + state.uf.epsilons <- pac :: state.uf.epsilons; + ignore (add_term state ct) | _ -> anomaly (Pp.str "wrong incomplete class.") let complete state = @@ -841,59 +841,59 @@ let make_fun_table state = Array.iteri (fun i inode -> if i < uf.size then match inode.clas with - Rep rep -> - PafMap.iter - (fun paf _ -> - let elem = - try PafMap.find paf !funtab - with Not_found -> Int.Set.empty in - funtab:= PafMap.add paf (Int.Set.add i elem) !funtab) - rep.functions - | _ -> ()) state.uf.map; + Rep rep -> + PafMap.iter + (fun paf _ -> + let elem = + try PafMap.find paf !funtab + with Not_found -> Int.Set.empty in + funtab:= PafMap.add paf (Int.Set.add i elem) !funtab) + rep.functions + | _ -> ()) state.uf.map; !funtab let do_match state res pb_stack = let mp=Stack.pop pb_stack in match mp.mp_stack with - [] -> - res:= (mp.mp_inst,mp.mp_subst) :: !res + [] -> + res:= (mp.mp_inst,mp.mp_subst) :: !res | (patt,cl)::remains -> - let uf=state.uf in - match patt with - PVar i -> - if mp.mp_subst.(pred i)<0 then - begin - mp.mp_subst.(pred i)<- cl; (* no aliasing problem here *) - Stack.push {mp with mp_stack=remains} pb_stack - end - else - if Int.equal mp.mp_subst.(pred i) cl then - Stack.push {mp with mp_stack=remains} pb_stack - else (* mismatch for non-linear variable in pattern *) () - | PApp (f,[]) -> - begin - try let j=Termhash.find uf.syms f in - if Int.equal (find uf j) cl then - Stack.push {mp with mp_stack=remains} pb_stack - with Not_found -> () - end - | PApp(f, ((last_arg::rem_args) as args)) -> - try - let j=Termhash.find uf.syms f in - let paf={fsym=j;fnargs=List.length args} in - let rep=get_representative uf cl in - let good_terms = PafMap.find paf rep.functions in - let aux i = - let (s,t) = signature state.uf i in - Stack.push - {mp with - mp_subst=Array.copy mp.mp_subst; - mp_stack= - (PApp(f,rem_args),s) :: - (last_arg,t) :: remains} pb_stack in - Int.Set.iter aux good_terms - with Not_found -> () + let uf=state.uf in + match patt with + PVar i -> + if mp.mp_subst.(pred i)<0 then + begin + mp.mp_subst.(pred i)<- cl; (* no aliasing problem here *) + Stack.push {mp with mp_stack=remains} pb_stack + end + else + if Int.equal mp.mp_subst.(pred i) cl then + Stack.push {mp with mp_stack=remains} pb_stack + else (* mismatch for non-linear variable in pattern *) () + | PApp (f,[]) -> + begin + try let j=Termhash.find uf.syms f in + if Int.equal (find uf j) cl then + Stack.push {mp with mp_stack=remains} pb_stack + with Not_found -> () + end + | PApp(f, ((last_arg::rem_args) as args)) -> + try + let j=Termhash.find uf.syms f in + let paf={fsym=j;fnargs=List.length args} in + let rep=get_representative uf cl in + let good_terms = PafMap.find paf rep.functions in + let aux i = + let (s,t) = signature state.uf i in + Stack.push + {mp with + mp_subst=Array.copy mp.mp_subst; + mp_stack= + (PApp(f,rem_args),s) :: + (last_arg,t) :: remains} pb_stack in + Int.Set.iter aux good_terms + with Not_found -> () let paf_of_patt syms = function PVar _ -> invalid_arg "paf_of_patt: pattern is trivial" @@ -908,49 +908,49 @@ let init_pb_stack state = let aux inst = begin let good_classes = - match inst.qe_lhs_valid with - Creates_variables -> Int.Set.empty - | Normal -> - begin - try - let paf= paf_of_patt syms inst.qe_lhs in - PafMap.find paf funtab - with Not_found -> Int.Set.empty - end - | Trivial typ -> - begin - try - Typehash.find state.by_type typ - with Not_found -> Int.Set.empty - end in - Int.Set.iter (fun i -> - Stack.push - {mp_subst = Array.make inst.qe_nvars (-1); - mp_inst=inst; - mp_stack=[inst.qe_lhs,i]} pb_stack) good_classes + match inst.qe_lhs_valid with + Creates_variables -> Int.Set.empty + | Normal -> + begin + try + let paf= paf_of_patt syms inst.qe_lhs in + PafMap.find paf funtab + with Not_found -> Int.Set.empty + end + | Trivial typ -> + begin + try + Typehash.find state.by_type typ + with Not_found -> Int.Set.empty + end in + Int.Set.iter (fun i -> + Stack.push + {mp_subst = Array.make inst.qe_nvars (-1); + mp_inst=inst; + mp_stack=[inst.qe_lhs,i]} pb_stack) good_classes end; begin let good_classes = - match inst.qe_rhs_valid with - Creates_variables -> Int.Set.empty - | Normal -> - begin - try - let paf= paf_of_patt syms inst.qe_rhs in - PafMap.find paf funtab - with Not_found -> Int.Set.empty - end - | Trivial typ -> - begin - try - Typehash.find state.by_type typ - with Not_found -> Int.Set.empty - end in - Int.Set.iter (fun i -> - Stack.push - {mp_subst = Array.make inst.qe_nvars (-1); - mp_inst=inst; - mp_stack=[inst.qe_rhs,i]} pb_stack) good_classes + match inst.qe_rhs_valid with + Creates_variables -> Int.Set.empty + | Normal -> + begin + try + let paf= paf_of_patt syms inst.qe_rhs in + PafMap.find paf funtab + with Not_found -> Int.Set.empty + end + | Trivial typ -> + begin + try + Typehash.find state.by_type typ + with Not_found -> Int.Set.empty + end in + Int.Set.iter (fun i -> + Stack.push + {mp_subst = Array.make inst.qe_nvars (-1); + mp_inst=inst; + mp_stack=[inst.qe_rhs,i]} pb_stack) good_classes end in List.iter aux state.quant; pb_stack @@ -962,8 +962,8 @@ let find_instances state = debug (fun () -> str "Running E-matching algorithm ... "); try while true do - Control.check_for_interrupt (); - do_match state res pb_stack + Control.check_for_interrupt (); + do_match state res pb_stack done; anomaly (Pp.str "get out of here!") with Stack.Empty -> () in @@ -977,37 +977,37 @@ let rec execute first_run state = one_step state do () done; match check_disequalities state with - None -> - if not(Int.Set.is_empty state.pa_classes) then - begin - debug (fun () -> str "First run was incomplete, completing ... "); - complete state; - execute false state - end - else - if state.rew_depth>0 then - let l=find_instances state in - List.iter (add_inst state) l; - if state.changed then - begin - state.changed <- false; - execute true state - end - else - begin - debug (fun () -> str "Out of instances ... "); - None - end - else - begin - debug (fun () -> str "Out of depth ... "); - None - end + None -> + if not(Int.Set.is_empty state.pa_classes) then + begin + debug (fun () -> str "First run was incomplete, completing ... "); + complete state; + execute false state + end + else + if state.rew_depth>0 then + let l=find_instances state in + List.iter (add_inst state) l; + if state.changed then + begin + state.changed <- false; + execute true state + end + else + begin + debug (fun () -> str "Out of instances ... "); + None + end + else + begin + debug (fun () -> str "Out of depth ... "); + None + end | Some dis -> Some - begin - if first_run then Contradiction dis - else Incomplete - end + begin + if first_run then Contradiction dis + else Incomplete + end with Discriminable(s,spac,t,tpac) -> Some begin if first_run then Discrimination (s,spac,t,tpac) diff --git a/plugins/cc/ccproof.ml b/plugins/cc/ccproof.ml index f47a14cdc7..f82a55fe71 100644 --- a/plugins/cc/ccproof.ml +++ b/plugins/cc/ccproof.ml @@ -43,25 +43,25 @@ let rec ptrans p1 p3= | Trans(p1,p2), _ ->ptrans p1 (ptrans p2 p3) | Congr(p1,p2), Congr(p3,p4) ->pcongr (ptrans p1 p3) (ptrans p2 p4) | Congr(p1,p2), Trans({p_rule=Congr(p3,p4)},p5) -> - ptrans (pcongr (ptrans p1 p3) (ptrans p2 p4)) p5 + ptrans (pcongr (ptrans p1 p3) (ptrans p2 p4)) p5 | _, _ -> if term_equal p1.p_rhs p3.p_lhs then - {p_lhs=p1.p_lhs; - p_rhs=p3.p_rhs; - p_rule=Trans (p1,p3)} + {p_lhs=p1.p_lhs; + p_rhs=p3.p_rhs; + p_rule=Trans (p1,p3)} else anomaly (Pp.str "invalid cc transitivity.") let rec psym p = match p.p_rule with Refl _ -> p | SymAx s -> - {p_lhs=p.p_rhs; - p_rhs=p.p_lhs; - p_rule=Ax s} + {p_lhs=p.p_rhs; + p_rhs=p.p_lhs; + p_rule=Ax s} | Ax s-> - {p_lhs=p.p_rhs; - p_rhs=p.p_lhs; - p_rule=SymAx s} + {p_lhs=p.p_rhs; + p_rhs=p.p_lhs; + p_rule=SymAx s} | Inject (p0,c,n,a)-> {p_lhs=p.p_rhs; p_rhs=p.p_lhs; @@ -84,9 +84,9 @@ let psymax axioms s = let rec nth_arg t n= match t with Appli (t1,t2)-> - if n>0 then - nth_arg t1 (n-1) - else t2 + if n>0 then + nth_arg t1 (n-1) + else t2 | _ -> anomaly ~label:"nth_arg" (Pp.str "not enough args.") let pinject p c n a = @@ -99,7 +99,7 @@ let rec equal_proof env sigma uf i j= if i=j then prefl (term uf i) else let (li,lj)=join_path uf i j in ptrans (path_proof env sigma uf i li) (psym (path_proof env sigma uf j lj)) - + and edge_proof env sigma uf ((i,j),eq)= debug (fun () -> str "edge_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ pr_idx_term env sigma uf j); let pi=equal_proof env sigma uf i eq.lhs in @@ -107,15 +107,15 @@ and edge_proof env sigma uf ((i,j),eq)= let pij= match eq.rule with Axiom (s,reversed)-> - if reversed then psymax (axioms uf) s - else pax (axioms uf) s + if reversed then psymax (axioms uf) s + else pax (axioms uf) s | Congruence ->congr_proof env sigma uf eq.lhs eq.rhs - | Injection (ti,ipac,tj,jpac,k) -> (* pi_k ipac = p_k jpac *) + | Injection (ti,ipac,tj,jpac,k) -> (* pi_k ipac = p_k jpac *) let p=ind_proof env sigma uf ti ipac tj jpac in let cinfo= get_constructor_info uf ipac.cnode in - pinject p cinfo.ci_constr cinfo.ci_nhyps k in + pinject p cinfo.ci_constr cinfo.ci_nhyps k in ptrans (ptrans pi pij) pj - + and constr_proof env sigma uf i ipac= debug (fun () -> str "constr_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20)); let t=find_oldest_pac uf i ipac in @@ -128,20 +128,20 @@ and constr_proof env sigma uf i ipac= let targ=term uf arg in let p=constr_proof env sigma uf fi fipac in ptrans eq_it (pcongr p (prefl targ)) - + and path_proof env sigma uf i l= debug (fun () -> str "path_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ str "{" ++ - (prlist_with_sep (fun () -> str ",") (fun ((_,j),_) -> int j) l) ++ str "}"); + (prlist_with_sep (fun () -> str ",") (fun ((_,j),_) -> int j) l) ++ str "}"); match l with | [] -> prefl (term uf i) | x::q->ptrans (path_proof env sigma uf (snd (fst x)) q) (edge_proof env sigma uf x) - + and congr_proof env sigma uf i j= debug (fun () -> str "congr_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ pr_idx_term env sigma uf j); let (i1,i2) = subterms uf i and (j1,j2) = subterms uf j in pcongr (equal_proof env sigma uf i1 j1) (equal_proof env sigma uf i2 j2) - + and ind_proof env sigma uf i ipac j jpac= debug (fun () -> str "ind_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ pr_idx_term env sigma uf j); let p=equal_proof env sigma uf i j diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index b5be1cdd89..556e6b48e6 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -51,40 +51,40 @@ let sf_of env sigma c = snd (sort_of env sigma c) let rec decompose_term env sigma t= match EConstr.kind sigma (whd env sigma t) with App (f,args)-> - let tf=decompose_term env sigma f in - let targs=Array.map (decompose_term env sigma) args in - Array.fold_left (fun s t->Appli (s,t)) tf targs + let tf=decompose_term env sigma f in + let targs=Array.map (decompose_term env sigma) args in + Array.fold_left (fun s t->Appli (s,t)) tf targs | Prod (_,a,_b) when noccurn sigma 1 _b -> - let b = Termops.pop _b in - let sort_b = sf_of env sigma b in - let sort_a = sf_of env sigma a in - Appli(Appli(Product (sort_a,sort_b) , - decompose_term env sigma a), - decompose_term env sigma b) + let b = Termops.pop _b in + let sort_b = sf_of env sigma b in + let sort_a = sf_of env sigma a in + Appli(Appli(Product (sort_a,sort_b) , + decompose_term env sigma a), + decompose_term env sigma b) | Construct c -> - let (((mind,i_ind),i_con),u)= c in - let u = EInstance.kind sigma u in - let canon_mind = MutInd.make1 (MutInd.canonical mind) in - let canon_ind = canon_mind,i_ind in - let (oib,_)=Global.lookup_inductive (canon_ind) in + let (((mind,i_ind),i_con),u)= c in + let u = EInstance.kind sigma u in + let canon_mind = MutInd.make1 (MutInd.canonical mind) in + let canon_ind = canon_mind,i_ind in + let (oib,_)=Global.lookup_inductive (canon_ind) in let nargs=constructor_nallargs env (canon_ind,i_con) in - Constructor {ci_constr= ((canon_ind,i_con),u); - ci_arity=nargs; - ci_nhyps=nargs-oib.mind_nparams} - | Ind c -> - let (mind,i_ind),u = c in - let u = EInstance.kind sigma u in - let canon_mind = MutInd.make1 (MutInd.canonical mind) in - let canon_ind = canon_mind,i_ind in (Symb (Constr.mkIndU (canon_ind,u))) - | Const (c,u) -> - let u = EInstance.kind sigma u in - let canon_const = Constant.make1 (Constant.canonical c) in - (Symb (Constr.mkConstU (canon_const,u))) - | Proj (p, c) -> + Constructor {ci_constr= ((canon_ind,i_con),u); + ci_arity=nargs; + ci_nhyps=nargs-oib.mind_nparams} + | Ind c -> + let (mind,i_ind),u = c in + let u = EInstance.kind sigma u in + let canon_mind = MutInd.make1 (MutInd.canonical mind) in + let canon_ind = canon_mind,i_ind in (Symb (Constr.mkIndU (canon_ind,u))) + | Const (c,u) -> + let u = EInstance.kind sigma u in + let canon_const = Constant.make1 (Constant.canonical c) in + (Symb (Constr.mkConstU (canon_const,u))) + | Proj (p, c) -> let canon_mind kn = MutInd.make1 (MutInd.canonical kn) in let p' = Projection.map canon_mind p in - let c = Retyping.expand_projection env sigma p' c [] in - decompose_term env sigma c + let c = Retyping.expand_projection env sigma p' c [] in + decompose_term env sigma c | _ -> let t = Termops.strip_outer_cast sigma t in if closed0 sigma t then Symb (EConstr.to_constr ~abort_on_undefined_evars:false sigma t) else raise Not_found @@ -97,33 +97,33 @@ let atom_of_constr env sigma term = let kot = EConstr.kind sigma wh in match kot with App (f,args)-> - if is_global sigma (Lazy.force _eq) f && Int.equal (Array.length args) 3 - then `Eq (args.(0), - decompose_term env sigma args.(1), - decompose_term env sigma args.(2)) - else `Other (decompose_term env sigma term) + if is_global sigma (Lazy.force _eq) f && Int.equal (Array.length args) 3 + then `Eq (args.(0), + decompose_term env sigma args.(1), + decompose_term env sigma args.(2)) + else `Other (decompose_term env sigma term) | _ -> `Other (decompose_term env sigma term) let rec pattern_of_constr env sigma c = match EConstr.kind sigma (whd env sigma c) with App (f,args)-> - let pf = decompose_term env sigma f in - let pargs,lrels = List.split - (Array.map_to_list (pattern_of_constr env sigma) args) in - PApp (pf,List.rev pargs), - List.fold_left Int.Set.union Int.Set.empty lrels + let pf = decompose_term env sigma f in + let pargs,lrels = List.split + (Array.map_to_list (pattern_of_constr env sigma) args) in + PApp (pf,List.rev pargs), + List.fold_left Int.Set.union Int.Set.empty lrels | Prod (_,a,_b) when noccurn sigma 1 _b -> - let b = Termops.pop _b in - let pa,sa = pattern_of_constr env sigma a in - let pb,sb = pattern_of_constr env sigma b in - let sort_b = sf_of env sigma b in - let sort_a = sf_of env sigma a in - PApp(Product (sort_a,sort_b), - [pa;pb]),(Int.Set.union sa sb) + let b = Termops.pop _b in + let pa,sa = pattern_of_constr env sigma a in + let pb,sb = pattern_of_constr env sigma b in + let sort_b = sf_of env sigma b in + let sort_a = sf_of env sigma a in + PApp(Product (sort_a,sort_b), + [pa;pb]),(Int.Set.union sa sb) | Rel i -> PVar i,Int.Set.singleton i | _ -> - let pf = decompose_term env sigma c in - PApp (pf,[]),Int.Set.empty + let pf = decompose_term env sigma c in + PApp (pf,[]),Int.Set.empty let non_trivial = function PVar _ -> false @@ -132,52 +132,52 @@ let non_trivial = function let patterns_of_constr env sigma nrels term= let f,args= try destApp sigma (whd_delta env sigma term) with DestKO -> raise Not_found in - if is_global sigma (Lazy.force _eq) f && Int.equal (Array.length args) 3 - then - let patt1,rels1 = pattern_of_constr env sigma args.(1) - and patt2,rels2 = pattern_of_constr env sigma args.(2) in - let valid1 = - if not (Int.equal (Int.Set.cardinal rels1) nrels) then Creates_variables - else if non_trivial patt1 then Normal - else Trivial (EConstr.to_constr sigma args.(0)) - and valid2 = - if not (Int.equal (Int.Set.cardinal rels2) nrels) then Creates_variables - else if non_trivial patt2 then Normal - else Trivial (EConstr.to_constr sigma args.(0)) in - if valid1 != Creates_variables - || valid2 != Creates_variables then - nrels,valid1,patt1,valid2,patt2 - else raise Not_found - else raise Not_found + if is_global sigma (Lazy.force _eq) f && Int.equal (Array.length args) 3 + then + let patt1,rels1 = pattern_of_constr env sigma args.(1) + and patt2,rels2 = pattern_of_constr env sigma args.(2) in + let valid1 = + if not (Int.equal (Int.Set.cardinal rels1) nrels) then Creates_variables + else if non_trivial patt1 then Normal + else Trivial (EConstr.to_constr sigma args.(0)) + and valid2 = + if not (Int.equal (Int.Set.cardinal rels2) nrels) then Creates_variables + else if non_trivial patt2 then Normal + else Trivial (EConstr.to_constr sigma args.(0)) in + if valid1 != Creates_variables + || valid2 != Creates_variables then + nrels,valid1,patt1,valid2,patt2 + else raise Not_found + else raise Not_found let rec quantified_atom_of_constr env sigma nrels term = match EConstr.kind sigma (whd_delta env sigma term) with Prod (id,atom,ff) -> - if is_global sigma (Lazy.force _False) ff then - let patts=patterns_of_constr env sigma nrels atom in - `Nrule patts - else + if is_global sigma (Lazy.force _False) ff then + let patts=patterns_of_constr env sigma nrels atom in + `Nrule patts + else quantified_atom_of_constr (EConstr.push_rel (RelDecl.LocalAssum (id,atom)) env) sigma (succ nrels) ff - | _ -> - let patts=patterns_of_constr env sigma nrels term in - `Rule patts + | _ -> + let patts=patterns_of_constr env sigma nrels term in + `Rule patts let litteral_of_constr env sigma term= match EConstr.kind sigma (whd_delta env sigma term) with | Prod (id,atom,ff) -> - if is_global sigma (Lazy.force _False) ff then - match (atom_of_constr env sigma atom) with - `Eq(t,a,b) -> `Neq(t,a,b) - | `Other(p) -> `Nother(p) - else - begin - try + if is_global sigma (Lazy.force _False) ff then + match (atom_of_constr env sigma atom) with + `Eq(t,a,b) -> `Neq(t,a,b) + | `Other(p) -> `Nother(p) + else + begin + try quantified_atom_of_constr (EConstr.push_rel (RelDecl.LocalAssum (id,atom)) env) sigma 1 ff - with Not_found -> - `Other (decompose_term env sigma term) - end + with Not_found -> + `Other (decompose_term env sigma term) + end | _ -> - atom_of_constr env sigma term + atom_of_constr env sigma term (* store all equalities from the context *) @@ -191,38 +191,38 @@ let make_prb gls depth additionnal_terms = let neg_hyps =ref [] in List.iter (fun c -> - let t = decompose_term env sigma c in - ignore (add_term state t)) additionnal_terms; + let t = decompose_term env sigma c in + ignore (add_term state t)) additionnal_terms; List.iter (fun decl -> let id = NamedDecl.get_id decl in - begin - let cid=Constr.mkVar id in - match litteral_of_constr env sigma (NamedDecl.get_type decl) with - `Eq (t,a,b) -> add_equality state cid a b - | `Neq (t,a,b) -> add_disequality state (Hyp cid) a b - | `Other ph -> - List.iter - (fun (cidn,nh) -> - add_disequality state (HeqnH (cid,cidn)) ph nh) - !neg_hyps; - pos_hyps:=(cid,ph):: !pos_hyps - | `Nother nh -> - List.iter - (fun (cidp,ph) -> - add_disequality state (HeqnH (cidp,cid)) ph nh) - !pos_hyps; - neg_hyps:=(cid,nh):: !neg_hyps - | `Rule patts -> add_quant state id true patts - | `Nrule patts -> add_quant state id false patts - end) (Proofview.Goal.hyps gls); + begin + let cid=Constr.mkVar id in + match litteral_of_constr env sigma (NamedDecl.get_type decl) with + `Eq (t,a,b) -> add_equality state cid a b + | `Neq (t,a,b) -> add_disequality state (Hyp cid) a b + | `Other ph -> + List.iter + (fun (cidn,nh) -> + add_disequality state (HeqnH (cid,cidn)) ph nh) + !neg_hyps; + pos_hyps:=(cid,ph):: !pos_hyps + | `Nother nh -> + List.iter + (fun (cidp,ph) -> + add_disequality state (HeqnH (cidp,cid)) ph nh) + !pos_hyps; + neg_hyps:=(cid,nh):: !neg_hyps + | `Rule patts -> add_quant state id true patts + | `Nrule patts -> add_quant state id false patts + end) (Proofview.Goal.hyps gls); begin match atom_of_constr env sigma (pf_concl gls) with - `Eq (t,a,b) -> add_disequality state Goal a b - | `Other g -> - List.iter - (fun (idp,ph) -> - add_disequality state (HeqG idp) ph g) !pos_hyps + `Eq (t,a,b) -> add_disequality state Goal a b + | `Other g -> + List.iter + (fun (idp,ph) -> + add_disequality state (HeqG idp) ph g) !pos_hyps end; state @@ -275,7 +275,7 @@ let assert_before n c = let refresh_type env evm ty = Evarsolve.refresh_universes ~status:Evd.univ_flexible ~refreshset:true - (Some false) env evm ty + (Some false) env evm ty let refresh_universes ty k = Proofview.Goal.enter begin fun gl -> @@ -295,60 +295,60 @@ let rec proof_tac p : unit Proofview.tactic = Ax c -> exact_check (EConstr.of_constr c) | SymAx c -> let c = EConstr.of_constr c in - let l=constr_of_term p.p_lhs and - r=constr_of_term p.p_rhs in - refresh_universes (type_of l) (fun typ -> + let l=constr_of_term p.p_lhs and + r=constr_of_term p.p_rhs in + refresh_universes (type_of l) (fun typ -> app_global _sym_eq [|typ;r;l;c|] exact_check) | Refl t -> - let lr = constr_of_term t in - refresh_universes (type_of lr) (fun typ -> + let lr = constr_of_term t in + refresh_universes (type_of lr) (fun typ -> app_global _refl_equal [|typ;constr_of_term t|] exact_check) | Trans (p1,p2)-> - let t1 = constr_of_term p1.p_lhs and - t2 = constr_of_term p1.p_rhs and - t3 = constr_of_term p2.p_rhs in - refresh_universes (type_of t2) (fun typ -> - let prf = app_global_with_holes _trans_eq [|typ;t1;t2;t3;|] 2 in + let t1 = constr_of_term p1.p_lhs and + t2 = constr_of_term p1.p_rhs and + t3 = constr_of_term p2.p_rhs in + refresh_universes (type_of t2) (fun typ -> + let prf = app_global_with_holes _trans_eq [|typ;t1;t2;t3;|] 2 in Tacticals.New.tclTHENS prf [(proof_tac p1);(proof_tac p2)]) | Congr (p1,p2)-> - let tf1=constr_of_term p1.p_lhs - and tx1=constr_of_term p2.p_lhs - and tf2=constr_of_term p1.p_rhs - and tx2=constr_of_term p2.p_rhs in - refresh_universes (type_of tf1) (fun typf -> - refresh_universes (type_of tx1) (fun typx -> - refresh_universes (type_of (mkApp (tf1,[|tx1|]))) (fun typfx -> + let tf1=constr_of_term p1.p_lhs + and tx1=constr_of_term p2.p_lhs + and tf2=constr_of_term p1.p_rhs + and tx2=constr_of_term p2.p_rhs in + refresh_universes (type_of tf1) (fun typf -> + refresh_universes (type_of tx1) (fun typx -> + refresh_universes (type_of (mkApp (tf1,[|tx1|]))) (fun typfx -> let id = Tacmach.New.pf_get_new_id (Id.of_string "f") gl in let appx1 = mkLambda(make_annot (Name id) Sorts.Relevant,typf,mkApp(mkRel 1,[|tx1|])) in - let lemma1 = app_global_with_holes _f_equal [|typf;typfx;appx1;tf1;tf2|] 1 in - let lemma2 = app_global_with_holes _f_equal [|typx;typfx;tf2;tx1;tx2|] 1 in - let prf = - app_global_with_holes _trans_eq - [|typfx; - mkApp(tf1,[|tx1|]); - mkApp(tf2,[|tx1|]); - mkApp(tf2,[|tx2|])|] 2 in - Tacticals.New.tclTHENS prf - [Tacticals.New.tclTHEN lemma1 (proof_tac p1); - Tacticals.New.tclFIRST - [Tacticals.New.tclTHEN lemma2 (proof_tac p2); - reflexivity; + let lemma1 = app_global_with_holes _f_equal [|typf;typfx;appx1;tf1;tf2|] 1 in + let lemma2 = app_global_with_holes _f_equal [|typx;typfx;tf2;tx1;tx2|] 1 in + let prf = + app_global_with_holes _trans_eq + [|typfx; + mkApp(tf1,[|tx1|]); + mkApp(tf2,[|tx1|]); + mkApp(tf2,[|tx2|])|] 2 in + Tacticals.New.tclTHENS prf + [Tacticals.New.tclTHEN lemma1 (proof_tac p1); + Tacticals.New.tclFIRST + [Tacticals.New.tclTHEN lemma2 (proof_tac p2); + reflexivity; Tacticals.New.tclZEROMSG - (Pp.str - "I don't know how to handle dependent equality")]]))) + (Pp.str + "I don't know how to handle dependent equality")]]))) | Inject (prf,cstr,nargs,argind) -> - let ti=constr_of_term prf.p_lhs in - let tj=constr_of_term prf.p_rhs in - let default=constr_of_term p.p_lhs in - let special=mkRel (1+nargs-argind) in - refresh_universes (type_of ti) (fun intype -> + let ti=constr_of_term prf.p_lhs in + let tj=constr_of_term prf.p_rhs in + let default=constr_of_term p.p_lhs in + let special=mkRel (1+nargs-argind) in + refresh_universes (type_of ti) (fun intype -> refresh_universes (type_of default) (fun outtype -> let sigma, proj = build_projection intype cstr special default gl in - let injt= + let injt= app_global_with_holes _f_equal [|intype;outtype;proj;ti;tj|] 1 in - Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (Tacticals.New.tclTHEN injt (proof_tac prf)))) with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e end @@ -371,7 +371,7 @@ let refine_exact_check c = Proofview.tclTHEN (Proofview.Unsafe.tclEVARS evm) (exact_check c) end -let convert_to_goal_tac c t1 t2 p = +let convert_to_goal_tac c t1 t2 p = Proofview.Goal.enter begin fun gl -> let tt1=constr_of_term t1 and tt2=constr_of_term t2 in let k sort = @@ -381,7 +381,7 @@ let convert_to_goal_tac c t1 t2 p = let identity=mkLambda (make_annot (Name x) Sorts.Relevant,sort,mkRel 1) in let endt = app_global _eq_rect [|sort;tt1;identity;c;tt2;mkVar e|] in Tacticals.New.tclTHENS (neweq (assert_before (Name e))) - [proof_tac p; endt refine_exact_check] + [proof_tac p; endt refine_exact_check] in refresh_universes (Tacmach.New.pf_unsafe_type_of gl tt2) k end @@ -405,7 +405,7 @@ let discriminate_tac cstru p = let hid = Tacmach.New.pf_get_new_id (Id.of_string "Heq") gl in let neweq=app_global _eq [|intype;lhs;rhs|] in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS evm) - (Tacticals.New.tclTHENS (neweq (assert_before (Name hid))) + (Tacticals.New.tclTHENS (neweq (assert_before (Name hid))) [proof_tac p; Equality.discrHyp hid]) end @@ -430,13 +430,13 @@ let cc_tactic depth additionnal_terms = match sol with None -> Tacticals.New.tclFAIL 0 (str "congruence failed") | Some reason -> - debug (fun () -> Pp.str "Goal solved, generating proof ..."); - match reason with - Discrimination (i,ipac,j,jpac) -> + debug (fun () -> Pp.str "Goal solved, generating proof ..."); + match reason with + Discrimination (i,ipac,j,jpac) -> let p=build_proof (Tacmach.New.pf_env gl) sigma uf (`Discr (i,ipac,j,jpac)) in - let cstr=(get_constructor_info uf ipac.cnode).ci_constr in - discriminate_tac cstr p - | Incomplete -> + let cstr=(get_constructor_info uf ipac.cnode).ci_constr in + discriminate_tac cstr p + | Incomplete -> let open Glob_term in let env = Proofview.Goal.env gl in let terms_to_complete = List.map (build_term_to_complete uf) (epsilons uf) in @@ -456,20 +456,20 @@ let cc_tactic depth additionnal_terms = end ++ str " replacing metavariables by arbitrary terms.") in Tacticals.New.tclFAIL 0 msg - | Contradiction dis -> + | Contradiction dis -> let env = Proofview.Goal.env gl in let p=build_proof env sigma uf (`Prove (dis.lhs,dis.rhs)) in - let ta=term uf dis.lhs and tb=term uf dis.rhs in - match dis.rule with - Goal -> proof_tac p - | Hyp id -> refute_tac (EConstr.of_constr id) ta tb p - | HeqG id -> + let ta=term uf dis.lhs and tb=term uf dis.rhs in + match dis.rule with + Goal -> proof_tac p + | Hyp id -> refute_tac (EConstr.of_constr id) ta tb p + | HeqG id -> let id = EConstr.of_constr id in - convert_to_goal_tac id ta tb p - | HeqnH (ida,idb) -> + convert_to_goal_tac id ta tb p + | HeqnH (ida,idb) -> let ida = EConstr.of_constr ida in let idb = EConstr.of_constr idb in - convert_to_hyp_tac ida ta idb tb p + convert_to_hyp_tac ida ta idb tb p end let cc_fail = @@ -509,21 +509,21 @@ let f_equal = let cut_eq c1 c2 = try (* type_of can raise an exception *) Tacticals.New.tclTHENS - (mk_eq _eq c1 c2 Tactics.cut) - [Proofview.tclUNIT ();Tacticals.New.tclTRY ((app_global _refl_equal [||]) apply)] + (mk_eq _eq c1 c2 Tactics.cut) + [Proofview.tclUNIT ();Tacticals.New.tclTRY ((app_global _refl_equal [||]) apply)] with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e in Proofview.tclORELSE begin match EConstr.kind sigma concl with | App (r,[|_;t;t'|]) when is_global sigma (Lazy.force _eq) r -> - begin match EConstr.kind sigma t, EConstr.kind sigma t' with - | App (f,v), App (f',v') when Int.equal (Array.length v) (Array.length v') -> - let rec cuts i = - if i < 0 then Tacticals.New.tclTRY (congruence_tac 1000 []) - else Tacticals.New.tclTHENFIRST (cut_eq v.(i) v'.(i)) (cuts (i-1)) - in cuts (Array.length v - 1) - | _ -> Proofview.tclUNIT () - end + begin match EConstr.kind sigma t, EConstr.kind sigma t' with + | App (f,v), App (f',v') when Int.equal (Array.length v) (Array.length v') -> + let rec cuts i = + if i < 0 then Tacticals.New.tclTRY (congruence_tac 1000 []) + else Tacticals.New.tclTHENFIRST (cut_eq v.(i) v'.(i)) (cuts (i-1)) + in cuts (Array.length v - 1) + | _ -> Proofview.tclUNIT () + end | _ -> Proofview.tclUNIT () end begin function (e, info) -> match e with diff --git a/plugins/extraction/common.ml b/plugins/extraction/common.ml index 1c325a8d3a..2f3f42c5f6 100644 --- a/plugins/extraction/common.ml +++ b/plugins/extraction/common.ml @@ -164,9 +164,9 @@ let rename_tvars avoid l = let rec rename avoid = function | [] -> [],avoid | id :: idl -> - let id = rename_id (lowercase_id id) avoid in - let idl, avoid = rename (Id.Set.add id avoid) idl in - (id :: idl, avoid) in + let id = rename_id (lowercase_id id) avoid in + let idl, avoid = rename (Id.Set.add id avoid) idl in + (id :: idl, avoid) in fst (rename avoid l) let push_vars ids (db,avoid) = @@ -271,8 +271,8 @@ let params_ren_add, params_ren_mem = *) type visible_layer = { mp : ModPath.t; - params : ModPath.t list; - mutable content : Label.t KMap.t; } + params : ModPath.t list; + mutable content : Label.t KMap.t; } let pop_visible, push_visible, get_visible = let vis = ref [] in @@ -281,10 +281,10 @@ let pop_visible, push_visible, get_visible = match !vis with | [] -> assert false | v :: vl -> - vis := vl; - (* we save the 1st-level-content of MPfile for later use *) - if get_phase () == Impl && modular () && is_modfile v.mp - then add_mpfiles_content v.mp v.content + vis := vl; + (* we save the 1st-level-content of MPfile for later use *) + if get_phase () == Impl && modular () && is_modfile v.mp + then add_mpfiles_content v.mp v.content and push mp mps = vis := { mp = mp; params = mps; content = KMap.empty } :: !vis and get () = !vis @@ -356,9 +356,9 @@ let modfstlev_rename = with Not_found -> let s = ascii_of_id id in if is_lower s || begins_with_CoqXX s then - (add_index id 1; "Coq_"^s) + (add_index id 1; "Coq_"^s) else - (add_index id 0; s) + (add_index id 0; s) (*s Creating renaming for a [module_path] : first, the real function ... *) @@ -448,13 +448,13 @@ let visible_clash mp0 ks = | [] -> false | v :: _ when ModPath.equal v.mp mp0 -> false | v :: vis -> - let b = KMap.mem ks v.content in - if b && not (is_mp_bound mp0) then true - else begin - if b then params_ren_add mp0; - if params_lookup mp0 ks v.params then false - else clash vis - end + let b = KMap.mem ks v.content in + if b && not (is_mp_bound mp0) then true + else begin + if b then params_ren_add mp0; + if params_lookup mp0 ks v.params then false + else clash vis + end in clash (get_visible ()) (* Same, but with verbose output (and mp0 shouldn't be a MPbound) *) @@ -464,10 +464,10 @@ let visible_clash_dbg mp0 ks = | [] -> None | v :: _ when ModPath.equal v.mp mp0 -> None | v :: vis -> - try Some (v.mp,KMap.find ks v.content) - with Not_found -> - if params_lookup mp0 ks v.params then None - else clash vis + try Some (v.mp,KMap.find ks v.content) + with Not_found -> + if params_lookup mp0 ks v.params then None + else clash vis in clash (get_visible ()) (* After the 1st pass, we can decide which modules will be opened initially *) @@ -483,9 +483,9 @@ let opened_libraries () = after such an open, there's no unambiguous way to refer to objects of B. *) let to_open = List.filter - (fun mp -> - not (List.exists (fun k -> KMap.mem k (get_mpfiles_content mp)) used_ks)) - used_files + (fun mp -> + not (List.exists (fun k -> KMap.mem k (get_mpfiles_content mp)) used_ks)) + used_files in mpfiles_clear (); List.iter mpfiles_add to_open; @@ -549,18 +549,18 @@ let pp_ocaml_extern k base rls = match rls with | [] -> assert false | base_s :: rls' -> if (not (modular ())) (* Pseudo qualification with "" *) - || (List.is_empty rls') (* Case of a file A.v used as a module later *) - || (not (mpfiles_mem base)) (* Module not opened *) - || (mpfiles_clash base (fstlev_ks k rls')) (* Conflict in opened files *) - || (visible_clash base (fstlev_ks k rls')) (* Local conflict *) + || (List.is_empty rls') (* Case of a file A.v used as a module later *) + || (not (mpfiles_mem base)) (* Module not opened *) + || (mpfiles_clash base (fstlev_ks k rls')) (* Conflict in opened files *) + || (visible_clash base (fstlev_ks k rls')) (* Local conflict *) then - (* We need to fully qualify. Last clash situation is unsupported *) - match visible_clash_dbg base (Mod,base_s) with - | None -> dottify rls - | Some (mp,l) -> error_module_clash base (MPdot (mp,l)) + (* We need to fully qualify. Last clash situation is unsupported *) + match visible_clash_dbg base (Mod,base_s) with + | None -> dottify rls + | Some (mp,l) -> error_module_clash base (MPdot (mp,l)) else - (* Standard situation : object in an opened file *) - dottify rls' + (* Standard situation : object in an opened file *) + dottify rls' (* [pp_ocaml_gen] : choosing between [pp_ocaml_local] or [pp_ocaml_extern] *) @@ -568,9 +568,9 @@ let pp_ocaml_gen k mp rls olab = match common_prefix_from_list mp (get_visible_mps ()) with | Some prefix -> pp_ocaml_local k prefix mp rls olab | None -> - let base = base_mp mp in - if is_mp_bound base then pp_ocaml_bound base rls - else pp_ocaml_extern k base rls + let base = base_mp mp in + if is_mp_bound base then pp_ocaml_bound base rls + else pp_ocaml_extern k base rls (* For Haskell, things are simpler: we have removed (almost) all structures *) @@ -607,9 +607,9 @@ let pp_module mp = match mp with | MPdot (mp0,l) when ModPath.equal mp0 (top_visible_mp ()) -> (* simplest situation: definition of mp (or use in the same context) *) - (* we update the visible environment *) - let s = List.hd ls in - add_visible (Mod,s) l; s + (* we update the visible environment *) + let s = List.hd ls in + add_visible (Mod,s) l; s | _ -> pp_ocaml_gen Mod mp (List.rev ls) None (** Special hack for constants of type Ascii.ascii : if an diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index 551dbdc6fb..35110552ab 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -147,8 +147,8 @@ let check_fix env sg cb i = | Def lbody -> (match EConstr.kind sg (get_body lbody) with | Fix ((_,j),recd) when Int.equal i j -> check_arity env cb; (true,recd) - | CoFix (j,recd) when Int.equal i j -> check_arity env cb; (false,recd) - | _ -> raise Impossible) + | CoFix (j,recd) when Int.equal i j -> check_arity env cb; (false,recd) + | _ -> raise Impossible) | Undef _ | OpaqueDef _ | Primitive _ -> raise Impossible let prec_declaration_equal sg (na1, ca1, ta1) (na2, ca2, ta2) = @@ -166,14 +166,14 @@ let factor_fix env sg l cb msb = let labels = Array.make n l in List.iteri (fun j -> - function - | (l,SFBconst cb') -> + function + | (l,SFBconst cb') -> let check' = check_fix env sg cb' (j+1) in if not ((fst check : bool) == (fst check') && prec_declaration_equal sg (snd check) (snd check')) - then raise Impossible; - labels.(j+1) <- l; - | _ -> raise Impossible) msb'; + then raise Impossible; + labels.(j+1) <- l; + | _ -> raise Impossible) msb'; labels, recd, msb'' end @@ -256,8 +256,8 @@ and extract_mexpr_spec env mp1 (me_struct_o,me_alg) = match me_alg with let sg = Evd.from_env env in (match extract_with_type env' sg (EConstr.of_constr c) with (* cb may contain some kn *) - | None -> mt - | Some (vl,typ) -> + | None -> mt + | Some (vl,typ) -> type_iter_references Visit.add_ref typ; MTwith(mt,ML_With_type(idl,vl,typ))) | MEwith(me',WithMod(idl,mp))-> @@ -271,8 +271,8 @@ and extract_mexpr_spec env mp1 (me_struct_o,me_alg) = match me_alg with and extract_mexpression_spec env mp1 (me_struct,me_alg) = match me_alg with | MoreFunctor (mbid, mtb, me_alg') -> let me_struct' = match me_struct with - | MoreFunctor (mbid',_,me') when MBId.equal mbid' mbid -> me' - | _ -> assert false + | MoreFunctor (mbid',_,me') when MBId.equal mbid' mbid -> me' + | _ -> assert false in let mp = MPbound mbid in let env' = Modops.add_module_type mp mtb env in @@ -288,7 +288,7 @@ and extract_msignature_spec env mp1 reso = function let mp = MPbound mbid in let env' = Modops.add_module_type mp mtb env in MTfunsig (mbid, extract_mbody_spec env mp mtb, - extract_msignature_spec env' mp1 reso me) + extract_msignature_spec env' mp1 reso me) and extract_mbody_spec : 'a. _ -> _ -> 'a generic_module_body -> _ = fun env mp mb -> match mb.mod_type_alg with @@ -308,38 +308,38 @@ let rec extract_structure env mp reso ~all = function (try let sg = Evd.from_env env in let vl,recd,struc = factor_fix env sg l cb struc in - let vc = Array.map (make_cst reso mp) vl in - let ms = extract_structure env mp reso ~all struc in - let b = Array.exists Visit.needed_cst vc in - if all || b then + let vc = Array.map (make_cst reso mp) vl in + let ms = extract_structure env mp reso ~all struc in + let b = Array.exists Visit.needed_cst vc in + if all || b then let d = extract_fixpoint env sg vc recd in - if (not b) && (logical_decl d) then ms - else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end - else ms + if (not b) && (logical_decl d) then ms + else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end + else ms with Impossible -> - let ms = extract_structure env mp reso ~all struc in - let c = make_cst reso mp l in - let b = Visit.needed_cst c in - if all || b then - let d = extract_constant env c cb in - if (not b) && (logical_decl d) then ms - else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end - else ms) + let ms = extract_structure env mp reso ~all struc in + let c = make_cst reso mp l in + let b = Visit.needed_cst c in + if all || b then + let d = extract_constant env c cb in + if (not b) && (logical_decl d) then ms + else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end + else ms) | (l,SFBmind mib) :: struc -> let ms = extract_structure env mp reso ~all struc in let mind = make_mind reso mp l in let b = Visit.needed_ind mind in if all || b then - let d = Dind (mind, extract_inductive env mind) in - if (not b) && (logical_decl d) then ms - else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end + let d = Dind (mind, extract_inductive env mind) in + if (not b) && (logical_decl d) then ms + else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end else ms | (l,SFBmodule mb) :: struc -> let ms = extract_structure env mp reso ~all struc in let mp = MPdot (mp,l) in let all' = all || Visit.needed_mp_all mp in if all' || Visit.needed_mp mp then - (l,SEmodule (extract_module env mp ~all:all' mb)) :: ms + (l,SEmodule (extract_module env mp ~all:all' mb)) :: ms else ms | (l,SFBmodtype mtb) :: struc -> let ms = extract_structure env mp reso ~all struc in @@ -363,7 +363,7 @@ and extract_mexpr env mp = function Visit.add_mp_all mp; Miniml.MEident mp | MEapply (me, arg) -> Miniml.MEapply (extract_mexpr env mp me, - extract_mexpr env mp (MEident arg)) + extract_mexpr env mp (MEident arg)) and extract_mexpression env mp = function | NoFunctor me -> extract_mexpr env mp me @@ -373,7 +373,7 @@ and extract_mexpression env mp = function Miniml.MEfunctor (mbid, extract_mbody_spec env mp1 mtb, - extract_mexpression env' mp me) + extract_mexpression env' mp me) and extract_msignature env mp reso ~all = function | NoFunctor struc -> @@ -385,7 +385,7 @@ and extract_msignature env mp reso ~all = function Miniml.MEfunctor (mbid, extract_mbody_spec env mp1 mtb, - extract_msignature env' mp reso ~all me) + extract_msignature env' mp reso ~all me) and extract_module env mp ~all mb = (* A module has an empty [mod_expr] when : @@ -447,19 +447,19 @@ let mono_filename f = match f with | None -> None, None, default_id | Some f -> - let f = - if Filename.check_suffix f d.file_suffix then - Filename.chop_suffix f d.file_suffix - else f - in - let id = - if lang () != Haskell then default_id - else + let f = + if Filename.check_suffix f d.file_suffix then + Filename.chop_suffix f d.file_suffix + else f + in + let id = + if lang () != Haskell then default_id + else try Id.of_string (Filename.basename f) - with UserError _ -> + with UserError _ -> user_err Pp.(str "Extraction: provided filename is not a valid identifier") - in - Some (f^d.file_suffix), Option.map ((^) f) d.sig_suffix, id + in + Some (f^d.file_suffix), Option.map ((^) f) d.sig_suffix, id (* Builds a suitable filename from a module id *) @@ -494,8 +494,8 @@ let formatter dry file = if dry then Format.make_formatter (fun _ _ _ -> ()) (fun _ -> ()) else match file with - | Some f -> Topfmt.with_output_to f - | None -> Format.formatter_of_buffer buf + | Some f -> Topfmt.with_output_to f + | None -> Format.formatter_of_buffer buf in (* XXX: Fixme, this shouldn't depend on Topfmt *) (* We never want to see ellipsis ... in extracted code *) @@ -554,14 +554,14 @@ let print_structure_to_file (fn,si,mo) dry struc = let cout = open_out si in let ft = formatter false (Some cout) in begin try - set_phase Intf; - pp_with ft (d.sig_preamble mo comment opened unsafe_needs); - pp_with ft (d.pp_sig (signature_of_structure struc)); + set_phase Intf; + pp_with ft (d.sig_preamble mo comment opened unsafe_needs); + pp_with ft (d.pp_sig (signature_of_structure struc)); Format.pp_print_flush ft (); - close_out cout; + close_out cout; with reraise -> Format.pp_print_flush ft (); - close_out cout; raise reraise + close_out cout; raise reraise end; info_file si) (if dry then None else si); @@ -606,9 +606,9 @@ let rec locate_ref = function in match mpo, ro with | None, None -> Nametab.error_global_not_found qid - | None, Some r -> let refs,mps = locate_ref l in r::refs,mps - | Some mp, None -> let refs,mps = locate_ref l in refs,mp::mps - | Some mp, Some r -> + | None, Some r -> let refs,mps = locate_ref l in r::refs,mps + | Some mp, None -> let refs,mps = locate_ref l in refs,mp::mps + | Some mp, Some r -> warning_ambiguous_name (qid,mp,r); let refs,mps = locate_ref l in refs,mp::mps @@ -637,7 +637,7 @@ let separate_extraction lr = warns (); let print = function | (MPfile dir as mp, sel) as e -> - print_structure_to_file (module_filename mp) false [e] + print_structure_to_file (module_filename mp) false [e] | _ -> assert false in List.iter print struc; @@ -686,8 +686,8 @@ let extraction_library is_rec m = warns (); let print = function | (MPfile dir as mp, sel) as e -> - let dry = not is_rec && not (DirPath.equal dir dir_m) in - print_structure_to_file (module_filename mp) dry [e] + let dry = not is_rec && not (DirPath.equal dir dir_m) in + print_structure_to_file (module_filename mp) dry [e] | _ -> assert false in List.iter print struc; diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index 04f5b66241..a4469b7ec1 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -243,8 +243,8 @@ let parse_ind_args si args relmax = | Kill _ :: s -> parse (i+1) j s | Keep :: s -> (match Constr.kind args.(i-1) with - | Rel k -> Int.Map.add (relmax+1-k) j (parse (i+1) (j+1) s) - | _ -> parse (i+1) (j+1) s) + | Rel k -> Int.Map.add (relmax+1-k) j (parse (i+1) (j+1) s) + | _ -> parse (i+1) (j+1) s) in parse 1 1 si (*S Extraction of a type. *) @@ -265,31 +265,31 @@ let rec extract_type env sg db j c args = extract_type env sg db j d (Array.to_list args' @ args) | Lambda (_,_,d) -> (match args with - | [] -> assert false (* A lambda cannot be a type. *) + | [] -> assert false (* A lambda cannot be a type. *) | a :: args -> extract_type env sg db j (EConstr.Vars.subst1 a d) args) | Prod (n,t,d) -> assert (List.is_empty args); let env' = push_rel_assum (n,t) env in (match flag_of_type env sg t with | (Info, Default) -> - (* Standard case: two [extract_type] ... *) + (* Standard case: two [extract_type] ... *) let mld = extract_type env' sg (0::db) j d [] in - (match expand env mld with - | Tdummy d -> Tdummy d + (match expand env mld with + | Tdummy d -> Tdummy d | _ -> Tarr (extract_type env sg db 0 t [], mld)) - | (Info, TypeScheme) when j > 0 -> - (* A new type var. *) + | (Info, TypeScheme) when j > 0 -> + (* A new type var. *) let mld = extract_type env' sg (j::db) (j+1) d [] in - (match expand env mld with - | Tdummy d -> Tdummy d - | _ -> Tarr (Tdummy Ktype, mld)) - | _,lvl -> + (match expand env mld with + | Tdummy d -> Tdummy d + | _ -> Tarr (Tdummy Ktype, mld)) + | _,lvl -> let mld = extract_type env' sg (0::db) j d [] in - (match expand env mld with - | Tdummy d -> Tdummy d - | _ -> - let reason = if lvl == TypeScheme then Ktype else Kprop in - Tarr (Tdummy reason, mld))) + (match expand env mld with + | Tdummy d -> Tdummy d + | _ -> + let reason = if lvl == TypeScheme then Ktype else Kprop in + Tarr (Tdummy reason, mld))) | Sort _ -> Tdummy Ktype (* The two logical cases. *) | _ when sort_of env sg (applistc c args) == InProp -> Tdummy Kprop | Rel n -> @@ -297,16 +297,16 @@ let rec extract_type env sg db j c args = | LocalDef (_,t,_) -> extract_type env sg db j (EConstr.Vars.lift n t) args | _ -> - (* Asks [db] a translation for [n]. *) - if n > List.length db then Tunknown - else let n' = List.nth db (n-1) in - if Int.equal n' 0 then Tunknown else Tvar n') + (* Asks [db] a translation for [n]. *) + if n > List.length db then Tunknown + else let n' = List.nth db (n-1) in + if Int.equal n' 0 then Tunknown else Tvar n') | Const (kn,u) -> let r = GlobRef.ConstRef kn in let typ = type_of env sg (EConstr.mkConstU (kn,u)) in (match flag_of_type env sg typ with - | (Logic,_) -> assert false (* Cf. logical cases above *) - | (Info, TypeScheme) -> + | (Logic,_) -> assert false (* Cf. logical cases above *) + | (Info, TypeScheme) -> let mlt = extract_type_app env sg db (r, type_sign env sg typ) args in (match (lookup_constant kn env).const_body with | Undef _ | OpaqueDef _ | Primitive _ -> mlt @@ -314,18 +314,18 @@ let rec extract_type env sg db j c args = | Def lbody -> let newc = applistc (get_body lbody) args in let mlt' = extract_type env sg db j newc [] in - (* ML type abbreviations interact badly with Coq *) - (* reduction, so [mlt] and [mlt'] might be different: *) - (* The more precise is [mlt'], extracted after reduction *) - (* The shortest is [mlt], which use abbreviations *) - (* If possible, we take [mlt], otherwise [mlt']. *) - if eq_ml_type (expand env mlt) (expand env mlt') then mlt else mlt') - | (Info, Default) -> + (* ML type abbreviations interact badly with Coq *) + (* reduction, so [mlt] and [mlt'] might be different: *) + (* The more precise is [mlt'], extracted after reduction *) + (* The shortest is [mlt], which use abbreviations *) + (* If possible, we take [mlt], otherwise [mlt']. *) + if eq_ml_type (expand env mlt) (expand env mlt') then mlt else mlt') + | (Info, Default) -> (* Not an ML type, for example [(c:forall X, X->X) Type nat] *) (match (lookup_constant kn env).const_body with | Undef _ | OpaqueDef _ | Primitive _ -> Tunknown (* Brutal approx ... *) - | Def lbody -> - (* We try to reduce. *) + | Def lbody -> + (* We try to reduce. *) let newc = applistc (get_body lbody) args in extract_type env sg db j newc [])) | Ind ((kn,i),u) -> @@ -415,15 +415,15 @@ and extract_really_ind env kn mib = (cf Vector and bug #2570) *) let equiv = if lang () != Ocaml || - (not (modular ()) && at_toplevel (MutInd.modpath kn)) || - KerName.equal (MutInd.canonical kn) (MutInd.user kn) + (not (modular ()) && at_toplevel (MutInd.modpath kn)) || + KerName.equal (MutInd.canonical kn) (MutInd.user kn) then - NoEquiv + NoEquiv else - begin - ignore (extract_ind env (MutInd.make1 (MutInd.canonical kn))); - Equiv (MutInd.canonical kn) - end + begin + ignore (extract_ind env (MutInd.make1 (MutInd.canonical kn))); + Equiv (MutInd.canonical kn) + end in (* Everything concerning parameters. *) (* We do that first, since they are common to all the [mib]. *) @@ -435,20 +435,20 @@ and extract_really_ind env kn mib = (* their type var list. *) let packets = Array.mapi - (fun i mip -> + (fun i mip -> let (_,u),_ = UnivGen.fresh_inductive_instance env (kn,i) in - let ar = Inductive.type_of_inductive env ((mib,mip),u) in + let ar = Inductive.type_of_inductive env ((mib,mip),u) in let ar = EConstr.of_constr ar in let info = (fst (flag_of_type env sg ar) = Info) in let s,v = if info then type_sign_vl env sg ar else [],[] in - let t = Array.make (Array.length mip.mind_nf_lc) [] in - { ip_typename = mip.mind_typename; - ip_consnames = mip.mind_consnames; - ip_logical = not info; - ip_sign = s; - ip_vars = v; - ip_types = t }, u) - mib.mind_packets + let t = Array.make (Array.length mip.mind_nf_lc) [] in + { ip_typename = mip.mind_typename; + ip_consnames = mip.mind_consnames; + ip_logical = not info; + ip_sign = s; + ip_vars = v; + ip_types = t }, u) + mib.mind_packets in add_ind kn mib @@ -461,85 +461,85 @@ and extract_really_ind env kn mib = for i = 0 to mib.mind_ntypes - 1 do let p,u = packets.(i) in if not p.ip_logical then - let types = arities_of_constructors env ((kn,i),u) in - for j = 0 to Array.length types - 1 do - let t = snd (decompose_prod_n npar types.(j)) in - let prods,head = dest_prod epar t in - let nprods = List.length prods in + let types = arities_of_constructors env ((kn,i),u) in + for j = 0 to Array.length types - 1 do + let t = snd (decompose_prod_n npar types.(j)) in + let prods,head = dest_prod epar t in + let nprods = List.length prods in let args = match Constr.kind head with | App (f,args) -> args (* [Constr.kind f = Ind ip] *) | _ -> [||] in - let dbmap = parse_ind_args p.ip_sign args (nprods + npar) in - let db = db_from_ind dbmap npar in + let dbmap = parse_ind_args p.ip_sign args (nprods + npar) in + let db = db_from_ind dbmap npar in p.ip_types.(j) <- extract_type_cons epar sg db dbmap (EConstr.of_constr t) (npar+1) - done + done done; (* Third pass: we determine special cases. *) let ind_info = try - let ip = (kn, 0) in + let ip = (kn, 0) in let r = GlobRef.IndRef ip in - if is_custom r then raise (I Standard); + if is_custom r then raise (I Standard); if mib.mind_finite == CoFinite then raise (I Coinductive); - if not (Int.equal mib.mind_ntypes 1) then raise (I Standard); - let p,u = packets.(0) in - if p.ip_logical then raise (I Standard); - if not (Int.equal (Array.length p.ip_types) 1) then raise (I Standard); - let typ = p.ip_types.(0) in - let l = List.filter (fun t -> not (isTdummy (expand env t))) typ in - if not (keep_singleton ()) && - Int.equal (List.length l) 1 && not (type_mem_kn kn (List.hd l)) - then raise (I Singleton); - if List.is_empty l then raise (I Standard); + if not (Int.equal mib.mind_ntypes 1) then raise (I Standard); + let p,u = packets.(0) in + if p.ip_logical then raise (I Standard); + if not (Int.equal (Array.length p.ip_types) 1) then raise (I Standard); + let typ = p.ip_types.(0) in + let l = List.filter (fun t -> not (isTdummy (expand env t))) typ in + if not (keep_singleton ()) && + Int.equal (List.length l) 1 && not (type_mem_kn kn (List.hd l)) + then raise (I Singleton); + if List.is_empty l then raise (I Standard); if mib.mind_record == Declarations.NotRecord then raise (I Standard); - (* Now we're sure it's a record. *) - (* First, we find its field names. *) - let rec names_prod t = match Constr.kind t with + (* Now we're sure it's a record. *) + (* First, we find its field names. *) + let rec names_prod t = match Constr.kind t with | Prod(n,_,t) -> n::(names_prod t) | LetIn(_,_,_,t) -> names_prod t - | Cast(t,_,_) -> names_prod t - | _ -> [] - in - let field_names = - List.skipn mib.mind_nparams (names_prod mip0.mind_user_lc.(0)) in - assert (Int.equal (List.length field_names) (List.length typ)); - let projs = ref Cset.empty in - let mp = MutInd.modpath kn in - let rec select_fields l typs = match l,typs with - | [],[] -> [] - | _::l, typ::typs when isTdummy (expand env typ) -> - select_fields l typs + | Cast(t,_,_) -> names_prod t + | _ -> [] + in + let field_names = + List.skipn mib.mind_nparams (names_prod mip0.mind_user_lc.(0)) in + assert (Int.equal (List.length field_names) (List.length typ)); + let projs = ref Cset.empty in + let mp = MutInd.modpath kn in + let rec select_fields l typs = match l,typs with + | [],[] -> [] + | _::l, typ::typs when isTdummy (expand env typ) -> + select_fields l typs | {binder_name=Anonymous}::l, typ::typs -> - None :: (select_fields l typs) + None :: (select_fields l typs) | {binder_name=Name id}::l, typ::typs -> - let knp = Constant.make2 mp (Label.of_id id) in - (* Is it safe to use [id] for projections [foo.id] ? *) - if List.for_all ((==) Keep) (type2signature env typ) - then projs := Cset.add knp !projs; + let knp = Constant.make2 mp (Label.of_id id) in + (* Is it safe to use [id] for projections [foo.id] ? *) + if List.for_all ((==) Keep) (type2signature env typ) + then projs := Cset.add knp !projs; Some (GlobRef.ConstRef knp) :: (select_fields l typs) - | _ -> assert false - in - let field_glob = select_fields field_names typ - in - (* Is this record officially declared with its projections ? *) - (* If so, we use this information. *) - begin try + | _ -> assert false + in + let field_glob = select_fields field_names typ + in + (* Is this record officially declared with its projections ? *) + (* If so, we use this information. *) + begin try let ty = Inductive.type_of_inductive env ((mib,mip0),u) in let n = nb_default_params env sg (EConstr.of_constr ty) in let check_proj kn = if Cset.mem kn !projs then add_projection n kn ip in - List.iter (Option.iter check_proj) (lookup_projections ip) - with Not_found -> () - end; - Record field_glob + List.iter (Option.iter check_proj) (lookup_projections ip) + with Not_found -> () + end; + Record field_glob with (I info) -> info in let i = {ind_kind = ind_info; - ind_nparams = npar; - ind_packets = Array.map fst packets; - ind_equiv = equiv } + ind_nparams = npar; + ind_packets = Array.map fst packets; + ind_equiv = equiv } in add_ind kn mib i; add_inductive_kind kn i.ind_kind; @@ -622,42 +622,42 @@ let rec extract_term env sg mle mlt c args = | Lambda (n, t, d) -> let id = map_annot id_of_name n in let idna = map_annot Name.mk_name id in - (match args with - | a :: l -> - (* We make as many [LetIn] as possible. *) + (match args with + | a :: l -> + (* We make as many [LetIn] as possible. *) let l' = List.map (EConstr.Vars.lift 1) l in let d' = EConstr.mkLetIn (idna,a,t,applistc d l') in extract_term env sg mle mlt d' [] | [] -> let env' = push_rel_assum (idna, t) env in - let id, a = + let id, a = try check_default env sg t; Id id.binder_name, new_meta() with NotDefault d -> Dummy, Tdummy d - in - let b = new_meta () in - (* If [mlt] cannot be unified with an arrow type, then magic! *) - let magic = needs_magic (mlt, Tarr (a, b)) in + in + let b = new_meta () in + (* If [mlt] cannot be unified with an arrow type, then magic! *) + let magic = needs_magic (mlt, Tarr (a, b)) in let d' = extract_term env' sg (Mlenv.push_type mle a) b d [] in - put_magic_if magic (MLlam (id, d'))) + put_magic_if magic (MLlam (id, d'))) | LetIn (n, c1, t1, c2) -> let id = map_annot id_of_name n in let env' = EConstr.push_rel (LocalDef (map_annot Name.mk_name id, c1, t1)) env in (* We directly push the args inside the [LetIn]. TODO: the opt_let_app flag is supposed to prevent that *) let args' = List.map (EConstr.Vars.lift 1) args in - (try + (try check_default env sg t1; - let a = new_meta () in + let a = new_meta () in let c1' = extract_term env sg mle a c1 [] in - (* The type of [c1'] is generalized and stored in [mle]. *) - let mle' = - if generalizable c1' - then Mlenv.push_gen mle a - else Mlenv.push_type mle a - in + (* The type of [c1'] is generalized and stored in [mle]. *) + let mle' = + if generalizable c1' + then Mlenv.push_gen mle a + else Mlenv.push_type mle a + in MLletin (Id id.binder_name, c1', extract_term env' sg mle' mlt c2 args') - with NotDefault d -> - let mle' = Mlenv.push_std_type mle (Tdummy d) in + with NotDefault d -> + let mle' = Mlenv.push_std_type mle (Tdummy d) in ast_pop (extract_term env' sg mle' mlt c2 args')) | Const (kn,_) -> extract_cst_app env sg mle mlt kn args @@ -667,9 +667,9 @@ let rec extract_term env sg mle mlt c args = let term = Retyping.expand_projection env (Evd.from_env env) p c [] in extract_term env sg mle mlt term args | Rel n -> - (* As soon as the expected [mlt] for the head is known, *) - (* we unify it with an fresh copy of the stored type of [Rel n]. *) - let extract_rel mlt = put_magic (mlt, Mlenv.get mle n) (MLrel n) + (* As soon as the expected [mlt] for the head is known, *) + (* we unify it with an fresh copy of the stored type of [Rel n]. *) + let extract_rel mlt = put_magic (mlt, Mlenv.get mle n) (MLrel n) in extract_app env sg mle mlt extract_rel args | Case ({ci_ind=ip},_,c0,br) -> extract_app env sg mle mlt (extract_case env sg mle (ip,c0,br)) args @@ -816,8 +816,8 @@ and extract_cons_app env sg mle mlt (((kn,i) as ip,j) as cp) args = put_magic_if magic1 (List.hd mla) (* assert (List.length mla = 1) *) else let typeargs = match snd (type_decomp type_cons) with - | Tglob (_,l) -> List.map type_simpl l - | _ -> assert false + | Tglob (_,l) -> List.map type_simpl l + | _ -> assert false in let typ = Tglob(GlobRef.IndRef ip, typeargs) in put_magic_if magic1 (MLcons (typ, GlobRef.ConstructRef cp, mla)) @@ -854,14 +854,14 @@ and extract_case env sg mle ((kn,i) as ip,c,br) mlt = (* The only non-informative case: [c] is of sort [Prop] *) if (sort_of env sg t) == InProp then begin - add_recursors env kn; (* May have passed unseen if logical ... *) - (* Logical singleton case: *) - (* [match c with C i j k -> t] becomes [t'] *) - assert (Int.equal br_size 1); - let s = iterate (fun l -> Kill Kprop :: l) ni.(0) [] in - let mlt = iterate (fun t -> Tarr (Tdummy Kprop, t)) ni.(0) mlt in + add_recursors env kn; (* May have passed unseen if logical ... *) + (* Logical singleton case: *) + (* [match c with C i j k -> t] becomes [t'] *) + assert (Int.equal br_size 1); + let s = iterate (fun l -> Kill Kprop :: l) ni.(0) [] in + let mlt = iterate (fun t -> Tarr (Tdummy Kprop, t)) ni.(0) mlt in let e = extract_maybe_term env sg mle mlt br.(0) in - snd (case_expunge s e) + snd (case_expunge s e) end else let mi = extract_ind env kn in @@ -873,32 +873,32 @@ and extract_case env sg mle ((kn,i) as ip,c,br) mlt = (* The extraction of each branch. *) let extract_branch i = let r = GlobRef.ConstructRef (ip,i+1) in - (* The types of the arguments of the corresponding constructor. *) - let f t = type_subst_vect metas (expand env t) in - let l = List.map f oi.ip_types.(i) in - (* the corresponding signature *) - let s = List.map (type2sign env) oi.ip_types.(i) in - let s = sign_with_implicits r s mi.ind_nparams in - (* Extraction of the branch (in functional form). *) + (* The types of the arguments of the corresponding constructor. *) + let f t = type_subst_vect metas (expand env t) in + let l = List.map f oi.ip_types.(i) in + (* the corresponding signature *) + let s = List.map (type2sign env) oi.ip_types.(i) in + let s = sign_with_implicits r s mi.ind_nparams in + (* Extraction of the branch (in functional form). *) let e = extract_maybe_term env sg mle (type_recomp (l,mlt)) br.(i) in - (* We suppress dummy arguments according to signature. *) - let ids,e = case_expunge s e in - (List.rev ids, Pusual r, e) + (* We suppress dummy arguments according to signature. *) + let ids,e = case_expunge s e in + (List.rev ids, Pusual r, e) in if mi.ind_kind == Singleton then - begin - (* Informative singleton case: *) - (* [match c with C i -> t] becomes [let i = c' in t'] *) - assert (Int.equal br_size 1); - let (ids,_,e') = extract_branch 0 in - assert (Int.equal (List.length ids) 1); - MLletin (tmp_id (List.hd ids),a,e') - end + begin + (* Informative singleton case: *) + (* [match c with C i -> t] becomes [let i = c' in t'] *) + assert (Int.equal br_size 1); + let (ids,_,e') = extract_branch 0 in + assert (Int.equal (List.length ids) 1); + MLletin (tmp_id (List.hd ids),a,e') + end else - (* Standard case: we apply [extract_branch]. *) - let typs = List.map type_simpl (Array.to_list metas) in + (* Standard case: we apply [extract_branch]. *) + let typs = List.map type_simpl (Array.to_list metas) in let typ = Tglob (GlobRef.IndRef ip,typs) in - MLcase (typ, a, Array.init br_size extract_branch) + MLcase (typ, a, Array.init br_size extract_branch) (*s Extraction of a (co)-fixpoint. *) @@ -932,7 +932,7 @@ let rec gentypvar_ok sg c = match EConstr.kind sg c with | Lambda _ | Const _ -> true | App (c,v) -> (* if all arguments are variables, these variables will - disappear after extraction (see [empty_s] below) *) + disappear after extraction (see [empty_s] below) *) Array.for_all (EConstr.isRel sg) v && gentypvar_ok sg c | Cast (c,_,_) -> gentypvar_ok sg c | _ -> false @@ -962,7 +962,7 @@ let extract_std_constant env sg kn body typ = else let s,s' = List.chop m s in if List.for_all ((==) Keep) s' && - (lang () == Haskell || sign_kind s != UnsafeLogicalSig) + (lang () == Haskell || sign_kind s != UnsafeLogicalSig) then decompose_lam_n sg m body else decomp_lams_eta_n n m env sg body typ in @@ -1114,27 +1114,27 @@ let extract_constant env kn cb = | (Info,TypeScheme) -> (match cb.const_body with | Primitive _ | Undef _ -> warn_info (); mk_typ_ax () - | Def c -> + | Def c -> (match Recordops.find_primitive_projection kn with | None -> mk_typ (get_body c) | Some p -> let body = fake_match_projection env p in mk_typ (EConstr.of_constr body)) - | OpaqueDef c -> - add_opaque r; + | OpaqueDef c -> + add_opaque r; if access_opaque () then mk_typ (get_opaque env c) else mk_typ_ax ()) | (Info,Default) -> (match cb.const_body with | Primitive _ | Undef _ -> warn_info (); mk_ax () - | Def c -> + | Def c -> (match Recordops.find_primitive_projection kn with | None -> mk_def (get_body c) | Some p -> let body = fake_match_projection env p in mk_def (EConstr.of_constr body)) - | OpaqueDef c -> - add_opaque r; + | OpaqueDef c -> + add_opaque r; if access_opaque () then mk_def (get_opaque env c) else mk_ax ()) with SingletonInductiveBecomesProp id -> @@ -1150,10 +1150,10 @@ let extract_constant_spec env kn cb = | (Logic, Default) -> Sval (r, Tdummy Kprop) | (Info, TypeScheme) -> let s,vl = type_sign_vl env sg typ in - (match cb.const_body with + (match cb.const_body with | Undef _ | OpaqueDef _ | Primitive _ -> Stype (r, vl, None) - | Def body -> - let db = db_from_sign s in + | Def body -> + let db = db_from_sign s in let body = get_body body in let t = extract_type_scheme env sg db body (List.length s) in Stype (r, vl, Some t)) @@ -1197,9 +1197,9 @@ let extract_inductive env kn = let rec filter i = function | [] -> [] | t::l -> - let l' = filter (succ i) l in - if isTdummy (expand env t) || Int.Set.mem i implicits then l' - else t::l' + let l' = filter (succ i) l in + if isTdummy (expand env t) || Int.Set.mem i implicits then l' + else t::l' in filter (1+ind.ind_nparams) l in let packets = diff --git a/plugins/extraction/haskell.ml b/plugins/extraction/haskell.ml index 4769bef475..f0053ba6b5 100644 --- a/plugins/extraction/haskell.ml +++ b/plugins/extraction/haskell.ml @@ -110,15 +110,15 @@ let rec pp_type par vl t = with Failure _ -> (str "a" ++ int i)) | Tglob (r,[]) -> pp_global Type r | Tglob (GlobRef.IndRef(kn,0),l) - when not (keep_singleton ()) && MutInd.equal kn (mk_ind "Coq.Init.Specif" "sig") -> - pp_type true vl (List.hd l) + when not (keep_singleton ()) && MutInd.equal kn (mk_ind "Coq.Init.Specif" "sig") -> + pp_type true vl (List.hd l) | Tglob (r,l) -> - pp_par par - (pp_global Type r ++ spc () ++ - prlist_with_sep spc (pp_type true vl) l) + pp_par par + (pp_global Type r ++ spc () ++ + prlist_with_sep spc (pp_type true vl) l) | Tarr (t1,t2) -> - pp_par par - (pp_rec true t1 ++ spc () ++ str "->" ++ spc () ++ pp_rec false t2) + pp_par par + (pp_rec true t1 ++ spc () ++ str "->" ++ spc () ++ pp_rec false t2) | Tdummy _ -> str "()" | Tunknown -> str "Any" | Taxiom -> str "() -- AXIOM TO BE REALIZED" ++ fnl () @@ -141,77 +141,77 @@ let rec pp_expr par env args = and apply2 st = pp_apply2 st par args in function | MLrel n -> - let id = get_db_name n env in + let id = get_db_name n env in (* Try to survive to the occurrence of a Dummy rel. TODO: we should get rid of this hack (cf. BZ#592) *) let id = if Id.equal id dummy_name then Id.of_string "__" else id in apply (Id.print id) | MLapp (f,args') -> - let stl = List.map (pp_expr true env []) args' in + let stl = List.map (pp_expr true env []) args' in pp_expr par env (stl @ args) f | MLlam _ as a -> - let fl,a' = collect_lams a in - let fl,env' = push_vars (List.map id_of_mlid fl) env in - let st = (pp_abst (List.rev fl) ++ pp_expr false env' [] a') in - apply2 st + let fl,a' = collect_lams a in + let fl,env' = push_vars (List.map id_of_mlid fl) env in + let st = (pp_abst (List.rev fl) ++ pp_expr false env' [] a') in + apply2 st | MLletin (id,a1,a2) -> - let i,env' = push_vars [id_of_mlid id] env in - let pp_id = Id.print (List.hd i) - and pp_a1 = pp_expr false env [] a1 - and pp_a2 = pp_expr (not par && expr_needs_par a2) env' [] a2 in - let pp_def = - str "let {" ++ cut () ++ - hov 1 (pp_id ++ str " = " ++ pp_a1 ++ str "}") - in - apply2 (hv 0 (hv 0 (hv 1 pp_def ++ spc () ++ str "in") ++ - spc () ++ hov 0 pp_a2)) + let i,env' = push_vars [id_of_mlid id] env in + let pp_id = Id.print (List.hd i) + and pp_a1 = pp_expr false env [] a1 + and pp_a2 = pp_expr (not par && expr_needs_par a2) env' [] a2 in + let pp_def = + str "let {" ++ cut () ++ + hov 1 (pp_id ++ str " = " ++ pp_a1 ++ str "}") + in + apply2 (hv 0 (hv 0 (hv 1 pp_def ++ spc () ++ str "in") ++ + spc () ++ hov 0 pp_a2)) | MLglob r -> - apply (pp_global Term r) + apply (pp_global Term r) | MLcons (_,r,a) as c -> assert (List.is_empty args); begin match a with - | _ when is_native_char c -> pp_native_char c - | [] -> pp_global Cons r - | [a] -> - pp_par par (pp_global Cons r ++ spc () ++ pp_expr true env [] a) - | _ -> - pp_par par (pp_global Cons r ++ spc () ++ - prlist_with_sep spc (pp_expr true env []) a) - end + | _ when is_native_char c -> pp_native_char c + | [] -> pp_global Cons r + | [a] -> + pp_par par (pp_global Cons r ++ spc () ++ pp_expr true env [] a) + | _ -> + pp_par par (pp_global Cons r ++ spc () ++ + prlist_with_sep spc (pp_expr true env []) a) + end | MLtuple l -> assert (List.is_empty args); pp_boxed_tuple (pp_expr true env []) l | MLcase (_,t, pv) when is_custom_match pv -> if not (is_regular_match pv) then - user_err Pp.(str "Cannot mix yet user-given match and general patterns."); - let mkfun (ids,_,e) = - if not (List.is_empty ids) then named_lams (List.rev ids) e - else dummy_lams (ast_lift 1 e) 1 - in - let pp_branch tr = pp_expr true env [] (mkfun tr) ++ fnl () in - let inner = - str (find_custom_match pv) ++ fnl () ++ - prvect pp_branch pv ++ - pp_expr true env [] t - in - apply2 (hov 2 inner) + user_err Pp.(str "Cannot mix yet user-given match and general patterns."); + let mkfun (ids,_,e) = + if not (List.is_empty ids) then named_lams (List.rev ids) e + else dummy_lams (ast_lift 1 e) 1 + in + let pp_branch tr = pp_expr true env [] (mkfun tr) ++ fnl () in + let inner = + str (find_custom_match pv) ++ fnl () ++ + prvect pp_branch pv ++ + pp_expr true env [] t + in + apply2 (hov 2 inner) | MLcase (typ,t,pv) -> apply2 - (v 0 (str "case " ++ pp_expr false env [] t ++ str " of {" ++ - fnl () ++ pp_pat env pv)) + (v 0 (str "case " ++ pp_expr false env [] t ++ str " of {" ++ + fnl () ++ pp_pat env pv)) | MLfix (i,ids,defs) -> - let ids',env' = push_vars (List.rev (Array.to_list ids)) env in - pp_fix par env' i (Array.of_list (List.rev ids'),defs) args + let ids',env' = push_vars (List.rev (Array.to_list ids)) env in + pp_fix par env' i (Array.of_list (List.rev ids'),defs) args | MLexn s -> - (* An [MLexn] may be applied, but I don't really care. *) - pp_par par (str "Prelude.error" ++ spc () ++ qs s) + (* An [MLexn] may be applied, but I don't really care. *) + pp_par par (str "Prelude.error" ++ spc () ++ qs s) | MLdummy k -> (* An [MLdummy] may be applied, but I don't really care. *) (match msg_of_implicit k with | "" -> str "__" | s -> str "__" ++ spc () ++ pp_bracket_comment (str s)) | MLmagic a -> - pp_apply (str "unsafeCoerce") par (pp_expr true env [] a :: args) + pp_apply (str "unsafeCoerce") par (pp_expr true env [] a :: args) | MLaxiom -> pp_par par (str "Prelude.error \"AXIOM TO BE REALIZED\"") | MLuint _ -> pp_par par (str "Prelude.error \"EXTRACTION OF UINT NOT IMPLEMENTED\"") @@ -232,16 +232,16 @@ and pp_gen_pat par ids env = function and pp_one_pat env (ids,p,t) = let ids',env' = push_vars (List.rev_map id_of_mlid ids) env in hov 2 (str " " ++ - pp_gen_pat false (List.rev ids') env' p ++ - str " ->" ++ spc () ++ - pp_expr (expr_needs_par t) env' [] t) + pp_gen_pat false (List.rev ids') env' p ++ + str " ->" ++ spc () ++ + pp_expr (expr_needs_par t) env' [] t) and pp_pat env pv = prvecti (fun i x -> pp_one_pat env pv.(i) ++ if Int.equal i (Array.length pv - 1) then str "}" else - (str ";" ++ fnl ())) + (str ";" ++ fnl ())) pv (*s names of the functions ([ids]) are already pushed in [env], @@ -251,10 +251,10 @@ and pp_fix par env i (ids,bl) args = pp_par par (v 0 (v 1 (str "let {" ++ fnl () ++ - prvect_with_sep (fun () -> str ";" ++ fnl ()) - (fun (fi,ti) -> pp_function env (Id.print fi) ti) - (Array.map2 (fun a b -> a,b) ids bl) ++ - str "}") ++ + prvect_with_sep (fun () -> str ";" ++ fnl ()) + (fun (fi,ti) -> pp_function env (Id.print fi) ti) + (Array.map2 (fun a b -> a,b) ids bl) ++ + str "}") ++ fnl () ++ str "in " ++ pp_apply (Id.print ids.(i)) false args)) and pp_function env f t = @@ -269,17 +269,17 @@ and pp_function env f t = let pp_logical_ind packet = pp_comment (Id.print packet.ip_typename ++ str " : logical inductive") ++ pp_comment (str "with constructors : " ++ - prvect_with_sep spc Id.print packet.ip_consnames) + prvect_with_sep spc Id.print packet.ip_consnames) let pp_singleton kn packet = let name = pp_global Type (GlobRef.IndRef (kn,0)) in let l = rename_tvars keywords packet.ip_vars in hov 2 (str "type " ++ name ++ spc () ++ - prlist_with_sep spc Id.print l ++ - (if not (List.is_empty l) then str " " else mt ()) ++ str "=" ++ spc () ++ - pp_type false l (List.hd packet.ip_types.(0)) ++ fnl () ++ - pp_comment (str "singleton inductive, whose constructor was " ++ - Id.print packet.ip_consnames.(0))) + prlist_with_sep spc Id.print l ++ + (if not (List.is_empty l) then str " " else mt ()) ++ str "=" ++ spc () ++ + pp_type false l (List.hd packet.ip_types.(0)) ++ fnl () ++ + pp_comment (str "singleton inductive, whose constructor was " ++ + Id.print packet.ip_consnames.(0))) let pp_one_ind ip pl cv = let pl = rename_tvars keywords pl in @@ -288,8 +288,8 @@ let pp_one_ind ip pl cv = match l with | [] -> (mt ()) | _ -> (str " " ++ - prlist_with_sep - (fun () -> (str " ")) (pp_type true pl) l)) + prlist_with_sep + (fun () -> (str " ")) (pp_type true pl) l)) in str (if Array.is_empty cv then "type " else "data ") ++ pp_global Type (GlobRef.IndRef ip) ++ @@ -298,7 +298,7 @@ let pp_one_ind ip pl cv = else (fnl () ++ str " " ++ v 0 (str " " ++ - prvect_with_sep (fun () -> fnl () ++ str "| ") pp_constructor + prvect_with_sep (fun () -> fnl () ++ str "| ") pp_constructor (Array.mapi (fun i c -> GlobRef.ConstructRef (ip,i+1),c) cv))) let rec pp_ind first kn i ind = @@ -310,10 +310,10 @@ let rec pp_ind first kn i ind = if is_custom (GlobRef.IndRef (kn,i)) then pp_ind first kn (i+1) ind else if p.ip_logical then - pp_logical_ind p ++ pp_ind first kn (i+1) ind + pp_logical_ind p ++ pp_ind first kn (i+1) ind else - pp_one_ind ip p.ip_vars p.ip_types ++ fnl () ++ - pp_ind false kn (i+1) ind + pp_one_ind ip p.ip_vars p.ip_types ++ fnl () ++ + pp_ind false kn (i+1) ind (*s Pretty-printing of a declaration. *) @@ -325,45 +325,45 @@ let pp_decl = function | Dtype (r, l, t) -> if is_inline_custom r then mt () else - let l = rename_tvars keywords l in - let st = - try - let ids,s = find_type_custom r in - prlist (fun id -> str (id^" ")) ids ++ str "=" ++ spc () ++ str s - with Not_found -> - prlist (fun id -> Id.print id ++ str " ") l ++ - if t == Taxiom then str "= () -- AXIOM TO BE REALIZED" ++ fnl () - else str "=" ++ spc () ++ pp_type false l t - in - hov 2 (str "type " ++ pp_global Type r ++ spc () ++ st) ++ fnl2 () + let l = rename_tvars keywords l in + let st = + try + let ids,s = find_type_custom r in + prlist (fun id -> str (id^" ")) ids ++ str "=" ++ spc () ++ str s + with Not_found -> + prlist (fun id -> Id.print id ++ str " ") l ++ + if t == Taxiom then str "= () -- AXIOM TO BE REALIZED" ++ fnl () + else str "=" ++ spc () ++ pp_type false l t + in + hov 2 (str "type " ++ pp_global Type r ++ spc () ++ st) ++ fnl2 () | Dfix (rv, defs, typs) -> let names = Array.map - (fun r -> if is_inline_custom r then mt () else pp_global Term r) rv + (fun r -> if is_inline_custom r then mt () else pp_global Term r) rv in prvecti - (fun i r -> - let void = is_inline_custom r || - (not (is_custom r) && + (fun i r -> + let void = is_inline_custom r || + (not (is_custom r) && match defs.(i) with MLexn "UNUSED" -> true | _ -> false) - in - if void then mt () - else - hov 2 (names.(i) ++ str " :: " ++ pp_type false [] typs.(i)) ++ fnl () ++ - (if is_custom r then - (names.(i) ++ str " = " ++ str (find_custom r)) - else - (pp_function (empty_env ()) names.(i) defs.(i))) - ++ fnl2 ()) - rv + in + if void then mt () + else + hov 2 (names.(i) ++ str " :: " ++ pp_type false [] typs.(i)) ++ fnl () ++ + (if is_custom r then + (names.(i) ++ str " = " ++ str (find_custom r)) + else + (pp_function (empty_env ()) names.(i) defs.(i))) + ++ fnl2 ()) + rv | Dterm (r, a, t) -> if is_inline_custom r then mt () else - let e = pp_global Term r in - hov 2 (e ++ str " :: " ++ pp_type false [] t) ++ fnl () ++ - if is_custom r then - hov 0 (e ++ str " = " ++ str (find_custom r) ++ fnl2 ()) - else - hov 0 (pp_function (empty_env ()) e a ++ fnl2 ()) + let e = pp_global Term r in + hov 2 (e ++ str " :: " ++ pp_type false [] t) ++ fnl () ++ + if is_custom r then + hov 0 (e ++ str " = " ++ str (find_custom r) ++ fnl2 ()) + else + hov 0 (pp_function (empty_env ()) e a ++ fnl2 ()) let rec pp_structure_elem = function | (l,SEdecl d) -> pp_decl d diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index 44b95ae4c1..fc0ba95b98 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -200,10 +200,10 @@ module Mlenv = struct let rec meta2var t = match t with | Tmeta {contents=Some u} -> meta2var u | Tmeta ({id=i} as m) -> - (try Tvar (Int.Map.find i !map) - with Not_found -> - if Metaset.mem m mle.free then t - else Tvar (add_new i)) + (try Tvar (Int.Map.find i !map) + with Not_found -> + if Metaset.mem m mle.free then t + else Tvar (add_new i)) | Tarr (t1,t2) -> Tarr (meta2var t1, meta2var t2) | Tglob (r,l) -> Tglob (r, List.map meta2var l) | t -> t @@ -279,9 +279,9 @@ let type_expand env t = let rec expand = function | Tmeta {contents = Some t} -> expand t | Tglob (r,l) -> - (match env r with - | Some mlt -> expand (type_subst_list l mlt) - | None -> Tglob (r, List.map expand l)) + (match env r with + | Some mlt -> expand (type_subst_list l mlt) + | None -> Tglob (r, List.map expand l)) | Tarr (a,b) -> Tarr (expand a, expand b) | a -> a in if Table.type_expand () then expand t else t @@ -348,8 +348,8 @@ let type_expunge_from_sign env s t = | _, Tmeta {contents = Some t} -> expunge s t | _, Tglob (r,l) -> (match env r with - | Some mlt -> expunge s (type_subst_list l mlt) - | None -> assert false) + | Some mlt -> expunge s (type_subst_list l mlt) + | None -> assert false) | _ -> assert false in let t = expunge (sign_no_final_keeps s) t in @@ -426,7 +426,7 @@ let ast_iter_rel f = | MLlam (_,a) -> iter (n+1) a | MLletin (_,a,b) -> iter n a; iter (n+1) b | MLcase (_,a,v) -> - iter n a; Array.iter (fun (l,_,t) -> iter (n + (List.length l)) t) v + iter n a; Array.iter (fun (l,_,t) -> iter (n + (List.length l)) t) v | MLfix (_,ids,v) -> let k = Array.length ids in Array.iter (iter (n+k)) v | MLapp (a,l) -> iter n a; List.iter (iter n) l | MLcons (_,_,l) | MLtuple l -> List.iter (iter n) l @@ -512,8 +512,8 @@ let nb_occur_match = | MLrel i -> if Int.equal i k then 1 else 0 | MLcase(_,a,v) -> (nb k a) + - Array.fold_left - (fun r (ids,_,a) -> max r (nb (k+(List.length ids)) a)) 0 v + Array.fold_left + (fun r (ids,_,a) -> max r (nb (k+(List.length ids)) a)) 0 v | MLletin (_,a,b) -> (nb k a) + (nb (k+1) b) | MLfix (_,ids,v) -> let k = k+(Array.length ids) in Array.fold_left (fun r a -> r+(nb k a)) 0 v @@ -605,10 +605,10 @@ let ast_pop t = ast_lift (-1) t let permut_rels k k' = let rec permut n = function | MLrel i as a -> - let i' = i-n in - if i'<1 || i'>k+k' then a - else if i'<=k then MLrel (i+k') - else MLrel (i-k) + let i' = i-n in + if i'<1 || i'>k+k' then a + else if i'<=k then MLrel (i+k') + else MLrel (i-k) | a -> ast_map_lift permut n a in permut 0 @@ -618,10 +618,10 @@ let permut_rels k k' = let ast_subst e = let rec subst n = function | MLrel i as a -> - let i' = i-n in - if Int.equal i' 1 then ast_lift n e - else if i'<1 then a - else MLrel (i-1) + let i' = i-n in + if Int.equal i' 1 then ast_lift n e + else if i'<1 then a + else MLrel (i-1) | a -> ast_map_lift subst n a in subst 0 @@ -633,13 +633,13 @@ let ast_subst e = let gen_subst v d t = let rec subst n = function | MLrel i as a -> - let i'= i-n in - if i' < 1 then a - else if i' <= Array.length v then - match v.(i'-1) with - | None -> assert false - | Some u -> ast_lift n u - else MLrel (i+d) + let i'= i-n in + if i' < 1 then a + else if i' <= Array.length v then + match v.(i'-1) with + | None -> assert false + | Some u -> ast_lift n u + else MLrel (i+d) | a -> ast_map_lift subst n a in subst 0 t @@ -661,18 +661,18 @@ let is_regular_match br = else try let get_r (ids,pat,c) = - match pat with - | Pusual r -> r - | Pcons (r,l) -> + match pat with + | Pusual r -> r + | Pcons (r,l) -> let is_rel i = function Prel j -> Int.equal i j | _ -> false in - if not (List.for_all_i is_rel 1 (List.rev l)) - then raise Impossible; - r - | _ -> raise Impossible + if not (List.for_all_i is_rel 1 (List.rev l)) + then raise Impossible; + r + | _ -> raise Impossible in let ind = match get_r br.(0) with | GlobRef.ConstructRef (ind,_) -> ind - | _ -> raise Impossible + | _ -> raise Impossible in let is_ref i tr = match get_r tr with | GlobRef.ConstructRef (ind', j) -> eq_ind ind ind' && Int.equal j (i + 1) @@ -767,20 +767,20 @@ let eta_red e = if Int.equal n 0 then e else match t with | MLapp (f,a) -> - let m = List.length a in - let ids,body,args = - if Int.equal m n then - [], f, a - else if m < n then - List.skipn m ids, f, a - else (* m > n *) - let a1,a2 = List.chop (m-n) a in - [], MLapp (f,a1), a2 - in - let p = List.length args in - if test_eta_args_lift 0 p args && not (ast_occurs_itvl 1 p body) - then named_lams ids (ast_lift (-p) body) - else e + let m = List.length a in + let ids,body,args = + if Int.equal m n then + [], f, a + else if m < n then + List.skipn m ids, f, a + else (* m > n *) + let a1,a2 = List.chop (m-n) a in + [], MLapp (f,a1), a2 + in + let p = List.length args in + if test_eta_args_lift 0 p args && not (ast_occurs_itvl 1 p body) + then named_lams ids (ast_lift (-p) body) + else e | _ -> e (* Performs an eta-reduction when the core is atomic and value, @@ -804,11 +804,11 @@ let rec linear_beta_red a t = match a,t with | [], _ -> t | a0::a, MLlam (id,t) -> (match nb_occur_match t with - | 0 -> linear_beta_red a (ast_pop t) - | 1 -> linear_beta_red a (ast_subst a0 t) - | _ -> - let a = List.map (ast_lift 1) a in - MLletin (id, a0, linear_beta_red a t)) + | 0 -> linear_beta_red a (ast_pop t) + | 1 -> linear_beta_red a (ast_subst a0 t) + | _ -> + let a = List.map (ast_lift 1) a in + MLletin (id, a0, linear_beta_red a t)) | _ -> MLapp (t, a) let rec tmp_head_lams = function @@ -860,10 +860,10 @@ let branch_as_fun typ (l,p,c) = in let rec genrec n = function | MLrel i as c -> - let i' = i-n in - if i'<1 then c - else if i'>nargs then MLrel (i-nargs+1) - else raise Impossible + let i' = i-n in + if i'<1 then c + else if i'>nargs then MLrel (i-nargs+1) + else raise Impossible | MLcons _ as cons' when eq_ml_ast cons' (ast_lift n cons) -> MLrel (n+1) | a -> ast_map_lift genrec n a in genrec 0 c @@ -909,8 +909,8 @@ let census_add, census_max, census_clean = let len = ref 0 and lst = ref Int.Set.empty and elm = ref MLaxiom in List.iter (fun (e, s) -> - let n = Int.Set.cardinal s in - if n > !len then begin len := n; lst := s; elm := e end) + let n = Int.Set.cardinal s in + if n > !len then begin len := n; lst := s; elm := e end) !h; (!elm,!lst) in @@ -931,9 +931,9 @@ let factor_branches o typ br = census_clean (); for i = 0 to Array.length br - 1 do if o.opt_case_idr then - (try census_add (branch_as_fun typ br.(i)) i with Impossible -> ()); + (try census_add (branch_as_fun typ br.(i)) i with Impossible -> ()); if o.opt_case_cst then - (try census_add (branch_as_cst br.(i)) i with Impossible -> ()); + (try census_add (branch_as_cst br.(i)) i with Impossible -> ()); done; let br_factor, br_set = census_max () in census_clean (); @@ -956,9 +956,9 @@ let is_exn = function MLexn _ -> true | _ -> false let permut_case_fun br acc = let nb = ref max_int in Array.iter (fun (_,_,t) -> - let ids, c = collect_lams t in - let n = List.length ids in - if (n < !nb) && (not (is_exn c)) then nb := n) br; + let ids, c = collect_lams t in + let n = List.length ids in + if (n < !nb) && (not (is_exn c)) then nb := n) br; if Int.equal !nb max_int || Int.equal !nb 0 then ([],br) else begin let br = Array.copy br in @@ -967,11 +967,11 @@ let permut_case_fun br acc = let (l,p,t) = br.(i) in let local_nb = nb_lams t in if local_nb < !nb then (* t = MLexn ... *) - br.(i) <- (l,p,remove_n_lams local_nb t) + br.(i) <- (l,p,remove_n_lams local_nb t) else begin - let local_ids,t = collect_n_lams !nb t in - ids := merge_ids !ids local_ids; - br.(i) <- (l,p,permut_rels !nb (List.length l) t) + let local_ids,t = collect_n_lams !nb t in + ids := merge_ids !ids local_ids; + br.(i) <- (l,p,permut_rels !nb (List.length l) t) end done; (!ids,br) @@ -1011,9 +1011,9 @@ let iota_gen br hd = let rec iota k = function | MLcons (typ,r,a) -> iota_red 0 k br (typ,r,a) | MLcase(typ,e,br') -> - let new_br = - Array.map (fun (i,p,c)->(i,p,iota (k+(List.length i)) c)) br' - in MLcase(typ,e,new_br) + let new_br = + Array.map (fun (i,p,c)->(i,p,iota (k+(List.length i)) c)) br' + in MLcase(typ,e,new_br) | _ -> raise Impossible in iota 0 hd @@ -1061,17 +1061,17 @@ let rec simpl o = function | MLletin(id,c,e) -> let e = simpl o e in if - (is_atomic c) || (is_atomic e) || - (let n = nb_occur_match e in - (Int.equal n 0 || (Int.equal n 1 && expand_linear_let o id e))) + (is_atomic c) || (is_atomic e) || + (let n = nb_occur_match e in + (Int.equal n 0 || (Int.equal n 1 && expand_linear_let o id e))) then - simpl o (ast_subst c e) + simpl o (ast_subst c e) else - MLletin(id, simpl o c, e) + MLletin(id, simpl o c, e) | MLfix(i,ids,c) -> let n = Array.length ids in if ast_occurs_itvl 1 n c.(i) then - MLfix (i, ids, Array.map (simpl o) c) + MLfix (i, ids, Array.map (simpl o) c) else simpl o (ast_lift (-n) c.(i)) (* Dummy fixpoint *) | MLmagic(MLmagic _ as e) -> simpl o e | MLmagic(MLapp (f,l)) -> simpl o (MLapp (MLmagic f, l)) @@ -1094,12 +1094,12 @@ and simpl_app o a = function simpl o (MLapp (ast_pop t, List.tl a)) | MLlam (id,t) -> (* Beta redex *) (match nb_occur_match t with - | 0 -> simpl o (MLapp (ast_pop t, List.tl a)) - | 1 when (is_tmp id || o.opt_lin_beta) -> - simpl o (MLapp (ast_subst (List.hd a) t, List.tl a)) - | _ -> - let a' = List.map (ast_lift 1) (List.tl a) in - simpl o (MLletin (id, List.hd a, MLapp (t, a')))) + | 0 -> simpl o (MLapp (ast_pop t, List.tl a)) + | 1 when (is_tmp id || o.opt_lin_beta) -> + simpl o (MLapp (ast_subst (List.hd a) t, List.tl a)) + | _ -> + let a' = List.map (ast_lift 1) (List.tl a) in + simpl o (MLletin (id, List.hd a, MLapp (t, a')))) | MLmagic (MLlam (id,t)) -> (* When we've at least one argument, we permute the magic and the lambda, to simplify things a bit (see #2795). @@ -1111,14 +1111,14 @@ and simpl_app o a = function | MLcase (typ,e,br) when o.opt_case_app -> (* Application of a case: we push arguments inside *) let br' = - Array.map - (fun (l,p,t) -> - let k = List.length l in - let a' = List.map (ast_lift k) a in - (l, p, simpl o (MLapp (t,a')))) br + Array.map + (fun (l,p,t) -> + let k = List.length l in + let a' = List.map (ast_lift k) a in + (l, p, simpl o (MLapp (t,a')))) br in simpl o (MLcase (typ,e,br')) | (MLdummy _ | MLexn _) as e -> e - (* We just discard arguments in those cases. *) + (* We just discard arguments in those cases. *) | f -> MLapp (f,a) (* Invariant : all empty matches should now be [MLexn] *) @@ -1139,19 +1139,19 @@ and simpl_case o typ br e = if lang() == Scheme || is_custom_match br then MLcase (typ, e, br) else match factor_branches o typ br with - | Some (f,ints) when Int.equal (Int.Set.cardinal ints) (Array.length br) -> - (* If all branches have been factorized, we remove the match *) - simpl o (MLletin (Tmp anonymous_name, e, f)) - | Some (f,ints) -> - let last_br = - if ast_occurs 1 f then ([Tmp anonymous_name], Prel 1, f) - else ([], Pwild, ast_pop f) - in - let brl = Array.to_list br in - let brl_opt = List.filteri (fun i _ -> not (Int.Set.mem i ints)) brl in - let brl_opt = brl_opt @ [last_br] in - MLcase (typ, e, Array.of_list brl_opt) - | None -> MLcase (typ, e, br) + | Some (f,ints) when Int.equal (Int.Set.cardinal ints) (Array.length br) -> + (* If all branches have been factorized, we remove the match *) + simpl o (MLletin (Tmp anonymous_name, e, f)) + | Some (f,ints) -> + let last_br = + if ast_occurs 1 f then ([Tmp anonymous_name], Prel 1, f) + else ([], Pwild, ast_pop f) + in + let brl = Array.to_list br in + let brl_opt = List.filteri (fun i _ -> not (Int.Set.mem i ints)) brl in + let brl_opt = brl_opt @ [last_br] in + MLcase (typ, e, Array.of_list brl_opt) + | None -> MLcase (typ, e, br) (*S Local prop elimination. *) (* We try to eliminate as many [prop] as possible inside an [ml_ast]. *) @@ -1230,8 +1230,8 @@ let kill_dummy_lams sign c = let eta_expansion_sign s (ids,c) = let rec abs ids rels i = function | [] -> - let a = List.rev_map (function MLrel x -> MLrel (i-x) | a -> a) rels - in ids, MLapp (ast_lift (i-1) c, a) + let a = List.rev_map (function MLrel x -> MLrel (i-x) | a -> a) rels + in ids, MLapp (ast_lift (i-1) c, a) | Keep :: l -> abs (anonymous :: ids) (MLrel i :: rels) (i+1) l | Kill k :: l -> abs (Dummy :: ids) (MLdummy k :: rels) (i+1) l in abs ids [] 1 s @@ -1275,14 +1275,14 @@ let kill_dummy_args (ids,bl) r t = in let rec killrec n = function | MLapp(e, a) when found n e -> - let k = max 0 (m - (List.length a)) in - let a = List.map (killrec n) a in - let a = List.map (ast_lift k) a in - let a = select_via_bl sign (a @ (eta_args k)) in - named_lams (List.firstn k ids) (MLapp (ast_lift k e, a)) + let k = max 0 (m - (List.length a)) in + let a = List.map (killrec n) a in + let a = List.map (ast_lift k) a in + let a = select_via_bl sign (a @ (eta_args k)) in + named_lams (List.firstn k ids) (MLapp (ast_lift k e, a)) | e when found n e -> - let a = select_via_bl sign (eta_args m) in - named_lams ids (MLapp (ast_lift m e, a)) + let a = select_via_bl sign (eta_args m) in + named_lams ids (MLapp (ast_lift m e, a)) | e -> ast_map_lift killrec n e in killrec 0 t @@ -1294,32 +1294,32 @@ let sign_of_args a = let rec kill_dummy = function | MLfix(i,fi,c) -> (try - let k,c = kill_dummy_fix i c [] in - ast_subst (MLfix (i,fi,c)) (kill_dummy_args k 1 (MLrel 1)) + let k,c = kill_dummy_fix i c [] in + ast_subst (MLfix (i,fi,c)) (kill_dummy_args k 1 (MLrel 1)) with Impossible -> MLfix (i,fi,Array.map kill_dummy c)) | MLapp (MLfix (i,fi,c),a) -> let a = List.map kill_dummy a in (* Heuristics: if some arguments are implicit args, we try to eliminate the corresponding arguments of the fixpoint *) (try - let k,c = kill_dummy_fix i c (sign_of_args a) in - let fake = MLapp (MLrel 1, List.map (ast_lift 1) a) in - let fake' = kill_dummy_args k 1 fake in - ast_subst (MLfix (i,fi,c)) fake' + let k,c = kill_dummy_fix i c (sign_of_args a) in + let fake = MLapp (MLrel 1, List.map (ast_lift 1) a) in + let fake' = kill_dummy_args k 1 fake in + ast_subst (MLfix (i,fi,c)) fake' with Impossible -> MLapp(MLfix(i,fi,Array.map kill_dummy c),a)) | MLletin(id, MLfix (i,fi,c),e) -> (try - let k,c = kill_dummy_fix i c [] in - let e = kill_dummy (kill_dummy_args k 1 e) in - MLletin(id, MLfix(i,fi,c),e) + let k,c = kill_dummy_fix i c [] in + let e = kill_dummy (kill_dummy_args k 1 e) in + MLletin(id, MLfix(i,fi,c),e) with Impossible -> - MLletin(id, MLfix(i,fi,Array.map kill_dummy c),kill_dummy e)) + MLletin(id, MLfix(i,fi,Array.map kill_dummy c),kill_dummy e)) | MLletin(id,c,e) -> (try - let k,c = kill_dummy_lams [] (kill_dummy_hd c) in - let e = kill_dummy (kill_dummy_args k 1 e) in - let c = kill_dummy c in - if is_atomic c then ast_subst c e else MLletin (id, c, e) + let k,c = kill_dummy_lams [] (kill_dummy_hd c) in + let e = kill_dummy (kill_dummy_args k 1 e) in + let c = kill_dummy c in + if is_atomic c then ast_subst c e else MLletin (id, c, e) with Impossible -> MLletin(id,kill_dummy c,kill_dummy e)) | a -> ast_map kill_dummy a @@ -1329,10 +1329,10 @@ and kill_dummy_hd = function | MLlam(id,e) -> MLlam(id, kill_dummy_hd e) | MLletin(id,c,e) -> (try - let k,c = kill_dummy_lams [] (kill_dummy_hd c) in - let e = kill_dummy_hd (kill_dummy_args k 1 e) in - let c = kill_dummy c in - if is_atomic c then ast_subst c e else MLletin (id, c, e) + let k,c = kill_dummy_lams [] (kill_dummy_hd c) in + let e = kill_dummy_hd (kill_dummy_args k 1 e) in + let c = kill_dummy c in + if is_atomic c then ast_subst c e else MLletin (id, c, e) with Impossible -> MLletin(id,kill_dummy c,kill_dummy_hd e)) | a -> a @@ -1361,7 +1361,7 @@ let general_optimize_fix f ids n args m c = for i=0 to (n-1) do v.(i)<-i done; let aux i = function | MLrel j when v.(j-1)>=0 -> - if ast_occurs (j+1) c then raise Impossible else v.(j-1)<-(-i-1) + if ast_occurs (j+1) c then raise Impossible else v.(j-1)<-(-i-1) | _ -> raise Impossible in List.iteri aux args; let args_f = List.rev_map (fun i -> MLrel (i+m+1)) (Array.to_list v) in @@ -1377,19 +1377,19 @@ let optimize_fix a = if Int.equal n 0 then a else match a' with | MLfix(_,[|f|],[|c|]) -> - let new_f = MLapp (MLrel (n+1),eta_args n) in - let new_c = named_lams ids (normalize (ast_subst new_f c)) - in MLfix(0,[|f|],[|new_c|]) + let new_f = MLapp (MLrel (n+1),eta_args n) in + let new_c = named_lams ids (normalize (ast_subst new_f c)) + in MLfix(0,[|f|],[|new_c|]) | MLapp(a',args) -> - let m = List.length args in - (match a' with - | MLfix(_,_,_) when - (test_eta_args_lift 0 n args) && not (ast_occurs_itvl 1 m a') - -> a' - | MLfix(_,[|f|],[|c|]) -> - (try general_optimize_fix f ids n args m c - with Impossible -> a) - | _ -> a) + let m = List.length args in + (match a' with + | MLfix(_,_,_) when + (test_eta_args_lift 0 n args) && not (ast_occurs_itvl 1 m a') + -> a' + | MLfix(_,[|f|],[|c|]) -> + (try general_optimize_fix f ids n args m c + with Impossible -> a) + | _ -> a) | _ -> a (*S Inlining. *) @@ -1463,12 +1463,12 @@ let rec non_stricts add cand = function (* so we make an union (in fact a merge). *) let cand = non_stricts false cand t in Array.fold_left - (fun c (i,_,t)-> - let n = List.length i in - let cand = lift n cand in - let cand = pop n (non_stricts add cand t) in - List.merge Int.compare cand c) [] v - (* [merge] may duplicates some indices, but I don't mind. *) + (fun c (i,_,t)-> + let n = List.length i in + let cand = lift n cand in + let cand = pop n (non_stricts add cand t) in + List.merge Int.compare cand c) [] v + (* [merge] may duplicates some indices, but I don't mind. *) | MLmagic t -> non_stricts add cand t | _ -> diff --git a/plugins/extraction/modutil.ml b/plugins/extraction/modutil.ml index fe49bfc1ec..ec39beb03b 100644 --- a/plugins/extraction/modutil.ml +++ b/plugins/extraction/modutil.ml @@ -36,19 +36,19 @@ let se_iter do_decl do_spec do_mp = | MTident mp -> do_mp mp | MTfunsig (_,mt,mt') -> mt_iter mt; mt_iter mt' | MTwith (mt,ML_With_type(idl,l,t))-> - let mp_mt = msid_of_mt mt in - let l',idl' = List.sep_last idl in - let mp_w = - List.fold_left (fun mp l -> MPdot(mp,Label.of_id l)) mp_mt idl' - in + let mp_mt = msid_of_mt mt in + let l',idl' = List.sep_last idl in + let mp_w = + List.fold_left (fun mp l -> MPdot(mp,Label.of_id l)) mp_mt idl' + in let r = GlobRef.ConstRef (Constant.make2 mp_w (Label.of_id l')) in mt_iter mt; do_spec (Stype(r,l,Some t)) | MTwith (mt,ML_With_module(idl,mp))-> let mp_mt = msid_of_mt mt in let mp_w = - List.fold_left (fun mp l -> MPdot(mp,Label.of_id l)) mp_mt idl - in - mt_iter mt; do_mp mp_w; do_mp mp + List.fold_left (fun mp l -> MPdot(mp,Label.of_id l)) mp_mt idl + in + mt_iter mt; do_mp mp_w; do_mp mp | MTsig (_, sign) -> List.iter spec_iter sign and spec_iter = function | (_,Spec s) -> do_spec s @@ -58,7 +58,7 @@ let se_iter do_decl do_spec do_mp = let rec se_iter = function | (_,SEdecl d) -> do_decl d | (_,SEmodule m) -> - me_iter m.ml_mod_expr; mt_iter m.ml_mod_type + me_iter m.ml_mod_expr; mt_iter m.ml_mod_type | (_,SEmodtype m) -> mt_iter m and me_iter = function | MEident mp -> do_mp mp @@ -103,8 +103,8 @@ let ast_iter_references do_term do_cons do_type a = | MLglob r -> do_term r | MLcons (_,r,_) -> do_cons r | MLcase (ty,_,v) -> - type_iter_references do_type ty; - Array.iter (fun (_,p,_) -> patt_iter_references do_cons p) v + type_iter_references do_type ty; + Array.iter (fun (_,p,_) -> patt_iter_references do_cons p) v | MLrel _ | MLlam _ | MLapp _ | MLletin _ | MLtuple _ | MLfix _ | MLexn _ | MLdummy _ | MLaxiom | MLmagic _ | MLuint _ | MLfloat _ -> () @@ -118,7 +118,7 @@ let ind_iter_references do_term do_cons do_type kn ind = if lang () == Ocaml then (match ind.ind_equiv with | Miniml.Equiv kne -> do_type (GlobRef.IndRef (MutInd.make1 kne, snd ip)); - | _ -> ()); + | _ -> ()); Array.iteri (fun j -> cons_iter (ip,j+1)) p.ip_types in if lang () == Ocaml then record_iter_references do_term ind.ind_kind; @@ -132,7 +132,7 @@ let decl_iter_references do_term do_cons do_type = | Dtype (r,_,t) -> do_type r; type_iter t | Dterm (r,a,t) -> do_term r; ast_iter a; type_iter t | Dfix(rv,c,t) -> - Array.iter do_term rv; Array.iter ast_iter c; Array.iter type_iter t + Array.iter do_term rv; Array.iter ast_iter c; Array.iter type_iter t let spec_iter_references do_term do_cons do_type = function | Sind (kn,ind) -> ind_iter_references do_term do_cons do_type kn ind @@ -163,7 +163,7 @@ let rec type_search f = function let decl_type_search f = function | Dind (_,{ind_packets=p}) -> Array.iter - (fun {ip_types=v} -> Array.iter (List.iter (type_search f)) v) p + (fun {ip_types=v} -> Array.iter (List.iter (type_search f)) v) p | Dterm (_,_,u) -> type_search f u | Dfix (_,_,v) -> Array.iter (type_search f) v | Dtype (_,_,u) -> type_search f u @@ -171,7 +171,7 @@ let decl_type_search f = function let spec_type_search f = function | Sind (_,{ind_packets=p}) -> Array.iter - (fun {ip_types=v} -> Array.iter (List.iter (type_search f)) v) p + (fun {ip_types=v} -> Array.iter (List.iter (type_search f)) v) p | Stype (_,_,ot) -> Option.iter (type_search f) ot | Sval (_,u) -> type_search f u @@ -195,7 +195,7 @@ let rec msig_of_ms = function | (l,SEdecl (Dfix (rv,_,tv))) :: ms -> let msig = ref (msig_of_ms ms) in for i = Array.length rv - 1 downto 0 do - msig := (l,Spec (Sval (rv.(i),tv.(i))))::!msig + msig := (l,Spec (Sval (rv.(i),tv.(i))))::!msig done; !msig | (l,SEmodule m) :: ms -> (l,Smodule m.ml_mod_type) :: (msig_of_ms ms) @@ -229,13 +229,13 @@ let get_decl_in_structure r struc = let rec go ll sel = match ll with | [] -> assert false | l :: ll -> - match search_structure l (not (List.is_empty ll)) sel with - | SEdecl d -> d - | SEmodtype m -> assert false - | SEmodule m -> - match m.ml_mod_expr with - | MEstruct (_,sel) -> go ll sel - | _ -> error_not_visible r + match search_structure l (not (List.is_empty ll)) sel with + | SEdecl d -> d + | SEmodtype m -> assert false + | SEmodule m -> + match m.ml_mod_expr with + | MEstruct (_,sel) -> go ll sel + | _ -> error_not_visible r in go ll sel with Not_found -> anomaly (Pp.str "reference not found in extracted structure.") @@ -258,7 +258,7 @@ let dfix_to_mlfix rv av i = in let rec subst n t = match t with | MLglob ((GlobRef.ConstRef kn) as refe) -> - (try MLrel (n + (Refmap'.find refe s)) with Not_found -> t) + (try MLrel (n + (Refmap'.find refe s)) with Not_found -> t) | _ -> ast_map_lift subst n t in let ids = Array.map (fun r -> Label.to_id (label_of_r r)) rv in @@ -277,9 +277,9 @@ let rec optim_se top to_appear s = function let i = inline r a in if i then s := Refmap'.add r a !s; let d = match dump_unused_vars (optimize_fix a) with - | MLfix (0, _, [|c|]) -> - Dfix ([|r|], [|ast_subst (MLglob r) c|], [|t|]) - | a -> Dterm (r, a, t) + | MLfix (0, _, [|c|]) -> + Dfix ([|r|], [|ast_subst (MLglob r) c|], [|t|]) + | a -> Dterm (r, a, t) in (l,SEdecl d) :: (optim_se top to_appear s lse) | (l,SEdecl (Dfix (rv,av,tv))) :: lse -> @@ -287,8 +287,8 @@ let rec optim_se top to_appear s = function (* This fake body ensures that no fixpoint will be auto-inlined. *) let fake_body = MLfix (0,[||],[||]) in for i = 0 to Array.length rv - 1 do - if inline rv.(i) fake_body - then s := Refmap'.add rv.(i) (dfix_to_mlfix rv av i) !s + if inline rv.(i) fake_body + then s := Refmap'.add rv.(i) (dfix_to_mlfix rv av i) !s done; let av' = Array.map dump_unused_vars av in (l,SEdecl (Dfix (rv, av', tv))) :: (optim_se top to_appear s lse) @@ -343,7 +343,7 @@ let compute_deps_decl = function | Dterm (r,u,t) -> type_iter_references add_needed t; if not (is_custom r) then - ast_iter_references add_needed add_needed add_needed u + ast_iter_references add_needed add_needed add_needed u | Dfix _ as d -> decl_iter_references add_needed add_needed add_needed d @@ -370,10 +370,10 @@ let rec depcheck_se = function List.iter found_needed refs'; (* Hack to avoid extracting unused part of a Dfix *) match d with - | Dfix (rv,trms,tys) when (List.for_all is_custom refs') -> - let trms' = Array.make (Array.length rv) (MLexn "UNUSED") in - ((l,SEdecl (Dfix (rv,trms',tys))) :: se') - | _ -> (compute_deps_decl d; t::se') + | Dfix (rv,trms,tys) when (List.for_all is_custom refs') -> + let trms' = Array.make (Array.length rv) (MLexn "UNUSED") in + ((l,SEdecl (Dfix (rv,trms',tys))) :: se') + | _ -> (compute_deps_decl d; t::se') end | t :: se -> let se' = depcheck_se se in diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml index 34ddf57b40..66429833b9 100644 --- a/plugins/extraction/ocaml.ml +++ b/plugins/extraction/ocaml.ml @@ -163,16 +163,16 @@ let pp_type par vl t = | Tvar i -> (try pp_tvar (List.nth vl (pred i)) with Failure _ -> (str "'a" ++ int i)) | Tglob (r,[a1;a2]) when is_infix r -> - pp_par par (pp_rec true a1 ++ str (get_infix r) ++ pp_rec true a2) + pp_par par (pp_rec true a1 ++ str (get_infix r) ++ pp_rec true a2) | Tglob (r,[]) -> pp_global Type r | Tglob (GlobRef.IndRef(kn,0),l) - when not (keep_singleton ()) && MutInd.equal kn (mk_ind "Coq.Init.Specif" "sig") -> - pp_tuple_light pp_rec l + when not (keep_singleton ()) && MutInd.equal kn (mk_ind "Coq.Init.Specif" "sig") -> + pp_tuple_light pp_rec l | Tglob (r,l) -> - pp_tuple_light pp_rec l ++ spc () ++ pp_global Type r + pp_tuple_light pp_rec l ++ spc () ++ pp_global Type r | Tarr (t1,t2) -> - pp_par par - (pp_rec true t1 ++ spc () ++ str "->" ++ spc () ++ pp_rec false t2) + pp_par par + (pp_rec true t1 ++ spc () ++ str "->" ++ spc () ++ pp_rec false t2) | Tdummy _ -> str "__" | Tunknown -> str "__" in @@ -209,101 +209,101 @@ let rec pp_expr par env args = and apply2 st = pp_apply2 st par args in function | MLrel n -> - let id = get_db_name n env in + let id = get_db_name n env in (* Try to survive to the occurrence of a Dummy rel. TODO: we should get rid of this hack (cf. #592) *) let id = if Id.equal id dummy_name then Id.of_string "__" else id in apply (Id.print id) | MLapp (f,args') -> - let stl = List.map (pp_expr true env []) args' in + let stl = List.map (pp_expr true env []) args' in pp_expr par env (stl @ args) f | MLlam _ as a -> - let fl,a' = collect_lams a in - let fl = List.map id_of_mlid fl in - let fl,env' = push_vars fl env in - let st = pp_abst (List.rev fl) ++ pp_expr false env' [] a' in - apply2 st + let fl,a' = collect_lams a in + let fl = List.map id_of_mlid fl in + let fl,env' = push_vars fl env in + let st = pp_abst (List.rev fl) ++ pp_expr false env' [] a' in + apply2 st | MLletin (id,a1,a2) -> - let i,env' = push_vars [id_of_mlid id] env in - let pp_id = Id.print (List.hd i) - and pp_a1 = pp_expr false env [] a1 - and pp_a2 = pp_expr (not par && expr_needs_par a2) env' [] a2 in - hv 0 (apply2 (pp_letin pp_id pp_a1 pp_a2)) + let i,env' = push_vars [id_of_mlid id] env in + let pp_id = Id.print (List.hd i) + and pp_a1 = pp_expr false env [] a1 + and pp_a2 = pp_expr (not par && expr_needs_par a2) env' [] a2 in + hv 0 (apply2 (pp_letin pp_id pp_a1 pp_a2)) | MLglob r -> apply (pp_global Term r) | MLfix (i,ids,defs) -> - let ids',env' = push_vars (List.rev (Array.to_list ids)) env in - pp_fix par env' i (Array.of_list (List.rev ids'),defs) args + let ids',env' = push_vars (List.rev (Array.to_list ids)) env in + pp_fix par env' i (Array.of_list (List.rev ids'),defs) args | MLexn s -> - (* An [MLexn] may be applied, but I don't really care. *) - pp_par par (str "assert false" ++ spc () ++ str ("(* "^s^" *)")) + (* An [MLexn] may be applied, but I don't really care. *) + pp_par par (str "assert false" ++ spc () ++ str ("(* "^s^" *)")) | MLdummy k -> (* An [MLdummy] may be applied, but I don't really care. *) (match msg_of_implicit k with | "" -> str "__" | s -> str "__" ++ spc () ++ str ("(* "^s^" *)")) | MLmagic a -> - pp_apply (str "Obj.magic") par (pp_expr true env [] a :: args) + pp_apply (str "Obj.magic") par (pp_expr true env [] a :: args) | MLaxiom -> - pp_par par (str "failwith \"AXIOM TO BE REALIZED\"") + pp_par par (str "failwith \"AXIOM TO BE REALIZED\"") | MLcons (_,r,a) as c -> assert (List.is_empty args); begin match a with - | _ when is_native_char c -> pp_native_char c - | [a1;a2] when is_infix r -> - let pp = pp_expr true env [] in - pp_par par (pp a1 ++ str (get_infix r) ++ pp a2) - | _ when is_coinductive r -> - let ne = not (List.is_empty a) in - let tuple = space_if ne ++ pp_tuple (pp_expr true env []) a in - pp_par par (str "lazy " ++ pp_par ne (pp_global Cons r ++ tuple)) - | [] -> pp_global Cons r - | _ -> - let fds = get_record_fields r in - if not (List.is_empty fds) then - pp_record_pat (pp_fields r fds, List.map (pp_expr true env []) a) - else - let tuple = pp_tuple (pp_expr true env []) a in - if String.is_empty (str_global Cons r) (* hack Extract Inductive prod *) - then tuple - else pp_par par (pp_global Cons r ++ spc () ++ tuple) - end + | _ when is_native_char c -> pp_native_char c + | [a1;a2] when is_infix r -> + let pp = pp_expr true env [] in + pp_par par (pp a1 ++ str (get_infix r) ++ pp a2) + | _ when is_coinductive r -> + let ne = not (List.is_empty a) in + let tuple = space_if ne ++ pp_tuple (pp_expr true env []) a in + pp_par par (str "lazy " ++ pp_par ne (pp_global Cons r ++ tuple)) + | [] -> pp_global Cons r + | _ -> + let fds = get_record_fields r in + if not (List.is_empty fds) then + pp_record_pat (pp_fields r fds, List.map (pp_expr true env []) a) + else + let tuple = pp_tuple (pp_expr true env []) a in + if String.is_empty (str_global Cons r) (* hack Extract Inductive prod *) + then tuple + else pp_par par (pp_global Cons r ++ spc () ++ tuple) + end | MLtuple l -> assert (List.is_empty args); pp_boxed_tuple (pp_expr true env []) l | MLcase (_, t, pv) when is_custom_match pv -> if not (is_regular_match pv) then - user_err Pp.(str "Cannot mix yet user-given match and general patterns."); - let mkfun (ids,_,e) = - if not (List.is_empty ids) then named_lams (List.rev ids) e - else dummy_lams (ast_lift 1 e) 1 - in - let pp_branch tr = pp_expr true env [] (mkfun tr) ++ fnl () in - let inner = - str (find_custom_match pv) ++ fnl () ++ - prvect pp_branch pv ++ - pp_expr true env [] t - in - apply2 (hov 2 inner) + user_err Pp.(str "Cannot mix yet user-given match and general patterns."); + let mkfun (ids,_,e) = + if not (List.is_empty ids) then named_lams (List.rev ids) e + else dummy_lams (ast_lift 1 e) 1 + in + let pp_branch tr = pp_expr true env [] (mkfun tr) ++ fnl () in + let inner = + str (find_custom_match pv) ++ fnl () ++ + prvect pp_branch pv ++ + pp_expr true env [] t + in + apply2 (hov 2 inner) | MLcase (typ, t, pv) -> let head = - if not (is_coinductive_type typ) then pp_expr false env [] t - else (str "Lazy.force" ++ spc () ++ pp_expr true env [] t) - in - (* First, can this match be printed as a mere record projection ? *) + if not (is_coinductive_type typ) then pp_expr false env [] t + else (str "Lazy.force" ++ spc () ++ pp_expr true env [] t) + in + (* First, can this match be printed as a mere record projection ? *) (try pp_record_proj par env typ t pv args - with Impossible -> - (* Second, can this match be printed as a let-in ? *) - if Int.equal (Array.length pv) 1 then - let s1,s2 = pp_one_pat env pv.(0) in - hv 0 (apply2 (pp_letin s1 head s2)) - else - (* Third, can this match be printed as [if ... then ... else] ? *) - (try apply2 (pp_ifthenelse env head pv) - with Not_found -> - (* Otherwise, standard match *) - apply2 - (v 0 (str "match " ++ head ++ str " with" ++ fnl () ++ - pp_pat env pv)))) + with Impossible -> + (* Second, can this match be printed as a let-in ? *) + if Int.equal (Array.length pv) 1 then + let s1,s2 = pp_one_pat env pv.(0) in + hv 0 (apply2 (pp_letin s1 head s2)) + else + (* Third, can this match be printed as [if ... then ... else] ? *) + (try apply2 (pp_ifthenelse env head pv) + with Not_found -> + (* Otherwise, standard match *) + apply2 + (v 0 (str "match " ++ head ++ str " with" ++ fnl () ++ + pp_pat env pv)))) | MLuint i -> assert (args=[]); str "(" ++ str (Uint63.compile i) ++ str ")" @@ -381,9 +381,9 @@ and pp_ifthenelse env expr pv = match pv with -> hv 0 (hov 2 (str "if " ++ expr) ++ spc () ++ hov 2 (str "then " ++ - hov 2 (pp_expr (expr_needs_par the) env [] the)) ++ spc () ++ - hov 2 (str "else " ++ - hov 2 (pp_expr (expr_needs_par els) env [] els))) + hov 2 (pp_expr (expr_needs_par the) env [] the)) ++ spc () ++ + hov 2 (str "else " ++ + hov 2 (pp_expr (expr_needs_par els) env [] els))) | _ -> raise Not_found and pp_one_pat env (ids,p,t) = @@ -404,20 +404,20 @@ and pp_function env t = let bl,env' = push_vars (List.map id_of_mlid bl) env in match t' with | MLcase(Tglob(r,_),MLrel 1,pv) when - not (is_coinductive r) && List.is_empty (get_record_fields r) && - not (is_custom_match pv) -> - if not (ast_occurs 1 (MLcase(Tunknown,MLaxiom,pv))) then - pr_binding (List.rev (List.tl bl)) ++ - str " = function" ++ fnl () ++ - v 0 (pp_pat env' pv) - else + not (is_coinductive r) && List.is_empty (get_record_fields r) && + not (is_custom_match pv) -> + if not (ast_occurs 1 (MLcase(Tunknown,MLaxiom,pv))) then + pr_binding (List.rev (List.tl bl)) ++ + str " = function" ++ fnl () ++ + v 0 (pp_pat env' pv) + else pr_binding (List.rev bl) ++ str " = match " ++ Id.print (List.hd bl) ++ str " with" ++ fnl () ++ - v 0 (pp_pat env' pv) + v 0 (pp_pat env' pv) | _ -> pr_binding (List.rev bl) ++ - str " =" ++ fnl () ++ str " " ++ - hov 2 (pp_expr false env' [] t') + str " =" ++ fnl () ++ str " " ++ + hov 2 (pp_expr false env' [] t') (*s names of the functions ([ids]) are already pushed in [env], and passed here just for convenience. *) @@ -425,12 +425,12 @@ and pp_function env t = and pp_fix par env i (ids,bl) args = pp_par par (v 0 (str "let rec " ++ - prvect_with_sep - (fun () -> fnl () ++ str "and ") - (fun (fi,ti) -> Id.print fi ++ pp_function env ti) - (Array.map2 (fun id b -> (id,b)) ids bl) ++ - fnl () ++ - hov 2 (str "in " ++ pp_apply (Id.print ids.(i)) false args))) + prvect_with_sep + (fun () -> fnl () ++ str "and ") + (fun (fi,ti) -> Id.print fi ++ pp_function env ti) + (Array.map2 (fun id b -> (id,b)) ids bl) ++ + fnl () ++ + hov 2 (str "in " ++ pp_apply (Id.print ids.(i)) false args))) (* Ad-hoc double-newline in v boxes, with enough negative whitespace to avoid indenting the intermediate blank line *) @@ -451,19 +451,19 @@ let pp_Dfix (rv,c,t) = if i >= Array.length rv then mt () else let void = is_inline_custom rv.(i) || - (not (is_custom rv.(i)) && + (not (is_custom rv.(i)) && match c.(i) with MLexn "UNUSED" -> true | _ -> false) in if void then pp init (i+1) else - let def = - if is_custom rv.(i) then str " = " ++ str (find_custom rv.(i)) - else pp_function (empty_env ()) c.(i) - in - (if init then mt () else cut2 ()) ++ - pp_val names.(i) t.(i) ++ - str (if init then "let rec " else "and ") ++ names.(i) ++ def ++ - pp false (i+1) + let def = + if is_custom rv.(i) then str " = " ++ str (find_custom rv.(i)) + else pp_function (empty_env ()) c.(i) + in + (if init then mt () else cut2 ()) ++ + pp_val names.(i) t.(i) ++ + str (if init then "let rec " else "and ") ++ names.(i) ++ def ++ + pp false (i+1) in pp true 0 (*s Pretty-printing of inductive types declaration. *) @@ -481,9 +481,9 @@ let pp_one_ind prefix ip_equiv pl name cnames ctyps = let pp_constructor i typs = (if Int.equal i 0 then mt () else fnl ()) ++ hov 3 (str "| " ++ cnames.(i) ++ - (if List.is_empty typs then mt () else str " of ") ++ - prlist_with_sep - (fun () -> spc () ++ str "* ") (pp_type true pl) typs) + (if List.is_empty typs then mt () else str " of ") ++ + prlist_with_sep + (fun () -> spc () ++ str "* ") (pp_type true pl) typs) in pp_parameters pl ++ str prefix ++ name ++ pp_equiv pl name ip_equiv ++ str " =" ++ @@ -494,16 +494,16 @@ let pp_logical_ind packet = pp_comment (Id.print packet.ip_typename ++ str " : logical inductive") ++ fnl () ++ pp_comment (str "with constructors : " ++ - prvect_with_sep spc Id.print packet.ip_consnames) ++ + prvect_with_sep spc Id.print packet.ip_consnames) ++ fnl () let pp_singleton kn packet = let name = pp_global Type (GlobRef.IndRef (kn,0)) in let l = rename_tvars keywords packet.ip_vars in hov 2 (str "type " ++ pp_parameters l ++ name ++ str " =" ++ spc () ++ - pp_type false l (List.hd packet.ip_types.(0)) ++ fnl () ++ - pp_comment (str "singleton inductive, whose constructor was " ++ - Id.print packet.ip_consnames.(0))) + pp_type false l (List.hd packet.ip_types.(0)) ++ fnl () ++ + pp_comment (str "singleton inductive, whose constructor was " ++ + Id.print packet.ip_consnames.(0))) let pp_record kn fields ip_equiv packet = let ind = GlobRef.IndRef (kn,0) in @@ -514,7 +514,7 @@ let pp_record kn fields ip_equiv packet = str "type " ++ pp_parameters pl ++ name ++ pp_equiv pl name ip_equiv ++ str " = { "++ hov 0 (prlist_with_sep (fun () -> str ";" ++ spc ()) - (fun (p,t) -> p ++ str " : " ++ pp_type true pl t) l) + (fun (p,t) -> p ++ str " : " ++ pp_type true pl t) l) ++ str " }" let pp_coind pl name = @@ -536,7 +536,7 @@ let pp_ind co kn ind = Array.mapi (fun i p -> if p.ip_logical then [||] else Array.mapi (fun j _ -> pp_global Cons (GlobRef.ConstructRef ((kn,i),j+1))) - p.ip_types) + p.ip_types) ind.ind_packets in let rec pp i kwd = @@ -548,9 +548,9 @@ let pp_ind co kn ind = if is_custom (GlobRef.IndRef ip) then pp (i+1) kwd else if p.ip_logical then pp_logical_ind p ++ pp (i+1) kwd else - kwd ++ (if co then pp_coind p.ip_vars names.(i) else mt ()) ++ - pp_one_ind prefix ip_equiv p.ip_vars names.(i) cnames.(i) p.ip_types ++ - pp (i+1) nextkwd + kwd ++ (if co then pp_coind p.ip_vars names.(i) else mt ()) ++ + pp_one_ind prefix ip_equiv p.ip_vars names.(i) cnames.(i) p.ip_types ++ + pp (i+1) nextkwd in pp 0 initkwd @@ -570,26 +570,26 @@ let pp_decl = function | Dind (kn,i) -> pp_mind kn i | Dtype (r, l, t) -> let name = pp_global Type r in - let l = rename_tvars keywords l in + let l = rename_tvars keywords l in let ids, def = - try - let ids,s = find_type_custom r in - pp_string_parameters ids, str " =" ++ spc () ++ str s - with Not_found -> - pp_parameters l, - if t == Taxiom then str " (* AXIOM TO BE REALIZED *)" - else str " =" ++ spc () ++ pp_type false l t - in - hov 2 (str "type " ++ ids ++ name ++ def) + try + let ids,s = find_type_custom r in + pp_string_parameters ids, str " =" ++ spc () ++ str s + with Not_found -> + pp_parameters l, + if t == Taxiom then str " (* AXIOM TO BE REALIZED *)" + else str " =" ++ spc () ++ pp_type false l t + in + hov 2 (str "type " ++ ids ++ name ++ def) | Dterm (r, a, t) -> - let def = - if is_custom r then str (" = " ^ find_custom r) - else pp_function (empty_env ()) a - in - let name = pp_global Term r in + let def = + if is_custom r then str (" = " ^ find_custom r) + else pp_function (empty_env ()) a + in + let name = pp_global Term r in pp_val name t ++ hov 0 (str "let " ++ name ++ def ++ mt ()) | Dfix (rv,defs,typs) -> - pp_Dfix (rv,defs,typs) + pp_Dfix (rv,defs,typs) let pp_spec = function | Sval (r,_) when is_inline_custom r -> mt () @@ -603,15 +603,15 @@ let pp_spec = function let name = pp_global Type r in let l = rename_tvars keywords vl in let ids, def = - try - let ids, s = find_type_custom r in - pp_string_parameters ids, str " =" ++ spc () ++ str s - with Not_found -> - let ids = pp_parameters l in - match ot with - | None -> ids, mt () - | Some Taxiom -> ids, str " (* AXIOM TO BE REALIZED *)" - | Some t -> ids, str " =" ++ spc () ++ pp_type false l t + try + let ids, s = find_type_custom r in + pp_string_parameters ids, str " =" ++ spc () ++ str s + with Not_found -> + let ids = pp_parameters l in + match ot with + | None -> ids, mt () + | Some Taxiom -> ids, str " (* AXIOM TO BE REALIZED *)" + | Some t -> ids, str " =" ++ spc () ++ pp_type false l t in hov 2 (str "type " ++ ids ++ name ++ def) @@ -621,8 +621,8 @@ let rec pp_specif = function (match Common.get_duplicate (top_visible_mp ()) l with | None -> pp_spec s | Some ren -> - hov 1 (str ("module "^ren^" : sig") ++ fnl () ++ pp_spec s) ++ - fnl () ++ str "end" ++ fnl () ++ + hov 1 (str ("module "^ren^" : sig") ++ fnl () ++ pp_spec s) ++ + fnl () ++ str "end" ++ fnl () ++ str ("include module type of struct include "^ren^" end")) | (l,Smodule mt) -> let def = pp_module_type [] mt in @@ -670,7 +670,7 @@ and pp_module_type params = function let mp_mt = msid_of_mt mt in let l,idl' = List.sep_last idl in let mp_w = - List.fold_left (fun mp l -> MPdot(mp,Label.of_id l)) mp_mt idl' + List.fold_left (fun mp l -> MPdot(mp,Label.of_id l)) mp_mt idl' in let r = GlobRef.ConstRef (Constant.make2 mp_w (Label.of_id l)) in push_visible mp_mt []; @@ -680,7 +680,7 @@ and pp_module_type params = function | MTwith(mt,ML_With_module(idl,mp)) -> let mp_mt = msid_of_mt mt in let mp_w = - List.fold_left (fun mp id -> MPdot(mp,Label.of_id id)) mp_mt idl + List.fold_left (fun mp id -> MPdot(mp,Label.of_id id)) mp_mt idl in push_visible mp_mt []; let pp_w = str " with module " ++ pp_modname mp_w in @@ -694,20 +694,20 @@ let rec pp_structure_elem = function (match Common.get_duplicate (top_visible_mp ()) l with | None -> pp_decl d | Some ren -> - hov 1 (str ("module "^ren^" = struct") ++ fnl () ++ pp_decl d) ++ - fnl () ++ str "end" ++ fnl () ++ str ("include "^ren)) + hov 1 (str ("module "^ren^" = struct") ++ fnl () ++ pp_decl d) ++ + fnl () ++ str "end" ++ fnl () ++ str ("include "^ren)) | (l,SEmodule m) -> let typ = (* virtual printing of the type, in order to have a correct mli later*) - if Common.get_phase () == Pre then - str ": " ++ pp_module_type [] m.ml_mod_type - else mt () + if Common.get_phase () == Pre then + str ": " ++ pp_module_type [] m.ml_mod_type + else mt () in let def = pp_module_expr [] m.ml_mod_expr in let name = pp_modname (MPdot (top_visible_mp (), l)) in hov 1 - (str "module " ++ name ++ typ ++ str " =" ++ - (if is_short m.ml_mod_expr then spc () else fnl ()) ++ def) ++ + (str "module " ++ name ++ typ ++ str " =" ++ + (if is_short m.ml_mod_expr then spc () else fnl ()) ++ def) ++ (match Common.get_duplicate (top_visible_mp ()) l with | Some ren -> fnl () ++ str ("module "^ren^" = ") ++ name | None -> mt ()) diff --git a/plugins/extraction/scheme.ml b/plugins/extraction/scheme.ml index c341ec8d57..c41b0d7a02 100644 --- a/plugins/extraction/scheme.ml +++ b/plugins/extraction/scheme.ml @@ -50,13 +50,13 @@ let pp_abst st = function | [] -> assert false | [id] -> paren (str "lambda " ++ paren (pr_id id) ++ spc () ++ st) | l -> paren - (str "lambdas " ++ paren (prlist_with_sep spc pr_id l) ++ spc () ++ st) + (str "lambdas " ++ paren (prlist_with_sep spc pr_id l) ++ spc () ++ st) let pp_apply st _ = function | [] -> st | [a] -> hov 2 (paren (st ++ spc () ++ a)) | args -> hov 2 (paren (str "@ " ++ st ++ - (prlist_strict (fun x -> spc () ++ x) args))) + (prlist_strict (fun x -> spc () ++ x) args))) (*s The pretty-printer for Scheme syntax *) @@ -68,66 +68,66 @@ let rec pp_expr env args = let apply st = pp_apply st true args in function | MLrel n -> - let id = get_db_name n env in apply (pr_id id) + let id = get_db_name n env in apply (pr_id id) | MLapp (f,args') -> - let stl = List.map (pp_expr env []) args' in + let stl = List.map (pp_expr env []) args' in pp_expr env (stl @ args) f | MLlam _ as a -> - let fl,a' = collect_lams a in - let fl,env' = push_vars (List.map id_of_mlid fl) env in - apply (pp_abst (pp_expr env' [] a') (List.rev fl)) + let fl,a' = collect_lams a in + let fl,env' = push_vars (List.map id_of_mlid fl) env in + apply (pp_abst (pp_expr env' [] a') (List.rev fl)) | MLletin (id,a1,a2) -> - let i,env' = push_vars [id_of_mlid id] env in - apply - (hv 0 - (hov 2 - (paren - (str "let " ++ - paren - (paren - (pr_id (List.hd i) ++ spc () ++ pp_expr env [] a1)) - ++ spc () ++ hov 0 (pp_expr env' [] a2))))) + let i,env' = push_vars [id_of_mlid id] env in + apply + (hv 0 + (hov 2 + (paren + (str "let " ++ + paren + (paren + (pr_id (List.hd i) ++ spc () ++ pp_expr env [] a1)) + ++ spc () ++ hov 0 (pp_expr env' [] a2))))) | MLglob r -> - apply (pp_global Term r) + apply (pp_global Term r) | MLcons (_,r,args') -> - assert (List.is_empty args); - let st = - str "`" ++ - paren (pp_global Cons r ++ - (if List.is_empty args' then mt () else spc ()) ++ - prlist_with_sep spc (pp_cons_args env) args') - in - if is_coinductive r then paren (str "delay " ++ st) else st + assert (List.is_empty args); + let st = + str "`" ++ + paren (pp_global Cons r ++ + (if List.is_empty args' then mt () else spc ()) ++ + prlist_with_sep spc (pp_cons_args env) args') + in + if is_coinductive r then paren (str "delay " ++ st) else st | MLtuple _ -> user_err Pp.(str "Cannot handle tuples in Scheme yet.") | MLcase (_,_,pv) when not (is_regular_match pv) -> - user_err Pp.(str "Cannot handle general patterns in Scheme yet.") + user_err Pp.(str "Cannot handle general patterns in Scheme yet.") | MLcase (_,t,pv) when is_custom_match pv -> - let mkfun (ids,_,e) = - if not (List.is_empty ids) then named_lams (List.rev ids) e - else dummy_lams (ast_lift 1 e) 1 - in - apply - (paren - (hov 2 - (str (find_custom_match pv) ++ fnl () ++ - prvect (fun tr -> pp_expr env [] (mkfun tr) ++ fnl ()) pv - ++ pp_expr env [] t))) + let mkfun (ids,_,e) = + if not (List.is_empty ids) then named_lams (List.rev ids) e + else dummy_lams (ast_lift 1 e) 1 + in + apply + (paren + (hov 2 + (str (find_custom_match pv) ++ fnl () ++ + prvect (fun tr -> pp_expr env [] (mkfun tr) ++ fnl ()) pv + ++ pp_expr env [] t))) | MLcase (typ,t, pv) -> let e = - if not (is_coinductive_type typ) then pp_expr env [] t - else paren (str "force" ++ spc () ++ pp_expr env [] t) - in - apply (v 3 (paren (str "match " ++ e ++ fnl () ++ pp_pat env pv))) + if not (is_coinductive_type typ) then pp_expr env [] t + else paren (str "force" ++ spc () ++ pp_expr env [] t) + in + apply (v 3 (paren (str "match " ++ e ++ fnl () ++ pp_pat env pv))) | MLfix (i,ids,defs) -> - let ids',env' = push_vars (List.rev (Array.to_list ids)) env in - pp_fix env' i (Array.of_list (List.rev ids'),defs) args + let ids',env' = push_vars (List.rev (Array.to_list ids)) env in + pp_fix env' i (Array.of_list (List.rev ids'),defs) args | MLexn s -> - (* An [MLexn] may be applied, but I don't really care. *) - paren (str "error" ++ spc () ++ qs s) + (* An [MLexn] may be applied, but I don't really care. *) + paren (str "error" ++ spc () ++ qs s) | MLdummy _ -> - str "__" (* An [MLdummy] may be applied, but I don't really care. *) + str "__" (* An [MLdummy] may be applied, but I don't really care. *) | MLmagic a -> - pp_expr env args a + pp_expr env args a | MLaxiom -> paren (str "error \"AXIOM TO BE REALIZED\"") | MLuint _ -> paren (str "Prelude.error \"EXTRACTION OF UINT NOT IMPLEMENTED\"") @@ -137,8 +137,8 @@ let rec pp_expr env args = and pp_cons_args env = function | MLcons (_,r,args) when is_coinductive r -> paren (pp_global Cons r ++ - (if List.is_empty args then mt () else spc ()) ++ - prlist_with_sep spc (pp_cons_args env) args) + (if List.is_empty args then mt () else spc ()) ++ + prlist_with_sep spc (pp_cons_args env) args) | e -> str "," ++ pp_expr env [] e and pp_one_pat env (ids,p,t) = @@ -166,12 +166,12 @@ and pp_fix env j (ids,bl) args = paren (str "letrec " ++ (v 0 (paren - (prvect_with_sep fnl - (fun (fi,ti) -> - paren ((pr_id fi) ++ spc () ++ (pp_expr env [] ti))) - (Array.map2 (fun id b -> (id,b)) ids bl)) ++ - fnl () ++ - hov 2 (pp_apply (pr_id (ids.(j))) true args)))) + (prvect_with_sep fnl + (fun (fi,ti) -> + paren ((pr_id fi) ++ spc () ++ (pp_expr env [] ti))) + (Array.map2 (fun id b -> (id,b)) ids bl)) ++ + fnl () ++ + hov 2 (pp_apply (pr_id (ids.(j))) true args)))) (*s Pretty-printing of a declaration. *) @@ -180,29 +180,29 @@ let pp_decl = function | Dtype _ -> mt () | Dfix (rv, defs,_) -> let names = Array.map - (fun r -> if is_inline_custom r then mt () else pp_global Term r) rv + (fun r -> if is_inline_custom r then mt () else pp_global Term r) rv in prvecti - (fun i r -> - let void = is_inline_custom r || - (not (is_custom r) && + (fun i r -> + let void = is_inline_custom r || + (not (is_custom r) && match defs.(i) with MLexn "UNUSED" -> true | _ -> false) - in - if void then mt () - else - hov 2 - (paren (str "define " ++ names.(i) ++ spc () ++ - (if is_custom r then str (find_custom r) - else pp_expr (empty_env ()) [] defs.(i))) - ++ fnl ()) ++ fnl ()) - rv + in + if void then mt () + else + hov 2 + (paren (str "define " ++ names.(i) ++ spc () ++ + (if is_custom r then str (find_custom r) + else pp_expr (empty_env ()) [] defs.(i))) + ++ fnl ()) ++ fnl ()) + rv | Dterm (r, a, _) -> if is_inline_custom r then mt () else - hov 2 (paren (str "define " ++ pp_global Term r ++ spc () ++ - (if is_custom r then str (find_custom r) - else pp_expr (empty_env ()) [] a))) - ++ fnl2 () + hov 2 (paren (str "define " ++ pp_global Term r ++ spc () ++ + (if is_custom r then str (find_custom r) + else pp_expr (empty_env ()) [] a))) + ++ fnl2 () let rec pp_structure_elem = function | (l,SEdecl d) -> pp_decl d diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index be9259861a..7b64706138 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -289,7 +289,7 @@ let safe_pr_long_global r = with Not_found -> match r with | GlobRef.ConstRef kn -> let mp,l = Constant.repr2 kn in - str ((ModPath.to_string mp)^"."^(Label.to_string l)) + str ((ModPath.to_string mp)^"."^(Label.to_string l)) | _ -> assert false let pr_long_mp mp = @@ -339,10 +339,10 @@ let warn_extraction_opaque_accessed = let warn_extraction_opaque_as_axiom = CWarnings.create ~name:"extraction-opaque-as-axiom" ~category:"extraction" (fun lst -> strbrk "The extraction now honors the opacity constraints by default, " ++ - strbrk "the following opaque constants have been extracted as axioms :" ++ - lst ++ str "." ++ fnl () ++ - strbrk "If necessary, use \"Set Extraction AccessOpaque\" to change this." - ++ fnl ()) + strbrk "the following opaque constants have been extracted as axioms :" ++ + lst ++ str "." ++ fnl () ++ + strbrk "If necessary, use \"Set Extraction AccessOpaque\" to change this." + ++ fnl ()) let warning_opaques accessed = let opaques = Refset'.elements !opaques in @@ -375,14 +375,14 @@ let warn_extraction_inside_module = let check_inside_module () = if Lib.is_modtype () then err (str "You can't do that within a Module Type." ++ fnl () ++ - str "Close it and try again.") + str "Close it and try again.") else if Lib.is_module () then warn_extraction_inside_module () let check_inside_section () = if Global.sections_are_opened () then err (str "You can't do that within a section." ++ fnl () ++ - str "Close it and try again.") + str "Close it and try again.") let warn_extraction_reserved_identifier = CWarnings.create ~name:"extraction-reserved-identifier" ~category:"extraction" @@ -441,9 +441,9 @@ let error_MPfile_as_mod mp b = let s1 = if b then "asked" else "required" in let s2 = if b then "extract some objects of this module or\n" else "" in err (str ("Extraction of file "^(raw_string_of_modfile mp)^ - ".v as a module is "^s1^".\n"^ - "Monolithic Extraction cannot deal with this situation.\n"^ - "Please "^s2^"use (Recursive) Extraction Library instead.\n")) + ".v as a module is "^s1^".\n"^ + "Monolithic Extraction cannot deal with this situation.\n"^ + "Please "^s2^"use (Recursive) Extraction Library instead.\n")) let argnames_of_global r = let env = Global.env () in @@ -481,10 +481,10 @@ let warning_remaining_implicit k = let check_loaded_modfile mp = match base_mp mp with | MPfile dp -> if not (Library.library_is_loaded dp) then begin - match base_mp (Lib.current_mp ()) with - | MPfile dp' when not (DirPath.equal dp dp') -> + match base_mp (Lib.current_mp ()) with + | MPfile dp' when not (DirPath.equal dp dp') -> err (str "Please load library " ++ DirPath.print dp ++ str " first.") - | _ -> () + | _ -> () end | _ -> () @@ -574,11 +574,11 @@ let chg_flag n = int_flag_ref := n; opt_flag_ref := flag_of_int n let optims () = !opt_flag_ref let () = declare_bool_option - {optdepr = false; - optname = "Extraction Optimize"; - optkey = ["Extraction"; "Optimize"]; - optread = (fun () -> not (Int.equal !int_flag_ref 0)); - optwrite = (fun b -> chg_flag (if b then int_flag_init else 0))} + {optdepr = false; + optname = "Extraction Optimize"; + optkey = ["Extraction"; "Optimize"]; + optread = (fun () -> not (Int.equal !int_flag_ref 0)); + optwrite = (fun b -> chg_flag (if b then int_flag_init else 0))} let () = declare_int_option { optdepr = false; @@ -671,11 +671,11 @@ let print_extraction_inline () = (str "Extraction Inline:" ++ fnl () ++ Refset'.fold (fun r p -> - (p ++ str " " ++ safe_pr_long_global r ++ fnl ())) i' (mt ()) ++ + (p ++ str " " ++ safe_pr_long_global r ++ fnl ())) i' (mt ()) ++ str "Extraction NoInline:" ++ fnl () ++ Refset'.fold (fun r p -> - (p ++ str " " ++ safe_pr_long_global r ++ fnl ())) n (mt ())) + (p ++ str " " ++ safe_pr_long_global r ++ fnl ())) n (mt ())) (* Reset part *) @@ -708,16 +708,16 @@ let add_implicits r l = let n = List.length names in let add_arg s = function | ArgInt i -> - if 1 <= i && i <= n then Int.Set.add i s - else err (int i ++ str " is not a valid argument number for " ++ - safe_pr_global r) + if 1 <= i && i <= n then Int.Set.add i s + else err (int i ++ str " is not a valid argument number for " ++ + safe_pr_global r) | ArgId id -> try let i = List.index Name.equal (Name id) names in Int.Set.add i s with Not_found -> - err (str "No argument " ++ Id.print id ++ str " for " ++ - safe_pr_global r) + err (str "No argument " ++ Id.print id ++ str " for " ++ + safe_pr_global r) in let ints = List.fold_left add_arg Int.Set.empty l in implicits_table := Refmap'.add r ints !implicits_table @@ -854,16 +854,16 @@ let extract_constant_inline inline r ids s = let g = Smartlocate.global_with_alias r in match g with | GlobRef.ConstRef kn -> - let env = Global.env () in + let env = Global.env () in let typ, _ = Typeops.type_of_global_in_context env (GlobRef.ConstRef kn) in - let typ = Reduction.whd_all env typ in - if Reduction.is_arity env typ - then begin - let nargs = Hook.get use_type_scheme_nb_args env typ in - if not (Int.equal (List.length ids) nargs) then error_axiom_scheme g nargs - end; - Lib.add_anonymous_leaf (inline_extraction (inline,[g])); - Lib.add_anonymous_leaf (in_customs (g,ids,s)) + let typ = Reduction.whd_all env typ in + if Reduction.is_arity env typ + then begin + let nargs = Hook.get use_type_scheme_nb_args env typ in + if not (Int.equal (List.length ids) nargs) then error_axiom_scheme g nargs + end; + Lib.add_anonymous_leaf (inline_extraction (inline,[g])); + Lib.add_anonymous_leaf (in_customs (g,ids,s)) | _ -> error_constant g @@ -873,18 +873,18 @@ let extract_inductive r s l optstr = Dumpglob.add_glob ?loc:r.CAst.loc g; match g with | GlobRef.IndRef ((kn,i) as ip) -> - let mib = Global.lookup_mind kn in - let n = Array.length mib.mind_packets.(i).mind_consnames in - if not (Int.equal n (List.length l)) then error_nb_cons (); - Lib.add_anonymous_leaf (inline_extraction (true,[g])); - Lib.add_anonymous_leaf (in_customs (g,[],s)); - Option.iter (fun s -> Lib.add_anonymous_leaf (in_custom_matchs (g,s))) - optstr; - List.iteri - (fun j s -> + let mib = Global.lookup_mind kn in + let n = Array.length mib.mind_packets.(i).mind_consnames in + if not (Int.equal n (List.length l)) then error_nb_cons (); + Lib.add_anonymous_leaf (inline_extraction (true,[g])); + Lib.add_anonymous_leaf (in_customs (g,[],s)); + Option.iter (fun s -> Lib.add_anonymous_leaf (in_custom_matchs (g,s))) + optstr; + List.iteri + (fun j s -> let g = GlobRef.ConstructRef (ip,succ j) in - Lib.add_anonymous_leaf (inline_extraction (true,[g])); - Lib.add_anonymous_leaf (in_customs (g,[],s))) l + Lib.add_anonymous_leaf (inline_extraction (true,[g])); + Lib.add_anonymous_leaf (in_customs (g,[],s))) l | _ -> error_inductive g diff --git a/plugins/firstorder/formula.ml b/plugins/firstorder/formula.ml index fb363b9393..38dd8992bc 100644 --- a/plugins/firstorder/formula.ml +++ b/plugins/firstorder/formula.ml @@ -41,7 +41,7 @@ let meta_succ m = m+1 let rec nb_prod_after n c= match Constr.kind c with | Prod (_,_,b) ->if n>0 then nb_prod_after (n-1) b else - 1+(nb_prod_after 0 b) + 1+(nb_prod_after 0 b) | _ -> 0 let construct_nhyps env ind = @@ -82,40 +82,40 @@ let kind_of_formula env sigma term = let normalize = special_nf env sigma in let cciterm = special_whd env sigma term in match match_with_imp_term env sigma cciterm with - Some (a,b)-> Arrow (a, pop b) + Some (a,b)-> Arrow (a, pop b) |_-> match match_with_forall_term env sigma cciterm with - Some (_,a,b)-> Forall (a, b) - |_-> + Some (_,a,b)-> Forall (a, b) + |_-> match match_with_nodep_ind env sigma cciterm with - Some (i,l,n)-> - let ind,u=EConstr.destInd sigma i in - let u = EConstr.EInstance.kind sigma u in - let (mib,mip) = Global.lookup_inductive ind in - let nconstr=Array.length mip.mind_consnames in - if Int.equal nconstr 0 then - False((ind,u),l) - else - let has_realargs=(n>0) in - let is_trivial= + Some (i,l,n)-> + let ind,u=EConstr.destInd sigma i in + let u = EConstr.EInstance.kind sigma u in + let (mib,mip) = Global.lookup_inductive ind in + let nconstr=Array.length mip.mind_consnames in + if Int.equal nconstr 0 then + False((ind,u),l) + else + let has_realargs=(n>0) in + let is_trivial= let is_constant n = Int.equal n 0 in Array.exists is_constant mip.mind_consnrealargs in - if Inductiveops.mis_is_recursive (ind,mib,mip) || - (has_realargs && not is_trivial) - then - Atom cciterm - else - if Int.equal nconstr 1 then - And((ind,u),l,is_trivial) - else - Or((ind,u),l,is_trivial) - | _ -> + if Inductiveops.mis_is_recursive (ind,mib,mip) || + (has_realargs && not is_trivial) + then + Atom cciterm + else + if Int.equal nconstr 1 then + And((ind,u),l,is_trivial) + else + Or((ind,u),l,is_trivial) + | _ -> match match_with_sigma_type env sigma cciterm with - Some (i,l)-> + Some (i,l)-> let (ind, u) = EConstr.destInd sigma i in let u = EConstr.EInstance.kind sigma u in Exists((ind, u), l) - |_-> Atom (normalize cciterm) + |_-> Atom (normalize cciterm) type atoms = {positive:constr list;negative:constr list} @@ -132,52 +132,52 @@ let build_atoms env sigma metagen side cciterm = let normalize=special_nf env sigma in let rec build_rec subst polarity cciterm= match kind_of_formula env sigma cciterm with - False(_,_)->if not polarity then trivial:=true + False(_,_)->if not polarity then trivial:=true | Arrow (a,b)-> - build_rec subst (not polarity) a; - build_rec subst polarity b + build_rec subst (not polarity) a; + build_rec subst polarity b | And(i,l,b) | Or(i,l,b)-> - if b then - begin - let unsigned=normalize (substnl subst 0 cciterm) in - if polarity then - positive:= unsigned :: !positive - else - negative:= unsigned :: !negative - end; - let v = ind_hyps env sigma 0 i l in - let g i _ decl = - build_rec subst polarity (lift i (RelDecl.get_type decl)) in - let f l = - List.fold_left_i g (1-(List.length l)) () l in - if polarity && (* we have a constant constructor *) - Array.exists (function []->true|_->false) v - then trivial:=true; - Array.iter f v + if b then + begin + let unsigned=normalize (substnl subst 0 cciterm) in + if polarity then + positive:= unsigned :: !positive + else + negative:= unsigned :: !negative + end; + let v = ind_hyps env sigma 0 i l in + let g i _ decl = + build_rec subst polarity (lift i (RelDecl.get_type decl)) in + let f l = + List.fold_left_i g (1-(List.length l)) () l in + if polarity && (* we have a constant constructor *) + Array.exists (function []->true|_->false) v + then trivial:=true; + Array.iter f v | Exists(i,l)-> - let var=mkMeta (metagen true) in - let v =(ind_hyps env sigma 1 i l).(0) in - let g i _ decl = - build_rec (var::subst) polarity (lift i (RelDecl.get_type decl)) in - List.fold_left_i g (2-(List.length l)) () v + let var=mkMeta (metagen true) in + let v =(ind_hyps env sigma 1 i l).(0) in + let g i _ decl = + build_rec (var::subst) polarity (lift i (RelDecl.get_type decl)) in + List.fold_left_i g (2-(List.length l)) () v | Forall(_,b)-> - let var=mkMeta (metagen true) in - build_rec (var::subst) polarity b + let var=mkMeta (metagen true) in + build_rec (var::subst) polarity b | Atom t-> - let unsigned=substnl subst 0 t in - if not (isMeta sigma unsigned) then (* discarding wildcard atoms *) - if polarity then - positive:= unsigned :: !positive - else - negative:= unsigned :: !negative in + let unsigned=substnl subst 0 t in + if not (isMeta sigma unsigned) then (* discarding wildcard atoms *) + if polarity then + positive:= unsigned :: !positive + else + negative:= unsigned :: !negative in begin match side with - Concl -> build_rec [] true cciterm - | Hyp -> build_rec [] false cciterm - | Hint -> - let rels,head=decompose_prod sigma cciterm in - let subst=List.rev_map (fun _->mkMeta (metagen true)) rels in - build_rec subst false head;trivial:=false (* special for hints *) + Concl -> build_rec [] true cciterm + | Hyp -> build_rec [] false cciterm + | Hint -> + let rels,head=decompose_prod sigma cciterm in + let subst=List.rev_map (fun _->mkMeta (metagen true)) rels in + build_rec subst false head;trivial:=false (* special for hints *) end; (!trivial, {positive= !positive; @@ -209,65 +209,65 @@ type left_pattern= | LA of constr*left_arrow_pattern type t={id:GlobRef.t; - constr:constr; - pat:(left_pattern,right_pattern) sum; - atoms:atoms} + constr:constr; + pat:(left_pattern,right_pattern) sum; + atoms:atoms} let build_formula env sigma side nam typ metagen= let normalize = special_nf env sigma in try let m=meta_succ(metagen false) in let trivial,atoms= - if !qflag then - build_atoms env sigma metagen side typ - else no_atoms in + if !qflag then + build_atoms env sigma metagen side typ + else no_atoms in let pattern= - match side with - Concl -> - let pat= - match kind_of_formula env sigma typ with - False(_,_) -> Rfalse - | Atom a -> raise (Is_atom a) - | And(_,_,_) -> Rand - | Or(_,_,_) -> Ror - | Exists (i,l) -> - let d = RelDecl.get_type (List.last (ind_hyps env sigma 0 i l).(0)) in - Rexists(m,d,trivial) - | Forall (_,a) -> Rforall - | Arrow (a,b) -> Rarrow in - Right pat - | _ -> - let pat= - match kind_of_formula env sigma typ with - False(i,_) -> Lfalse - | Atom a -> raise (Is_atom a) - | And(i,_,b) -> - if b then - let nftyp=normalize typ in raise (Is_atom nftyp) - else Land i - | Or(i,_,b) -> - if b then - let nftyp=normalize typ in raise (Is_atom nftyp) - else Lor i - | Exists (ind,_) -> Lexists ind - | Forall (d,_) -> - Lforall(m,d,trivial) - | Arrow (a,b) -> - let nfa=normalize a in - LA (nfa, - match kind_of_formula env sigma a with - False(i,l)-> LLfalse(i,l) - | Atom t-> LLatom - | And(i,l,_)-> LLand(i,l) - | Or(i,l,_)-> LLor(i,l) - | Arrow(a,c)-> LLarrow(a,c,b) - | Exists(i,l)->LLexists(i,l) - | Forall(_,_)->LLforall a) in - Left pat + match side with + Concl -> + let pat= + match kind_of_formula env sigma typ with + False(_,_) -> Rfalse + | Atom a -> raise (Is_atom a) + | And(_,_,_) -> Rand + | Or(_,_,_) -> Ror + | Exists (i,l) -> + let d = RelDecl.get_type (List.last (ind_hyps env sigma 0 i l).(0)) in + Rexists(m,d,trivial) + | Forall (_,a) -> Rforall + | Arrow (a,b) -> Rarrow in + Right pat + | _ -> + let pat= + match kind_of_formula env sigma typ with + False(i,_) -> Lfalse + | Atom a -> raise (Is_atom a) + | And(i,_,b) -> + if b then + let nftyp=normalize typ in raise (Is_atom nftyp) + else Land i + | Or(i,_,b) -> + if b then + let nftyp=normalize typ in raise (Is_atom nftyp) + else Lor i + | Exists (ind,_) -> Lexists ind + | Forall (d,_) -> + Lforall(m,d,trivial) + | Arrow (a,b) -> + let nfa=normalize a in + LA (nfa, + match kind_of_formula env sigma a with + False(i,l)-> LLfalse(i,l) + | Atom t-> LLatom + | And(i,l,_)-> LLand(i,l) + | Or(i,l,_)-> LLor(i,l) + | Arrow(a,c)-> LLarrow(a,c,b) + | Exists(i,l)->LLexists(i,l) + | Forall(_,_)->LLforall a) in + Left pat in - Left {id=nam; - constr=normalize typ; - pat=pattern; - atoms=atoms} + Left {id=nam; + constr=normalize typ; + pat=pattern; + atoms=atoms} with Is_atom a-> Right a (* already in nf *) diff --git a/plugins/firstorder/formula.mli b/plugins/firstorder/formula.mli index dc422fa284..b8a619d1e6 100644 --- a/plugins/firstorder/formula.mli +++ b/plugins/firstorder/formula.mli @@ -66,9 +66,9 @@ type left_pattern= | LA of constr*left_arrow_pattern type t={id: GlobRef.t; - constr: constr; - pat: (left_pattern,right_pattern) sum; - atoms: atoms} + constr: constr; + pat: (left_pattern,right_pattern) sum; + atoms: atoms} (*exception Is_atom of constr*) diff --git a/plugins/firstorder/g_ground.mlg b/plugins/firstorder/g_ground.mlg index 35cd10a1ff..2bc79d45d4 100644 --- a/plugins/firstorder/g_ground.mlg +++ b/plugins/firstorder/g_ground.mlg @@ -41,7 +41,7 @@ let ()= optread=(fun ()->Some !ground_depth); optwrite= (function - None->ground_depth:=3 + None->ground_depth:=3 | Some i->ground_depth:=(max i 0))} in declare_int_option gdopt @@ -68,7 +68,7 @@ let default_intuition_tac = Tacenv.register_ml_tactic name [| tac |]; Tacexpr.TacML (CAst.make (entry, [])) -let (set_default_solver, default_solver, print_default_solver) = +let (set_default_solver, default_solver, print_default_solver) = Tactic_option.declare_tactic_option ~default:default_intuition_tac "Firstorder default solver" } @@ -95,12 +95,12 @@ let gen_ground_tac flag taco ids bases = Proofview.Goal.enter begin fun gl -> qflag:=flag; let solver= - match taco with - Some tac-> tac - | None-> snd (default_solver ()) in + match taco with + Some tac-> tac + | None-> snd (default_solver ()) in let startseq k = Proofview.Goal.enter begin fun gl -> - let seq=empty_seq !ground_depth in + let seq=empty_seq !ground_depth in let seq, sigma = extend_with_ref_list (pf_env gl) (project gl) ids seq in let seq, sigma = extend_with_auto_hints (pf_env gl) (project gl) bases seq in tclTHEN (Proofview.Unsafe.tclEVARS sigma) (k seq) @@ -124,10 +124,10 @@ let defined_connectives=lazy let normalize_evaluables= onAllHypsAndConcl (function - None->unfold_in_concl (Lazy.force defined_connectives) + None->unfold_in_concl (Lazy.force defined_connectives) | Some id-> - unfold_in_hyp (Lazy.force defined_connectives) - (Tacexpr.InHypType id)) *) + unfold_in_hyp (Lazy.force defined_connectives) + (Tacexpr.InHypType id)) *) open Ppconstr open Printer diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml index e134562702..2f26226f4e 100644 --- a/plugins/firstorder/ground.ml +++ b/plugins/firstorder/ground.ml @@ -41,89 +41,89 @@ let ground_tac solver startseq = in tclORELSE (axiom_tac seq.gl seq) begin - try - let (hd,seq1)=take_formula (project gl) seq - and re_add s=re_add_formula_list (project gl) skipped s in - let continue=toptac [] - and backtrack =toptac (hd::skipped) seq1 in - match hd.pat with - Right rpat-> - begin - match rpat with - Rand-> - and_tac backtrack continue (re_add seq1) - | Rforall-> - let backtrack1= - if !qflag then - tclFAIL 0 (Pp.str "reversible in 1st order mode") - else - backtrack in - forall_tac backtrack1 continue (re_add seq1) - | Rarrow-> - arrow_tac backtrack continue (re_add seq1) - | Ror-> - or_tac backtrack continue (re_add seq1) - | Rfalse->backtrack - | Rexists(i,dom,triv)-> - let (lfp,seq2)=collect_quantified (project gl) seq in - let backtrack2=toptac (lfp@skipped) seq2 in - if !qflag && seq.depth>0 then - quantified_tac lfp backtrack2 - continue (re_add seq) - else - backtrack2 (* need special backtracking *) - end - | Left lpat-> - begin - match lpat with - Lfalse-> - left_false_tac hd.id - | Land ind-> - left_and_tac ind backtrack - hd.id continue (re_add seq1) - | Lor ind-> - left_or_tac ind backtrack - hd.id continue (re_add seq1) - | Lforall (_,_,_)-> - let (lfp,seq2)=collect_quantified (project gl) seq in - let backtrack2=toptac (lfp@skipped) seq2 in - if !qflag && seq.depth>0 then - quantified_tac lfp backtrack2 - continue (re_add seq) - else - backtrack2 (* need special backtracking *) - | Lexists ind -> - if !qflag then - left_exists_tac ind backtrack hd.id - continue (re_add seq1) - else backtrack - | LA (typ,lap)-> - let la_tac= - begin - match lap with - LLatom -> backtrack - | LLand (ind,largs) | LLor(ind,largs) - | LLfalse (ind,largs)-> - (ll_ind_tac ind largs backtrack - hd.id continue (re_add seq1)) - | LLforall p -> - if seq.depth>0 && !qflag then - (ll_forall_tac p backtrack - hd.id continue (re_add seq1)) - else backtrack - | LLexists (ind,l) -> - if !qflag then - ll_ind_tac ind l backtrack - hd.id continue (re_add seq1) - else - backtrack - | LLarrow (a,b,c) -> - (ll_arrow_tac a b c backtrack - hd.id continue (re_add seq1)) - end in - ll_atom_tac typ la_tac hd.id continue (re_add seq1) - end - with Heap.EmptyHeap->solver + try + let (hd,seq1)=take_formula (project gl) seq + and re_add s=re_add_formula_list (project gl) skipped s in + let continue=toptac [] + and backtrack =toptac (hd::skipped) seq1 in + match hd.pat with + Right rpat-> + begin + match rpat with + Rand-> + and_tac backtrack continue (re_add seq1) + | Rforall-> + let backtrack1= + if !qflag then + tclFAIL 0 (Pp.str "reversible in 1st order mode") + else + backtrack in + forall_tac backtrack1 continue (re_add seq1) + | Rarrow-> + arrow_tac backtrack continue (re_add seq1) + | Ror-> + or_tac backtrack continue (re_add seq1) + | Rfalse->backtrack + | Rexists(i,dom,triv)-> + let (lfp,seq2)=collect_quantified (project gl) seq in + let backtrack2=toptac (lfp@skipped) seq2 in + if !qflag && seq.depth>0 then + quantified_tac lfp backtrack2 + continue (re_add seq) + else + backtrack2 (* need special backtracking *) + end + | Left lpat-> + begin + match lpat with + Lfalse-> + left_false_tac hd.id + | Land ind-> + left_and_tac ind backtrack + hd.id continue (re_add seq1) + | Lor ind-> + left_or_tac ind backtrack + hd.id continue (re_add seq1) + | Lforall (_,_,_)-> + let (lfp,seq2)=collect_quantified (project gl) seq in + let backtrack2=toptac (lfp@skipped) seq2 in + if !qflag && seq.depth>0 then + quantified_tac lfp backtrack2 + continue (re_add seq) + else + backtrack2 (* need special backtracking *) + | Lexists ind -> + if !qflag then + left_exists_tac ind backtrack hd.id + continue (re_add seq1) + else backtrack + | LA (typ,lap)-> + let la_tac= + begin + match lap with + LLatom -> backtrack + | LLand (ind,largs) | LLor(ind,largs) + | LLfalse (ind,largs)-> + (ll_ind_tac ind largs backtrack + hd.id continue (re_add seq1)) + | LLforall p -> + if seq.depth>0 && !qflag then + (ll_forall_tac p backtrack + hd.id continue (re_add seq1)) + else backtrack + | LLexists (ind,l) -> + if !qflag then + ll_ind_tac ind l backtrack + hd.id continue (re_add seq1) + else + backtrack + | LLarrow (a,b,c) -> + (ll_arrow_tac a b c backtrack + hd.id continue (re_add seq1)) + end in + ll_atom_tac typ la_tac hd.id continue (re_add seq1) + end + with Heap.EmptyHeap->solver end end in let n = List.length (Proofview.Goal.hyps gl) in diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index eff0db5bf4..e131cad7da 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -26,13 +26,13 @@ open Context.Rel.Declaration let compare_instance inst1 inst2= let cmp c1 c2 = Constr.compare (EConstr.Unsafe.to_constr c1) (EConstr.Unsafe.to_constr c2) in - match inst1,inst2 with - Phantom(d1),Phantom(d2)-> - (cmp d1 d2) - | Real((m1,c1),n1),Real((m2,c2),n2)-> - ((-) =? (-) ==? cmp) m2 m1 n1 n2 c1 c2 - | Phantom(_),Real((m,_),_)-> if Int.equal m 0 then -1 else 1 - | Real((m,_),_),Phantom(_)-> if Int.equal m 0 then 1 else -1 + match inst1,inst2 with + Phantom(d1),Phantom(d2)-> + (cmp d1 d2) + | Real((m1,c1),n1),Real((m2,c2),n2)-> + ((-) =? (-) ==? cmp) m2 m1 n1 n2 c1 c2 + | Phantom(_),Real((m,_),_)-> if Int.equal m 0 then -1 else 1 + | Real((m,_),_),Phantom(_)-> if Int.equal m 0 then 1 else -1 let compare_gr id1 id2 = if id1==id2 then 0 else @@ -53,7 +53,7 @@ module IS=Set.Make(OrderedInstance) let make_simple_atoms seq= let ratoms= match seq.glatom with - Some t->[t] + Some t->[t] | None->[] in {negative=seq.latoms;positive=ratoms} @@ -63,9 +63,9 @@ let do_sequent sigma setref triv id seq i dom atoms= let do_atoms a1 a2 = let do_pair t1 t2 = match unif_atoms sigma i dom t1 t2 with - None->() - | Some (Phantom _) ->phref:=true - | Some c ->flag:=false;setref:=IS.add (c,id) !setref in + None->() + | Some (Phantom _) ->phref:=true + | Some c ->flag:=false;setref:=IS.add (c,id) !setref in List.iter (fun t->List.iter (do_pair t) a2.negative) a1.positive; List.iter (fun t->List.iter (do_pair t) a2.positive) a1.negative in HP.iter (fun lf->do_atoms atoms lf.atoms) seq.redexes; @@ -75,8 +75,8 @@ let do_sequent sigma setref triv id seq i dom atoms= let match_one_quantified_hyp sigma setref seq lf= match lf.pat with Left(Lforall(i,dom,triv))|Right(Rexists(i,dom,triv))-> - if do_sequent sigma setref triv lf.id seq i dom lf.atoms then - setref:=IS.add ((Phantom dom),lf.id) !setref + if do_sequent sigma setref triv lf.id seq i dom lf.atoms then + setref:=IS.add ((Phantom dom),lf.id) !setref | _ -> anomaly (Pp.str "can't happen.") let give_instances sigma lf seq= @@ -90,10 +90,10 @@ let rec collect_quantified sigma seq= try let hd,seq1=take_formula sigma seq in (match hd.pat with - Left(Lforall(_,_,_)) | Right(Rexists(_,_,_)) -> - let (q,seq2)=collect_quantified sigma seq1 in - ((hd::q),seq2) - | _->[],seq) + Left(Lforall(_,_,_)) | Right(Rexists(_,_,_)) -> + let (q,seq2)=collect_quantified sigma seq1 in + ((hd::q),seq2) + | _->[],seq) with Heap.EmptyHeap -> [],seq (* open instances processor *) @@ -104,19 +104,19 @@ let mk_open_instance env evmap id idc m t = let var_id= if id==dummy_id then dummy_bvid else let typ=Typing.unsafe_type_of env evmap idc in - (* since we know we will get a product, - reduction is not too expensive *) + (* since we know we will get a product, + reduction is not too expensive *) let (nam,_,_)=destProd evmap (whd_all env evmap typ) in match nam.Context.binder_name with - Name id -> id - | Anonymous -> dummy_bvid in + Name id -> id + | Anonymous -> dummy_bvid in let revt=substl (List.init m (fun i->mkRel (m-i))) t in let rec aux n avoid env evmap decls = if Int.equal n 0 then evmap, decls else let nid=(fresh_id_in_env avoid var_id env) in let (evmap, (c, _)) = Evarutil.new_type_evar env evmap Evd.univ_flexible in let decl = LocalAssum (Context.make_annot (Name nid) Sorts.Relevant, c) in - aux (n-1) (Id.Set.add nid avoid) (EConstr.push_rel decl env) evmap (decl::decls) in + aux (n-1) (Id.Set.add nid avoid) (EConstr.push_rel decl env) evmap (decl::decls) in let evmap, decls = aux m Id.Set.empty env evmap [] in (evmap, decls, revt) @@ -128,49 +128,49 @@ let left_instance_tac (inst,id) continue seq= let sigma = project gl in match inst with Phantom dom-> - if lookup sigma (id,None) seq then - tclFAIL 0 (Pp.str "already done") - else - tclTHENS (cut dom) - [tclTHENLIST - [introf; + if lookup sigma (id,None) seq then + tclFAIL 0 (Pp.str "already done") + else + tclTHENS (cut dom) + [tclTHENLIST + [introf; (pf_constr_of_global id >>= fun idc -> Proofview.Goal.enter begin fun gl -> let id0 = List.nth (pf_ids_of_hyps gl) 0 in generalize [mkApp(idc, [|mkVar id0|])] end); - introf; - tclSOLVE [wrap 1 false continue - (deepen (record (id,None) seq))]]; - tclTRY assumption] + introf; + tclSOLVE [wrap 1 false continue + (deepen (record (id,None) seq))]]; + tclTRY assumption] | Real((m,t),_)-> let c = (m, EConstr.to_constr sigma t) in - if lookup sigma (id,Some c) seq then - tclFAIL 0 (Pp.str "already done") - else - let special_generalize= - if m>0 then - (pf_constr_of_global id >>= fun idc -> - Proofview.Goal.enter begin fun gl-> - let (evmap, rc, ot) = mk_open_instance (pf_env gl) (project gl) id idc m t in - let gt= - it_mkLambda_or_LetIn - (mkApp(idc,[|ot|])) rc in - let evmap, _ = - try Typing.type_of (pf_env gl) evmap gt - with e when CErrors.noncritical e -> - user_err Pp.(str "Untypable instance, maybe higher-order non-prenex quantification") in + if lookup sigma (id,Some c) seq then + tclFAIL 0 (Pp.str "already done") + else + let special_generalize= + if m>0 then + (pf_constr_of_global id >>= fun idc -> + Proofview.Goal.enter begin fun gl-> + let (evmap, rc, ot) = mk_open_instance (pf_env gl) (project gl) id idc m t in + let gt= + it_mkLambda_or_LetIn + (mkApp(idc,[|ot|])) rc in + let evmap, _ = + try Typing.type_of (pf_env gl) evmap gt + with e when CErrors.noncritical e -> + user_err Pp.(str "Untypable instance, maybe higher-order non-prenex quantification") in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS evmap) - (generalize [gt]) + (generalize [gt]) end) - else - pf_constr_of_global id >>= fun idc -> generalize [mkApp(idc,[|t|])] - in - tclTHENLIST - [special_generalize; - introf; - tclSOLVE - [wrap 1 false continue (deepen (record (id,Some c) seq))]] + else + pf_constr_of_global id >>= fun idc -> generalize [mkApp(idc,[|t|])] + in + tclTHENLIST + [special_generalize; + introf; + tclSOLVE + [wrap 1 false continue (deepen (record (id,Some c) seq))]] end let right_instance_tac inst continue seq= @@ -178,20 +178,20 @@ let right_instance_tac inst continue seq= Proofview.Goal.enter begin fun gl -> match inst with Phantom dom -> - tclTHENS (cut dom) - [tclTHENLIST - [introf; + tclTHENS (cut dom) + [tclTHENLIST + [introf; Proofview.Goal.enter begin fun gl -> let id0 = List.nth (pf_ids_of_hyps gl) 0 in split (Tactypes.ImplicitBindings [mkVar id0]) end; - tclSOLVE [wrap 0 true continue (deepen seq)]]; - tclTRY assumption] + tclSOLVE [wrap 0 true continue (deepen seq)]]; + tclTRY assumption] | Real ((0,t),_) -> (tclTHEN (split (Tactypes.ImplicitBindings [t])) - (tclSOLVE [wrap 0 true continue (deepen seq)])) + (tclSOLVE [wrap 0 true continue (deepen seq)])) | Real ((m,t),_) -> - tclFAIL 0 (Pp.str "not implemented ... yet") + tclFAIL 0 (Pp.str "not implemented ... yet") end let instance_tac inst= diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml index 79386f7ac9..3413db930b 100644 --- a/plugins/firstorder/rules.ml +++ b/plugins/firstorder/rules.ml @@ -40,13 +40,13 @@ let wrap n b continue seq = let rec aux i nc ctx= if i<=0 then seq else match nc with - []->anomaly (Pp.str "Not the expected number of hyps.") - | nd::q-> + []->anomaly (Pp.str "Not the expected number of hyps.") + | nd::q-> let id = NamedDecl.get_id nd in - if occur_var env sigma id (pf_concl gls) || - List.exists (occur_var_in_decl env sigma id) ctx then - (aux (i-1) q (nd::ctx)) - else + if occur_var env sigma id (pf_concl gls) || + List.exists (occur_var_in_decl env sigma id) ctx then + (aux (i-1) q (nd::ctx)) + else add_formula env sigma Hyp (GlobRef.VarRef id) (NamedDecl.get_type nd) (aux (i-1) q (nd::ctx)) in let seq1=aux n nc [] in let seq2=if b then @@ -72,17 +72,17 @@ let ll_atom_tac a backtrack id continue seq = let open EConstr in tclIFTHENELSE (tclTHENLIST - [(Proofview.tclEVARMAP >>= fun sigma -> + [(Proofview.tclEVARMAP >>= fun sigma -> let gr = try Proofview.tclUNIT (find_left sigma a seq) with Not_found -> tclFAIL 0 (Pp.str "No link") in gr >>= fun gr -> pf_constr_of_global gr >>= fun left -> - pf_constr_of_global id >>= fun id -> - generalize [(mkApp(id, [|left|]))]); - clear_global id; - intro]) + pf_constr_of_global id >>= fun id -> + generalize [(mkApp(id, [|left|]))]); + clear_global id; + intro]) (wrap 1 false continue seq) backtrack (* right connectives rules *) @@ -151,12 +151,12 @@ let ll_ind_tac (ind,u as indu) largs backtrack id continue seq = EConstr.it_mkLambda_or_LetIn head rc in let lp=Array.length rcs in let newhyps idc =List.init lp (myterm idc) in - tclIFTHENELSE - (tclTHENLIST - [(pf_constr_of_global id >>= fun idc -> generalize (newhyps idc)); - clear_global id; - tclDO lp intro]) - (wrap lp false continue seq) backtrack + tclIFTHENELSE + (tclTHENLIST + [(pf_constr_of_global id >>= fun idc -> generalize (newhyps idc)); + clear_global id; + tclDO lp intro]) + (wrap lp false continue seq) backtrack end let ll_arrow_tac a b c backtrack id continue seq= @@ -167,18 +167,18 @@ let ll_arrow_tac a b c backtrack id continue seq= mkApp (idc, [|mkLambda (Context.make_annot Anonymous Sorts.Relevant,(lift 1 a),(mkRel 2))|])) in tclORELSE (tclTHENS (cut c) - [tclTHENLIST - [introf; - clear_global id; - wrap 1 false continue seq]; - tclTHENS (cut cc) + [tclTHENLIST + [introf; + clear_global id; + wrap 1 false continue seq]; + tclTHENS (cut cc) [(pf_constr_of_global id >>= fun c -> exact_no_check c); - tclTHENLIST - [(pf_constr_of_global id >>= fun idc -> generalize [d idc]); - clear_global id; - introf; - introf; - tclCOMPLETE (wrap 2 true continue seq)]]]) + tclTHENLIST + [(pf_constr_of_global id >>= fun idc -> generalize [d idc]); + clear_global id; + introf; + introf; + tclCOMPLETE (wrap 2 true continue seq)]]]) backtrack (* quantifier rules (easy side) *) @@ -187,8 +187,8 @@ let forall_tac backtrack continue seq= tclORELSE (tclIFTHENELSE intro (wrap 0 true continue seq) (tclORELSE - (tclTHEN introf (tclCOMPLETE (wrap 0 true continue seq))) - backtrack)) + (tclTHEN introf (tclCOMPLETE (wrap 0 true continue seq))) + backtrack)) (if !qflag then tclFAIL 0 (Pp.str "reversible in 1st order mode") else @@ -209,18 +209,18 @@ let ll_forall_tac prod backtrack id continue seq= tclORELSE (tclTHENS (cut prod) [tclTHENLIST - [intro; + [intro; (pf_constr_of_global id >>= fun idc -> - Proofview.Goal.enter begin fun gls-> + Proofview.Goal.enter begin fun gls-> let open EConstr in - let id0 = List.nth (pf_ids_of_hyps gls) 0 in + let id0 = List.nth (pf_ids_of_hyps gls) 0 in let term=mkApp(idc,[|mkVar(id0)|]) in tclTHEN (generalize [term]) (clear [id0]) end); - clear_global id; - intro; - tclCOMPLETE (wrap 1 false continue (deepen seq))]; - tclCOMPLETE (wrap 0 true continue (deepen seq))]) + clear_global id; + intro; + tclCOMPLETE (wrap 1 false continue (deepen seq))]; + tclCOMPLETE (wrap 0 true continue (deepen seq))]) backtrack (* rules for instantiation with unification moved to instances.ml *) diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml index e53412383c..9ff05c33e4 100644 --- a/plugins/firstorder/sequent.ml +++ b/plugins/firstorder/sequent.ml @@ -23,37 +23,37 @@ let newcnt ()= let priority = (* pure heuristics, <=0 for non reversible *) function Right rf-> - begin - match rf with - Rarrow -> 100 - | Rand -> 40 - | Ror -> -15 - | Rfalse -> -50 - | Rforall -> 100 - | Rexists (_,_,_) -> -29 - end + begin + match rf with + Rarrow -> 100 + | Rand -> 40 + | Ror -> -15 + | Rfalse -> -50 + | Rforall -> 100 + | Rexists (_,_,_) -> -29 + end | Left lf -> - match lf with - Lfalse -> 999 - | Land _ -> 90 - | Lor _ -> 40 - | Lforall (_,_,_) -> -30 - | Lexists _ -> 60 - | LA(_,lap) -> - match lap with - LLatom -> 0 - | LLfalse (_,_) -> 100 - | LLand (_,_) -> 80 - | LLor (_,_) -> 70 - | LLforall _ -> -20 - | LLexists (_,_) -> 50 - | LLarrow (_,_,_) -> -10 + match lf with + Lfalse -> 999 + | Land _ -> 90 + | Lor _ -> 40 + | Lforall (_,_,_) -> -30 + | Lexists _ -> 60 + | LA(_,lap) -> + match lap with + LLatom -> 0 + | LLfalse (_,_) -> 100 + | LLand (_,_) -> 80 + | LLor (_,_) -> 70 + | LLforall _ -> -20 + | LLexists (_,_) -> 50 + | LLarrow (_,_,_) -> -10 module OrderedFormula= struct type t=Formula.t let compare e1 e2= - (priority e1.pat) - (priority e2.pat) + (priority e1.pat) - (priority e2.pat) end type h_item = GlobRef.t * (int*Constr.t) option @@ -89,8 +89,8 @@ let cm_remove sigma typ nam cm= let l=CM.find typ cm in let l0=List.filter (fun id-> not (GlobRef.equal id nam)) l in match l0 with - []->CM.remove typ cm - | _ ->CM.add typ l0 cm + []->CM.remove typ cm + | _ ->CM.add typ l0 cm with Not_found ->cm module HP=Heap.Functional(OrderedFormula) @@ -114,35 +114,35 @@ let lookup sigma item seq= match item with (_,None)->false | (id,Some (m, t))-> - let p (id2,o)= - match o with - None -> false + let p (id2,o)= + match o with + None -> false | Some (m2, t2)-> GlobRef.equal id id2 && m2>m && more_general sigma (m2, EConstr.of_constr t2) (m, EConstr.of_constr t) in - History.exists p seq.history + History.exists p seq.history let add_formula env sigma side nam t seq = match build_formula env sigma side nam t seq.cnt with Left f-> - begin - match side with - Concl -> - {seq with - redexes=HP.add f seq.redexes; - gl=f.constr; - glatom=None} - | _ -> - {seq with - redexes=HP.add f seq.redexes; - context=cm_add sigma f.constr nam seq.context} - end + begin + match side with + Concl -> + {seq with + redexes=HP.add f seq.redexes; + gl=f.constr; + glatom=None} + | _ -> + {seq with + redexes=HP.add f seq.redexes; + context=cm_add sigma f.constr nam seq.context} + end | Right t-> - match side with - Concl -> - {seq with gl=t;glatom=Some t} - | _ -> - {seq with - context=cm_add sigma t nam seq.context; - latoms=t::seq.latoms} + match side with + Concl -> + {seq with gl=t;glatom=Some t} + | _ -> + {seq with + context=cm_add sigma t nam seq.context; + latoms=t::seq.latoms} let re_add_formula_list sigma lf seq= let do_one f cm= @@ -166,14 +166,14 @@ let rec take_formula sigma seq= and hp=HP.remove seq.redexes in if hd.id == dummy_id then let nseq={seq with redexes=hp} in - if seq.gl==hd.constr then - hd,nseq - else - take_formula sigma nseq (* discarding deprecated goal *) + if seq.gl==hd.constr then + hd,nseq + else + take_formula sigma nseq (* discarding deprecated goal *) else hd,{seq with - redexes=hp; - context=cm_remove sigma hd.constr hd.id seq.context} + redexes=hp; + context=cm_remove sigma hd.constr hd.id seq.context} let empty_seq depth= {redexes=HP.empty; @@ -191,7 +191,7 @@ let expand_constructor_hints = List.init (Inductiveops.nconstructors (Global.env()) ind) (fun i -> GlobRef.ConstructRef (ind,i+1)) | gr -> - [gr]) + [gr]) let extend_with_ref_list env sigma l seq = let l = expand_constructor_hints l in @@ -207,22 +207,22 @@ let extend_with_auto_hints env sigma l seq = let seqref=ref seq in let f p_a_t = match repr_hint p_a_t.code with - Res_pf (c,_) | Give_exact (c,_) + Res_pf (c,_) | Give_exact (c,_) | Res_pf_THEN_trivial_fail (c,_) -> let (c, _, _) = c in - (try - let (gr, _) = Termops.global_of_constr sigma c in - let typ=(Typing.unsafe_type_of env sigma c) in - seqref:=add_formula env sigma Hint gr typ !seqref - with Not_found->()) + (try + let (gr, _) = Termops.global_of_constr sigma c in + let typ=(Typing.unsafe_type_of env sigma c) in + seqref:=add_formula env sigma Hint gr typ !seqref + with Not_found->()) | _-> () in let g _ _ l = List.iter f l in let h dbname= let hdb= try - searchtable_map dbname + searchtable_map dbname with Not_found-> - user_err Pp.(str ("Firstorder: "^dbname^" : No such Hint database")) in + user_err Pp.(str ("Firstorder: "^dbname^" : No such Hint database")) in Hint_db.iter g hdb in List.iter h l; !seqref, sigma (*FIXME: forgetting about universes*) @@ -239,9 +239,9 @@ let print_cmap map= cut () ++ s in (v 0 - (str "-----" ++ - cut () ++ - CM.fold print_entry map (mt ()) ++ - str "-----")) + (str "-----" ++ + cut () ++ + CM.fold print_entry map (mt ()) ++ + str "-----")) diff --git a/plugins/firstorder/sequent.mli b/plugins/firstorder/sequent.mli index 724e1abcc4..2e262fd996 100644 --- a/plugins/firstorder/sequent.mli +++ b/plugins/firstorder/sequent.mli @@ -28,12 +28,12 @@ module HP: Heap.S with type elt=Formula.t type t = {redexes:HP.t; context: GlobRef.t list CM.t; - latoms:constr list; - gl:types; - glatom:constr option; - cnt:counter; - history:History.t; - depth:int} + latoms:constr list; + gl:types; + glatom:constr option; + cnt:counter; + history:History.t; + depth:int} val deepen: t -> t diff --git a/plugins/firstorder/unify.ml b/plugins/firstorder/unify.ml index 35b64ccb8f..6fa831fda9 100644 --- a/plugins/firstorder/unify.ml +++ b/plugins/firstorder/unify.ml @@ -38,58 +38,58 @@ let unif evd t1 t2= let rec head_reduce t= (* forbids non-sigma-normal meta in head position*) match EConstr.kind evd t with - Meta i-> - (try - head_reduce (Int.List.assoc i !sigma) - with Not_found->t) + Meta i-> + (try + head_reduce (Int.List.assoc i !sigma) + with Not_found->t) | _->t in Queue.add (t1,t2) bige; try while true do let t1,t2=Queue.take bige in let nt1=head_reduce (whd_betaiotazeta evd t1) and nt2=head_reduce (whd_betaiotazeta evd t2) in - match (EConstr.kind evd nt1),(EConstr.kind evd nt2) with - Meta i,Meta j-> - if not (Int.equal i j) then - if i<j then bind j nt1 - else bind i nt2 - | Meta i,_ -> - let t=subst_meta !sigma nt2 in - if Int.Set.is_empty (free_rels evd t) && + match (EConstr.kind evd nt1),(EConstr.kind evd nt2) with + Meta i,Meta j-> + if not (Int.equal i j) then + if i<j then bind j nt1 + else bind i nt2 + | Meta i,_ -> + let t=subst_meta !sigma nt2 in + if Int.Set.is_empty (free_rels evd t) && not (occur_metavariable evd i t) then - bind i t else raise (UFAIL(nt1,nt2)) - | _,Meta i -> - let t=subst_meta !sigma nt1 in - if Int.Set.is_empty (free_rels evd t) && + bind i t else raise (UFAIL(nt1,nt2)) + | _,Meta i -> + let t=subst_meta !sigma nt1 in + if Int.Set.is_empty (free_rels evd t) && not (occur_metavariable evd i t) then - bind i t else raise (UFAIL(nt1,nt2)) - | Cast(_,_,_),_->Queue.add (strip_outer_cast evd nt1,nt2) bige - | _,Cast(_,_,_)->Queue.add (nt1,strip_outer_cast evd nt2) bige + bind i t else raise (UFAIL(nt1,nt2)) + | Cast(_,_,_),_->Queue.add (strip_outer_cast evd nt1,nt2) bige + | _,Cast(_,_,_)->Queue.add (nt1,strip_outer_cast evd nt2) bige | (Prod(_,a,b),Prod(_,c,d))|(Lambda(_,a,b),Lambda(_,c,d))-> - Queue.add (a,c) bige;Queue.add (pop b,pop d) bige - | Case (_,pa,ca,va),Case (_,pb,cb,vb)-> - Queue.add (pa,pb) bige; - Queue.add (ca,cb) bige; - let l=Array.length va in + Queue.add (a,c) bige;Queue.add (pop b,pop d) bige + | Case (_,pa,ca,va),Case (_,pb,cb,vb)-> + Queue.add (pa,pb) bige; + Queue.add (ca,cb) bige; + let l=Array.length va in if not (Int.equal l (Array.length vb)) then - raise (UFAIL (nt1,nt2)) - else - for i=0 to l-1 do - Queue.add (va.(i),vb.(i)) bige - done - | App(ha,va),App(hb,vb)-> - Queue.add (ha,hb) bige; - let l=Array.length va in - if not (Int.equal l (Array.length vb)) then - raise (UFAIL (nt1,nt2)) - else - for i=0 to l-1 do - Queue.add (va.(i),vb.(i)) bige - done - | _->if not (eq_constr_nounivs evd nt1 nt2) then raise (UFAIL (nt1,nt2)) + raise (UFAIL (nt1,nt2)) + else + for i=0 to l-1 do + Queue.add (va.(i),vb.(i)) bige + done + | App(ha,va),App(hb,vb)-> + Queue.add (ha,hb) bige; + let l=Array.length va in + if not (Int.equal l (Array.length vb)) then + raise (UFAIL (nt1,nt2)) + else + for i=0 to l-1 do + Queue.add (va.(i),vb.(i)) bige + done + | _->if not (eq_constr_nounivs evd nt1 nt2) then raise (UFAIL (nt1,nt2)) done; assert false - (* this place is unreachable but needed for the sake of typing *) + (* this place is unreachable but needed for the sake of typing *) with Queue.Empty-> !sigma let value evd i t= @@ -99,7 +99,7 @@ let value evd i t= if isMeta evd term && Int.equal (destMeta evd term) i then 0 else let f v t=add v (vaux t) in let vr=EConstr.fold evd f (-1) term in - if vr<0 then -1 else vr+1 in + if vr<0 then -1 else vr+1 in vaux t type instance= @@ -111,14 +111,14 @@ let mk_rel_inst evd t= let rel_env=ref [] in let rec renum_rec d t= match EConstr.kind evd t with - Meta n-> - (try - mkRel (d+(Int.List.assoc n !rel_env)) - with Not_found-> - let m= !new_rel in - incr new_rel; - rel_env:=(n,m) :: !rel_env; - mkRel (m+d)) + Meta n-> + (try + mkRel (d+(Int.List.assoc n !rel_env)) + with Not_found-> + let m= !new_rel in + incr new_rel; + rel_env:=(n,m) :: !rel_env; + mkRel (m+d)) | _ -> EConstr.map_with_binders evd succ renum_rec d t in let nt=renum_rec 0 t in (!new_rel - 1,nt) @@ -142,5 +142,5 @@ let more_general evd (m1,t1) (m2,t2)= try let sigma=unif evd mt1 mt2 in let p (n,t)= n<m1 || isMeta evd t in - List.for_all p sigma + List.for_all p sigma with UFAIL(_,_)->false diff --git a/plugins/funind/g_indfun.mlg b/plugins/funind/g_indfun.mlg index 2b990400e3..a02cb24bee 100644 --- a/plugins/funind/g_indfun.mlg +++ b/plugins/funind/g_indfun.mlg @@ -99,9 +99,9 @@ TACTIC EXTEND newfunind | ["functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] -> { let c = match cl with - | [] -> assert false - | [c] -> c - | c::cl -> EConstr.applist(c,cl) + | [] -> assert false + | [c] -> c + | c::cl -> EConstr.applist(c,cl) in Extratactics.onSomeWithHoles (fun x -> functional_induction true c x pat) princl } END @@ -110,9 +110,9 @@ TACTIC EXTEND snewfunind | ["soft" "functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] -> { let c = match cl with - | [] -> assert false - | [c] -> c - | c::cl -> EConstr.applist(c,cl) + | [] -> assert false + | [c] -> c + | c::cl -> EConstr.applist(c,cl) in Extratactics.onSomeWithHoles (fun x -> functional_induction false c x pat) princl } END @@ -260,7 +260,7 @@ VERNAC COMMAND EXTEND NewFunctionalScheme let names = List.map (fun (_,na,_) -> na) fas in warning_error names e end - | _ -> assert false (* we can only have non empty list *) + | _ -> assert false (* we can only have non empty list *) end | e when CErrors.noncritical e -> let names = List.map (fun (_,na,_) -> na) fas in diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 895b6a37ee..e41b92d4dc 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -38,7 +38,7 @@ let rec solve_trivial_holes pat_as_term e = | GApp(fp,argsp),GApp(fe,argse) when glob_constr_eq fp fe -> DAst.make (GApp((solve_trivial_holes fp fe),List.map2 solve_trivial_holes argsp argse)) | _,_ -> pat_as_term - + (* compose_glob_context [(bt_1,n_1,t_1);......] rt returns b_1(n_1,t_1,.....,bn(n_k,t_k,rt)) where the b_i's are the @@ -90,11 +90,11 @@ let combine_results = let pre_result = List.map ( fun res1 -> (* for each result in arg_res *) - List.map (* we add it in each args_res *) - (fun res2 -> - combine_fun res1 res2 - ) - res2.result + List.map (* we add it in each args_res *) + (fun res2 -> + combine_fun res1 res2 + ) + res2.result ) res1.result in (* and then we flatten the map *) @@ -127,18 +127,18 @@ let rec change_vars_in_binder mapping = function | (bt,t)::l -> let new_mapping = Id.Set.fold Id.Map.remove (ids_of_binder bt) mapping in (bt,change_vars mapping t):: - (if Id.Map.is_empty new_mapping - then l - else change_vars_in_binder new_mapping l - ) + (if Id.Map.is_empty new_mapping + then l + else change_vars_in_binder new_mapping l + ) let rec replace_var_by_term_in_binder x_id term = function | [] -> [] | (bt,t)::l -> (bt,replace_var_by_term x_id term t):: - if Id.Set.mem x_id (ids_of_binder bt) - then l - else replace_var_by_term_in_binder x_id term l + if Id.Set.mem x_id (ids_of_binder bt) + then l + else replace_var_by_term_in_binder x_id term l let add_bt_names bt = Id.Set.union (ids_of_binder bt) @@ -152,66 +152,66 @@ let apply_args ctxt body args = let next_name_away (na:Name.t) (mapping: Id.t Id.Map.t) (avoid: Id.Set.t) = match na with | Name id when Id.Set.mem id avoid -> - let new_id = Namegen.next_ident_away id avoid in - Name new_id,Id.Map.add id new_id mapping,Id.Set.add new_id avoid + let new_id = Namegen.next_ident_away id avoid in + Name new_id,Id.Map.add id new_id mapping,Id.Set.add new_id avoid | _ -> na,mapping,avoid in let next_bt_away bt (avoid:Id.Set.t) = match bt with | LetIn na -> - let new_na,mapping,new_avoid = next_name_away na Id.Map.empty avoid in - LetIn new_na,mapping,new_avoid + let new_na,mapping,new_avoid = next_name_away na Id.Map.empty avoid in + LetIn new_na,mapping,new_avoid | Prod na -> - let new_na,mapping,new_avoid = next_name_away na Id.Map.empty avoid in - Prod new_na,mapping,new_avoid + let new_na,mapping,new_avoid = next_name_away na Id.Map.empty avoid in + Prod new_na,mapping,new_avoid | Lambda na -> - let new_na,mapping,new_avoid = next_name_away na Id.Map.empty avoid in - Lambda new_na,mapping,new_avoid + let new_na,mapping,new_avoid = next_name_away na Id.Map.empty avoid in + Lambda new_na,mapping,new_avoid in let rec do_apply avoid ctxt body args = match ctxt,args with | _,[] -> (* No more args *) - (ctxt,body) + (ctxt,body) | [],_ -> (* no more fun *) - let f,args' = glob_decompose_app body in - (ctxt,mkGApp(f,args'@args)) + let f,args' = glob_decompose_app body in + (ctxt,mkGApp(f,args'@args)) | (Lambda Anonymous,t)::ctxt',arg::args' -> - do_apply avoid ctxt' body args' + do_apply avoid ctxt' body args' | (Lambda (Name id),t)::ctxt',arg::args' -> - let new_avoid,new_ctxt',new_body,new_id = - if need_convert_id avoid id - then - let new_avoid = Id.Set.add id avoid in - let new_id = Namegen.next_ident_away id new_avoid in - let new_avoid' = Id.Set.add new_id new_avoid in - let mapping = Id.Map.add id new_id Id.Map.empty in - let new_ctxt' = change_vars_in_binder mapping ctxt' in - let new_body = change_vars mapping body in - new_avoid',new_ctxt',new_body,new_id - else - Id.Set.add id avoid,ctxt',body,id - in - let new_body = replace_var_by_term new_id arg new_body in - let new_ctxt' = replace_var_by_term_in_binder new_id arg new_ctxt' in - do_apply avoid new_ctxt' new_body args' + let new_avoid,new_ctxt',new_body,new_id = + if need_convert_id avoid id + then + let new_avoid = Id.Set.add id avoid in + let new_id = Namegen.next_ident_away id new_avoid in + let new_avoid' = Id.Set.add new_id new_avoid in + let mapping = Id.Map.add id new_id Id.Map.empty in + let new_ctxt' = change_vars_in_binder mapping ctxt' in + let new_body = change_vars mapping body in + new_avoid',new_ctxt',new_body,new_id + else + Id.Set.add id avoid,ctxt',body,id + in + let new_body = replace_var_by_term new_id arg new_body in + let new_ctxt' = replace_var_by_term_in_binder new_id arg new_ctxt' in + do_apply avoid new_ctxt' new_body args' | (bt,t)::ctxt',_ -> - let new_avoid,new_ctxt',new_body,new_bt = - let new_avoid = add_bt_names bt avoid in - if need_convert avoid bt - then - let new_bt,mapping,new_avoid = next_bt_away bt new_avoid in - ( - new_avoid, - change_vars_in_binder mapping ctxt', - change_vars mapping body, - new_bt - ) - else new_avoid,ctxt',body,bt - in - let new_ctxt',new_body = - do_apply new_avoid new_ctxt' new_body args - in - (new_bt,t)::new_ctxt',new_body + let new_avoid,new_ctxt',new_body,new_bt = + let new_avoid = add_bt_names bt avoid in + if need_convert avoid bt + then + let new_bt,mapping,new_avoid = next_bt_away bt new_avoid in + ( + new_avoid, + change_vars_in_binder mapping ctxt', + change_vars mapping body, + new_bt + ) + else new_avoid,ctxt',body,bt + in + let new_ctxt',new_body = + do_apply new_avoid new_ctxt' new_body args + in + (new_bt,t)::new_ctxt',new_body in do_apply Id.Set.empty ctxt body args @@ -230,14 +230,14 @@ let combine_lam n t b = { context = []; value = mkGLambda(n, compose_glob_context t.context t.value, - compose_glob_context b.context b.value ) + compose_glob_context b.context b.value ) } let combine_prod2 n t b = { context = []; value = mkGProd(n, compose_glob_context t.context t.value, - compose_glob_context b.context b.value ) + compose_glob_context b.context b.value ) } let combine_prod n t b = @@ -251,8 +251,8 @@ let mk_result ctxt value avoid = { result = [{context = ctxt; - value = value}] - ; + value = value}] + ; to_avoid = avoid } (************************************************* @@ -298,8 +298,8 @@ let make_discr_match_brl i = let make_discr_match brl = fun el i -> mkGCases(None, - make_discr_match_el el, - make_discr_match_brl i brl) + make_discr_match_el el, + make_discr_match_brl i brl) (**********************************************************************) (* functions used to build case expression from lettuple and if ones *) @@ -310,27 +310,27 @@ let build_constructors_of_type ind' argl = let (mib,ind) = Inductive.lookup_mind_specif (Global.env()) ind' in let npar = mib.Declarations.mind_nparams in Array.mapi (fun i _ -> - let construct = ind',i+1 in + let construct = ind',i+1 in let constructref = GlobRef.ConstructRef(construct) in - let _implicit_positions_of_cst = - Impargs.implicits_of_global constructref - in - let cst_narg = + let _implicit_positions_of_cst = + Impargs.implicits_of_global constructref + in + let cst_narg = Inductiveops.constructor_nallargs - (Global.env ()) - construct - in - let argl = + (Global.env ()) + construct + in + let argl = if List.is_empty argl then List.make cst_narg (mkGHole ()) else List.make npar (mkGHole ()) @ argl - in - let pat_as_term = + in + let pat_as_term = mkGApp(mkGRef (GlobRef.ConstructRef(ind',i+1)),argl) - in + in cases_pattern_of_glob_constr (Global.env()) Anonymous pat_as_term - ) + ) ind.Declarations.mind_consnames (******************) @@ -359,20 +359,20 @@ let add_pat_variables sigma pat typ env : Environ.env = match DAst.get pat with | PatVar na -> Environ.push_rel (RelDecl.LocalAssum (make_annot na Sorts.Relevant,typ)) env | PatCstr(c,patl,na) -> - let Inductiveops.IndType(indf,indargs) = - try Inductiveops.find_rectype env (Evd.from_env env) (EConstr.of_constr typ) - with Not_found -> assert false - in - let constructors = Inductiveops.get_constructors env indf in - let constructor : Inductiveops.constructor_summary = List.find (fun cs -> eq_constructor c (fst cs.Inductiveops.cs_cstr)) (Array.to_list constructors) in - let cs_args_types :types list = List.map RelDecl.get_type constructor.Inductiveops.cs_args in - List.fold_left2 add_pat_variables env patl (List.rev cs_args_types) + let Inductiveops.IndType(indf,indargs) = + try Inductiveops.find_rectype env (Evd.from_env env) (EConstr.of_constr typ) + with Not_found -> assert false + in + let constructors = Inductiveops.get_constructors env indf in + let constructor : Inductiveops.constructor_summary = List.find (fun cs -> eq_constructor c (fst cs.Inductiveops.cs_cstr)) (Array.to_list constructors) in + let cs_args_types :types list = List.map RelDecl.get_type constructor.Inductiveops.cs_args in + List.fold_left2 add_pat_variables env patl (List.rev cs_args_types) in let new_env = add_pat_variables env pat typ in let res = fst ( Context.Rel.fold_outside - (fun decl (env,ctxt) -> + (fun decl (env,ctxt) -> let open Context.Rel.Declaration in match decl with | LocalAssum ({binder_name=Anonymous},_) | LocalDef ({binder_name=Anonymous},_,_) -> assert false @@ -398,8 +398,8 @@ let add_pat_variables sigma pat typ env : Environ.env = let open Context.Named.Declaration in (Environ.push_named (LocalDef (na,new_v,new_t)) env,mkVar id::ctxt) ) - (Environ.rel_context new_env) - ~init:(env,[]) + (Environ.rel_context new_env) + ~init:(env,[]) ) in observe (str "new var env := " ++ Printer.pr_named_context_of res (Evd.from_env env)); @@ -411,16 +411,16 @@ let add_pat_variables sigma pat typ env : Environ.env = let rec pattern_to_term_and_type env typ = DAst.with_val (function | PatVar Anonymous -> assert false | PatVar (Name id) -> - mkGVar id + mkGVar id | PatCstr(constr,patternl,_) -> let cst_narg = Inductiveops.constructor_nallargs - (Global.env ()) - constr + (Global.env ()) + constr in let Inductiveops.IndType(indf,indargs) = - try Inductiveops.find_rectype env (Evd.from_env env) (EConstr.of_constr typ) - with Not_found -> assert false + try Inductiveops.find_rectype env (Evd.from_env env) (EConstr.of_constr typ) + with Not_found -> assert false in let constructors = Inductiveops.get_constructors env indf in let constructor = List.find (fun cs -> eq_constructor (fst cs.Inductiveops.cs_cstr) constr) (Array.to_list constructors) in @@ -428,18 +428,18 @@ let rec pattern_to_term_and_type env typ = DAst.with_val (function let _,cstl = Inductiveops.dest_ind_family indf in let csta = Array.of_list cstl in let implicit_args = - Array.to_list - (Array.init - (cst_narg - List.length patternl) - (fun i -> Detyping.detype Detyping.Now false Id.Set.empty env (Evd.from_env env) (EConstr.of_constr csta.(i))) - ) + Array.to_list + (Array.init + (cst_narg - List.length patternl) + (fun i -> Detyping.detype Detyping.Now false Id.Set.empty env (Evd.from_env env) (EConstr.of_constr csta.(i))) + ) in let patl_as_term = - List.map2 (pattern_to_term_and_type env) (List.rev cs_args_types) patternl + List.map2 (pattern_to_term_and_type env) (List.rev cs_args_types) patternl in mkGApp(mkGRef(GlobRef.ConstructRef constr), - implicit_args@patl_as_term - ) + implicit_args@patl_as_term + ) ) (* [build_entry_lc funnames avoid rt] construct the list (in fact a build_entry_return) @@ -479,220 +479,220 @@ let rec build_entry_lc env sigma funnames avoid rt : glob_constr build_entry_ret let open CAst in match DAst.get rt with | GRef _ | GVar _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GInt _ | GFloat _ -> - (* do nothing (except changing type of course) *) - mk_result [] rt avoid + (* do nothing (except changing type of course) *) + mk_result [] rt avoid | GApp(_,_) -> - let f,args = glob_decompose_app rt in - let args_res : (glob_constr list) build_entry_return = - List.fold_right (* create the arguments lists of constructors and combine them *) - (fun arg ctxt_argsl -> + let f,args = glob_decompose_app rt in + let args_res : (glob_constr list) build_entry_return = + List.fold_right (* create the arguments lists of constructors and combine them *) + (fun arg ctxt_argsl -> let arg_res = build_entry_lc env sigma funnames ctxt_argsl.to_avoid arg in - combine_results combine_args arg_res ctxt_argsl - ) - args - (mk_result [] [] avoid) - in - begin - match DAst.get f with - | GLambda _ -> - let rec aux t l = - match l with - | [] -> t - | u::l -> DAst.make @@ - match DAst.get t with - | GLambda(na,_,nat,b) -> - GLetIn(na,u,None,aux b l) - | _ -> - GApp(t,l) - in + combine_results combine_args arg_res ctxt_argsl + ) + args + (mk_result [] [] avoid) + in + begin + match DAst.get f with + | GLambda _ -> + let rec aux t l = + match l with + | [] -> t + | u::l -> DAst.make @@ + match DAst.get t with + | GLambda(na,_,nat,b) -> + GLetIn(na,u,None,aux b l) + | _ -> + GApp(t,l) + in build_entry_lc env sigma funnames avoid (aux f args) - | GVar id when Id.Set.mem id funnames -> - (* if we have [f t1 ... tn] with [f]$\in$[fnames] - then we create a fresh variable [res], - add [res] and its "value" (i.e. [res v1 ... vn]) to each - pseudo constructor build for the arguments (i.e. a pseudo context [ctxt] and - a pseudo value "v1 ... vn". - The "value" of this branch is then simply [res] - *) - let rt_as_constr,ctx = Pretyping.understand env (Evd.from_env env) rt in + | GVar id when Id.Set.mem id funnames -> + (* if we have [f t1 ... tn] with [f]$\in$[fnames] + then we create a fresh variable [res], + add [res] and its "value" (i.e. [res v1 ... vn]) to each + pseudo constructor build for the arguments (i.e. a pseudo context [ctxt] and + a pseudo value "v1 ... vn". + The "value" of this branch is then simply [res] + *) + let rt_as_constr,ctx = Pretyping.understand env (Evd.from_env env) rt in let rt_typ = Typing.unsafe_type_of env (Evd.from_env env) rt_as_constr in - let res_raw_type = Detyping.detype Detyping.Now false Id.Set.empty env (Evd.from_env env) rt_typ in - let res = fresh_id args_res.to_avoid "_res" in - let new_avoid = res::args_res.to_avoid in - let res_rt = mkGVar res in - let new_result = - List.map - (fun arg_res -> - let new_hyps = - [Prod (Name res),res_raw_type; - Prod Anonymous,mkGApp(res_rt,(mkGVar id)::arg_res.value)] - in - {context = arg_res.context@new_hyps; value = res_rt } - ) - args_res.result - in - { result = new_result; to_avoid = new_avoid } - | GVar _ | GEvar _ | GPatVar _ | GHole _ | GSort _ | GRef _ -> - (* if have [g t1 ... tn] with [g] not appearing in [funnames] - then - foreach [ctxt,v1 ... vn] in [args_res] we return - [ctxt, g v1 .... vn] - *) - { - args_res with - result = - List.map - (fun args_res -> - {args_res with value = mkGApp(f,args_res.value)}) - args_res.result - } - | GApp _ -> assert false (* we have collected all the app in [glob_decompose_app] *) - | GLetIn(n,v,t,b) -> - (* if we have [(let x := v in b) t1 ... tn] , - we discard our work and compute the list of constructor for - [let x = v in (b t1 ... tn)] up to alpha conversion - *) - let new_n,new_b,new_avoid = - match n with - | Name id when List.exists (is_free_in id) args -> - (* need to alpha-convert the name *) - let new_id = Namegen.next_ident_away id (Id.Set.of_list avoid) in - let new_avoid = id:: avoid in - let new_b = - replace_var_by_term - id - (DAst.make @@ GVar id) - b - in - (Name new_id,new_b,new_avoid) - | _ -> n,b,avoid - in - build_entry_lc - env + let res_raw_type = Detyping.detype Detyping.Now false Id.Set.empty env (Evd.from_env env) rt_typ in + let res = fresh_id args_res.to_avoid "_res" in + let new_avoid = res::args_res.to_avoid in + let res_rt = mkGVar res in + let new_result = + List.map + (fun arg_res -> + let new_hyps = + [Prod (Name res),res_raw_type; + Prod Anonymous,mkGApp(res_rt,(mkGVar id)::arg_res.value)] + in + {context = arg_res.context@new_hyps; value = res_rt } + ) + args_res.result + in + { result = new_result; to_avoid = new_avoid } + | GVar _ | GEvar _ | GPatVar _ | GHole _ | GSort _ | GRef _ -> + (* if have [g t1 ... tn] with [g] not appearing in [funnames] + then + foreach [ctxt,v1 ... vn] in [args_res] we return + [ctxt, g v1 .... vn] + *) + { + args_res with + result = + List.map + (fun args_res -> + {args_res with value = mkGApp(f,args_res.value)}) + args_res.result + } + | GApp _ -> assert false (* we have collected all the app in [glob_decompose_app] *) + | GLetIn(n,v,t,b) -> + (* if we have [(let x := v in b) t1 ... tn] , + we discard our work and compute the list of constructor for + [let x = v in (b t1 ... tn)] up to alpha conversion + *) + let new_n,new_b,new_avoid = + match n with + | Name id when List.exists (is_free_in id) args -> + (* need to alpha-convert the name *) + let new_id = Namegen.next_ident_away id (Id.Set.of_list avoid) in + let new_avoid = id:: avoid in + let new_b = + replace_var_by_term + id + (DAst.make @@ GVar id) + b + in + (Name new_id,new_b,new_avoid) + | _ -> n,b,avoid + in + build_entry_lc + env sigma funnames - avoid - (mkGLetIn(new_n,v,t,mkGApp(new_b,args))) - | GCases _ | GIf _ | GLetTuple _ -> - (* we have [(match e1, ...., en with ..... end) t1 tn] - we first compute the result from the case and - then combine each of them with each of args one - *) + avoid + (mkGLetIn(new_n,v,t,mkGApp(new_b,args))) + | GCases _ | GIf _ | GLetTuple _ -> + (* we have [(match e1, ...., en with ..... end) t1 tn] + we first compute the result from the case and + then combine each of them with each of args one + *) let f_res = build_entry_lc env sigma funnames args_res.to_avoid f in - combine_results combine_app f_res args_res - | GCast(b,_) -> - (* for an applied cast we just trash the cast part - and restart the work. + combine_results combine_app f_res args_res + | GCast(b,_) -> + (* for an applied cast we just trash the cast part + and restart the work. - WARNING: We need to restart since [b] itself should be an application term - *) + WARNING: We need to restart since [b] itself should be an application term + *) build_entry_lc env sigma funnames avoid (mkGApp(b,args)) - | GRec _ -> user_err Pp.(str "Not handled GRec") - | GProd _ -> user_err Pp.(str "Cannot apply a type") + | GRec _ -> user_err Pp.(str "Not handled GRec") + | GProd _ -> user_err Pp.(str "Cannot apply a type") | GInt _ -> user_err Pp.(str "Cannot apply an integer") | GFloat _ -> user_err Pp.(str "Cannot apply a float") - end (* end of the application treatement *) + end (* end of the application treatement *) | GLambda(n,_,t,b) -> - (* we first compute the list of constructor - corresponding to the body of the function, - then the one corresponding to the type - and combine the two result - *) + (* we first compute the list of constructor + corresponding to the body of the function, + then the one corresponding to the type + and combine the two result + *) let t_res = build_entry_lc env sigma funnames avoid t in - let new_n = - match n with - | Name _ -> n - | Anonymous -> Name (Indfun_common.fresh_id [] "_x") - in - let new_env = raw_push_named (new_n,None,t) env in + let new_n = + match n with + | Name _ -> n + | Anonymous -> Name (Indfun_common.fresh_id [] "_x") + in + let new_env = raw_push_named (new_n,None,t) env in let b_res = build_entry_lc new_env sigma funnames avoid b in - combine_results (combine_lam new_n) t_res b_res + combine_results (combine_lam new_n) t_res b_res | GProd(n,_,t,b) -> - (* we first compute the list of constructor - corresponding to the body of the function, - then the one corresponding to the type - and combine the two result - *) + (* we first compute the list of constructor + corresponding to the body of the function, + then the one corresponding to the type + and combine the two result + *) let t_res = build_entry_lc env sigma funnames avoid t in - let new_env = raw_push_named (n,None,t) env in + let new_env = raw_push_named (n,None,t) env in let b_res = build_entry_lc new_env sigma funnames avoid b in if List.length t_res.result = 1 && List.length b_res.result = 1 then combine_results (combine_prod2 n) t_res b_res else combine_results (combine_prod n) t_res b_res | GLetIn(n,v,typ,b) -> - (* we first compute the list of constructor - corresponding to the body of the function, - then the one corresponding to the value [t] - and combine the two result - *) + (* we first compute the list of constructor + corresponding to the body of the function, + then the one corresponding to the value [t] + and combine the two result + *) let v = match typ with None -> v | Some t -> DAst.make ?loc:rt.loc @@ GCast (v,CastConv t) in let v_res = build_entry_lc env sigma funnames avoid v in - let v_as_constr,ctx = Pretyping.understand env (Evd.from_env env) v in + let v_as_constr,ctx = Pretyping.understand env (Evd.from_env env) v in let v_type = Typing.unsafe_type_of env (Evd.from_env env) v_as_constr in let v_r = Sorts.Relevant in (* TODO relevance *) - let new_env = - match n with - Anonymous -> env + let new_env = + match n with + Anonymous -> env | Name id -> EConstr.push_named (NamedDecl.LocalDef (make_annot id v_r,v_as_constr,v_type)) env in let b_res = build_entry_lc new_env sigma funnames avoid b in - combine_results (combine_letin n) v_res b_res + combine_results (combine_letin n) v_res b_res | GCases(_,_,el,brl) -> - (* we create the discrimination function - and treat the case itself - *) - let make_discr = make_discr_match brl in + (* we create the discrimination function + and treat the case itself + *) + let make_discr = make_discr_match brl in build_entry_lc_from_case env sigma funnames make_discr el brl avoid | GIf(b,(na,e_option),lhs,rhs) -> - let b_as_constr,ctx = Pretyping.understand env (Evd.from_env env) b in + let b_as_constr,ctx = Pretyping.understand env (Evd.from_env env) b in let b_typ = Typing.unsafe_type_of env (Evd.from_env env) b_as_constr in - let (ind,_) = - try Inductiveops.find_inductive env (Evd.from_env env) b_typ - with Not_found -> - user_err (str "Cannot find the inductive associated to " ++ + let (ind,_) = + try Inductiveops.find_inductive env (Evd.from_env env) b_typ + with Not_found -> + user_err (str "Cannot find the inductive associated to " ++ Printer.pr_glob_constr_env env b ++ str " in " ++ Printer.pr_glob_constr_env env rt ++ str ". try again with a cast") - in - let case_pats = build_constructors_of_type (fst ind) [] in - assert (Int.equal (Array.length case_pats) 2); - let brl = - List.map_i + in + let case_pats = build_constructors_of_type (fst ind) [] in + assert (Int.equal (Array.length case_pats) 2); + let brl = + List.map_i (fun i x -> CAst.make ([],[case_pats.(i)],x)) - 0 - [lhs;rhs] - in - let match_expr = - mkGCases(None,[(b,(Anonymous,None))],brl) - in - (* Pp.msgnl (str "new case := " ++ Printer.pr_glob_constr match_expr); *) + 0 + [lhs;rhs] + in + let match_expr = + mkGCases(None,[(b,(Anonymous,None))],brl) + in + (* Pp.msgnl (str "new case := " ++ Printer.pr_glob_constr match_expr); *) build_entry_lc env sigma funnames avoid match_expr | GLetTuple(nal,_,b,e) -> - begin - let nal_as_glob_constr = - List.map - (function - Name id -> mkGVar id - | Anonymous -> mkGHole () - ) - nal - in - let b_as_constr,ctx = Pretyping.understand env (Evd.from_env env) b in + begin + let nal_as_glob_constr = + List.map + (function + Name id -> mkGVar id + | Anonymous -> mkGHole () + ) + nal + in + let b_as_constr,ctx = Pretyping.understand env (Evd.from_env env) b in let b_typ = Typing.unsafe_type_of env (Evd.from_env env) b_as_constr in - let (ind,_) = - try Inductiveops.find_inductive env (Evd.from_env env) b_typ - with Not_found -> - user_err (str "Cannot find the inductive associated to " ++ + let (ind,_) = + try Inductiveops.find_inductive env (Evd.from_env env) b_typ + with Not_found -> + user_err (str "Cannot find the inductive associated to " ++ Printer.pr_glob_constr_env env b ++ str " in " ++ Printer.pr_glob_constr_env env rt ++ str ". try again with a cast") - in - let case_pats = build_constructors_of_type (fst ind) nal_as_glob_constr in - assert (Int.equal (Array.length case_pats) 1); + in + let case_pats = build_constructors_of_type (fst ind) nal_as_glob_constr in + assert (Int.equal (Array.length case_pats) 1); let br = CAst.make ([],[case_pats.(0)],e) in - let match_expr = mkGCases(None,[b,(Anonymous,None)],[br]) in + let match_expr = mkGCases(None,[b,(Anonymous,None)],[br]) in build_entry_lc env sigma funnames avoid match_expr - end + end | GRec _ -> user_err Pp.(str "Not handled GRec") | GCast(b,_) -> build_entry_lc env sigma funnames avoid b @@ -703,177 +703,177 @@ and build_entry_lc_from_case env sigma funname make_discr match el with | [] -> assert false (* this case correspond to match <nothing> with .... !*) | el -> - (* this case correspond to - match el with brl end - we first compute the list of lists corresponding to [el] and - combine them . - Then for each element of the combinations, - we compute the result we compute one list per branch in [brl] and - finally we just concatenate those list - *) - let case_resl = - List.fold_right - (fun (case_arg,_) ctxt_argsl -> + (* this case correspond to + match el with brl end + we first compute the list of lists corresponding to [el] and + combine them . + Then for each element of the combinations, + we compute the result we compute one list per branch in [brl] and + finally we just concatenate those list + *) + let case_resl = + List.fold_right + (fun (case_arg,_) ctxt_argsl -> let arg_res = build_entry_lc env sigma funname ctxt_argsl.to_avoid case_arg in - combine_results combine_args arg_res ctxt_argsl - ) - el - (mk_result [] [] avoid) - in - let types = - List.map (fun (case_arg,_) -> - let case_arg_as_constr,ctx = Pretyping.understand env (Evd.from_env env) case_arg in + combine_results combine_args arg_res ctxt_argsl + ) + el + (mk_result [] [] avoid) + in + let types = + List.map (fun (case_arg,_) -> + let case_arg_as_constr,ctx = Pretyping.understand env (Evd.from_env env) case_arg in EConstr.Unsafe.to_constr (Typing.unsafe_type_of env (Evd.from_env env) case_arg_as_constr) - ) el - in - (****** The next works only if the match is not dependent ****) - let results = - List.map - (fun ca -> - let res = build_entry_lc_from_case_term + ) el + in + (****** The next works only if the match is not dependent ****) + let results = + List.map + (fun ca -> + let res = build_entry_lc_from_case_term env sigma types - funname (make_discr) - [] brl - case_resl.to_avoid - ca - in - res - ) - case_resl.result - in - { - result = List.concat (List.map (fun r -> r.result) results); - to_avoid = - List.fold_left (fun acc r -> List.union Id.equal acc r.to_avoid) + funname (make_discr) + [] brl + case_resl.to_avoid + ca + in + res + ) + case_resl.result + in + { + result = List.concat (List.map (fun r -> r.result) results); + to_avoid = + List.fold_left (fun acc r -> List.union Id.equal acc r.to_avoid) [] results - } + } and build_entry_lc_from_case_term env sigma types funname make_discr patterns_to_prevent brl avoid matched_expr = match brl with | [] -> (* computed_branches *) {result = [];to_avoid = avoid} | br::brl' -> - (* alpha conversion to prevent name clashes *) + (* alpha conversion to prevent name clashes *) let {CAst.v=(idl,patl,return)} = alpha_br avoid br in - let new_avoid = idl@avoid in (* for now we can no more use idl as an identifier *) - (* building a list of precondition stating that we are not in this branch - (will be used in the following recursive calls) - *) + let new_avoid = idl@avoid in (* for now we can no more use idl as an identifier *) + (* building a list of precondition stating that we are not in this branch + (will be used in the following recursive calls) + *) let new_env = List.fold_right2 (add_pat_variables sigma) patl types env in - let not_those_patterns : (Id.t list -> glob_constr -> glob_constr) list = - List.map2 - (fun pat typ -> - fun avoid pat'_as_term -> - let renamed_pat,_,_ = alpha_pat avoid pat in - let pat_ids = get_pattern_id renamed_pat in + let not_those_patterns : (Id.t list -> glob_constr -> glob_constr) list = + List.map2 + (fun pat typ -> + fun avoid pat'_as_term -> + let renamed_pat,_,_ = alpha_pat avoid pat in + let pat_ids = get_pattern_id renamed_pat in let env_with_pat_ids = add_pat_variables sigma pat typ new_env in - List.fold_right - (fun id acc -> - let typ_of_id = - Typing.unsafe_type_of env_with_pat_ids (Evd.from_env env) (EConstr.mkVar id) - in - let raw_typ_of_id = - Detyping.detype Detyping.Now false Id.Set.empty - env_with_pat_ids (Evd.from_env env) typ_of_id - in - mkGProd (Name id,raw_typ_of_id,acc)) - pat_ids - (glob_make_neq pat'_as_term (pattern_to_term renamed_pat)) - ) - patl - types - in - (* Checking if we can be in this branch - (will be used in the following recursive calls) - *) - let unify_with_those_patterns : (cases_pattern -> bool*bool) list = - List.map - (fun pat pat' -> are_unifiable pat pat',eq_cases_pattern pat pat') - patl - in - (* - we first compute the other branch result (in ordrer to keep the order of the matching - as much as possible) - *) - let brl'_res = - build_entry_lc_from_case_term - env + List.fold_right + (fun id acc -> + let typ_of_id = + Typing.unsafe_type_of env_with_pat_ids (Evd.from_env env) (EConstr.mkVar id) + in + let raw_typ_of_id = + Detyping.detype Detyping.Now false Id.Set.empty + env_with_pat_ids (Evd.from_env env) typ_of_id + in + mkGProd (Name id,raw_typ_of_id,acc)) + pat_ids + (glob_make_neq pat'_as_term (pattern_to_term renamed_pat)) + ) + patl + types + in + (* Checking if we can be in this branch + (will be used in the following recursive calls) + *) + let unify_with_those_patterns : (cases_pattern -> bool*bool) list = + List.map + (fun pat pat' -> are_unifiable pat pat',eq_cases_pattern pat pat') + patl + in + (* + we first compute the other branch result (in ordrer to keep the order of the matching + as much as possible) + *) + let brl'_res = + build_entry_lc_from_case_term + env sigma - types - funname - make_discr - ((unify_with_those_patterns,not_those_patterns)::patterns_to_prevent) - brl' - avoid - matched_expr - in - (* We now create the precondition of this branch i.e. - 1- the list of variable appearing in the different patterns of this branch and - the list of equation stating than el = patl (List.flatten ...) - 2- If there exists a previous branch which pattern unify with the one of this branch + types + funname + make_discr + ((unify_with_those_patterns,not_those_patterns)::patterns_to_prevent) + brl' + avoid + matched_expr + in + (* We now create the precondition of this branch i.e. + 1- the list of variable appearing in the different patterns of this branch and + the list of equation stating than el = patl (List.flatten ...) + 2- If there exists a previous branch which pattern unify with the one of this branch then a discrimination precond stating that we are not in a previous branch (if List.exists ...) - *) - let those_pattern_preconds = - (List.flatten - ( - List.map3 - (fun pat e typ_as_constr -> - let this_pat_ids = ids_of_pat pat in - let typ_as_constr = EConstr.of_constr typ_as_constr in - let typ = Detyping.detype Detyping.Now false Id.Set.empty new_env (Evd.from_env env) typ_as_constr in - let pat_as_term = pattern_to_term pat in - (* removing trivial holes *) - let pat_as_term = solve_trivial_holes pat_as_term e in + *) + let those_pattern_preconds = + (List.flatten + ( + List.map3 + (fun pat e typ_as_constr -> + let this_pat_ids = ids_of_pat pat in + let typ_as_constr = EConstr.of_constr typ_as_constr in + let typ = Detyping.detype Detyping.Now false Id.Set.empty new_env (Evd.from_env env) typ_as_constr in + let pat_as_term = pattern_to_term pat in + (* removing trivial holes *) + let pat_as_term = solve_trivial_holes pat_as_term e in (* observe (str "those_pattern_preconds" ++ spc () ++ *) (* str "pat" ++ spc () ++ pr_glob_constr pat_as_term ++ spc ()++ *) (* str "e" ++ spc () ++ pr_glob_constr e ++spc ()++ *) (* str "typ_as_constr" ++ spc () ++ pr_lconstr typ_as_constr); *) - List.fold_right - (fun id acc -> - if Id.Set.mem id this_pat_ids - then (Prod (Name id), - let typ_of_id = Typing.unsafe_type_of new_env (Evd.from_env env) (EConstr.mkVar id) in - let raw_typ_of_id = - Detyping.detype Detyping.Now false Id.Set.empty new_env (Evd.from_env env) typ_of_id - in - raw_typ_of_id - )::acc - else acc - ) - idl - [(Prod Anonymous,glob_make_eq ~typ pat_as_term e)] - ) - patl - matched_expr.value - types - ) - ) - @ - (if List.exists (function (unifl,_) -> - let (unif,_) = - List.split (List.map2 (fun x y -> x y) unifl patl) - in - List.for_all (fun x -> x) unif) patterns_to_prevent - then - let i = List.length patterns_to_prevent in - let pats_as_constr = List.map2 (pattern_to_term_and_type new_env) types patl in - [(Prod Anonymous,make_discr pats_as_constr i )] - else - [] - ) - in - (* We compute the result of the value returned by the branch*) + List.fold_right + (fun id acc -> + if Id.Set.mem id this_pat_ids + then (Prod (Name id), + let typ_of_id = Typing.unsafe_type_of new_env (Evd.from_env env) (EConstr.mkVar id) in + let raw_typ_of_id = + Detyping.detype Detyping.Now false Id.Set.empty new_env (Evd.from_env env) typ_of_id + in + raw_typ_of_id + )::acc + else acc + ) + idl + [(Prod Anonymous,glob_make_eq ~typ pat_as_term e)] + ) + patl + matched_expr.value + types + ) + ) + @ + (if List.exists (function (unifl,_) -> + let (unif,_) = + List.split (List.map2 (fun x y -> x y) unifl patl) + in + List.for_all (fun x -> x) unif) patterns_to_prevent + then + let i = List.length patterns_to_prevent in + let pats_as_constr = List.map2 (pattern_to_term_and_type new_env) types patl in + [(Prod Anonymous,make_discr pats_as_constr i )] + else + [] + ) + in + (* We compute the result of the value returned by the branch*) let return_res = build_entry_lc new_env sigma funname new_avoid return in - (* and combine it with the preconds computed for this branch *) - let this_branch_res = - List.map - (fun res -> - { context = matched_expr.context@those_pattern_preconds@res.context ; - value = res.value} - ) - return_res.result - in - { brl'_res with result = this_branch_res@brl'_res.result } + (* and combine it with the preconds computed for this branch *) + let this_branch_res = + List.map + (fun res -> + { context = matched_expr.context@those_pattern_preconds@res.context ; + value = res.value} + ) + return_res.result + in + { brl'_res with result = this_branch_res@brl'_res.result } let is_res r = match DAst.get r with @@ -891,8 +891,8 @@ let is_gvar c = match DAst.get c with | GVar id -> true | _ -> false -let same_raw_term rt1 rt2 = - match DAst.get rt1, DAst.get rt2 with +let same_raw_term rt1 rt2 = + match DAst.get rt1, DAst.get rt2 with | GRef(r1,_), GRef (r2,_) -> GlobRef.equal r1 r2 | GHole _, GHole _ -> true | _ -> false @@ -927,288 +927,288 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let open CAst in match DAst.get rt with | GProd(n,k,t,b) -> - let not_free_in_t id = not (is_free_in id t) in - let new_crossed_types = t::crossed_types in - begin - match DAst.get t with - | GApp(res_rt ,args') when is_res res_rt -> - begin + let not_free_in_t id = not (is_free_in id t) in + let new_crossed_types = t::crossed_types in + begin + match DAst.get t with + | GApp(res_rt ,args') when is_res res_rt -> + begin let arg = List.hd args' in - match DAst.get arg with - | GVar this_relname -> - (*i The next call to mk_rel_id is - valid since we are constructing the graph - Ensures by: obvious - i*) - - let new_t = - mkGApp(mkGVar(mk_rel_id this_relname),List.tl args'@[res_rt]) - in + match DAst.get arg with + | GVar this_relname -> + (*i The next call to mk_rel_id is + valid since we are constructing the graph + Ensures by: obvious + i*) + + let new_t = + mkGApp(mkGVar(mk_rel_id this_relname),List.tl args'@[res_rt]) + in let t',ctx = Pretyping.understand env (Evd.from_env env) new_t in let r = Sorts.Relevant in (* TODO relevance *) let new_env = EConstr.push_rel (LocalAssum (make_annot n r,t')) env in let new_b,id_to_exclude = - rebuild_cons new_env - nb_args relname - args new_crossed_types - (depth + 1) b - in - mkGProd(n,new_t,new_b), - Id.Set.filter not_free_in_t id_to_exclude - | _ -> (* the first args is the name of the function! *) - assert false - end - | GApp(eq_as_ref,[ty; id ;rt]) + rebuild_cons new_env + nb_args relname + args new_crossed_types + (depth + 1) b + in + mkGProd(n,new_t,new_b), + Id.Set.filter not_free_in_t id_to_exclude + | _ -> (* the first args is the name of the function! *) + assert false + end + | GApp(eq_as_ref,[ty; id ;rt]) when is_gvar id && is_gr eq_as_ref Coqlib.(lib_ref "core.eq.type") && n == Anonymous - -> + -> let loc1 = rt.CAst.loc in let loc2 = eq_as_ref.CAst.loc in let loc3 = id.CAst.loc in let id = match DAst.get id with GVar id -> id | _ -> assert false in - begin - try + begin + try observe (str "computing new type for eq : " ++ pr_glob_constr_env env rt); - let t' = - try fst (Pretyping.understand env (Evd.from_env env) t)(*FIXME*) + let t' = + try fst (Pretyping.understand env (Evd.from_env env) t)(*FIXME*) with e when CErrors.noncritical e -> raise Continue - in - let is_in_b = is_free_in id b in - let _keep_eq = - not (List.exists (is_free_in id) args) || is_in_b || - List.exists (is_free_in id) crossed_types - in - let new_args = List.map (replace_var_by_term id rt) args in - let subst_b = - if is_in_b then b else replace_var_by_term id rt b + in + let is_in_b = is_free_in id b in + let _keep_eq = + not (List.exists (is_free_in id) args) || is_in_b || + List.exists (is_free_in id) crossed_types + in + let new_args = List.map (replace_var_by_term id rt) args in + let subst_b = + if is_in_b then b else replace_var_by_term id rt b in let r = Sorts.Relevant in (* TODO relevance *) let new_env = EConstr.push_rel (LocalAssum (make_annot n r,t')) env in let new_b,id_to_exclude = - rebuild_cons - new_env - nb_args relname - new_args new_crossed_types - (depth + 1) subst_b - in - mkGProd(n,t,new_b),id_to_exclude - with Continue -> + rebuild_cons + new_env + nb_args relname + new_args new_crossed_types + (depth + 1) subst_b + in + mkGProd(n,t,new_b),id_to_exclude + with Continue -> let jmeq = GlobRef.IndRef (fst (EConstr.destInd Evd.empty (jmeq ()))) in - let ty',ctx = Pretyping.understand env (Evd.from_env env) ty in + let ty',ctx = Pretyping.understand env (Evd.from_env env) ty in let ind,args' = Inductiveops.find_inductive env Evd.(from_env env) ty' in - let mib,_ = Global.lookup_inductive (fst ind) in - let nparam = mib.Declarations.mind_nparams in - let params,arg' = - ((Util.List.chop nparam args')) - in - let rt_typ = DAst.make @@ + let mib,_ = Global.lookup_inductive (fst ind) in + let nparam = mib.Declarations.mind_nparams in + let params,arg' = + ((Util.List.chop nparam args')) + in + let rt_typ = DAst.make @@ GApp(DAst.make @@ GRef (GlobRef.IndRef (fst ind),None), - (List.map - (fun p -> Detyping.detype Detyping.Now false Id.Set.empty - env (Evd.from_env env) - (EConstr.of_constr p)) params)@(Array.to_list - (Array.make - (List.length args' - nparam) - (mkGHole ())))) - in - let eq' = - DAst.make ?loc:loc1 @@ GApp(DAst.make ?loc:loc2 @@GRef(jmeq,None),[ty;DAst.make ?loc:loc3 @@ GVar id;rt_typ;rt]) - in + (List.map + (fun p -> Detyping.detype Detyping.Now false Id.Set.empty + env (Evd.from_env env) + (EConstr.of_constr p)) params)@(Array.to_list + (Array.make + (List.length args' - nparam) + (mkGHole ())))) + in + let eq' = + DAst.make ?loc:loc1 @@ GApp(DAst.make ?loc:loc2 @@GRef(jmeq,None),[ty;DAst.make ?loc:loc3 @@ GVar id;rt_typ;rt]) + in observe (str "computing new type for jmeq : " ++ pr_glob_constr_env env eq'); - let eq'_as_constr,ctx = Pretyping.understand env (Evd.from_env env) eq' in - observe (str " computing new type for jmeq : done") ; + let eq'_as_constr,ctx = Pretyping.understand env (Evd.from_env env) eq' in + observe (str " computing new type for jmeq : done") ; let sigma = Evd.(from_env env) in - let new_args = + let new_args = match EConstr.kind sigma eq'_as_constr with - | App(_,[|_;_;ty;_|]) -> + | App(_,[|_;_;ty;_|]) -> let ty = Array.to_list (snd (EConstr.destApp sigma ty)) in - let ty' = snd (Util.List.chop nparam ty) in - List.fold_left2 - (fun acc var_as_constr arg -> - if isRel var_as_constr - then - let na = RelDecl.get_name (Environ.lookup_rel (destRel var_as_constr) env) in - match na with - | Anonymous -> acc - | Name id' -> - (id',Detyping.detype Detyping.Now false Id.Set.empty - env + let ty' = snd (Util.List.chop nparam ty) in + List.fold_left2 + (fun acc var_as_constr arg -> + if isRel var_as_constr + then + let na = RelDecl.get_name (Environ.lookup_rel (destRel var_as_constr) env) in + match na with + | Anonymous -> acc + | Name id' -> + (id',Detyping.detype Detyping.Now false Id.Set.empty + env (Evd.from_env env) - arg)::acc - else if isVar var_as_constr - then (destVar var_as_constr,Detyping.detype Detyping.Now false Id.Set.empty - env + arg)::acc + else if isVar var_as_constr + then (destVar var_as_constr,Detyping.detype Detyping.Now false Id.Set.empty + env (Evd.from_env env) - arg)::acc - else acc - ) - [] - arg' - ty' - | _ -> assert false - in - let is_in_b = is_free_in id b in - let _keep_eq = - not (List.exists (is_free_in id) args) || is_in_b || - List.exists (is_free_in id) crossed_types - in - let new_args = - List.fold_left - (fun args (id,rt) -> - List.map (replace_var_by_term id rt) args - ) - args - ((id,rt)::new_args) - in - let subst_b = - if is_in_b then b else replace_var_by_term id rt b - in - let new_env = - let t',ctx = Pretyping.understand env (Evd.from_env env) eq' in + arg)::acc + else acc + ) + [] + arg' + ty' + | _ -> assert false + in + let is_in_b = is_free_in id b in + let _keep_eq = + not (List.exists (is_free_in id) args) || is_in_b || + List.exists (is_free_in id) crossed_types + in + let new_args = + List.fold_left + (fun args (id,rt) -> + List.map (replace_var_by_term id rt) args + ) + args + ((id,rt)::new_args) + in + let subst_b = + if is_in_b then b else replace_var_by_term id rt b + in + let new_env = + let t',ctx = Pretyping.understand env (Evd.from_env env) eq' in let r = Sorts.Relevant in (* TODO relevance *) EConstr.push_rel (LocalAssum (make_annot n r,t')) env in - let new_b,id_to_exclude = - rebuild_cons - new_env - nb_args relname - new_args new_crossed_types - (depth + 1) subst_b - in - mkGProd(n,eq',new_b),id_to_exclude - end - (* J.F:. keep this comment it explain how to remove some meaningless equalities - if keep_eq then - mkGProd(n,t,new_b),id_to_exclude - else new_b, Id.Set.add id id_to_exclude - *) - | GApp(eq_as_ref,[ty;rt1;rt2]) + let new_b,id_to_exclude = + rebuild_cons + new_env + nb_args relname + new_args new_crossed_types + (depth + 1) subst_b + in + mkGProd(n,eq',new_b),id_to_exclude + end + (* J.F:. keep this comment it explain how to remove some meaningless equalities + if keep_eq then + mkGProd(n,t,new_b),id_to_exclude + else new_b, Id.Set.add id id_to_exclude + *) + | GApp(eq_as_ref,[ty;rt1;rt2]) when is_gr eq_as_ref Coqlib.(lib_ref "core.eq.type") && n == Anonymous - -> - begin - try + -> + begin + try let l = decompose_raw_eq env rt1 rt2 in - if List.length l > 1 - then - let new_rt = - List.fold_left - (fun acc (lhs,rhs) -> - mkGProd(Anonymous, + if List.length l > 1 + then + let new_rt = + List.fold_left + (fun acc (lhs,rhs) -> + mkGProd(Anonymous, mkGApp(mkGRef Coqlib.(lib_ref "core.eq.type"),[mkGHole ();lhs;rhs]),acc) - ) - b - l - in - rebuild_cons env nb_args relname args crossed_types depth new_rt - else raise Continue - with Continue -> + ) + b + l + in + rebuild_cons env nb_args relname args crossed_types depth new_rt + else raise Continue + with Continue -> observe (str "computing new type for prod : " ++ pr_glob_constr_env env rt); - let t',ctx = Pretyping.understand env (Evd.from_env env) t in + let t',ctx = Pretyping.understand env (Evd.from_env env) t in let r = Sorts.Relevant in (* TODO relevance *) let new_env = EConstr.push_rel (LocalAssum (make_annot n r,t')) env in let new_b,id_to_exclude = - rebuild_cons new_env - nb_args relname - args new_crossed_types - (depth + 1) b - in - match n with - | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args -> - new_b,Id.Set.remove id - (Id.Set.filter not_free_in_t id_to_exclude) - | _ -> mkGProd(n,t,new_b),Id.Set.filter not_free_in_t id_to_exclude - end - | _ -> + rebuild_cons new_env + nb_args relname + args new_crossed_types + (depth + 1) b + in + match n with + | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args -> + new_b,Id.Set.remove id + (Id.Set.filter not_free_in_t id_to_exclude) + | _ -> mkGProd(n,t,new_b),Id.Set.filter not_free_in_t id_to_exclude + end + | _ -> observe (str "computing new type for prod : " ++ pr_glob_constr_env env rt); - let t',ctx = Pretyping.understand env (Evd.from_env env) t in + let t',ctx = Pretyping.understand env (Evd.from_env env) t in let r = Sorts.Relevant in (* TODO relevance *) let new_env = EConstr.push_rel (LocalAssum (make_annot n r,t')) env in let new_b,id_to_exclude = - rebuild_cons new_env - nb_args relname - args new_crossed_types - (depth + 1) b - in - match n with - | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args -> - new_b,Id.Set.remove id - (Id.Set.filter not_free_in_t id_to_exclude) - | _ -> mkGProd(n,t,new_b),Id.Set.filter not_free_in_t id_to_exclude - end + rebuild_cons new_env + nb_args relname + args new_crossed_types + (depth + 1) b + in + match n with + | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args -> + new_b,Id.Set.remove id + (Id.Set.filter not_free_in_t id_to_exclude) + | _ -> mkGProd(n,t,new_b),Id.Set.filter not_free_in_t id_to_exclude + end | GLambda(n,k,t,b) -> - begin - let not_free_in_t id = not (is_free_in id t) in - let new_crossed_types = t :: crossed_types in + begin + let not_free_in_t id = not (is_free_in id t) in + let new_crossed_types = t :: crossed_types in observe (str "computing new type for lambda : " ++ pr_glob_constr_env env rt); - let t',ctx = Pretyping.understand env (Evd.from_env env) t in - match n with - | Name id -> + let t',ctx = Pretyping.understand env (Evd.from_env env) t in + match n with + | Name id -> let r = Sorts.Relevant in (* TODO relevance *) let new_env = EConstr.push_rel (LocalAssum (make_annot n r,t')) env in let new_b,id_to_exclude = - rebuild_cons new_env - nb_args relname - (args@[mkGVar id])new_crossed_types - (depth + 1 ) b - in - if Id.Set.mem id id_to_exclude && depth >= nb_args - then - new_b, Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) - else - DAst.make @@ GProd(n,k,t,new_b),Id.Set.filter not_free_in_t id_to_exclude - | _ -> anomaly (Pp.str "Should not have an anonymous function here.") - (* We have renamed all the anonymous functions during alpha_renaming phase *) - - end + rebuild_cons new_env + nb_args relname + (args@[mkGVar id])new_crossed_types + (depth + 1 ) b + in + if Id.Set.mem id id_to_exclude && depth >= nb_args + then + new_b, Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) + else + DAst.make @@ GProd(n,k,t,new_b),Id.Set.filter not_free_in_t id_to_exclude + | _ -> anomaly (Pp.str "Should not have an anonymous function here.") + (* We have renamed all the anonymous functions during alpha_renaming phase *) + + end | GLetIn(n,v,t,b) -> - begin + begin let t = match t with None -> v | Some t -> DAst.make ?loc:rt.loc @@ GCast (v,CastConv t) in - let not_free_in_t id = not (is_free_in id t) in - let evd = (Evd.from_env env) in - let t',ctx = Pretyping.understand env evd t in - let evd = Evd.from_ctx ctx in + let not_free_in_t id = not (is_free_in id t) in + let evd = (Evd.from_env env) in + let t',ctx = Pretyping.understand env evd t in + let evd = Evd.from_ctx ctx in let type_t' = Typing.unsafe_type_of env evd t' in let t' = EConstr.Unsafe.to_constr t' in - let type_t' = EConstr.Unsafe.to_constr type_t' in + let type_t' = EConstr.Unsafe.to_constr type_t' in let new_env = Environ.push_rel (LocalDef (make_annot n Sorts.Relevant,t',type_t')) env in - let new_b,id_to_exclude = - rebuild_cons new_env - nb_args relname - args (t::crossed_types) - (depth + 1 ) b in - match n with - | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args -> - new_b,Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) - | _ -> DAst.make @@ GLetIn(n,t,None,new_b), (* HOPING IT WOULD WORK *) - Id.Set.filter not_free_in_t id_to_exclude - end + let new_b,id_to_exclude = + rebuild_cons new_env + nb_args relname + args (t::crossed_types) + (depth + 1 ) b in + match n with + | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args -> + new_b,Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) + | _ -> DAst.make @@ GLetIn(n,t,None,new_b), (* HOPING IT WOULD WORK *) + Id.Set.filter not_free_in_t id_to_exclude + end | GLetTuple(nal,(na,rto),t,b) -> - assert (Option.is_empty rto); - begin - let not_free_in_t id = not (is_free_in id t) in - let new_t,id_to_exclude' = - rebuild_cons env - nb_args - relname - args (crossed_types) - depth t - in - let t',ctx = Pretyping.understand env (Evd.from_env env) new_t in + assert (Option.is_empty rto); + begin + let not_free_in_t id = not (is_free_in id t) in + let new_t,id_to_exclude' = + rebuild_cons env + nb_args + relname + args (crossed_types) + depth t + in + let t',ctx = Pretyping.understand env (Evd.from_env env) new_t in let r = Sorts.Relevant in (* TODO relevance *) let new_env = EConstr.push_rel (LocalAssum (make_annot na r,t')) env in let new_b,id_to_exclude = - rebuild_cons new_env - nb_args relname - args (t::crossed_types) - (depth + 1) b - in + rebuild_cons new_env + nb_args relname + args (t::crossed_types) + (depth + 1) b + in (* match n with *) (* | Name id when Id.Set.mem id id_to_exclude -> *) (* new_b,Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) *) (* | _ -> *) - DAst.make @@ GLetTuple(nal,(na,None),t,new_b), - Id.Set.filter not_free_in_t (Id.Set.union id_to_exclude id_to_exclude') + DAst.make @@ GLetTuple(nal,(na,None),t,new_b), + Id.Set.filter not_free_in_t (Id.Set.union id_to_exclude id_to_exclude') - end + end | _ -> mkGApp(mkGVar relname,args@[rt]),Id.Set.empty @@ -1249,7 +1249,7 @@ let rec compute_cst_params relnames params gt = DAst.with_val (function compute_cst_params relnames t_params b | GCases _ -> params (* If there is still cases at this point they can only be - discrimination ones *) + discrimination ones *) | GSort _ -> params | GHole _ -> params | GIf _ | GRec _ | GCast _ -> @@ -1260,17 +1260,17 @@ and compute_cst_params_from_app acc (params,rtl) = match params,rtl with | _::_,[] -> assert false (* the rel has at least nargs + 1 arguments ! *) | ((Name id,_,None) as param)::params', c::rtl' when is_gid id c -> - compute_cst_params_from_app (param::acc) (params',rtl') + compute_cst_params_from_app (param::acc) (params',rtl') | _ -> List.rev acc let compute_params_name relnames (args : (Name.t * Glob_term.glob_constr * glob_constr option) list array) csts = let rels_params = Array.mapi (fun i args -> - List.fold_left - (fun params (_,cst) -> compute_cst_params relnames params cst) - args - csts.(i) + List.fold_left + (fun params (_,cst) -> compute_cst_params relnames params cst) + args + csts.(i) ) args in @@ -1278,16 +1278,16 @@ let compute_params_name relnames (args : (Name.t * Glob_term.glob_constr * glob_ let _ = try List.iteri - (fun i ((n,nt,typ) as param) -> - if Array.for_all - (fun l -> - let (n',nt',typ') = List.nth l i in - Name.equal n n' && glob_constr_eq nt nt' && Option.equal glob_constr_eq typ typ') - rels_params - then - l := param::!l - ) - rels_params.(0) + (fun i ((n,nt,typ) as param) -> + if Array.for_all + (fun l -> + let (n',nt',typ') = List.nth l i in + Name.equal n n' && glob_constr_eq nt nt' && Option.equal glob_constr_eq typ typ') + rels_params + then + l := param::!l + ) + rels_params.(0) with e when CErrors.noncritical e -> () in @@ -1333,7 +1333,7 @@ let do_build_inductive let t = EConstr.Unsafe.to_constr t in evd, Environ.push_named (LocalAssum (make_annot id Sorts.Relevant,t)) - env + env ) funnames (Array.of_list funconstants) @@ -1350,23 +1350,23 @@ let do_build_inductive let env_with_graphs = let rel_arity i funargs = (* Rebuilding arities (with parameters) *) let rel_first_args :(Name.t * Glob_term.glob_constr * Glob_term.glob_constr option ) list = - funargs + funargs in List.fold_right - (fun (n,t,typ) acc -> + (fun (n,t,typ) acc -> match typ with | Some typ -> CAst.make @@ Constrexpr.CLetIn((CAst.make n),with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t, Some (with_full_print (Constrextern.extern_glob_constr Id.Set.empty) typ), - acc) - | None -> - CAst.make @@ Constrexpr.CProdN + acc) + | None -> + CAst.make @@ Constrexpr.CProdN ([Constrexpr.CLocalAssum([CAst.make n],Constrexpr_ops.default_binder_kind,with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t)], - acc - ) - ) - rel_first_args - (rebuild_return_type returned_types.(i)) + acc + ) + ) + rel_first_args + (rebuild_return_type returned_types.(i)) in (* We need to lift back our work topconstr but only with all information We mimic a Set Printing All. @@ -1383,15 +1383,15 @@ let do_build_inductive let constr i res = List.map (function result (* (args',concl') *) -> - let rt = compose_glob_context result.context result.value in - let nb_args = List.length funsargs.(i) in - (* with_full_print (fun rt -> Pp.msgnl (str "glob constr " ++ pr_glob_constr rt)) rt; *) - fst ( - rebuild_cons env_with_graphs nb_args relnames.(i) - [] - [] - rt - ) + let rt = compose_glob_context result.context result.value in + let nb_args = List.length funsargs.(i) in + (* with_full_print (fun rt -> Pp.msgnl (str "glob constr " ++ pr_glob_constr rt)) rt; *) + fst ( + rebuild_cons env_with_graphs nb_args relnames.(i) + [] + [] + rt + ) ) res.result in @@ -1427,12 +1427,12 @@ let do_build_inductive | Some typ -> CAst.make @@ Constrexpr.CLetIn((CAst.make n),with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t, Some (with_full_print (Constrextern.extern_glob_constr Id.Set.empty) typ), - acc) - | None -> + acc) + | None -> CAst.make @@ Constrexpr.CProdN ([Constrexpr.CLocalAssum([CAst.make n],Constrexpr_ops.default_binder_kind,with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t)], - acc - ) + acc + ) ) rel_first_args (rebuild_return_type returned_types.(i)) @@ -1446,7 +1446,7 @@ let do_build_inductive List.fold_left (fun acc (na,_,_) -> match na with - Anonymous -> acc + Anonymous -> acc | Name id -> id::acc ) [] @@ -1459,8 +1459,8 @@ let do_build_inductive | Some typ -> Constrexpr.CLocalDef((CAst.make n), Constrextern.extern_glob_constr Id.Set.empty t, Some (with_full_print (Constrextern.extern_glob_constr Id.Set.empty) typ)) - | None -> - Constrexpr.CLocalAssum + | None -> + Constrexpr.CLocalAssum ([(CAst.make n)], Constrexpr_ops.default_binder_kind, Constrextern.extern_glob_constr Id.Set.empty t) ) rels_params @@ -1469,9 +1469,9 @@ let do_build_inductive Array.map (List.map (fun (id,t) -> false,((CAst.make id), - with_full_print - (Constrextern.extern_glob_type Id.Set.empty) ((* zeta_normalize *) (alpha_rt rel_params_ids t)) - ) + with_full_print + (Constrextern.extern_glob_type Id.Set.empty) ((* zeta_normalize *) (alpha_rt rel_params_ids t)) + ) )) (rel_constructors) in @@ -1510,35 +1510,35 @@ let do_build_inductive Declarations.Finite with | UserError(s,msg) as e -> - let _time3 = System.get_time () in + let _time3 = System.get_time () in (* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) - let repacked_rel_inds = + let repacked_rel_inds = List.map (fun ((a , b , c , l),ntn) -> ((false,(a,None)) , b, c , Vernacexpr.Inductive_kw, Vernacexpr.Constructors l),ntn ) - rel_inds - in - let msg = - str "while trying to define"++ spc () ++ + rel_inds + in + let msg = + str "while trying to define"++ spc () ++ Ppvernac.pr_vernac (CAst.make Vernacexpr.{ control = []; attrs = []; expr = VernacInductive(None,false,Declarations.Finite,repacked_rel_inds)}) - ++ fnl () ++ - msg - in - observe (msg); - raise e + ++ fnl () ++ + msg + in + observe (msg); + raise e | reraise -> - let _time3 = System.get_time () in + let _time3 = System.get_time () in (* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) - let repacked_rel_inds = + let repacked_rel_inds = List.map (fun ((a , b , c , l),ntn) -> ((false,(a,None)) , b, c , Vernacexpr.Inductive_kw, Vernacexpr.Constructors l),ntn ) - rel_inds - in - let msg = - str "while trying to define"++ spc () ++ + rel_inds + in + let msg = + str "while trying to define"++ spc () ++ Ppvernac.pr_vernac (CAst.make @@ Vernacexpr.{ control = []; attrs = []; expr = VernacInductive(None,false,Declarations.Finite,repacked_rel_inds)}) - ++ fnl () ++ - CErrors.print reraise - in - observe msg; - raise reraise + ++ fnl () ++ + CErrors.print reraise + in + observe msg; + raise reraise diff --git a/plugins/funind/glob_term_to_relation.mli b/plugins/funind/glob_term_to_relation.mli index ff0e98d00f..a29e5dff23 100644 --- a/plugins/funind/glob_term_to_relation.mli +++ b/plugins/funind/glob_term_to_relation.mli @@ -8,10 +8,10 @@ open Names val build_inductive : (* (ModPath.t * DirPath.t) option -> - Id.t list -> (* The list of function name *) + Id.t list -> (* The list of function name *) *) Evd.evar_map -> - Constr.pconstant list -> + Constr.pconstant list -> (Name.t*Glob_term.glob_constr*Glob_term.glob_constr option) list list -> (* The list of function args *) Constrexpr.constr_expr list -> (* The list of function returned type *) Glob_term.glob_constr list -> (* the list of body *) diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index 5f54bad598..f2d98a13ab 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -36,7 +36,7 @@ let glob_decompose_app = (* msgnl (str "glob_decompose_app on : "++ Printer.pr_glob_constr rt); *) match DAst.get rt with | GApp(rt,rtl) -> - decompose_rapp (List.fold_left (fun y x -> x::y) acc rtl) rt + decompose_rapp (List.fold_left (fun y x -> x::y) acc rtl) rt | _ -> rt,List.rev acc in decompose_rapp [] @@ -62,62 +62,62 @@ let change_vars = DAst.map_with_loc (fun ?loc -> function | GRef _ as x -> x | GVar id -> - let new_id = - try - Id.Map.find id mapping - with Not_found -> id - in - GVar(new_id) + let new_id = + try + Id.Map.find id mapping + with Not_found -> id + in + GVar(new_id) | GEvar _ as x -> x | GPatVar _ as x -> x | GApp(rt',rtl) -> - GApp(change_vars mapping rt', - List.map (change_vars mapping) rtl - ) + GApp(change_vars mapping rt', + List.map (change_vars mapping) rtl + ) | GLambda(name,k,t,b) -> - GLambda(name, - k, - change_vars mapping t, - change_vars (remove_name_from_mapping mapping name) b - ) + GLambda(name, + k, + change_vars mapping t, + change_vars (remove_name_from_mapping mapping name) b + ) | GProd(name,k,t,b) -> - GProd( name, - k, - change_vars mapping t, - change_vars (remove_name_from_mapping mapping name) b - ) + GProd( name, + k, + change_vars mapping t, + change_vars (remove_name_from_mapping mapping name) b + ) | GLetIn(name,def,typ,b) -> - GLetIn(name, - change_vars mapping def, - Option.map (change_vars mapping) typ, - change_vars (remove_name_from_mapping mapping name) b - ) + GLetIn(name, + change_vars mapping def, + Option.map (change_vars mapping) typ, + change_vars (remove_name_from_mapping mapping name) b + ) | GLetTuple(nal,(na,rto),b,e) -> - let new_mapping = List.fold_left remove_name_from_mapping mapping nal in - GLetTuple(nal, - (na, Option.map (change_vars mapping) rto), - change_vars mapping b, - change_vars new_mapping e - ) + let new_mapping = List.fold_left remove_name_from_mapping mapping nal in + GLetTuple(nal, + (na, Option.map (change_vars mapping) rto), + change_vars mapping b, + change_vars new_mapping e + ) | GCases(sty,infos,el,brl) -> - GCases(sty, - infos, - List.map (fun (e,x) -> (change_vars mapping e,x)) el, - List.map (change_vars_br mapping) brl - ) + GCases(sty, + infos, + List.map (fun (e,x) -> (change_vars mapping e,x)) el, + List.map (change_vars_br mapping) brl + ) | GIf(b,(na,e_option),lhs,rhs) -> - GIf(change_vars mapping b, - (na,Option.map (change_vars mapping) e_option), - change_vars mapping lhs, - change_vars mapping rhs - ) + GIf(change_vars mapping b, + (na,Option.map (change_vars mapping) e_option), + change_vars mapping lhs, + change_vars mapping rhs + ) | GRec _ -> user_err ?loc Pp.(str "Local (co)fixes are not supported") | GSort _ as x -> x | GHole _ as x -> x | GInt _ as x -> x | GFloat _ as x -> x | GCast(b,c) -> - GCast(change_vars mapping b, + GCast(change_vars mapping b, Glob_ops.map_cast_type (change_vars mapping) c) ) rt and change_vars_br mapping ({CAst.loc;v=(idl,patl,res)} as br) = @@ -134,40 +134,40 @@ let rec alpha_pat excluded pat = let loc = pat.CAst.loc in match DAst.get pat with | PatVar Anonymous -> - let new_id = Indfun_common.fresh_id excluded "_x" in - (DAst.make ?loc @@ PatVar(Name new_id)),(new_id::excluded),Id.Map.empty + let new_id = Indfun_common.fresh_id excluded "_x" in + (DAst.make ?loc @@ PatVar(Name new_id)),(new_id::excluded),Id.Map.empty | PatVar(Name id) -> - if Id.List.mem id excluded - then - let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in - (DAst.make ?loc @@ PatVar(Name new_id)),(new_id::excluded), - (Id.Map.add id new_id Id.Map.empty) - else pat, excluded,Id.Map.empty + if Id.List.mem id excluded + then + let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in + (DAst.make ?loc @@ PatVar(Name new_id)),(new_id::excluded), + (Id.Map.add id new_id Id.Map.empty) + else pat, excluded,Id.Map.empty | PatCstr(constr,patl,na) -> - let new_na,new_excluded,map = - match na with - | Name id when Id.List.mem id excluded -> - let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in - Name new_id,new_id::excluded, Id.Map.add id new_id Id.Map.empty - | _ -> na,excluded,Id.Map.empty - in - let new_patl,new_excluded,new_map = - List.fold_left - (fun (patl,excluded,map) pat -> - let new_pat,new_excluded,new_map = alpha_pat excluded pat in - (new_pat::patl,new_excluded,Id.Map.fold Id.Map.add new_map map) - ) - ([],new_excluded,map) - patl - in + let new_na,new_excluded,map = + match na with + | Name id when Id.List.mem id excluded -> + let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in + Name new_id,new_id::excluded, Id.Map.add id new_id Id.Map.empty + | _ -> na,excluded,Id.Map.empty + in + let new_patl,new_excluded,new_map = + List.fold_left + (fun (patl,excluded,map) pat -> + let new_pat,new_excluded,new_map = alpha_pat excluded pat in + (new_pat::patl,new_excluded,Id.Map.fold Id.Map.add new_map map) + ) + ([],new_excluded,map) + patl + in (DAst.make ?loc @@ PatCstr(constr,List.rev new_patl,new_na)),new_excluded,new_map let alpha_patl excluded patl = let patl,new_excluded,map = List.fold_left (fun (patl,excluded,map) pat -> - let new_pat,new_excluded,new_map = alpha_pat excluded pat in - new_pat::patl,new_excluded,(Id.Map.fold Id.Map.add new_map map) + let new_pat,new_excluded,new_map = alpha_pat excluded pat in + new_pat::patl,new_excluded,(Id.Map.fold Id.Map.add new_map map) ) ([],excluded,Id.Map.empty) patl @@ -182,15 +182,15 @@ let raw_get_pattern_id pat acc = match DAst.get pat with | PatVar(Anonymous) -> assert false | PatVar(Name id) -> - [id] + [id] | PatCstr(constr,patternl,_) -> - List.fold_right - (fun pat idl -> - let idl' = get_pattern_id pat in - idl'@idl - ) - patternl - [] + List.fold_right + (fun pat idl -> + let idl' = get_pattern_id pat in + idl'@idl + ) + patternl + [] in (get_pattern_id pat)@acc @@ -202,109 +202,109 @@ let rec alpha_rt excluded rt = match DAst.get rt with | GRef _ | GVar _ | GEvar _ | GPatVar _ as rt -> rt | GLambda(Anonymous,k,t,b) -> - let new_id = Namegen.next_ident_away (Id.of_string "_x") (Id.Set.of_list excluded) in - let new_excluded = new_id :: excluded in - let new_t = alpha_rt new_excluded t in - let new_b = alpha_rt new_excluded b in - GLambda(Name new_id,k,new_t,new_b) + let new_id = Namegen.next_ident_away (Id.of_string "_x") (Id.Set.of_list excluded) in + let new_excluded = new_id :: excluded in + let new_t = alpha_rt new_excluded t in + let new_b = alpha_rt new_excluded b in + GLambda(Name new_id,k,new_t,new_b) | GProd(Anonymous,k,t,b) -> - let new_t = alpha_rt excluded t in - let new_b = alpha_rt excluded b in - GProd(Anonymous,k,new_t,new_b) + let new_t = alpha_rt excluded t in + let new_b = alpha_rt excluded b in + GProd(Anonymous,k,new_t,new_b) | GLetIn(Anonymous,b,t,c) -> - let new_b = alpha_rt excluded b in - let new_t = Option.map (alpha_rt excluded) t in - let new_c = alpha_rt excluded c in - GLetIn(Anonymous,new_b,new_t,new_c) + let new_b = alpha_rt excluded b in + let new_t = Option.map (alpha_rt excluded) t in + let new_c = alpha_rt excluded c in + GLetIn(Anonymous,new_b,new_t,new_c) | GLambda(Name id,k,t,b) -> - let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in - let t,b = - if Id.equal new_id id - then t, b - else - let replace = change_vars (Id.Map.add id new_id Id.Map.empty) in - (t,replace b) - in - let new_excluded = new_id::excluded in - let new_t = alpha_rt new_excluded t in - let new_b = alpha_rt new_excluded b in - GLambda(Name new_id,k,new_t,new_b) + let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in + let t,b = + if Id.equal new_id id + then t, b + else + let replace = change_vars (Id.Map.add id new_id Id.Map.empty) in + (t,replace b) + in + let new_excluded = new_id::excluded in + let new_t = alpha_rt new_excluded t in + let new_b = alpha_rt new_excluded b in + GLambda(Name new_id,k,new_t,new_b) | GProd(Name id,k,t,b) -> - let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in - let new_excluded = new_id::excluded in - let t,b = - if Id.equal new_id id - then t,b - else - let replace = change_vars (Id.Map.add id new_id Id.Map.empty) in - (t,replace b) - in - let new_t = alpha_rt new_excluded t in - let new_b = alpha_rt new_excluded b in - GProd(Name new_id,k,new_t,new_b) + let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in + let new_excluded = new_id::excluded in + let t,b = + if Id.equal new_id id + then t,b + else + let replace = change_vars (Id.Map.add id new_id Id.Map.empty) in + (t,replace b) + in + let new_t = alpha_rt new_excluded t in + let new_b = alpha_rt new_excluded b in + GProd(Name new_id,k,new_t,new_b) | GLetIn(Name id,b,t,c) -> - let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in - let c = - if Id.equal new_id id then c - else change_vars (Id.Map.add id new_id Id.Map.empty) c - in - let new_excluded = new_id::excluded in - let new_b = alpha_rt new_excluded b in - let new_t = Option.map (alpha_rt new_excluded) t in - let new_c = alpha_rt new_excluded c in - GLetIn(Name new_id,new_b,new_t,new_c) + let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in + let c = + if Id.equal new_id id then c + else change_vars (Id.Map.add id new_id Id.Map.empty) c + in + let new_excluded = new_id::excluded in + let new_b = alpha_rt new_excluded b in + let new_t = Option.map (alpha_rt new_excluded) t in + let new_c = alpha_rt new_excluded c in + GLetIn(Name new_id,new_b,new_t,new_c) | GLetTuple(nal,(na,rto),t,b) -> - let rev_new_nal,new_excluded,mapping = - List.fold_left - (fun (nal,excluded,mapping) na -> - match na with - | Anonymous -> (na::nal,excluded,mapping) - | Name id -> - let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in - if Id.equal new_id id - then - na::nal,id::excluded,mapping - else - (Name new_id)::nal,id::excluded,(Id.Map.add id new_id mapping) - ) - ([],excluded,Id.Map.empty) - nal - in - let new_nal = List.rev rev_new_nal in - let new_rto,new_t,new_b = - if Id.Map.is_empty mapping - then rto,t,b - else let replace = change_vars mapping in - (Option.map replace rto, t,replace b) - in - let new_t = alpha_rt new_excluded new_t in - let new_b = alpha_rt new_excluded new_b in - let new_rto = Option.map (alpha_rt new_excluded) new_rto in - GLetTuple(new_nal,(na,new_rto),new_t,new_b) + let rev_new_nal,new_excluded,mapping = + List.fold_left + (fun (nal,excluded,mapping) na -> + match na with + | Anonymous -> (na::nal,excluded,mapping) + | Name id -> + let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in + if Id.equal new_id id + then + na::nal,id::excluded,mapping + else + (Name new_id)::nal,id::excluded,(Id.Map.add id new_id mapping) + ) + ([],excluded,Id.Map.empty) + nal + in + let new_nal = List.rev rev_new_nal in + let new_rto,new_t,new_b = + if Id.Map.is_empty mapping + then rto,t,b + else let replace = change_vars mapping in + (Option.map replace rto, t,replace b) + in + let new_t = alpha_rt new_excluded new_t in + let new_b = alpha_rt new_excluded new_b in + let new_rto = Option.map (alpha_rt new_excluded) new_rto in + GLetTuple(new_nal,(na,new_rto),new_t,new_b) | GCases(sty,infos,el,brl) -> - let new_el = - List.map (function (rt,i) -> alpha_rt excluded rt, i) el - in - GCases(sty,infos,new_el,List.map (alpha_br excluded) brl) + let new_el = + List.map (function (rt,i) -> alpha_rt excluded rt, i) el + in + GCases(sty,infos,new_el,List.map (alpha_br excluded) brl) | GIf(b,(na,e_o),lhs,rhs) -> - GIf(alpha_rt excluded b, - (na,Option.map (alpha_rt excluded) e_o), - alpha_rt excluded lhs, - alpha_rt excluded rhs - ) + GIf(alpha_rt excluded b, + (na,Option.map (alpha_rt excluded) e_o), + alpha_rt excluded lhs, + alpha_rt excluded rhs + ) | GRec _ -> user_err Pp.(str "Not handled GRec") | GSort _ | GInt _ | GFloat _ | GHole _ as rt -> rt | GCast (b,c) -> - GCast(alpha_rt excluded b, + GCast(alpha_rt excluded b, Glob_ops.map_cast_type (alpha_rt excluded) c) | GApp(f,args) -> - GApp(alpha_rt excluded f, - List.map (alpha_rt excluded) args - ) + GApp(alpha_rt excluded f, + List.map (alpha_rt excluded) args + ) in new_rt @@ -327,30 +327,30 @@ let is_free_in id = | GPatVar _ -> false | GApp(rt,rtl) -> List.exists is_free_in (rt::rtl) | GLambda(n,_,t,b) | GProd(n,_,t,b) -> - let check_in_b = - match n with - | Name id' -> not (Id.equal id' id) - | _ -> true - in - is_free_in t || (check_in_b && is_free_in b) + let check_in_b = + match n with + | Name id' -> not (Id.equal id' id) + | _ -> true + in + is_free_in t || (check_in_b && is_free_in b) | GLetIn(n,b,t,c) -> - let check_in_c = - match n with - | Name id' -> not (Id.equal id' id) - | _ -> true - in - is_free_in b || Option.cata is_free_in true t || (check_in_c && is_free_in c) + let check_in_c = + match n with + | Name id' -> not (Id.equal id' id) + | _ -> true + in + is_free_in b || Option.cata is_free_in true t || (check_in_c && is_free_in c) | GCases(_,_,el,brl) -> - (List.exists (fun (e,_) -> is_free_in e) el) || - List.exists is_free_in_br brl + (List.exists (fun (e,_) -> is_free_in e) el) || + List.exists is_free_in_br brl | GLetTuple(nal,_,b,t) -> - let check_in_nal = - not (List.exists (function Name id' -> Id.equal id' id | _ -> false) nal) - in - is_free_in t || (check_in_nal && is_free_in b) + let check_in_nal = + not (List.exists (function Name id' -> Id.equal id' id | _ -> false) nal) + in + is_free_in t || (check_in_nal && is_free_in b) | GIf(cond,_,br1,br2) -> - is_free_in cond || is_free_in br1 || is_free_in br2 + is_free_in cond || is_free_in br1 || is_free_in br2 | GRec _ -> user_err Pp.(str "Not handled GRec") | GSort _ -> false | GHole _ -> false @@ -368,26 +368,26 @@ let is_free_in id = let rec pattern_to_term pt = DAst.with_val (function | PatVar Anonymous -> assert false | PatVar(Name id) -> - mkGVar id + mkGVar id | PatCstr(constr,patternl,_) -> let cst_narg = Inductiveops.constructor_nallargs - (Global.env ()) - constr + (Global.env ()) + constr in let implicit_args = - Array.to_list - (Array.init - (cst_narg - List.length patternl) - (fun _ -> mkGHole ()) - ) + Array.to_list + (Array.init + (cst_narg - List.length patternl) + (fun _ -> mkGHole ()) + ) in let patl_as_term = - List.map pattern_to_term patternl + List.map pattern_to_term patternl in mkGApp(mkGRef(GlobRef.ConstructRef constr), - implicit_args@patl_as_term - ) + implicit_args@patl_as_term + ) ) pt @@ -399,51 +399,51 @@ let replace_var_by_term x_id term = | GEvar _ | GPatVar _ as rt -> rt | GApp(rt',rtl) -> - GApp(replace_var_by_pattern rt', - List.map replace_var_by_pattern rtl - ) + GApp(replace_var_by_pattern rt', + List.map replace_var_by_pattern rtl + ) | GLambda(Name id,_,_,_) as rt when Id.compare id x_id == 0 -> rt | GLambda(name,k,t,b) -> - GLambda(name, - k, - replace_var_by_pattern t, - replace_var_by_pattern b - ) + GLambda(name, + k, + replace_var_by_pattern t, + replace_var_by_pattern b + ) | GProd(Name id,_,_,_) as rt when Id.compare id x_id == 0 -> rt | GProd(name,k,t,b) -> - GProd( name, - k, - replace_var_by_pattern t, - replace_var_by_pattern b - ) + GProd( name, + k, + replace_var_by_pattern t, + replace_var_by_pattern b + ) | GLetIn(Name id,_,_,_) as rt when Id.compare id x_id == 0 -> rt | GLetIn(name,def,typ,b) -> - GLetIn(name, - replace_var_by_pattern def, - Option.map (replace_var_by_pattern) typ, - replace_var_by_pattern b - ) + GLetIn(name, + replace_var_by_pattern def, + Option.map (replace_var_by_pattern) typ, + replace_var_by_pattern b + ) | GLetTuple(nal,_,_,_) as rt - when List.exists (function Name id -> Id.equal id x_id | _ -> false) nal -> - rt + when List.exists (function Name id -> Id.equal id x_id | _ -> false) nal -> + rt | GLetTuple(nal,(na,rto),def,b) -> - GLetTuple(nal, - (na,Option.map replace_var_by_pattern rto), - replace_var_by_pattern def, - replace_var_by_pattern b - ) + GLetTuple(nal, + (na,Option.map replace_var_by_pattern rto), + replace_var_by_pattern def, + replace_var_by_pattern b + ) | GCases(sty,infos,el,brl) -> - GCases(sty, - infos, - List.map (fun (e,x) -> (replace_var_by_pattern e,x)) el, - List.map replace_var_by_pattern_br brl - ) + GCases(sty, + infos, + List.map (fun (e,x) -> (replace_var_by_pattern e,x)) el, + List.map replace_var_by_pattern_br brl + ) | GIf(b,(na,e_option),lhs,rhs) -> - GIf(replace_var_by_pattern b, - (na,Option.map replace_var_by_pattern e_option), - replace_var_by_pattern lhs, - replace_var_by_pattern rhs - ) + GIf(replace_var_by_pattern b, + (na,Option.map replace_var_by_pattern e_option), + replace_var_by_pattern lhs, + replace_var_by_pattern rhs + ) | GRec _ -> CErrors.user_err (Pp.str "Not handled GRec") | GSort _ @@ -451,7 +451,7 @@ let replace_var_by_term x_id term = | GInt _ as rt -> rt | GFloat _ as rt -> rt | GCast(b,c) -> - GCast(replace_var_by_pattern b, + GCast(replace_var_by_pattern b, Glob_ops.map_cast_type replace_var_by_pattern c) ) x and replace_var_by_pattern_br ({CAst.loc;v=(idl,patl,res)} as br) = @@ -471,16 +471,16 @@ let rec are_unifiable_aux = function | [] -> () | (l, r) ::eqs -> match DAst.get l, DAst.get r with - | PatVar _ ,_ | _, PatVar _-> are_unifiable_aux eqs - | PatCstr(constructor1,cpl1,_), PatCstr(constructor2,cpl2,_) -> - if not (eq_constructor constructor2 constructor1) - then raise NotUnifiable - else - let eqs' = - try (List.combine cpl1 cpl2) @ eqs - with Invalid_argument _ -> anomaly (Pp.str "are_unifiable_aux.") - in - are_unifiable_aux eqs' + | PatVar _ ,_ | _, PatVar _-> are_unifiable_aux eqs + | PatCstr(constructor1,cpl1,_), PatCstr(constructor2,cpl2,_) -> + if not (eq_constructor constructor2 constructor1) + then raise NotUnifiable + else + let eqs' = + try (List.combine cpl1 cpl2) @ eqs + with Invalid_argument _ -> anomaly (Pp.str "are_unifiable_aux.") + in + are_unifiable_aux eqs' let are_unifiable pat1 pat2 = try @@ -493,17 +493,17 @@ let rec eq_cases_pattern_aux = function | [] -> () | (l, r) ::eqs -> match DAst.get l, DAst.get r with - | PatVar _, PatVar _ -> eq_cases_pattern_aux eqs - | PatCstr(constructor1,cpl1,_), PatCstr(constructor2,cpl2,_) -> - if not (eq_constructor constructor2 constructor1) - then raise NotUnifiable - else - let eqs' = - try (List.combine cpl1 cpl2) @ eqs - with Invalid_argument _ -> anomaly (Pp.str "eq_cases_pattern_aux.") - in - eq_cases_pattern_aux eqs' - | _ -> raise NotUnifiable + | PatVar _, PatVar _ -> eq_cases_pattern_aux eqs + | PatCstr(constructor1,cpl1,_), PatCstr(constructor2,cpl2,_) -> + if not (eq_constructor constructor2 constructor1) + then raise NotUnifiable + else + let eqs' = + try (List.combine cpl1 cpl2) @ eqs + with Invalid_argument _ -> anomaly (Pp.str "eq_cases_pattern_aux.") + in + eq_cases_pattern_aux eqs' + | _ -> raise NotUnifiable let eq_cases_pattern pat1 pat2 = try @@ -528,50 +528,50 @@ let expand_as = match DAst.get rt with | PatVar _ -> map | PatCstr(_,patl,Name id) -> - Id.Map.add id (pattern_to_term rt) (List.fold_left add_as map patl) + Id.Map.add id (pattern_to_term rt) (List.fold_left add_as map patl) | PatCstr(_,patl,_) -> List.fold_left add_as map patl in let rec expand_as map = DAst.map (function | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GInt _ | GFloat _ as rt -> rt | GVar id as rt -> - begin - try - DAst.get (Id.Map.find id map) - with Not_found -> rt - end + begin + try + DAst.get (Id.Map.find id map) + with Not_found -> rt + end | GApp(f,args) -> GApp(expand_as map f,List.map (expand_as map) args) | GLambda(na,k,t,b) -> GLambda(na,k,expand_as map t, expand_as map b) | GProd(na,k,t,b) -> GProd(na,k,expand_as map t, expand_as map b) | GLetIn(na,v,typ,b) -> GLetIn(na, expand_as map v,Option.map (expand_as map) typ,expand_as map b) | GLetTuple(nal,(na,po),v,b) -> - GLetTuple(nal,(na,Option.map (expand_as map) po), - expand_as map v, expand_as map b) + GLetTuple(nal,(na,Option.map (expand_as map) po), + expand_as map v, expand_as map b) | GIf(e,(na,po),br1,br2) -> - GIf(expand_as map e,(na,Option.map (expand_as map) po), - expand_as map br1, expand_as map br2) + GIf(expand_as map e,(na,Option.map (expand_as map) po), + expand_as map br1, expand_as map br2) | GRec _ -> user_err Pp.(str "Not handled GRec") | GCast(b,c) -> - GCast(expand_as map b, + GCast(expand_as map b, Glob_ops.map_cast_type (expand_as map) c) | GCases(sty,po,el,brl) -> - GCases(sty, Option.map (expand_as map) po, List.map (fun (rt,t) -> expand_as map rt,t) el, - List.map (expand_as_br map) brl) + GCases(sty, Option.map (expand_as map) po, List.map (fun (rt,t) -> expand_as map rt,t) el, + List.map (expand_as_br map) brl) ) and expand_as_br map {CAst.loc; v=(idl,cpl,rt)} = CAst.make ?loc (idl,cpl, expand_as (List.fold_left add_as map cpl) rt) in expand_as Id.Map.empty -(* [resolve_and_replace_implicits ?expected_type env sigma rt] solves implicits of [rt] w.r.t. [env] and [sigma] and then replace them by their solution +(* [resolve_and_replace_implicits ?expected_type env sigma rt] solves implicits of [rt] w.r.t. [env] and [sigma] and then replace them by their solution *) exception Found of Evd.evar_info let resolve_and_replace_implicits ?(flags=Pretyping.all_and_fail_flags) ?(expected_type=Pretyping.WithoutTypeConstraint) env sigma rt = let open Evd in - let open Evar_kinds in + let open Evar_kinds in (* we first (pseudo) understand [rt] and get back the computed evar_map *) - (* FIXME : JF (30/03/2017) I'm not completely sure to have split understand as needed. -If someone knows how to prevent solved existantial removal in understand, please do not hesitate to change the computation of [ctx] here *) + (* FIXME : JF (30/03/2017) I'm not completely sure to have split understand as needed. +If someone knows how to prevent solved existantial removal in understand, please do not hesitate to change the computation of [ctx] here *) let ctx,_,_ = Pretyping.ise_pretype_gen flags env sigma Glob_ops.empty_lvar expected_type rt in let ctx = Evd.minimize_universes ctx in let f c = EConstr.of_constr (Evarutil.nf_evars_universes ctx (EConstr.Unsafe.to_constr c)) in @@ -603,7 +603,7 @@ If someone knows how to prevent solved existantial removal in understand, pleas ) | (GHole(BinderType na,_,_)) -> (* we only want to deal with implicit arguments *) ( - let res = + let res = try (* we scan the new evar map to find the evar corresponding to this hole (by looking the source *) Evd.fold (* to simulate an iter *) (fun _ evi _ -> @@ -622,9 +622,9 @@ If someone knows how to prevent solved existantial removal in understand, pleas (* we just have to lift the solution in glob_term *) Detyping.detype Detyping.Now false Id.Set.empty env ctx (f c) | Evar_empty -> rt (* the hole was not solved : we d when falseo nothing *) - in + in res ) - | _ -> Glob_ops.map_glob_constr change rt + | _ -> Glob_ops.map_glob_constr change rt in change rt diff --git a/plugins/funind/glob_termops.mli b/plugins/funind/glob_termops.mli index 70211a1860..bdde66bbd7 100644 --- a/plugins/funind/glob_termops.mli +++ b/plugins/funind/glob_termops.mli @@ -101,8 +101,8 @@ val ids_of_pat : cases_pattern -> Id.Set.t val expand_as : glob_constr -> glob_constr -(* [resolve_and_replace_implicits ?expected_type env sigma rt] solves implicits of [rt] w.r.t. [env] and [sigma] and then replace them by their solution +(* [resolve_and_replace_implicits ?expected_type env sigma rt] solves implicits of [rt] w.r.t. [env] and [sigma] and then replace them by their solution *) val resolve_and_replace_implicits : - ?flags:Pretyping.inference_flags -> + ?flags:Pretyping.inference_flags -> ?expected_type:Pretyping.typing_constraint -> Environ.env -> Evd.evar_map -> glob_constr -> glob_constr diff --git a/plugins/ltac/evar_tactics.ml b/plugins/ltac/evar_tactics.ml index 5211bedd46..c87eb7c3c9 100644 --- a/plugins/ltac/evar_tactics.ml +++ b/plugins/ltac/evar_tactics.ml @@ -51,20 +51,20 @@ let instantiate_tac n c ido = let sigma = gl.sigma in let evl = match ido with - ConclLocation () -> evar_list sigma (pf_concl gl) + ConclLocation () -> evar_list sigma (pf_concl gl) | HypLocation (id,hloc) -> let decl = Environ.lookup_named id (pf_env gl) in - match hloc with - InHyp -> - (match decl with + match hloc with + InHyp -> + (match decl with | LocalAssum (_,typ) -> evar_list sigma (EConstr.of_constr typ) - | _ -> user_err Pp.(str "Please be more specific: in type or value?")) - | InHypTypeOnly -> - evar_list sigma (EConstr.of_constr (NamedDecl.get_type decl)) - | InHypValueOnly -> - (match decl with + | _ -> user_err Pp.(str "Please be more specific: in type or value?")) + | InHypTypeOnly -> + evar_list sigma (EConstr.of_constr (NamedDecl.get_type decl)) + | InHypValueOnly -> + (match decl with | LocalDef (_,body,_) -> evar_list sigma (EConstr.of_constr body) - | _ -> user_err Pp.(str "Not a defined hypothesis.")) in + | _ -> user_err Pp.(str "Not a defined hypothesis.")) in if List.length evl < n then user_err Pp.(str "Not enough uninstantiated existential variables."); if n <= 0 then user_err Pp.(str "Incorrect existential variable index."); @@ -97,7 +97,7 @@ let let_evar name typ = Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (Tactics.pose_tac (Name.Name id) evar) end - + let hget_evar n = let open EConstr in Proofview.Goal.enter begin fun gl -> diff --git a/plugins/ltac/extraargs.mlg b/plugins/ltac/extraargs.mlg index e6e6e29d4f..bab6bfd78e 100644 --- a/plugins/ltac/extraargs.mlg +++ b/plugins/ltac/extraargs.mlg @@ -115,8 +115,8 @@ let interp_occs ist gl l = match l with | ArgArg x -> x | ArgVar ({ CAst.v = id } as locid) -> - (try int_list_of_VList (Id.Map.find id ist.lfun) - with Not_found | CannotCoerceTo _ -> [interp_int ist locid]) + (try int_list_of_VList (Id.Map.find id ist.lfun) + with Not_found | CannotCoerceTo _ -> [interp_int ist locid]) let interp_occs ist gl l = Tacmach.project gl , interp_occs ist gl l diff --git a/plugins/ltac/extratactics.mlg b/plugins/ltac/extratactics.mlg index f7215a9d13..a9e5271e81 100644 --- a/plugins/ltac/extratactics.mlg +++ b/plugins/ltac/extratactics.mlg @@ -204,7 +204,7 @@ TACTIC EXTEND dependent_rewrite END (** To be deprecated?, "cutrewrite (t=u) as <-" is equivalent to - "replace u with t" or "enough (t=u) as <-" and + "replace u with t" or "enough (t=u) as <-" and "cutrewrite (t=u) as ->" is equivalent to "enough (t=u) as ->". *) TACTIC EXTEND cut_rewrite @@ -314,8 +314,8 @@ let add_rewrite_hint ~poly bases ort t lcsr = let ctx = let ctx = UState.context_set ctx in if poly then ctx - else (* This is a global universe context that shouldn't be - refreshed at every use of the hint, declare it globally. *) + else (* This is a global universe context that shouldn't be + refreshed at every use of the hint, declare it globally. *) (Declare.declare_universe_context ~poly:false ctx; Univ.ContextSet.empty) in @@ -595,7 +595,7 @@ TACTIC EXTEND dep_generalize_eqs_vars | ["dependent" "generalize_eqs_vars" hyp(id) ] -> { abstract_generalize ~force_dep:true ~generalize_vars:true id } END -(** Tactic to automatically simplify hypotheses of the form [Π Δ, x_i = t_i -> T] +(** Tactic to automatically simplify hypotheses of the form [Π Δ, x_i = t_i -> T] where [t_i] is closed w.r.t. Δ. Such hypotheses are automatically generated during dependent induction. For internal use. *) @@ -613,17 +613,17 @@ END { -let subst_var_with_hole occ tid t = +let subst_var_with_hole occ tid t = let occref = if occ > 0 then ref occ else Find_subterm.error_invalid_occurrence [occ] in let locref = ref 0 in let rec substrec x = match DAst.get x with | GVar id -> - if Id.equal id tid + if Id.equal id tid then - (decr occref; - if Int.equal !occref 0 then x + (decr occref; + if Int.equal !occref 0 then x else - (incr locref; + (incr locref; DAst.make ~loc:(Loc.make_loc (!locref,0)) @@ GHole (Evar_kinds.QuestionMark { Evar_kinds.qm_obligation=Evar_kinds.Define true; @@ -648,7 +648,7 @@ let subst_hole_with_term occ tc t = decr occref; if Int.equal !occref 0 then tc else - (incr locref; + (incr locref; DAst.make ~loc:(Loc.make_loc (!locref,0)) @@ GHole (Evar_kinds.QuestionMark { Evar_kinds.qm_obligation=Evar_kinds.Define true; @@ -670,7 +670,7 @@ let hResolve id c occ t = let c_raw = Detyping.detype Detyping.Now true env_ids env sigma c in let t_raw = Detyping.detype Detyping.Now true env_ids env sigma t in let rec resolve_hole t_hole = - try + try Pretyping.understand env sigma t_hole with | Pretype_errors.PretypeError (_,_,Pretype_errors.UnsolvableImplicit _) as e -> @@ -686,7 +686,7 @@ let hResolve id c occ t = end let hResolve_auto id c t = - let rec resolve_auto n = + let rec resolve_auto n = try hResolve id c n t with @@ -727,7 +727,7 @@ exception Found of unit Proofview.tactic let rewrite_except h = Proofview.Goal.enter begin fun gl -> let hyps = Tacmach.New.pf_ids_of_hyps gl in - Tacticals.New.tclMAP (fun id -> if Id.equal id h then Proofview.tclUNIT () else + Tacticals.New.tclMAP (fun id -> if Id.equal id h then Proofview.tclUNIT () else Tacticals.New.tclTRY (Equality.general_rewrite_in true Locus.AllOccurrences true true id (mkVar h) false)) hyps end @@ -750,9 +750,9 @@ let mkCaseEq a : unit Proofview.tactic = (* FIXME: this looks really wrong. Does anybody really use this tactic? *) let (_, c) = Tacred.pattern_occs [Locus.OnlyOccurrences [1], a] env (Evd.from_env env) concl in - change_concl c + change_concl c end; - simplest_case a] + simplest_case a] end @@ -769,8 +769,8 @@ let case_eq_intros_rewrite x = let h = fresh_id_in_env hyps (Id.of_string "heq") (Proofview.Goal.env gl) in Tacticals.New.tclTHENLIST [ Tacticals.New.tclDO (n'-n-1) intro; - introduction h; - rewrite_except h] + introduction h; + rewrite_except h] end ] end @@ -781,14 +781,14 @@ let rec find_a_destructable_match sigma t = let dest = TacAtom (CAst.make @@ TacInductionDestruct(false, false, cl)) in match EConstr.kind sigma t with | Case (_,_,x,_) when closed0 sigma x -> - if isVar sigma x then - (* TODO check there is no rel n. *) - raise (Found (Tacinterp.eval_tactic dest)) - else - (* let _ = Pp.msgnl (Printer.pr_lconstr x) in *) - raise (Found (case_eq_intros_rewrite x)) + if isVar sigma x then + (* TODO check there is no rel n. *) + raise (Found (Tacinterp.eval_tactic dest)) + else + (* let _ = Pp.msgnl (Printer.pr_lconstr x) in *) + raise (Found (case_eq_intros_rewrite x)) | _ -> EConstr.iter sigma (fun c -> find_a_destructable_match sigma c) t - + let destauto t = Proofview.tclEVARMAP >>= fun sigma -> @@ -796,7 +796,7 @@ let destauto t = Tacticals.New.tclZEROMSG (str "No destructable match found") with Found tac -> tac -let destauto_in id = +let destauto_in id = Proofview.Goal.enter begin fun gl -> let ctype = Tacmach.New.pf_unsafe_type_of gl (mkVar id) in (* Pp.msgnl (Printer.pr_lconstr (mkVar id)); *) diff --git a/plugins/ltac/g_ltac.mlg b/plugins/ltac/g_ltac.mlg index cab8ed0a55..81a6651745 100644 --- a/plugins/ltac/g_ltac.mlg +++ b/plugins/ltac/g_ltac.mlg @@ -69,8 +69,8 @@ let test_bracket_ident = | KEYWORD "[" -> (match stream_nth 1 strm with | IDENT _ -> () - | _ -> raise Stream.Failure) - | _ -> raise Stream.Failure) + | _ -> raise Stream.Failure) + | _ -> raise Stream.Failure) (* Tactics grammar rules *) @@ -110,11 +110,11 @@ GRAMMAR EXTEND Gram | ta0 = tactic_expr; ";"; ta1 = tactic_expr -> { TacThen (ta0,ta1) } | ta0 = tactic_expr; ";"; l = tactic_then_locality; tg = tactic_then_gen; "]" -> { let (first,tail) = tg in - match l , tail with + match l , tail with | false , Some (t,last) -> TacThen (ta0,TacExtendTac (Array.of_list first, t, last)) - | true , Some (t,last) -> TacThens3parts (ta0, Array.of_list first, t, last) + | true , Some (t,last) -> TacThens3parts (ta0, Array.of_list first, t, last) | false , None -> TacThen (ta0,TacDispatch first) - | true , None -> TacThens (ta0,first) } ] + | true , None -> TacThens (ta0,first) } ] | "3" RIGHTA [ IDENT "try"; ta = tactic_expr -> { TacTry ta } | IDENT "do"; n = int_or_var; ta = tactic_expr -> { TacDo (n,ta) } @@ -148,12 +148,12 @@ GRAMMAR EXTEND Gram | b = match_key; c = tactic_expr; "with"; mrl = match_list; "end" -> { TacMatch (b,c,mrl) } | IDENT "first" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> - { TacFirst l } + { TacFirst l } | IDENT "solve" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> - { TacSolve l } + { TacSolve l } | IDENT "idtac"; l = LIST0 message_token -> { TacId l } | g=failkw; n = [ n = int_or_var -> { n } | -> { fail_default_value } ]; - l = LIST0 message_token -> { TacFail (g,n,l) } + l = LIST0 message_token -> { TacFail (g,n,l) } | st = simple_tactic -> { st } | a = tactic_arg -> { TacArg(CAst.make ~loc a) } | r = reference; la = LIST0 tactic_arg_compat -> @@ -247,12 +247,12 @@ GRAMMAR EXTEND Gram | na = name; ":="; "["; mpv = match_pattern; "]"; ":"; mpt = match_pattern -> { Def (na, mpv, mpt) } | na = name; ":="; mpv = match_pattern -> { let t, ty = - match mpv with - | Term t -> (match t with - | { CAst.v = CCast (t, (CastConv ty | CastVM ty | CastNative ty)) } -> Term t, Some (Term ty) - | _ -> mpv, None) - | _ -> mpv, None - in Def (na, t, Option.default (Term (CAst.make @@ CHole (None, IntroAnonymous, None))) ty) } + match mpv with + | Term t -> (match t with + | { CAst.v = CCast (t, (CastConv ty | CastVM ty | CastNative ty)) } -> Term t, Some (Term ty) + | _ -> mpv, None) + | _ -> mpv, None + in Def (na, t, Option.default (Term (CAst.make @@ CHole (None, IntroAnonymous, None))) ty) } ] ] ; match_context_rule: @@ -337,9 +337,9 @@ GRAMMAR EXTEND Gram | g = OPT toplevel_selector; "{" -> { Vernacexpr.VernacSubproof g } ] ] ; command: - [ [ IDENT "Proof"; "with"; ta = Pltac.tactic; + [ [ IDENT "Proof"; "with"; ta = Pltac.tactic; l = OPT [ "using"; l = G_vernac.section_subset_expr -> { l } ] -> - { Vernacexpr.VernacProof (Some (in_tac ta), l) } + { Vernacexpr.VernacProof (Some (in_tac ta), l) } | IDENT "Proof"; "using"; l = G_vernac.section_subset_expr; ta = OPT [ "with"; ta = Pltac.tactic -> { in_tac ta } ] -> { Vernacexpr.VernacProof (ta,Some l) } ] ] diff --git a/plugins/ltac/g_obligations.mlg b/plugins/ltac/g_obligations.mlg index 61cc77c42a..5a7a634ed0 100644 --- a/plugins/ltac/g_obligations.mlg +++ b/plugins/ltac/g_obligations.mlg @@ -20,7 +20,7 @@ open Stdarg open Tacarg open Extraargs -let (set_default_tactic, get_default_tactic, print_default_tactic) = +let (set_default_tactic, get_default_tactic, print_default_tactic) = Tactic_option.declare_tactic_option "Program tactic" let () = diff --git a/plugins/ltac/g_rewrite.mlg b/plugins/ltac/g_rewrite.mlg index d25448b5cb..2209edcbb4 100644 --- a/plugins/ltac/g_rewrite.mlg +++ b/plugins/ltac/g_rewrite.mlg @@ -71,7 +71,7 @@ END type raw_strategy = (constr_expr, Tacexpr.raw_red_expr) strategy_ast type glob_strategy = (glob_constr_and_expr, Tacexpr.raw_red_expr) strategy_ast -let interp_strategy ist gl s = +let interp_strategy ist gl s = let sigma = project gl in sigma, strategy_of_ast s let glob_strategy ist s = map_strategy (Tacintern.intern_constr ist) (fun c -> c) s diff --git a/plugins/ltac/g_tactic.mlg b/plugins/ltac/g_tactic.mlg index eb282d1f83..d82eadcfc7 100644 --- a/plugins/ltac/g_tactic.mlg +++ b/plugins/ltac/g_tactic.mlg @@ -45,10 +45,10 @@ let test_lpar_id_coloneq = (match stream_nth 1 strm with | IDENT _ -> (match stream_nth 2 strm with - | KEYWORD ":=" -> () - | _ -> err ()) - | _ -> err ()) - | _ -> err ()) + | KEYWORD ":=" -> () + | _ -> err ()) + | _ -> err ()) + | _ -> err ()) (* Hack to recognize "(x)" *) let test_lpar_id_rpar = @@ -59,10 +59,10 @@ let test_lpar_id_rpar = (match stream_nth 1 strm with | IDENT _ -> (match stream_nth 2 strm with - | KEYWORD ")" -> () - | _ -> err ()) - | _ -> err ()) - | _ -> err ()) + | KEYWORD ")" -> () + | _ -> err ()) + | _ -> err ()) + | _ -> err ()) (* idem for (x:=t) and (1:=t) *) let test_lpar_idnum_coloneq = @@ -86,22 +86,22 @@ let check_for_coloneq = Pcoq.Entry.of_parser "lpar_id_colon" (fun _ strm -> let rec skip_to_rpar p n = - match List.last (Stream.npeek n strm) with + match List.last (Stream.npeek n strm) with | KEYWORD "(" -> skip_to_rpar (p+1) (n+1) | KEYWORD ")" -> if Int.equal p 0 then n+1 else skip_to_rpar (p-1) (n+1) - | KEYWORD "." -> err () - | _ -> skip_to_rpar p (n+1) in + | KEYWORD "." -> err () + | _ -> skip_to_rpar p (n+1) in let rec skip_names n = - match List.last (Stream.npeek n strm) with + match List.last (Stream.npeek n strm) with | IDENT _ | KEYWORD "_" -> skip_names (n+1) - | KEYWORD ":" -> skip_to_rpar 0 (n+1) (* skip a constr *) - | _ -> err () in + | KEYWORD ":" -> skip_to_rpar 0 (n+1) (* skip a constr *) + | _ -> err () in let rec skip_binders n = - match List.last (Stream.npeek n strm) with + match List.last (Stream.npeek n strm) with | KEYWORD "(" -> skip_binders (skip_names (n+1)) | IDENT _ | KEYWORD "_" -> skip_binders (n+1) - | KEYWORD ":=" -> () - | _ -> err () in + | KEYWORD ":=" -> () + | _ -> err () in match stream_nth 0 strm with | KEYWORD "(" -> skip_binders 2 | _ -> err ()) @@ -110,8 +110,8 @@ let lookup_at_as_comma = Pcoq.Entry.of_parser "lookup_at_as_comma" (fun _ strm -> match stream_nth 0 strm with - | KEYWORD (","|"at"|"as") -> () - | _ -> err ()) + | KEYWORD (","|"at"|"as") -> () + | _ -> err ()) open Constr open Prim @@ -164,7 +164,7 @@ let mkTacCase with_evar = function | ic -> if List.exists (function ((_, ElimOnAnonHyp _),_,_) -> true | _ -> false) (fst ic) then - user_err Pp.(str "Use of numbers as direct arguments of 'case' is not supported."); + user_err Pp.(str "Use of numbers as direct arguments of 'case' is not supported."); TacInductionDestruct (false,with_evar,ic) let rec mkCLambdaN_simple_loc ?loc bll c = @@ -188,7 +188,7 @@ let merge_occurrences loc cl = function | None -> if Locusops.clause_with_generic_occurrences cl then (None, cl) else - user_err ~loc (str "Found an \"at\" clause without \"with\" clause.") + user_err ~loc (str "Found an \"at\" clause without \"with\" clause.") | Some (occs, p) -> let ans = match occs with | AllOccurrences -> cl @@ -264,7 +264,7 @@ GRAMMAR EXTEND Gram occs_nums: [ [ nl = LIST1 nat_or_var -> { OnlyOccurrences nl } | "-"; n = nat_or_var; nl = LIST0 int_or_var -> - (* have used int_or_var instead of nat_or_var for compatibility *) + (* have used int_or_var instead of nat_or_var for compatibility *) { AllOccurrencesBut (List.map (Locusops.or_var_map abs) (n::nl)) } ] ] ; occs: @@ -296,12 +296,12 @@ GRAMMAR EXTEND Gram tc = LIST1 simple_intropattern SEP "," ; ")" -> { IntroAndPattern (si::tc) } | "("; si = simple_intropattern; "&"; - tc = LIST1 simple_intropattern SEP "&" ; ")" -> - (* (A & B & C) is translated into (A,(B,C)) *) - { let rec pairify = function - | ([]|[_]|[_;_]) as l -> l + tc = LIST1 simple_intropattern SEP "&" ; ")" -> + (* (A & B & C) is translated into (A,(B,C)) *) + { let rec pairify = function + | ([]|[_]|[_;_]) as l -> l | t::q -> [t; CAst.make ?loc:(loc_of_ne_list q) (IntroAction (IntroOrAndPattern (IntroAndPattern (pairify q))))] - in IntroAndPattern (pairify (si::tc)) } ] ] + in IntroAndPattern (pairify (si::tc)) } ] ] ; equality_intropattern: [ [ "->" -> { IntroRewrite true } @@ -550,24 +550,24 @@ GRAMMAR EXTEND Gram | IDENT "case"; icl = induction_clause_list -> { TacAtom (CAst.make ~loc @@ mkTacCase false icl) } | IDENT "ecase"; icl = induction_clause_list -> { TacAtom (CAst.make ~loc @@ mkTacCase true icl) } | "fix"; id = ident; n = natural; "with"; fd = LIST1 fixdecl -> - { TacAtom (CAst.make ~loc @@ TacMutualFix (id,n,List.map mk_fix_tac fd)) } + { TacAtom (CAst.make ~loc @@ TacMutualFix (id,n,List.map mk_fix_tac fd)) } | "cofix"; id = ident; "with"; fd = LIST1 cofixdecl -> - { TacAtom (CAst.make ~loc @@ TacMutualCofix (id,List.map mk_cofix_tac fd)) } + { TacAtom (CAst.make ~loc @@ TacMutualCofix (id,List.map mk_cofix_tac fd)) } | IDENT "pose"; bl = bindings_with_parameters -> - { let (id,b) = bl in TacAtom (CAst.make ~loc @@ TacLetTac (false,Names.Name.Name id,b,Locusops.nowhere,true,None)) } + { let (id,b) = bl in TacAtom (CAst.make ~loc @@ TacLetTac (false,Names.Name.Name id,b,Locusops.nowhere,true,None)) } | IDENT "pose"; b = constr; na = as_name -> - { TacAtom (CAst.make ~loc @@ TacLetTac (false,na,b,Locusops.nowhere,true,None)) } + { TacAtom (CAst.make ~loc @@ TacLetTac (false,na,b,Locusops.nowhere,true,None)) } | IDENT "epose"; bl = bindings_with_parameters -> - { let (id,b) = bl in TacAtom (CAst.make ~loc @@ TacLetTac (true,Names.Name id,b,Locusops.nowhere,true,None)) } + { let (id,b) = bl in TacAtom (CAst.make ~loc @@ TacLetTac (true,Names.Name id,b,Locusops.nowhere,true,None)) } | IDENT "epose"; b = constr; na = as_name -> - { TacAtom (CAst.make ~loc @@ TacLetTac (true,na,b,Locusops.nowhere,true,None)) } + { TacAtom (CAst.make ~loc @@ TacLetTac (true,na,b,Locusops.nowhere,true,None)) } | IDENT "set"; bl = bindings_with_parameters; p = clause_dft_concl -> - { let (id,c) = bl in TacAtom (CAst.make ~loc @@ TacLetTac (false,Names.Name.Name id,c,p,true,None)) } + { let (id,c) = bl in TacAtom (CAst.make ~loc @@ TacLetTac (false,Names.Name.Name id,c,p,true,None)) } | IDENT "set"; c = constr; na = as_name; p = clause_dft_concl -> { TacAtom (CAst.make ~loc @@ TacLetTac (false,na,c,p,true,None)) } | IDENT "eset"; bl = bindings_with_parameters; p = clause_dft_concl -> - { let (id,c) = bl in TacAtom (CAst.make ~loc @@ TacLetTac (true,Names.Name id,c,p,true,None)) } + { let (id,c) = bl in TacAtom (CAst.make ~loc @@ TacLetTac (true,Names.Name id,c,p,true,None)) } | IDENT "eset"; c = constr; na = as_name; p = clause_dft_concl -> { TacAtom (CAst.make ~loc @@ TacLetTac (true,na,c,p,true,None)) } | IDENT "remember"; c = constr; na = as_name; e = eqn_ipat; @@ -579,51 +579,51 @@ GRAMMAR EXTEND Gram (* Alternative syntax for "pose proof c as id" *) | IDENT "assert"; test_lpar_id_coloneq; "("; lid = identref; ":="; - c = lconstr; ")" -> + c = lconstr; ")" -> { let { CAst.loc = loc; v = id } = lid in TacAtom (CAst.make ?loc @@ TacAssert (false,true,None,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } | IDENT "eassert"; test_lpar_id_coloneq; "("; lid = identref; ":="; - c = lconstr; ")" -> + c = lconstr; ")" -> { let { CAst.loc = loc; v = id } = lid in TacAtom (CAst.make ?loc @@ TacAssert (true,true,None,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } (* Alternative syntax for "assert c as id by tac" *) | IDENT "assert"; test_lpar_id_colon; "("; lid = identref; ":"; - c = lconstr; ")"; tac=by_tactic -> + c = lconstr; ")"; tac=by_tactic -> { let { CAst.loc = loc; v = id } = lid in TacAtom (CAst.make ?loc @@ TacAssert (false,true,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } | IDENT "eassert"; test_lpar_id_colon; "("; lid = identref; ":"; - c = lconstr; ")"; tac=by_tactic -> + c = lconstr; ")"; tac=by_tactic -> { let { CAst.loc = loc; v = id } = lid in TacAtom (CAst.make ?loc @@ TacAssert (true,true,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } (* Alternative syntax for "enough c as id by tac" *) | IDENT "enough"; test_lpar_id_colon; "("; lid = identref; ":"; - c = lconstr; ")"; tac=by_tactic -> + c = lconstr; ")"; tac=by_tactic -> { let { CAst.loc = loc; v = id } = lid in TacAtom (CAst.make ?loc @@ TacAssert (false,false,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } | IDENT "eenough"; test_lpar_id_colon; "("; lid = identref; ":"; - c = lconstr; ")"; tac=by_tactic -> + c = lconstr; ")"; tac=by_tactic -> { let { CAst.loc = loc; v = id } = lid in TacAtom (CAst.make ?loc @@ TacAssert (true,false,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } | IDENT "assert"; c = constr; ipat = as_ipat; tac = by_tactic -> - { TacAtom (CAst.make ~loc @@ TacAssert (false,true,Some tac,ipat,c)) } + { TacAtom (CAst.make ~loc @@ TacAssert (false,true,Some tac,ipat,c)) } | IDENT "eassert"; c = constr; ipat = as_ipat; tac = by_tactic -> - { TacAtom (CAst.make ~loc @@ TacAssert (true,true,Some tac,ipat,c)) } + { TacAtom (CAst.make ~loc @@ TacAssert (true,true,Some tac,ipat,c)) } | IDENT "pose"; IDENT "proof"; c = lconstr; ipat = as_ipat -> - { TacAtom (CAst.make ~loc @@ TacAssert (false,true,None,ipat,c)) } + { TacAtom (CAst.make ~loc @@ TacAssert (false,true,None,ipat,c)) } | IDENT "epose"; IDENT "proof"; c = lconstr; ipat = as_ipat -> - { TacAtom (CAst.make ~loc @@ TacAssert (true,true,None,ipat,c)) } + { TacAtom (CAst.make ~loc @@ TacAssert (true,true,None,ipat,c)) } | IDENT "enough"; c = constr; ipat = as_ipat; tac = by_tactic -> - { TacAtom (CAst.make ~loc @@ TacAssert (false,false,Some tac,ipat,c)) } + { TacAtom (CAst.make ~loc @@ TacAssert (false,false,Some tac,ipat,c)) } | IDENT "eenough"; c = constr; ipat = as_ipat; tac = by_tactic -> - { TacAtom (CAst.make ~loc @@ TacAssert (true,false,Some tac,ipat,c)) } + { TacAtom (CAst.make ~loc @@ TacAssert (true,false,Some tac,ipat,c)) } | IDENT "generalize"; c = constr -> - { TacAtom (CAst.make ~loc @@ TacGeneralize [((AllOccurrences,c),Names.Name.Anonymous)]) } + { TacAtom (CAst.make ~loc @@ TacGeneralize [((AllOccurrences,c),Names.Name.Anonymous)]) } | IDENT "generalize"; c = constr; l = LIST1 constr -> - { let gen_everywhere c = ((AllOccurrences,c),Names.Name.Anonymous) in + { let gen_everywhere c = ((AllOccurrences,c),Names.Name.Anonymous) in TacAtom (CAst.make ~loc @@ TacGeneralize (List.map gen_everywhere (c::l))) } | IDENT "generalize"; c = constr; lookup_at_as_comma; nl = occs; na = as_name; @@ -632,41 +632,41 @@ GRAMMAR EXTEND Gram (* Derived basic tactics *) | IDENT "induction"; ic = induction_clause_list -> - { TacAtom (CAst.make ~loc @@ TacInductionDestruct (true,false,ic)) } + { TacAtom (CAst.make ~loc @@ TacInductionDestruct (true,false,ic)) } | IDENT "einduction"; ic = induction_clause_list -> - { TacAtom (CAst.make ~loc @@ TacInductionDestruct(true,true,ic)) } + { TacAtom (CAst.make ~loc @@ TacInductionDestruct(true,true,ic)) } | IDENT "destruct"; icl = induction_clause_list -> - { TacAtom (CAst.make ~loc @@ TacInductionDestruct(false,false,icl)) } + { TacAtom (CAst.make ~loc @@ TacInductionDestruct(false,false,icl)) } | IDENT "edestruct"; icl = induction_clause_list -> - { TacAtom (CAst.make ~loc @@ TacInductionDestruct(false,true,icl)) } + { TacAtom (CAst.make ~loc @@ TacInductionDestruct(false,true,icl)) } (* Equality and inversion *) | IDENT "rewrite"; l = LIST1 oriented_rewriter SEP ","; - cl = clause_dft_concl; t=by_tactic -> { TacAtom (CAst.make ~loc @@ TacRewrite (false,l,cl,t)) } + cl = clause_dft_concl; t=by_tactic -> { TacAtom (CAst.make ~loc @@ TacRewrite (false,l,cl,t)) } | IDENT "erewrite"; l = LIST1 oriented_rewriter SEP ","; - cl = clause_dft_concl; t=by_tactic -> { TacAtom (CAst.make ~loc @@ TacRewrite (true,l,cl,t)) } + cl = clause_dft_concl; t=by_tactic -> { TacAtom (CAst.make ~loc @@ TacRewrite (true,l,cl,t)) } | IDENT "dependent"; k = - [ IDENT "simple"; IDENT "inversion" -> { SimpleInversion } - | IDENT "inversion" -> { FullInversion } - | IDENT "inversion_clear" -> { FullInversionClear } ]; - hyp = quantified_hypothesis; - ids = as_or_and_ipat; co = OPT ["with"; c = constr -> { c } ] -> - { TacAtom (CAst.make ~loc @@ TacInversion (DepInversion (k,co,ids),hyp)) } + [ IDENT "simple"; IDENT "inversion" -> { SimpleInversion } + | IDENT "inversion" -> { FullInversion } + | IDENT "inversion_clear" -> { FullInversionClear } ]; + hyp = quantified_hypothesis; + ids = as_or_and_ipat; co = OPT ["with"; c = constr -> { c } ] -> + { TacAtom (CAst.make ~loc @@ TacInversion (DepInversion (k,co,ids),hyp)) } | IDENT "simple"; IDENT "inversion"; - hyp = quantified_hypothesis; ids = as_or_and_ipat; - cl = in_hyp_list -> - { TacAtom (CAst.make ~loc @@ TacInversion (NonDepInversion (SimpleInversion, cl, ids), hyp)) } + hyp = quantified_hypothesis; ids = as_or_and_ipat; + cl = in_hyp_list -> + { TacAtom (CAst.make ~loc @@ TacInversion (NonDepInversion (SimpleInversion, cl, ids), hyp)) } | IDENT "inversion"; - hyp = quantified_hypothesis; ids = as_or_and_ipat; - cl = in_hyp_list -> - { TacAtom (CAst.make ~loc @@ TacInversion (NonDepInversion (FullInversion, cl, ids), hyp)) } + hyp = quantified_hypothesis; ids = as_or_and_ipat; + cl = in_hyp_list -> + { TacAtom (CAst.make ~loc @@ TacInversion (NonDepInversion (FullInversion, cl, ids), hyp)) } | IDENT "inversion_clear"; - hyp = quantified_hypothesis; ids = as_or_and_ipat; - cl = in_hyp_list -> - { TacAtom (CAst.make ~loc @@ TacInversion (NonDepInversion (FullInversionClear, cl, ids), hyp)) } + hyp = quantified_hypothesis; ids = as_or_and_ipat; + cl = in_hyp_list -> + { TacAtom (CAst.make ~loc @@ TacInversion (NonDepInversion (FullInversionClear, cl, ids), hyp)) } | IDENT "inversion"; hyp = quantified_hypothesis; - "using"; c = constr; cl = in_hyp_list -> - { TacAtom (CAst.make ~loc @@ TacInversion (InversionUsing (c,cl), hyp)) } + "using"; c = constr; cl = in_hyp_list -> + { TacAtom (CAst.make ~loc @@ TacInversion (InversionUsing (c,cl), hyp)) } (* Conversion *) | IDENT "red"; cl = clause_dft_concl -> @@ -696,8 +696,8 @@ GRAMMAR EXTEND Gram (* Change ne doit pas s'appliquer dans un Definition t := Eval ... *) | IDENT "change"; c = conversion; cl = clause_dft_concl -> - { let (oc, c) = c in - let p,cl = merge_occurrences loc cl oc in + { let (oc, c) = c in + let p,cl = merge_occurrences loc cl oc in TacAtom (CAst.make ~loc @@ TacChange (true,p,c,cl)) } | IDENT "change_no_check"; c = conversion; cl = clause_dft_concl -> { let (oc, c) = c in diff --git a/plugins/ltac/pltac.ml b/plugins/ltac/pltac.ml index e3042dc3cb..0e21115474 100644 --- a/plugins/ltac/pltac.ml +++ b/plugins/ltac/pltac.ml @@ -34,7 +34,7 @@ let int_or_var = make_gen_entry utactic "int_or_var" let simple_intropattern = make_gen_entry utactic "simple_intropattern" let in_clause = make_gen_entry utactic "in_clause" -let clause_dft_concl = +let clause_dft_concl = make_gen_entry utactic "clause" diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 6be358be21..5618fd7bc3 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -76,7 +76,7 @@ let find_global dir s = let gr = lazy (find_reference dir s) in fun (evd,cstrs) -> let (evd, c) = Evarutil.new_global evd (Lazy.force gr) in - (evd, cstrs), c + (evd, cstrs), c (** Utility for dealing with polymorphic applications *) @@ -122,7 +122,7 @@ let app_poly_nocheck env evars f args = let app_poly_sort b = if b then app_poly_nocheck else app_poly_check - + let find_class_proof proof_type proof_method env evars carrier relation = try let evars, goal = app_poly_check env evars proof_type [| carrier ; relation |] in @@ -130,7 +130,7 @@ let find_class_proof proof_type proof_method env evars carrier relation = if extends_undefined (goalevars evars) evars' then raise Not_found else app_poly_check env (evars',cstrevars evars) proof_method [| carrier; relation; c |] with e when Logic.catchable_exception e -> raise Not_found - + (** Utility functions *) module GlobalBindings (M : sig @@ -146,7 +146,7 @@ end) = struct let reflexive_type = find_global relation_classes "Reflexive" let reflexive_proof = find_global relation_classes "reflexivity" - + let symmetric_type = find_global relation_classes "Symmetric" let symmetric_proof = find_global relation_classes "symmetry" @@ -201,53 +201,53 @@ end) = struct let get_symmetric_proof env = find_class_proof symmetric_type symmetric_proof env let get_transitive_proof env = find_class_proof transitive_type transitive_proof env - let mk_relation env evd a = + let mk_relation env evd a = app_poly env evd relation [| a |] (** Build an inferred signature from constraints on the arguments and expected output relation *) - + let build_signature evars env m (cstrs : (types * types option) option list) (finalcstr : (types * types option) option) = let mk_relty evars newenv ty obj = match obj with | None | Some (_, None) -> - let evars, relty = mk_relation env evars ty in - if closed0 (goalevars evars) ty then - let env' = Environ.reset_with_named_context (Environ.named_context_val env) env in - new_cstr_evar evars env' relty - else new_cstr_evar evars newenv relty + let evars, relty = mk_relation env evars ty in + if closed0 (goalevars evars) ty then + let env' = Environ.reset_with_named_context (Environ.named_context_val env) env in + new_cstr_evar evars env' relty + else new_cstr_evar evars newenv relty | Some (x, Some rel) -> evars, rel in let rec aux env evars ty l = let t = Reductionops.whd_all env (goalevars evars) ty in - match EConstr.kind (goalevars evars) t, l with + match EConstr.kind (goalevars evars) t, l with | Prod (na, ty, b), obj :: cstrs -> let b = Reductionops.nf_betaiota env (goalevars evars) b in if noccurn (goalevars evars) 1 b (* non-dependent product *) then let ty = Reductionops.nf_betaiota env (goalevars evars) ty in - let (evars, b', arg, cstrs) = aux env evars (subst1 mkProp b) cstrs in - let evars, relty = mk_relty evars env ty obj in - let evars, newarg = app_poly env evars respectful [| ty ; b' ; relty ; arg |] in + let (evars, b', arg, cstrs) = aux env evars (subst1 mkProp b) cstrs in + let evars, relty = mk_relty evars env ty obj in + let evars, newarg = app_poly env evars respectful [| ty ; b' ; relty ; arg |] in evars, mkProd(na, ty, b), newarg, (ty, Some relty) :: cstrs - else - let (evars, b, arg, cstrs) = + else + let (evars, b, arg, cstrs) = aux (push_rel (LocalAssum (na, ty)) env) evars b cstrs - in + in let ty = Reductionops.nf_betaiota env (goalevars evars) ty in let pred = mkLambda (na, ty, b) in let liftarg = mkLambda (na, ty, arg) in let evars, arg' = app_poly env evars forall_relation [| ty ; pred ; liftarg |] in if Option.is_empty obj then evars, mkProd(na, ty, b), arg', (ty, None) :: cstrs - else user_err Pp.(str "build_signature: no constraint can apply on a dependent argument") - | _, obj :: _ -> anomaly ~label:"build_signature" (Pp.str "not enough products.") - | _, [] -> - (match finalcstr with - | None | Some (_, None) -> + else user_err Pp.(str "build_signature: no constraint can apply on a dependent argument") + | _, obj :: _ -> anomaly ~label:"build_signature" (Pp.str "not enough products.") + | _, [] -> + (match finalcstr with + | None | Some (_, None) -> let t = Reductionops.nf_betaiota env (fst evars) ty in - let evars, rel = mk_relty evars env t None in - evars, t, rel, [t, Some rel] - | Some (t, Some rel) -> evars, t, rel, [t, Some rel]) + let evars, rel = mk_relty evars env t None in + evars, t, rel, [t, Some rel] + | Some (t, Some rel) -> evars, t, rel, [t, Some rel]) in aux env evars m cstrs (** Folding/unfolding of the tactic constants. *) @@ -278,30 +278,30 @@ end) = struct let ap = is_Prop (goalevars evd) ta and bp = is_Prop (goalevars evd) tb in if ap && bp then app_poly env evd impl [| a; b |], unfold_impl else if ap then (* Domain in Prop, CoDomain in Type *) - (app_poly env evd arrow [| a; b |]), unfold_impl - (* (evd, mkProd (Anonymous, a, b)), (fun x -> x) *) + (app_poly env evd arrow [| a; b |]), unfold_impl + (* (evd, mkProd (Anonymous, a, b)), (fun x -> x) *) else if bp then (* Dummy forall *) (app_poly env evd coq_all [| a; mkLambda (make_annot Anonymous Sorts.Relevant, a, lift 1 b) |]), unfold_forall else (* None in Prop, use arrow *) - (app_poly env evd arrow [| a; b |]), unfold_impl + (app_poly env evd arrow [| a; b |]), unfold_impl let rec decomp_pointwise sigma n c = if Int.equal n 0 then c else match EConstr.kind sigma c with | App (f, [| a; b; relb |]) when Termops.is_global sigma (pointwise_relation_ref ()) f -> - decomp_pointwise sigma (pred n) relb + decomp_pointwise sigma (pred n) relb | App (f, [| a; b; arelb |]) when Termops.is_global sigma (forall_relation_ref ()) f -> - decomp_pointwise sigma (pred n) (Reductionops.beta_applist sigma (arelb, [mkRel 1])) + decomp_pointwise sigma (pred n) (Reductionops.beta_applist sigma (arelb, [mkRel 1])) | _ -> invalid_arg "decomp_pointwise" let rec apply_pointwise sigma rel = function | arg :: args -> (match EConstr.kind sigma rel with | App (f, [| a; b; relb |]) when Termops.is_global sigma (pointwise_relation_ref ()) f -> - apply_pointwise sigma relb args + apply_pointwise sigma relb args | App (f, [| a; b; arelb |]) when Termops.is_global sigma (forall_relation_ref ()) f -> - apply_pointwise sigma (Reductionops.beta_applist sigma (arelb, [arg])) args + apply_pointwise sigma (Reductionops.beta_applist sigma (arelb, [arg])) args | _ -> invalid_arg "apply_pointwise") | [] -> rel @@ -316,36 +316,36 @@ end) = struct let lift_cstr env evars (args : constr list) c ty cstr = let start evars env car = match cstr with - | None | Some (_, None) -> - let evars, rel = mk_relation env evars car in - new_cstr_evar evars env rel + | None | Some (_, None) -> + let evars, rel = mk_relation env evars car in + new_cstr_evar evars env rel | Some (ty, Some rel) -> evars, rel in - let rec aux evars env prod n = + let rec aux evars env prod n = if Int.equal n 0 then start evars env prod else let sigma = goalevars evars in - match EConstr.kind sigma (Reductionops.whd_all env sigma prod) with + match EConstr.kind sigma (Reductionops.whd_all env sigma prod) with | Prod (na, ty, b) -> - if noccurn sigma 1 b then - let b' = lift (-1) b in - let evars, rb = aux evars env b' (pred n) in - app_poly env evars pointwise_relation [| ty; b'; rb |] - else + if noccurn sigma 1 b then + let b' = lift (-1) b in + let evars, rb = aux evars env b' (pred n) in + app_poly env evars pointwise_relation [| ty; b'; rb |] + else let evars, rb = aux evars (push_rel (LocalAssum (na, ty)) env) b (pred n) in - app_poly env evars forall_relation + app_poly env evars forall_relation [| ty; mkLambda (na, ty, b); mkLambda (na, ty, rb) |] - | _ -> raise Not_found - in + | _ -> raise Not_found + in let rec find env c ty = function | [] -> None | arg :: args -> - try let evars, found = aux evars env ty (succ (List.length args)) in - Some (evars, found, c, ty, arg :: args) - with Not_found -> + try let evars, found = aux evars env ty (succ (List.length args)) in + Some (evars, found, c, ty, arg :: args) + with Not_found -> let sigma = goalevars evars in - let ty = Reductionops.whd_all env sigma ty in - find env (mkApp (c, [| arg |])) (prod_applist sigma ty [arg]) args + let ty = Reductionops.whd_all env sigma ty in + find env (mkApp (c, [| arg |])) (prod_applist sigma ty [arg]) args in find env c ty args let unlift_cstr env sigma = function @@ -357,18 +357,18 @@ end) = struct match EConstr.kind sigma t with | App (c, args) when Array.length args >= 2 -> let head = if isApp sigma c then fst (destApp sigma c) else c in - if Termops.is_global sigma (coq_eq_ref ()) head then None - else - (try - let params, args = Array.chop (Array.length args - 2) args in - let env' = push_rel_context rels env in - let (evars, (evar, _)) = Evarutil.new_type_evar env' sigma Evd.univ_flexible in - let evars, inst = - app_poly env (evars,Evar.Set.empty) - rewrite_relation_class [| evar; mkApp (c, params) |] in - let _ = Typeclasses.resolve_one_typeclass env' (goalevars evars) inst in - Some (it_mkProd_or_LetIn t rels) - with e when CErrors.noncritical e -> None) + if Termops.is_global sigma (coq_eq_ref ()) head then None + else + (try + let params, args = Array.chop (Array.length args - 2) args in + let env' = push_rel_context rels env in + let (evars, (evar, _)) = Evarutil.new_type_evar env' sigma Evd.univ_flexible in + let evars, inst = + app_poly env (evars,Evar.Set.empty) + rewrite_relation_class [| evar; mkApp (c, params) |] in + let _ = Typeclasses.resolve_one_typeclass env' (goalevars evars) inst in + Some (it_mkProd_or_LetIn t rels) + with e when CErrors.noncritical e -> None) | _ -> None @@ -386,7 +386,7 @@ let type_app_poly env env evd f args = module PropGlobal = struct module Consts = - struct + struct let relation_classes = ["Coq"; "Classes"; "RelationClasses"] let morphisms = ["Coq"; "Classes"; "Morphisms"] let relation = ["Coq"; "Relations";"Relation_Definitions"], "relation" @@ -399,15 +399,15 @@ module PropGlobal = struct include G include Consts - let inverse env evd car rel = + let inverse env evd car rel = type_app_poly env env evd coq_inverse [| car ; car; mkProp; rel |] (* app_poly env evd coq_inverse [| car ; car; mkProp; rel |] *) end module TypeGlobal = struct - module Consts = - struct + module Consts = + struct let relation_classes = ["Coq"; "Classes"; "CRelationClasses"] let morphisms = ["Coq"; "Classes"; "CMorphisms"] let relation = relation_classes, "crelation" @@ -421,7 +421,7 @@ module TypeGlobal = struct include Consts - let inverse env (evd,cstrs) car rel = + let inverse env (evd,cstrs) car rel = let (evd, sort) = Evarutil.new_Type ~rigid:Evd.univ_flexible evd in app_poly_check env (evd,cstrs) coq_inverse [| car ; car; sort; rel |] @@ -471,12 +471,12 @@ type hypinfo = { holes : Clenv.hole list; } -let get_symmetric_proof b = +let get_symmetric_proof b = if b then PropGlobal.get_symmetric_proof else TypeGlobal.get_symmetric_proof let error_no_relation () = user_err Pp.(str "Cannot find a relation to rewrite.") -let rec decompose_app_rel env evd t = +let rec decompose_app_rel env evd t = (* Head normalize for compatibility with the old meta mechanism *) let t = Reductionops.whd_betaiota evd t in match EConstr.kind evd t with @@ -525,10 +525,10 @@ let decompose_applied_relation env sigma (c,l) = match find_rel ctype with | Some c -> c | None -> - let ctx,t' = Reductionops.splay_prod env sigma ctype in (* Search for underlying eq *) + let ctx,t' = Reductionops.splay_prod env sigma ctype in (* Search for underlying eq *) match find_rel (it_mkProd_or_LetIn t' (List.map (fun (n,t) -> LocalAssum (n, t)) ctx)) with - | Some c -> c - | None -> user_err Pp.(str "Cannot find an homogeneous relation to rewrite.") + | Some c -> c + | None -> user_err Pp.(str "Cannot find an homogeneous relation to rewrite.") let rewrite_db = "rewrite" @@ -644,13 +644,13 @@ let solve_remaining_by env sigma holes by = in List.fold_left solve sigma indep -let no_constraints cstrs = +let no_constraints cstrs = fun ev _ -> not (Evar.Set.mem ev cstrs) let poly_inverse sort = if sort then PropGlobal.inverse else TypeGlobal.inverse -type rewrite_proof = +type rewrite_proof = | RewPrf of constr * constr (** A Relation (R : rew_car -> rew_car -> Prop) and a proof of R rew_from rew_to *) @@ -675,13 +675,13 @@ type rewrite_result = | Success of rewrite_result_info type 'a strategy_input = { state : 'a ; (* a parameter: for instance, a state *) - env : Environ.env ; - unfresh : Id.Set.t; (* Unfresh names *) - term1 : constr ; - ty1 : types ; (* first term and its type (convertible to rew_from) *) - cstr : (bool (* prop *) * constr option) ; - evars : evars } - + env : Environ.env ; + unfresh : Id.Set.t; (* Unfresh names *) + term1 : constr ; + ty1 : types ; (* first term and its type (convertible to rew_from) *) + cstr : (bool (* prop *) * constr option) ; + evars : evars } + type 'a pure_strategy = { strategy : 'a strategy_input -> 'a * rewrite_result (* the updated state and the "result" *) } @@ -723,7 +723,7 @@ let unify_eqn (car, rel, prf, c1, c2, holes, sort) l2r flags env (sigma, cstrs) let rew = { rew_evars; rew_prf; rew_car; rew_from = c1; rew_to = c2; } in let rew = if l2r then rew else symmetry env sort rew in Some rew - with + with | e when Class_tactics.catchable e -> None | Reduction.NotConvertible -> None @@ -740,7 +740,7 @@ let unify_abs (car, rel, prf, c1, c2) l2r sort env (sigma, cstrs) t = let rew = { rew_car = car; rew_from = c1; rew_to = c2; rew_prf; rew_evars; } in let rew = if l2r then rew else symmetry env sort rew in Some rew - with + with | e when Class_tactics.catchable e -> None | Reduction.NotConvertible -> None @@ -766,9 +766,9 @@ let get_rew_prf evars r = match r.rew_prf with let evars, eq_refl = make_eq_refl evars in let rel = mkApp (eq, [| r.rew_car |]) in evars, (rel, mkCast (mkApp (eq_refl, [| r.rew_car; r.rew_from |]), - c, mkApp (rel, [| r.rew_from; r.rew_to |]))) + c, mkApp (rel, [| r.rew_from; r.rew_to |]))) -let poly_subrelation sort = +let poly_subrelation sort = if sort then PropGlobal.subrelation else TypeGlobal.subrelation let resolve_subrelation env avoid car rel sort prf rel' res = @@ -778,8 +778,8 @@ let resolve_subrelation env avoid car rel sort prf rel' res = let evars, subrel = new_cstr_evar evars env app in let appsub = mkApp (subrel, [| res.rew_from ; res.rew_to ; prf |]) in { res with - rew_prf = RewPrf (rel', appsub); - rew_evars = evars } + rew_prf = RewPrf (rel', appsub); + rew_evars = evars } let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' (b,cstr) evars = let evars, morph_instance, proj, sigargs, m', args, args' = @@ -790,12 +790,12 @@ let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' (b,cstr) ev let morphargs', morphobjs' = Array.chop first args' in let appm = mkApp(m, morphargs) in let appmtype = Typing.unsafe_type_of env (goalevars evars) appm in - let cstrs = List.map - (Option.map (fun r -> r.rew_car, get_opt_rew_rel r.rew_prf)) - (Array.to_list morphobjs') + let cstrs = List.map + (Option.map (fun r -> r.rew_car, get_opt_rew_rel r.rew_prf)) + (Array.to_list morphobjs') in (* Desired signature *) - let evars, appmtype', signature, sigargs = + let evars, appmtype', signature, sigargs = if b then PropGlobal.build_signature evars env appmtype cstrs cstr else TypeGlobal.build_signature evars env appmtype cstrs cstr in @@ -803,16 +803,16 @@ let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' (b,cstr) ev let cl_args = [| appmtype' ; signature ; appm |] in let evars, app = app_poly_sort b env evars (if b then PropGlobal.proper_type env else TypeGlobal.proper_type env) cl_args in - let env' = - let dosub, appsub = - if b then PropGlobal.do_subrelation, PropGlobal.apply_subrelation - else TypeGlobal.do_subrelation, TypeGlobal.apply_subrelation + let env' = + let dosub, appsub = + if b then PropGlobal.do_subrelation, PropGlobal.apply_subrelation + else TypeGlobal.do_subrelation, TypeGlobal.apply_subrelation in - EConstr.push_named + EConstr.push_named (LocalDef (make_annot (Id.of_string "do_subrelation") Sorts.Relevant, - snd (app_poly_sort b env evars dosub [||]), - snd (app_poly_nocheck env evars appsub [||]))) - env + snd (app_poly_sort b env evars dosub [||]), + snd (app_poly_nocheck env evars appsub [||]))) + env in let evars, morph = new_cstr_evar evars env' app in evars, morph, morph, sigargs, appm, morphobjs, morphobjs' @@ -820,31 +820,31 @@ let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' (b,cstr) ev let projargs, subst, evars, respars, typeargs = Array.fold_left2 (fun (acc, subst, evars, sigargs, typeargs') x y -> - let (carrier, relation), sigargs = split_head sigargs in - match relation with - | Some relation -> - let carrier = substl subst carrier - and relation = substl subst relation in - (match y with - | None -> - let evars, proof = - (if b then PropGlobal.proper_proof else TypeGlobal.proper_proof) - env evars carrier relation x in - [ proof ; x ; x ] @ acc, subst, evars, sigargs, x :: typeargs' - | Some r -> + let (carrier, relation), sigargs = split_head sigargs in + match relation with + | Some relation -> + let carrier = substl subst carrier + and relation = substl subst relation in + (match y with + | None -> + let evars, proof = + (if b then PropGlobal.proper_proof else TypeGlobal.proper_proof) + env evars carrier relation x in + [ proof ; x ; x ] @ acc, subst, evars, sigargs, x :: typeargs' + | Some r -> let evars, proof = get_rew_prf evars r in - [ snd proof; r.rew_to; x ] @ acc, subst, evars, - sigargs, r.rew_to :: typeargs') - | None -> - if not (Option.is_empty y) then - user_err Pp.(str "Cannot rewrite inside dependent arguments of a function"); - x :: acc, x :: subst, evars, sigargs, x :: typeargs') + [ snd proof; r.rew_to; x ] @ acc, subst, evars, + sigargs, r.rew_to :: typeargs') + | None -> + if not (Option.is_empty y) then + user_err Pp.(str "Cannot rewrite inside dependent arguments of a function"); + x :: acc, x :: subst, evars, sigargs, x :: typeargs') ([], [], evars, sigargs, []) args args' in let proof = applist (proj, List.rev projargs) in let newt = applist (m', List.rev typeargs) in match respars with - [ a, Some r ] -> evars, proof, substl subst a, substl subst r, oldt, fnewt newt + [ a, Some r ] -> evars, proof, substl subst a, substl subst r, oldt, fnewt newt | _ -> assert(false) let apply_constraint env avoid car rel prf cstr res = @@ -852,7 +852,7 @@ let apply_constraint env avoid car rel prf cstr res = | None -> res | Some r -> resolve_subrelation env avoid car rel (fst cstr) prf r res -let coerce env avoid cstr res = +let coerce env avoid cstr res = let evars, (rel, prf) = get_rew_prf res.rew_evars res in let res = { res with rew_evars = evars } in apply_constraint env avoid res.rew_car rel prf cstr res @@ -860,22 +860,22 @@ let coerce env avoid cstr res = let apply_rule unify loccs : int pure_strategy = let (nowhere_except_in,occs) = convert_occs loccs in let is_occ occ = - if nowhere_except_in - then List.mem occ occs - else not (List.mem occ occs) + if nowhere_except_in + then List.mem occ occs + else not (List.mem occ occs) in { strategy = fun { state = occ ; env ; unfresh ; - term1 = t ; ty1 = ty ; cstr ; evars } -> + term1 = t ; ty1 = ty ; cstr ; evars } -> let unif = if isEvar (goalevars evars) t then None else unify env evars t in - match unif with - | None -> (occ, Fail) + match unif with + | None -> (occ, Fail) | Some rew -> - let occ = succ occ in - if not (is_occ occ) then (occ, Fail) - else if Termops.eq_constr (fst rew.rew_evars) t rew.rew_to then (occ, Identity) - else - let res = { rew with rew_car = ty } in - let res = Success (coerce env unfresh cstr res) in + let occ = succ occ in + if not (is_occ occ) then (occ, Fail) + else if Termops.eq_constr (fst rew.rew_evars) t rew.rew_to then (occ, Identity) + else + let res = { rew with rew_car = ty } in + let res = Success (coerce env unfresh cstr res) in (occ, res) } @@ -893,10 +893,10 @@ let apply_lemma l2r flags oc by loccs : strategy = { strategy = | Some rew -> Some rew in let _, res = (apply_rule unify loccs).strategy { input with - state = 0 ; - evars } in + state = 0 ; + evars } in (), res - } + } let e_app_poly env evars f args = let evars', c = app_poly_nocheck env !evars f args in @@ -905,16 +905,16 @@ let e_app_poly env evars f args = let make_leibniz_proof env c ty r = let evars = ref r.rew_evars in - let prf = + let prf = match r.rew_prf with - | RewPrf (rel, prf) -> - let rel = e_app_poly env evars coq_eq [| ty |] in - let prf = - e_app_poly env evars coq_f_equal - [| r.rew_car; ty; + | RewPrf (rel, prf) -> + let rel = e_app_poly env evars coq_eq [| ty |] in + let prf = + e_app_poly env evars coq_f_equal + [| r.rew_car; ty; mkLambda (make_annot Anonymous Sorts.Relevant, r.rew_car, c); - r.rew_from; r.rew_to; prf |] - in RewPrf (rel, prf) + r.rew_from; r.rew_to; prf |] + in RewPrf (rel, prf) | RewCast k -> r.rew_prf in { rew_car = ty; rew_evars = !evars; @@ -923,39 +923,39 @@ let make_leibniz_proof env c ty r = let reset_env env = let env' = Global.env_of_context (Environ.named_context_val env) in Environ.push_rel_context (Environ.rel_context env) env' - + let fold_match ?(force=false) env sigma c = let (ci, p, c, brs) = destCase sigma c in let cty = Retyping.get_type_of env sigma c in - let dep, pred, exists, (sk,eff) = + let dep, pred, exists, (sk,eff) = let env', ctx, body = let ctx, pred = decompose_lam_assum sigma p in let env' = push_rel_context ctx env in - env', ctx, pred + env', ctx, pred in let sortp = Retyping.get_sort_family_of env' sigma body in let sortc = Retyping.get_sort_family_of env sigma cty in let dep = not (noccurn sigma 1 body) in let pred = if dep then p else - it_mkProd_or_LetIn (subst1 mkProp body) (List.tl ctx) + it_mkProd_or_LetIn (subst1 mkProp body) (List.tl ctx) in - let sk = + let sk = if sortp == Sorts.InProp then - if sortc == Sorts.InProp then - if dep then case_dep_scheme_kind_from_prop - else case_scheme_kind_from_prop - else ( + if sortc == Sorts.InProp then + if dep then case_dep_scheme_kind_from_prop + else case_scheme_kind_from_prop + else ( if dep then case_dep_scheme_kind_from_type_in_prop else case_scheme_kind_from_type) else ((* sortc <> InProp by typing *) - if dep - then case_dep_scheme_kind_from_type - else case_scheme_kind_from_type) - in + if dep + then case_dep_scheme_kind_from_type + else case_scheme_kind_from_type) + in let exists = Ind_tables.check_scheme sk ci.ci_ind in if exists || force then - dep, pred, exists, Ind_tables.find_scheme sk ci.ci_ind + dep, pred, exists, Ind_tables.find_scheme sk ci.ci_ind else raise Not_found in let app = @@ -963,7 +963,7 @@ let fold_match ?(force=false) env sigma c = let pars, args = List.chop ci.ci_npar args in let meths = List.map (fun br -> br) (Array.to_list brs) in applist (mkConst sk, pars @ [pred] @ meths @ args @ [c]) - in + in sk, (if exists then env else reset_env env), app, eff let unfold_match env sigma sk app = @@ -971,128 +971,128 @@ let unfold_match env sigma sk app = | App (f', args) when Constant.equal (fst (destConst sigma f')) sk -> let v = Environ.constant_value_in (Global.env ()) (sk,Univ.Instance.empty)(*FIXME*) in let v = EConstr.of_constr v in - Reductionops.whd_beta sigma (mkApp (v, args)) + Reductionops.whd_beta sigma (mkApp (v, args)) | _ -> app let is_rew_cast = function RewCast _ -> true | _ -> false let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = let rec aux { state ; env ; unfresh ; - term1 = t ; ty1 = ty ; cstr = (prop, cstr) ; evars } = + term1 = t ; ty1 = ty ; cstr = (prop, cstr) ; evars } = let cstr' = Option.map (fun c -> (ty, Some c)) cstr in match EConstr.kind (goalevars evars) t with | App (m, args) -> - let rewrite_args state success = - let state, (args', evars', progress) = - Array.fold_left - (fun (state, (acc, evars, progress)) arg -> - if not (Option.is_empty progress) && not all then - state, (None :: acc, evars, progress) - else - let argty = Retyping.get_type_of env (goalevars evars) arg in - let state, res = s.strategy { state ; env ; - unfresh ; - term1 = arg ; ty1 = argty ; - cstr = (prop,None) ; - evars } in - let res' = - match res with - | Identity -> - let progress = if Option.is_empty progress then Some false else progress in - (None :: acc, evars, progress) - | Success r -> - (Some r :: acc, r.rew_evars, Some true) - | Fail -> (None :: acc, evars, progress) - in state, res') - (state, ([], evars, success)) args - in - let res = - match progress with - | None -> Fail - | Some false -> Identity - | Some true -> - let args' = Array.of_list (List.rev args') in - if Array.exists - (function - | None -> false - | Some r -> not (is_rew_cast r.rew_prf)) args' - then - let evars', prf, car, rel, c1, c2 = - resolve_morphism env unfresh t m args args' (prop, cstr') evars' - in - let res = { rew_car = ty; rew_from = c1; - rew_to = c2; rew_prf = RewPrf (rel, prf); - rew_evars = evars' } - in Success res - else - let args' = Array.map2 - (fun aorig anew -> - match anew with None -> aorig - | Some r -> r.rew_to) args args' - in - let res = { rew_car = ty; rew_from = t; - rew_to = mkApp (m, args'); rew_prf = RewCast DEFAULTcast; - rew_evars = evars' } - in Success res - in state, res - in - if flags.on_morphisms then - let mty = Retyping.get_type_of env (goalevars evars) m in - let evars, cstr', m, mty, argsl, args = - let argsl = Array.to_list args in - let lift = if prop then PropGlobal.lift_cstr else TypeGlobal.lift_cstr in - match lift env evars argsl m mty None with - | Some (evars, cstr', m, mty, args) -> - evars, Some cstr', m, mty, args, Array.of_list args - | None -> evars, None, m, mty, argsl, args - in - let state, m' = s.strategy { state ; env ; unfresh ; - term1 = m ; ty1 = mty ; - cstr = (prop, cstr') ; evars } in - match m' with - | Fail -> rewrite_args state None (* Standard path, try rewrite on arguments *) - | Identity -> rewrite_args state (Some false) - | Success r -> - (* We rewrote the function and get a proof of pointwise rel for the arguments. - We just apply it. *) - let prf = match r.rew_prf with - | RewPrf (rel, prf) -> - let app = if prop then PropGlobal.apply_pointwise - else TypeGlobal.apply_pointwise - in - RewPrf (app (goalevars evars) rel argsl, mkApp (prf, args)) - | x -> x - in - let res = - { rew_car = Reductionops.hnf_prod_appvect env (goalevars evars) r.rew_car args; - rew_from = mkApp(r.rew_from, args); rew_to = mkApp(r.rew_to, args); - rew_prf = prf; rew_evars = r.rew_evars } - in - let res = - match prf with - | RewPrf (rel, prf) -> - Success (apply_constraint env unfresh res.rew_car - rel prf (prop,cstr) res) - | _ -> Success res - in state, res - else rewrite_args state None - + let rewrite_args state success = + let state, (args', evars', progress) = + Array.fold_left + (fun (state, (acc, evars, progress)) arg -> + if not (Option.is_empty progress) && not all then + state, (None :: acc, evars, progress) + else + let argty = Retyping.get_type_of env (goalevars evars) arg in + let state, res = s.strategy { state ; env ; + unfresh ; + term1 = arg ; ty1 = argty ; + cstr = (prop,None) ; + evars } in + let res' = + match res with + | Identity -> + let progress = if Option.is_empty progress then Some false else progress in + (None :: acc, evars, progress) + | Success r -> + (Some r :: acc, r.rew_evars, Some true) + | Fail -> (None :: acc, evars, progress) + in state, res') + (state, ([], evars, success)) args + in + let res = + match progress with + | None -> Fail + | Some false -> Identity + | Some true -> + let args' = Array.of_list (List.rev args') in + if Array.exists + (function + | None -> false + | Some r -> not (is_rew_cast r.rew_prf)) args' + then + let evars', prf, car, rel, c1, c2 = + resolve_morphism env unfresh t m args args' (prop, cstr') evars' + in + let res = { rew_car = ty; rew_from = c1; + rew_to = c2; rew_prf = RewPrf (rel, prf); + rew_evars = evars' } + in Success res + else + let args' = Array.map2 + (fun aorig anew -> + match anew with None -> aorig + | Some r -> r.rew_to) args args' + in + let res = { rew_car = ty; rew_from = t; + rew_to = mkApp (m, args'); rew_prf = RewCast DEFAULTcast; + rew_evars = evars' } + in Success res + in state, res + in + if flags.on_morphisms then + let mty = Retyping.get_type_of env (goalevars evars) m in + let evars, cstr', m, mty, argsl, args = + let argsl = Array.to_list args in + let lift = if prop then PropGlobal.lift_cstr else TypeGlobal.lift_cstr in + match lift env evars argsl m mty None with + | Some (evars, cstr', m, mty, args) -> + evars, Some cstr', m, mty, args, Array.of_list args + | None -> evars, None, m, mty, argsl, args + in + let state, m' = s.strategy { state ; env ; unfresh ; + term1 = m ; ty1 = mty ; + cstr = (prop, cstr') ; evars } in + match m' with + | Fail -> rewrite_args state None (* Standard path, try rewrite on arguments *) + | Identity -> rewrite_args state (Some false) + | Success r -> + (* We rewrote the function and get a proof of pointwise rel for the arguments. + We just apply it. *) + let prf = match r.rew_prf with + | RewPrf (rel, prf) -> + let app = if prop then PropGlobal.apply_pointwise + else TypeGlobal.apply_pointwise + in + RewPrf (app (goalevars evars) rel argsl, mkApp (prf, args)) + | x -> x + in + let res = + { rew_car = Reductionops.hnf_prod_appvect env (goalevars evars) r.rew_car args; + rew_from = mkApp(r.rew_from, args); rew_to = mkApp(r.rew_to, args); + rew_prf = prf; rew_evars = r.rew_evars } + in + let res = + match prf with + | RewPrf (rel, prf) -> + Success (apply_constraint env unfresh res.rew_car + rel prf (prop,cstr) res) + | _ -> Success res + in state, res + else rewrite_args state None + | Prod (n, x, b) when noccurn (goalevars evars) 1 b -> - let b = subst1 mkProp b in - let tx = Retyping.get_type_of env (goalevars evars) x - and tb = Retyping.get_type_of env (goalevars evars) b in - let arr = if prop then PropGlobal.arrow_morphism - else TypeGlobal.arrow_morphism - in - let (evars', mor), unfold = arr env evars tx tb x b in - let state, res = aux { state ; env ; unfresh ; - term1 = mor ; ty1 = ty ; - cstr = (prop,cstr) ; evars = evars' } in - let res = - match res with - | Success r -> Success { r with rew_to = unfold (goalevars r.rew_evars) r.rew_to } - | Fail | Identity -> res - in state, res + let b = subst1 mkProp b in + let tx = Retyping.get_type_of env (goalevars evars) x + and tb = Retyping.get_type_of env (goalevars evars) b in + let arr = if prop then PropGlobal.arrow_morphism + else TypeGlobal.arrow_morphism + in + let (evars', mor), unfold = arr env evars tx tb x b in + let state, res = aux { state ; env ; unfresh ; + term1 = mor ; ty1 = ty ; + cstr = (prop,cstr) ; evars = evars' } in + let res = + match res with + | Success r -> Success { r with rew_to = unfold (goalevars r.rew_evars) r.rew_to } + | Fail | Identity -> res + in state, res (* if x' = None && flags.under_lambdas then *) (* let lam = mkLambda (n, x, b) in *) @@ -1110,23 +1110,23 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = | Prod (n, dom, codom) -> let lam = mkLambda (n, dom, codom) in - let (evars', app), unfold = - if eq_constr (fst evars) ty mkProp then - (app_poly_sort prop env evars coq_all [| dom; lam |]), TypeGlobal.unfold_all - else - let forall = if prop then PropGlobal.coq_forall else TypeGlobal.coq_forall in - (app_poly_sort prop env evars forall [| dom; lam |]), TypeGlobal.unfold_forall - in - let state, res = aux { state ; env ; unfresh ; - term1 = app ; ty1 = ty ; - cstr = (prop,cstr) ; evars = evars' } in - let res = - match res with - | Success r -> Success { r with rew_to = unfold (goalevars r.rew_evars) r.rew_to } - | Fail | Identity -> res - in state, res - -(* TODO: real rewriting under binders: introduce x x' (H : R x x') and rewrite with + let (evars', app), unfold = + if eq_constr (fst evars) ty mkProp then + (app_poly_sort prop env evars coq_all [| dom; lam |]), TypeGlobal.unfold_all + else + let forall = if prop then PropGlobal.coq_forall else TypeGlobal.coq_forall in + (app_poly_sort prop env evars forall [| dom; lam |]), TypeGlobal.unfold_forall + in + let state, res = aux { state ; env ; unfresh ; + term1 = app ; ty1 = ty ; + cstr = (prop,cstr) ; evars = evars' } in + let res = + match res with + | Success r -> Success { r with rew_to = unfold (goalevars r.rew_evars) r.rew_to } + | Fail | Identity -> res + in state, res + +(* TODO: real rewriting under binders: introduce x x' (H : R x x') and rewrite with H at any occurrence of x. Ask for (R ==> R') for the lambda. Formalize this. B. Barras' idea is to have a context of relations, of length 1, with Σ for gluing dependent relations and using projections to get them out. @@ -1158,88 +1158,88 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = let n' = map_annot (Nameops.Name.map (fun id -> Tactics.fresh_id_in_env unfresh id env)) n in let open Context.Rel.Declaration in let env' = EConstr.push_rel (LocalAssum (n', t)) env in - let bty = Retyping.get_type_of env' (goalevars evars) b in - let unlift = if prop then PropGlobal.unlift_cstr else TypeGlobal.unlift_cstr in - let state, b' = s.strategy { state ; env = env' ; unfresh ; - term1 = b ; ty1 = bty ; - cstr = (prop, unlift env evars cstr) ; - evars } in - let res = - match b' with - | Success r -> - let r = match r.rew_prf with - | RewPrf (rel, prf) -> - let point = if prop then PropGlobal.pointwise_or_dep_relation else - TypeGlobal.pointwise_or_dep_relation - in + let bty = Retyping.get_type_of env' (goalevars evars) b in + let unlift = if prop then PropGlobal.unlift_cstr else TypeGlobal.unlift_cstr in + let state, b' = s.strategy { state ; env = env' ; unfresh ; + term1 = b ; ty1 = bty ; + cstr = (prop, unlift env evars cstr) ; + evars } in + let res = + match b' with + | Success r -> + let r = match r.rew_prf with + | RewPrf (rel, prf) -> + let point = if prop then PropGlobal.pointwise_or_dep_relation else + TypeGlobal.pointwise_or_dep_relation + in let evars, rel = point env r.rew_evars n'.binder_name t r.rew_car rel in let prf = mkLambda (n', t, prf) in - { r with rew_prf = RewPrf (rel, prf); rew_evars = evars } - | x -> r - in - Success { r with + { r with rew_prf = RewPrf (rel, prf); rew_evars = evars } + | x -> r + in + Success { r with rew_car = mkProd (n, t, r.rew_car); rew_from = mkLambda(n, t, r.rew_from); rew_to = mkLambda (n, t, r.rew_to) } - | Fail | Identity -> b' - in state, res - + | Fail | Identity -> b' + in state, res + | Case (ci, p, c, brs) -> - let cty = Retyping.get_type_of env (goalevars evars) c in - let evars', eqty = app_poly_sort prop env evars coq_eq [| cty |] in - let cstr' = Some eqty in - let state, c' = s.strategy { state ; env ; unfresh ; - term1 = c ; ty1 = cty ; - cstr = (prop, cstr') ; evars = evars' } in - let state, res = - match c' with - | Success r -> - let case = mkCase (ci, lift 1 p, mkRel 1, Array.map (lift 1) brs) in - let res = make_leibniz_proof env case ty r in - state, Success (coerce env unfresh (prop,cstr) res) - | Fail | Identity -> - if Array.for_all (Int.equal 0) ci.ci_cstr_ndecls then - let evars', eqty = app_poly_sort prop env evars coq_eq [| ty |] in - let cstr = Some eqty in - let state, found, brs' = Array.fold_left - (fun (state, found, acc) br -> - if not (Option.is_empty found) then - (state, found, fun x -> lift 1 br :: acc x) - else - let state, res = s.strategy { state ; env ; unfresh ; - term1 = br ; ty1 = ty ; - cstr = (prop,cstr) ; evars } in - match res with - | Success r -> (state, Some r, fun x -> mkRel 1 :: acc x) - | Fail | Identity -> (state, None, fun x -> lift 1 br :: acc x)) - (state, None, fun x -> []) brs - in - match found with - | Some r -> - let ctxc = mkCase (ci, lift 1 p, lift 1 c, Array.of_list (List.rev (brs' c'))) in - state, Success (make_leibniz_proof env ctxc ty r) - | None -> state, c' - else - match try Some (fold_match env (goalevars evars) t) with Not_found -> None with - | None -> state, c' - | Some (cst, _, t', eff (*FIXME*)) -> - let state, res = aux { state ; env ; unfresh ; - term1 = t' ; ty1 = ty ; - cstr = (prop,cstr) ; evars } in - let res = - match res with - | Success prf -> - Success { prf with - rew_from = t; - rew_to = unfold_match env (goalevars evars) cst prf.rew_to } - | x' -> c' - in state, res - in - let res = - match res with - | Success r -> Success (coerce env unfresh (prop,cstr) r) - | Fail | Identity -> res - in state, res + let cty = Retyping.get_type_of env (goalevars evars) c in + let evars', eqty = app_poly_sort prop env evars coq_eq [| cty |] in + let cstr' = Some eqty in + let state, c' = s.strategy { state ; env ; unfresh ; + term1 = c ; ty1 = cty ; + cstr = (prop, cstr') ; evars = evars' } in + let state, res = + match c' with + | Success r -> + let case = mkCase (ci, lift 1 p, mkRel 1, Array.map (lift 1) brs) in + let res = make_leibniz_proof env case ty r in + state, Success (coerce env unfresh (prop,cstr) res) + | Fail | Identity -> + if Array.for_all (Int.equal 0) ci.ci_cstr_ndecls then + let evars', eqty = app_poly_sort prop env evars coq_eq [| ty |] in + let cstr = Some eqty in + let state, found, brs' = Array.fold_left + (fun (state, found, acc) br -> + if not (Option.is_empty found) then + (state, found, fun x -> lift 1 br :: acc x) + else + let state, res = s.strategy { state ; env ; unfresh ; + term1 = br ; ty1 = ty ; + cstr = (prop,cstr) ; evars } in + match res with + | Success r -> (state, Some r, fun x -> mkRel 1 :: acc x) + | Fail | Identity -> (state, None, fun x -> lift 1 br :: acc x)) + (state, None, fun x -> []) brs + in + match found with + | Some r -> + let ctxc = mkCase (ci, lift 1 p, lift 1 c, Array.of_list (List.rev (brs' c'))) in + state, Success (make_leibniz_proof env ctxc ty r) + | None -> state, c' + else + match try Some (fold_match env (goalevars evars) t) with Not_found -> None with + | None -> state, c' + | Some (cst, _, t', eff (*FIXME*)) -> + let state, res = aux { state ; env ; unfresh ; + term1 = t' ; ty1 = ty ; + cstr = (prop,cstr) ; evars } in + let res = + match res with + | Success prf -> + Success { prf with + rew_from = t; + rew_to = unfold_match env (goalevars evars) cst prf.rew_to } + | x' -> c' + in state, res + in + let res = + match res with + | Success r -> Success (coerce env unfresh (prop,cstr) r) + | Fail | Identity -> res + in state, res | _ -> state, Fail in { strategy = aux } @@ -1249,15 +1249,15 @@ let one_subterm = subterm false default_flags (** Requires transitivity of the rewrite step, if not a reduction. Not tail-recursive. *) -let transitivity state env unfresh prop (res : rewrite_result_info) (next : 'a pure_strategy) : +let transitivity state env unfresh prop (res : rewrite_result_info) (next : 'a pure_strategy) : 'a * rewrite_result = let state, nextres = next.strategy { state ; env ; unfresh ; - term1 = res.rew_to ; ty1 = res.rew_car ; - cstr = (prop, get_opt_rew_rel res.rew_prf) ; - evars = res.rew_evars } - in - let res = + term1 = res.rew_to ; ty1 = res.rew_car ; + cstr = (prop, get_opt_rew_rel res.rew_prf) ; + evars = res.rew_evars } + in + let res = match nextres with | Fail -> Fail | Identity -> Success res @@ -1265,21 +1265,21 @@ let transitivity state env unfresh prop (res : rewrite_result_info) (next : 'a p match res.rew_prf with | RewCast c -> Success { res' with rew_from = res.rew_from } | RewPrf (rew_rel, rew_prf) -> - match res'.rew_prf with - | RewCast _ -> Success { res with rew_to = res'.rew_to } - | RewPrf (res'_rel, res'_prf) -> - let trans = - if prop then PropGlobal.transitive_type - else TypeGlobal.transitive_type - in - let evars, prfty = - app_poly_sort prop env res'.rew_evars trans [| res.rew_car; rew_rel |] - in - let evars, prf = new_cstr_evar evars env prfty in - let prf = mkApp (prf, [|res.rew_from; res'.rew_from; res'.rew_to; - rew_prf; res'_prf |]) - in Success { res' with rew_from = res.rew_from; - rew_evars = evars; rew_prf = RewPrf (res'_rel, prf) } + match res'.rew_prf with + | RewCast _ -> Success { res with rew_to = res'.rew_to } + | RewPrf (res'_rel, res'_prf) -> + let trans = + if prop then PropGlobal.transitive_type + else TypeGlobal.transitive_type + in + let evars, prfty = + app_poly_sort prop env res'.rew_evars trans [| res.rew_car; rew_rel |] + in + let evars, prf = new_cstr_evar evars env prfty in + let prf = mkApp (prf, [|res.rew_from; res'.rew_from; res'.rew_to; + rew_prf; res'_prf |]) + in Success { res' with rew_from = res.rew_from; + rew_evars = evars; rew_prf = RewPrf (res'_rel, prf) } in state, res (** Rewriting strategies. @@ -1299,54 +1299,54 @@ module Strategies = let refl : 'a pure_strategy = { strategy = - fun { state ; env ; - term1 = t ; ty1 = ty ; - cstr = (prop,cstr) ; evars } -> - let evars, rel = match cstr with - | None -> - let mkr = if prop then PropGlobal.mk_relation else TypeGlobal.mk_relation in - let evars, rty = mkr env evars ty in - new_cstr_evar evars env rty - | Some r -> evars, r - in - let evars, proof = - let proxy = + fun { state ; env ; + term1 = t ; ty1 = ty ; + cstr = (prop,cstr) ; evars } -> + let evars, rel = match cstr with + | None -> + let mkr = if prop then PropGlobal.mk_relation else TypeGlobal.mk_relation in + let evars, rty = mkr env evars ty in + new_cstr_evar evars env rty + | Some r -> evars, r + in + let evars, proof = + let proxy = if prop then PropGlobal.proper_proxy_type env else TypeGlobal.proper_proxy_type env - in - let evars, mty = app_poly_sort prop env evars proxy [| ty ; rel; t |] in - new_cstr_evar evars env mty - in - let res = Success { rew_car = ty; rew_from = t; rew_to = t; - rew_prf = RewPrf (rel, proof); rew_evars = evars } - in state, res + in + let evars, mty = app_poly_sort prop env evars proxy [| ty ; rel; t |] in + new_cstr_evar evars env mty + in + let res = Success { rew_car = ty; rew_from = t; rew_to = t; + rew_prf = RewPrf (rel, proof); rew_evars = evars } + in state, res } let progress (s : 'a pure_strategy) : 'a pure_strategy = { strategy = fun input -> - let state, res = s.strategy input in - match res with - | Fail -> state, Fail - | Identity -> state, Fail - | Success r -> state, Success r - } - + let state, res = s.strategy input in + match res with + | Fail -> state, Fail + | Identity -> state, Fail + | Success r -> state, Success r + } + let seq first snd : 'a pure_strategy = { strategy = fun ({ env ; unfresh ; cstr } as input) -> - let state, res = first.strategy input in - match res with - | Fail -> state, Fail - | Identity -> snd.strategy { input with state } - | Success res -> transitivity state env unfresh (fst cstr) res snd - } - + let state, res = first.strategy input in + match res with + | Fail -> state, Fail + | Identity -> snd.strategy { input with state } + | Success res -> transitivity state env unfresh (fst cstr) res snd + } + let choice fst snd : 'a pure_strategy = { strategy = fun input -> - let state, res = fst.strategy input in - match res with - | Fail -> snd.strategy { input with state } - | Identity | Success _ -> state, res - } + let state, res = fst.strategy input in + match res with + | Fail -> snd.strategy { input with state } + | Identity | Success _ -> state, res + } let try_ str : 'a pure_strategy = choice str id @@ -1357,7 +1357,7 @@ module Strategies = let fix (f : 'a pure_strategy -> 'a pure_strategy) : 'a pure_strategy = let rec aux input = (f { strategy = fun input -> check_interrupt aux input }).strategy input in { strategy = aux } - + let any (s : 'a pure_strategy) : 'a pure_strategy = fix (fun any -> try_ (seq s any)) @@ -1378,8 +1378,8 @@ module Strategies = let lemmas cs : 'a pure_strategy = List.fold_left (fun tac (l,l2r,by) -> - choice tac (apply_lemma l2r rewrite_unif_flags l by AllOccurrences)) - fail cs + choice tac (apply_lemma l2r rewrite_unif_flags l by AllOccurrences)) + fail cs let inj_open hint = (); fun sigma -> let ctx = UState.of_context_set hint.Autorewrite.rew_ctx in @@ -1388,51 +1388,51 @@ module Strategies = let old_hints (db : string) : 'a pure_strategy = let rules = Autorewrite.find_rewrites db in - lemmas - (List.map (fun hint -> (inj_open hint, hint.Autorewrite.rew_l2r, - hint.Autorewrite.rew_tac)) rules) + lemmas + (List.map (fun hint -> (inj_open hint, hint.Autorewrite.rew_l2r, + hint.Autorewrite.rew_tac)) rules) let hints (db : string) : 'a pure_strategy = { strategy = fun ({ term1 = t } as input) -> let t = EConstr.Unsafe.to_constr t in let rules = Autorewrite.find_matches db t in let lemma hint = (inj_open hint, hint.Autorewrite.rew_l2r, - hint.Autorewrite.rew_tac) in + hint.Autorewrite.rew_tac) in let lems = List.map lemma rules in (lemmas lems).strategy input - } + } let reduce (r : Redexpr.red_expr) : 'a pure_strategy = { strategy = - fun { state = state ; env = env ; term1 = t ; ty1 = ty ; cstr = cstr ; evars = evars } -> + fun { state = state ; env = env ; term1 = t ; ty1 = ty ; cstr = cstr ; evars = evars } -> let rfn, ckind = Redexpr.reduction_of_red_expr env r in let sigma = goalevars evars in - let (sigma, t') = rfn env sigma t in - if Termops.eq_constr sigma t' t then - state, Identity - else - state, Success { rew_car = ty; rew_from = t; rew_to = t'; - rew_prf = RewCast ckind; - rew_evars = sigma, cstrevars evars } - } - + let (sigma, t') = rfn env sigma t in + if Termops.eq_constr sigma t' t then + state, Identity + else + state, Success { rew_car = ty; rew_from = t; rew_to = t'; + rew_prf = RewCast ckind; + rew_evars = sigma, cstrevars evars } + } + let fold_glob c : 'a pure_strategy = { strategy = fun { state ; env ; term1 = t ; ty1 = ty ; cstr ; evars } -> (* let sigma, (c,_) = Tacinterp.interp_open_constr_with_bindings is env (goalevars evars) c in *) - let sigma, c = Pretyping.understand_tcc env (goalevars evars) c in - let unfolded = - try Tacred.try_red_product env sigma c - with e when CErrors.noncritical e -> + let sigma, c = Pretyping.understand_tcc env (goalevars evars) c in + let unfolded = + try Tacred.try_red_product env sigma c + with e when CErrors.noncritical e -> user_err Pp.(str "fold: the term is not unfoldable!") - in - try - let sigma = Unification.w_unify env sigma CONV ~flags:(Unification.elim_flags ()) unfolded t in - let c' = Reductionops.nf_evar sigma c in - state, Success { rew_car = ty; rew_from = t; rew_to = c'; - rew_prf = RewCast DEFAULTcast; - rew_evars = (sigma, snd evars) } - with e when CErrors.noncritical e -> state, Fail - } - + in + try + let sigma = Unification.w_unify env sigma CONV ~flags:(Unification.elim_flags ()) unfolded t in + let c' = Reductionops.nf_evar sigma c in + state, Success { rew_car = ty; rew_from = t; rew_to = c'; + rew_prf = RewCast DEFAULTcast; + rew_evars = (sigma, snd evars) } + with e when CErrors.noncritical e -> state, Fail + } + end @@ -1450,19 +1450,19 @@ let rewrite_with l2r flags c occs : strategy = { strategy = unify_eqn rew l2r flags env (sigma, cstrs) None t in let app = apply_rule unify occs in - let strat = - Strategies.fix (fun aux -> - Strategies.choice app (subterm true default_flags aux)) + let strat = + Strategies.fix (fun aux -> + Strategies.choice app (subterm true default_flags aux)) in let _, res = strat.strategy { input with state = 0 } in ((), res) - } + } let apply_strategy (s : strategy) env unfresh concl (prop, cstr) evars = let ty = Retyping.get_type_of env (goalevars evars) concl in let _, res = s.strategy { state = () ; env ; unfresh ; - term1 = concl ; ty1 = ty ; - cstr = (prop, Some cstr) ; evars } in + term1 = concl ; ty1 = ty ; + cstr = (prop, Some cstr) ; evars } in res let solve_constraints env (evars,cstrs) = @@ -1483,14 +1483,14 @@ let cl_rewrite_clause_aux ?(abs=None) strat env avoid sigma concl is_hyp : resul let evdref = ref sigma in let evars = (!evdref, Evar.Set.empty) in let evars, cstr = - let prop, (evars, arrow) = + let prop, (evars, arrow) = if Sorts.is_prop sort then true, app_poly_sort true env evars impl [||] else false, app_poly_sort false env evars TypeGlobal.arrow [||] in match is_hyp with - | None -> - let evars, t = poly_inverse prop env evars (mkSort sort) arrow in - evars, (prop, t) + | None -> + let evars, t = poly_inverse prop env evars (mkSort sort) arrow in + evars, (prop, t) | Some _ -> evars, (prop, arrow) in let eq = apply_strategy strat env avoid concl cstr evars in @@ -1502,29 +1502,29 @@ let cl_rewrite_clause_aux ?(abs=None) strat env avoid sigma concl is_hyp : resul let evars' = solve_constraints env res.rew_evars in let newt = Reductionops.nf_evar evars' res.rew_to in let evars = (* Keep only original evars (potentially instantiated) and goal evars, - the rest has been defined and substituted already. *) - Evar.Set.fold - (fun ev acc -> - if not (Evd.is_defined acc ev) then - user_err ~hdr:"rewrite" - (str "Unsolved constraint remaining: " ++ spc () ++ + the rest has been defined and substituted already. *) + Evar.Set.fold + (fun ev acc -> + if not (Evd.is_defined acc ev) then + user_err ~hdr:"rewrite" + (str "Unsolved constraint remaining: " ++ spc () ++ Termops.pr_evar_info env acc (Evd.find acc ev)) - else Evd.remove acc ev) - cstrs evars' + else Evd.remove acc ev) + cstrs evars' in let res = match res.rew_prf with - | RewCast c -> None - | RewPrf (rel, p) -> - let p = nf_zeta env evars' (Reductionops.nf_evar evars' p) in - let term = - match abs with - | None -> p - | Some (t, ty) -> + | RewCast c -> None + | RewPrf (rel, p) -> + let p = nf_zeta env evars' (Reductionops.nf_evar evars' p) in + let term = + match abs with + | None -> p + | Some (t, ty) -> let t = Reductionops.nf_evar evars' t in let ty = Reductionops.nf_evar evars' ty in mkApp (mkLambda (make_annot (Name (Id.of_string "lemma")) Sorts.Relevant, ty, p), [| t |]) - in - let proof = match is_hyp with + in + let proof = match is_hyp with | None -> term | Some id -> mkApp (term, [| mkVar id |]) in Some proof @@ -1539,7 +1539,7 @@ let rec insert_dependent env sigma decl accu hyps = match hyps with else insert_dependent env sigma decl (ndecl :: accu) rem -let assert_replacing id newt tac = +let assert_replacing id newt tac = let prf = Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in @@ -1565,7 +1565,7 @@ let assert_replacing id newt tac = end in Proofview.tclTHEN prf (Proofview.tclFOCUS 2 2 tac) -let newfail n s = +let newfail n s = Proofview.tclZERO (Refiner.FailError (n, lazy s)) let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = @@ -1573,29 +1573,29 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = (* For compatibility *) let beta = Tactics.reduct_in_concl ~check:false (Reductionops.nf_betaiota, DEFAULTcast) in let beta_hyp id = Tactics.reduct_in_hyp ~check:false ~reorder:false Reductionops.nf_betaiota (id, InHyp) in - let treat sigma res = + let treat sigma res = match res with | None -> newfail 0 (str "Nothing to rewrite") | Some None -> if progress then newfail 0 (str"Failed to progress") - else Proofview.tclUNIT () + else Proofview.tclUNIT () | Some (Some res) -> let (undef, prf, newt) = res in let fold ev _ accu = if Evd.mem sigma ev then accu else ev :: accu in let gls = List.rev (Evd.fold_undefined fold undef []) in let gls = List.map Proofview.with_empty_state gls in match clause, prf with - | Some id, Some p -> + | Some id, Some p -> let tac = tclTHENLIST [ Refine.refine ~typecheck:true (fun h -> (h,p)); Proofview.Unsafe.tclNEWGOALS gls; ] in Proofview.Unsafe.tclEVARS undef <*> - tclTHENFIRST (assert_replacing id newt tac) (beta_hyp id) - | Some id, None -> + tclTHENFIRST (assert_replacing id newt tac) (beta_hyp id) + | Some id, None -> Proofview.Unsafe.tclEVARS undef <*> convert_hyp ~check:false ~reorder:false (LocalAssum (make_annot id Sorts.Relevant, newt)) <*> beta_hyp id - | None, Some p -> + | None, Some p -> Proofview.Unsafe.tclEVARS undef <*> Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in @@ -1605,7 +1605,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = end in Refine.refine ~typecheck:true make <*> Proofview.Unsafe.tclNEWGOALS gls end - | None, None -> + | None, None -> Proofview.Unsafe.tclEVARS undef <*> convert_concl ~check:false newt DEFAULTcast in @@ -1639,7 +1639,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = raise (RewriteFailure (Himsg.explain_pretype_error env evd e)) end -let tactic_init_setoid () = +let tactic_init_setoid () = try init_setoid (); Proofview.tclUNIT () with e when CErrors.noncritical e -> Tacticals.New.tclFAIL 0 (str"Setoid library not loaded") @@ -1650,9 +1650,9 @@ let cl_rewrite_clause_strat progress strat clause = (cl_rewrite_clause_newtac ~progress strat clause) (fun (e, info) -> match e with | RewriteFailure e -> - tclZEROMSG (str"setoid rewrite failed: " ++ e) - | Refiner.FailError (n, pp) -> - tclFAIL n (str"setoid rewrite failed: " ++ Lazy.force pp) + tclZEROMSG (str"setoid rewrite failed: " ++ e) + | Refiner.FailError (n, pp) -> + tclFAIL n (str"setoid rewrite failed: " ++ Lazy.force pp) | e -> Proofview.tclZERO ~info e)) (** Setoid rewriting when called with "setoid_rewrite" *) @@ -1663,7 +1663,7 @@ let cl_rewrite_clause l left2right occs clause = (** Setoid rewriting when called with "rewrite_strat" *) let cl_rewrite_clause_strat strat clause = cl_rewrite_clause_strat false strat clause - + let apply_glob_constr c l2r occs = (); fun ({ state = () ; env = env } as input) -> let c sigma = let (sigma, c) = Pretyping.understand_tcc env sigma c in @@ -1681,22 +1681,22 @@ let interp_glob_constr_list env = (* Syntax for rewriting with strategies *) -type unary_strategy = +type unary_strategy = Subterms | Subterm | Innermost | Outermost | Bottomup | Topdown | Progress | Try | Any | Repeat -type binary_strategy = +type binary_strategy = | Compose | Choice -type ('constr,'redexpr) strategy_ast = +type ('constr,'redexpr) strategy_ast = | StratId | StratFail | StratRefl | StratUnary of unary_strategy * ('constr,'redexpr) strategy_ast - | StratBinary of binary_strategy + | StratBinary of binary_strategy * ('constr,'redexpr) strategy_ast * ('constr,'redexpr) strategy_ast | StratConstr of 'constr * bool | StratTerms of 'constr list | StratHints of bool * string - | StratEval of 'redexpr + | StratEval of 'redexpr | StratFold of 'constr let rec map_strategy (f : 'a -> 'a2) (g : 'b -> 'b2) : ('a,'b) strategy_ast -> ('a2,'b2) strategy_ast = function @@ -1747,7 +1747,7 @@ let rec strategy_of_ast = function | StratId -> Strategies.id | StratFail -> Strategies.fail | StratRefl -> Strategies.refl - | StratUnary (f, s) -> + | StratUnary (f, s) -> let s' = strategy_of_ast s in let f' = match f with | Subterms -> all_subterms @@ -1774,12 +1774,12 @@ let rec strategy_of_ast = function (fun ({ state = () ; env } as input) -> let l' = interp_glob_constr_list env (List.map fst l) in (Strategies.lemmas l').strategy input) - } + } | StratEval r -> { strategy = (fun ({ state = () ; env ; evars } as input) -> let (sigma,r_interp) = Tacinterp.interp_redexp env (goalevars evars) r in (Strategies.reduce r_interp).strategy { input with - evars = (sigma,cstrevars evars) }) } + evars = (sigma,cstrevars evars) }) } | StratFold c -> Strategies.fold_glob (fst c) @@ -1862,7 +1862,7 @@ let proper_projection env sigma r ty = let mor, args = destApp sigma inst in let instarg = mkApp (r, rel_vect 0 (List.length ctx)) in let app = mkApp (PropGlobal.proper_proj env sigma, - Array.append args [| instarg |]) in + Array.append args [| instarg |]) in it_mkLambda_or_LetIn app ctx let declare_projection n instance_id r = @@ -1877,17 +1877,17 @@ let declare_projection n instance_id r = let typ = let n = let rec aux t = - match EConstr.kind sigma t with - | App (f, [| a ; a' ; rel; rel' |]) - when Termops.is_global sigma (PropGlobal.respectful_ref ()) f -> - succ (aux rel') - | _ -> 0 + match EConstr.kind sigma t with + | App (f, [| a ; a' ; rel; rel' |]) + when Termops.is_global sigma (PropGlobal.respectful_ref ()) f -> + succ (aux rel') + | _ -> 0 in let init = - match EConstr.kind sigma typ with - App (f, args) when Termops.is_global sigma (PropGlobal.respectful_ref ()) f -> - mkApp (f, fst (Array.chop (Array.length args - 2) args)) - | _ -> typ + match EConstr.kind sigma typ with + App (f, args) when Termops.is_global sigma (PropGlobal.respectful_ref ()) f -> + mkApp (f, fst (Array.chop (Array.length args - 2) args)) + | _ -> typ in aux init in let ctx,ccl = Reductionops.splay_prod_n env sigma (3 * n) typ @@ -1911,19 +1911,19 @@ let build_morphism_signature env sigma m = let rec aux t = match EConstr.kind sigma t with | Prod (na, a, b) -> - None :: aux b - | _ -> [] + None :: aux b + | _ -> [] in aux t in - let evars, t', sig_, cstrs = + let evars, t', sig_, cstrs = PropGlobal.build_signature (sigma, Evar.Set.empty) env t cstrs None in let evd = ref evars in let _ = List.iter (fun (ty, rel) -> Option.iter (fun rel -> - let default = e_app_poly env evd PropGlobal.default_relation [| ty; rel |] in - ignore(e_new_cstr_evar env evd default)) - rel) + let default = e_app_poly env evd PropGlobal.default_relation [| ty; rel |] in + ignore(e_new_cstr_evar env evd default)) + rel) cstrs in let morph = e_app_poly env evd (PropGlobal.proper_type env) [| t; sig_; m |] in @@ -2062,14 +2062,14 @@ let unification_rewrite l2r c1 c2 sigma prf car rel but env = (* ~flags:(false,true) to allow to mark occurrences that must not be rewritten simply by replacing them with let-defined definitions in the context *) - Unification.w_unify_to_subterm + Unification.w_unify_to_subterm ~flags:rewrite_unif_flags env sigma ((if l2r then c1 else c2),but) with | ex when Pretype_errors.precatchable_exception ex -> - (* ~flags:(true,true) to make Ring work (since it really + (* ~flags:(true,true) to make Ring work (since it really exploits conversion) *) - Unification.w_unify_to_subterm + Unification.w_unify_to_subterm ~flags:rewrite_conv_unif_flags env sigma ((if l2r then c1 else c2),but) in @@ -2112,15 +2112,15 @@ let general_s_rewrite cl l2r occs (c,l) ~new_goals = let strat = { strategy = fun ({ state = () } as input) -> let _, res = substrat.strategy { input with state = 0 } in (), res - } + } in let origsigma = Tacmach.New.project gl in tactic_init_setoid () <*> Proofview.tclOR (tclPROGRESS - (tclTHEN + (tclTHEN (Proofview.Unsafe.tclEVARS evd) - (cl_rewrite_clause_newtac ~progress:true ~abs:(Some abs) ~origsigma strat cl))) + (cl_rewrite_clause_newtac ~progress:true ~abs:(Some abs) ~origsigma strat cl))) (fun (e, info) -> match e with | RewriteFailure e -> tclFAIL 0 (str"setoid rewrite failed: " ++ e) @@ -2147,7 +2147,7 @@ let setoid_proof ty fn fallback = let rel, _, _ = decompose_app_rel env sigma concl in let (sigma, t) = Typing.type_of env sigma rel in let car = snd (List.hd (fst (Reductionops.splay_prod env sigma t))) in - (try init_relation_classes () with _ -> raise Not_found); + (try init_relation_classes () with _ -> raise Not_found); fn env sigma car rel with e -> Proofview.tclZERO e end @@ -2157,18 +2157,18 @@ let setoid_proof ty fn fallback = fallback begin function (e', info) -> match e' with | Hipattern.NoEquationFound -> - begin match e with - | (Not_found, _) -> - let rel, _, _ = decompose_app_rel env sigma concl in - not_declared env sigma ty rel - | (e, info) -> Proofview.tclZERO ~info e + begin match e with + | (Not_found, _) -> + let rel, _, _ = decompose_app_rel env sigma concl in + not_declared env sigma ty rel + | (e, info) -> Proofview.tclZERO ~info e end | e' -> Proofview.tclZERO ~info e' end end end -let tac_open ((evm,_), c) tac = +let tac_open ((evm,_), c) tac = (tclTHEN (Proofview.Unsafe.tclEVARS evm) (tac c)) let poly_proof getp gett env evm car rel = @@ -2178,32 +2178,32 @@ let poly_proof getp gett env evm car rel = let setoid_reflexivity = setoid_proof "reflexive" - (fun env evm car rel -> + (fun env evm car rel -> tac_open (poly_proof PropGlobal.get_reflexive_proof - TypeGlobal.get_reflexive_proof - env evm car rel) - (fun c -> tclCOMPLETE (apply c))) + TypeGlobal.get_reflexive_proof + env evm car rel) + (fun c -> tclCOMPLETE (apply c))) (reflexivity_red true) let setoid_symmetry = setoid_proof "symmetric" - (fun env evm car rel -> + (fun env evm car rel -> tac_open - (poly_proof PropGlobal.get_symmetric_proof TypeGlobal.get_symmetric_proof - env evm car rel) - (fun c -> apply c)) + (poly_proof PropGlobal.get_symmetric_proof TypeGlobal.get_symmetric_proof + env evm car rel) + (fun c -> apply c)) (symmetry_red true) - + let setoid_transitivity c = setoid_proof "transitive" (fun env evm car rel -> tac_open (poly_proof PropGlobal.get_transitive_proof TypeGlobal.get_transitive_proof - env evm car rel) - (fun proof -> match c with - | None -> eapply proof - | Some c -> apply_with_bindings (proof,ImplicitBindings [ c ]))) + env evm car rel) + (fun proof -> match c with + | None -> eapply proof + | Some c -> apply_with_bindings (proof,ImplicitBindings [ c ]))) (transitivity_red true c) - + let setoid_symmetry_in id = let open Tacmach.New in Proofview.Goal.enter begin fun gl -> @@ -2230,16 +2230,16 @@ let _ = Hook.set Tactics.setoid_symmetry setoid_symmetry let _ = Hook.set Tactics.setoid_symmetry_in setoid_symmetry_in let _ = Hook.set Tactics.setoid_transitivity setoid_transitivity -let get_lemma_proof f env evm x y = +let get_lemma_proof f env evm x y = let (evm, _), c = f env (evm,Evar.Set.empty) x y in evm, c let get_reflexive_proof = get_lemma_proof PropGlobal.get_reflexive_proof -let get_symmetric_proof = +let get_symmetric_proof = get_lemma_proof PropGlobal.get_symmetric_proof -let get_transitive_proof = +let get_transitive_proof = get_lemma_proof PropGlobal.get_transitive_proof - + diff --git a/plugins/ltac/rewrite.mli b/plugins/ltac/rewrite.mli index 8e0b0a8003..576ed686d4 100644 --- a/plugins/ltac/rewrite.mli +++ b/plugins/ltac/rewrite.mli @@ -23,25 +23,25 @@ open Tacinterp type rewrite_attributes val rewrite_attributes : rewrite_attributes Attributes.attribute -type unary_strategy = +type unary_strategy = Subterms | Subterm | Innermost | Outermost | Bottomup | Topdown | Progress | Try | Any | Repeat -type binary_strategy = +type binary_strategy = | Compose | Choice -type ('constr,'redexpr) strategy_ast = +type ('constr,'redexpr) strategy_ast = | StratId | StratFail | StratRefl | StratUnary of unary_strategy * ('constr,'redexpr) strategy_ast - | StratBinary of binary_strategy + | StratBinary of binary_strategy * ('constr,'redexpr) strategy_ast * ('constr,'redexpr) strategy_ast | StratConstr of 'constr * bool | StratTerms of 'constr list | StratHints of bool * string - | StratEval of 'redexpr + | StratEval of 'redexpr | StratFold of 'constr -type rewrite_proof = +type rewrite_proof = | RewPrf of constr * constr | RewCast of Constr.cast_kind diff --git a/plugins/ltac/taccoerce.ml b/plugins/ltac/taccoerce.ml index da89a027e2..a57cc76faa 100644 --- a/plugins/ltac/taccoerce.ml +++ b/plugins/ltac/taccoerce.ml @@ -191,7 +191,7 @@ let id_of_name = function | None -> fail () | Some c -> match EConstr.kind sigma c with - | Var id -> id + | Var id -> id | Meta m -> id_of_name (Evd.meta_name sigma m) | Evar (kn,_) -> begin match Evd.evar_ident kn sigma with @@ -201,12 +201,12 @@ let id_of_name = function | Const (cst,_) -> Label.to_id (Constant.label cst) | Construct (cstr,_) -> let ref = GlobRef.ConstructRef cstr in - let basename = Nametab.basename_of_global ref in - basename + let basename = Nametab.basename_of_global ref in + basename | Ind (ind,_) -> let ref = GlobRef.IndRef ind in - let basename = Nametab.basename_of_global ref in - basename + let basename = Nametab.basename_of_global ref in + basename | Sort s -> begin match ESorts.kind sigma s with diff --git a/plugins/ltac/tacenv.ml b/plugins/ltac/tacenv.ml index 6a5ab55604..8bafbb7ea3 100644 --- a/plugins/ltac/tacenv.ml +++ b/plugins/ltac/tacenv.ml @@ -107,7 +107,7 @@ let interp_ml_tactic { mltac_name = s; mltac_index = i } = let () = if Array.length tacs <= i then raise Not_found in tacs.(i) with Not_found -> - CErrors.user_err + CErrors.user_err (str "The tactic " ++ pr_tacname s ++ str " is not installed.") (***************************************************************************) diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index 63559cf488..4dc2ade7a1 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -279,11 +279,11 @@ let intern_destruction_arg ist = function | clear,ElimOnAnonHyp n as x -> x | clear,ElimOnIdent {loc;v=id} -> if !strict_check then - (* If in a defined tactic, no intros-until *) + (* If in a defined tactic, no intros-until *) let c, p = intern_constr ist (make @@ CRef (qualid_of_ident id, None)) in - match DAst.get c with + match DAst.get c with | GVar id -> clear,ElimOnIdent (make ?loc:c.loc id) - | _ -> clear,ElimOnConstr ((c, p), NoBindings) + | _ -> clear,ElimOnConstr ((c, p), NoBindings) else clear,ElimOnIdent (make ?loc id) @@ -401,13 +401,13 @@ let dump_glob_red_expr = function | Unfold occs -> List.iter (fun (_, r) -> try Dumpglob.add_glob ?loc:r.loc - (Smartlocate.smart_global r) + (Smartlocate.smart_global r) with e when CErrors.noncritical e -> ()) occs | Cbv grf | Lazy grf -> List.iter (fun r -> try Dumpglob.add_glob ?loc:r.loc - (Smartlocate.smart_global r) + (Smartlocate.smart_global r) with e when CErrors.noncritical e -> ()) grf.rConst | _ -> () @@ -525,18 +525,18 @@ let rec intern_atomic lf ist x = intern_constr_gen false (not (Option.is_empty otac)) ist c) | TacGeneralize cl -> TacGeneralize (List.map (fun (c,na) -> - intern_constr_with_occurrences ist c, + intern_constr_with_occurrences ist c, intern_name lf ist na) cl) | TacLetTac (ev,na,c,cls,b,eqpat) -> let na = intern_name lf ist na in TacLetTac (ev,na,intern_constr ist c, (clause_app (intern_hyp_location ist) cls),b, - (Option.map (intern_intro_pattern_naming_loc lf ist) eqpat)) + (Option.map (intern_intro_pattern_naming_loc lf ist) eqpat)) (* Derived basic tactics *) | TacInductionDestruct (ev,isrec,(l,el)) -> TacInductionDestruct (ev,isrec,(List.map (fun (c,(ipato,ipats),cls) -> - (intern_destruction_arg ist c, + (intern_destruction_arg ist c, (Option.map (intern_intro_pattern_naming_loc lf ist) ipato, Option.map (intern_or_and_intro_pattern_loc lf ist) ipats), Option.map (clause_app (intern_hyp_location ist)) cls)) l, @@ -557,7 +557,7 @@ let rec intern_atomic lf ist x = TacChange (check,None, (if is_onhyps && is_onconcl then intern_type ist c else intern_constr ist c), - clause_app (intern_hyp_location ist) cl) + clause_app (intern_hyp_location ist) cl) | TacChange (check,Some p,c,cl) -> let { ltacvars } = ist in let metas,pat = intern_typed_pattern ist ~as_type:false ~ltacvars p in @@ -565,15 +565,15 @@ let rec intern_atomic lf ist x = let ltacvars = List.fold_left fold ltacvars metas in let ist' = { ist with ltacvars } in TacChange (check,Some pat,intern_constr ist' c, - clause_app (intern_hyp_location ist) cl) + clause_app (intern_hyp_location ist) cl) (* Equality and inversion *) | TacRewrite (ev,l,cl,by) -> TacRewrite - (ev, - List.map (fun (b,m,c) -> (b,m,intern_constr_with_bindings_arg ist c)) l, - clause_app (intern_hyp_location ist) cl, - Option.map (intern_pure_tactic ist) by) + (ev, + List.map (fun (b,m,c) -> (b,m,intern_constr_with_bindings_arg ist c)) l, + clause_app (intern_hyp_location ist) cl, + Option.map (intern_pure_tactic ist) by) | TacInversion (inv,hyp) -> TacInversion (intern_inversion_strength lf ist inv, intern_quantified_hypothesis ist hyp) @@ -590,7 +590,7 @@ and intern_tactic_seq onlytac ist = function let ltacvars = Id.Set.union (extract_let_names l) ist.ltacvars in let ist' = { ist with ltacvars } in let l = List.map (fun (n,b) -> - (n,intern_tacarg !strict_check false (if isrec then ist' else ist) b)) l in + (n,intern_tacarg !strict_check false (if isrec then ist' else ist) b)) l in ist.ltacvars, TacLetIn (isrec,l,intern_tactic onlytac ist' u) | TacMatchGoal (lz,lr,lmr) -> @@ -615,13 +615,13 @@ and intern_tactic_seq onlytac ist = function ist.ltacvars , TacExtendTac (Array.map (intern_pure_tactic ist) tf, intern_pure_tactic ist t, - Array.map (intern_pure_tactic ist) tl) + Array.map (intern_pure_tactic ist) tl) | TacThens3parts (t1,tf,t2,tl) -> let lfun', t1 = intern_tactic_seq onlytac ist t1 in let ist' = { ist with ltacvars = lfun' } in (* Que faire en cas de (tac complexe avec Match et Thens; tac2) ?? *) lfun', TacThens3parts (t1,Array.map (intern_pure_tactic ist') tf,intern_pure_tactic ist' t2, - Array.map (intern_pure_tactic ist') tl) + Array.map (intern_pure_tactic ist') tl) | TacThens (t,tl) -> let lfun', t = intern_tactic_seq true ist t in let ist' = { ist with ltacvars = lfun' } in diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index c252372f21..9633c9bd77 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -240,7 +240,7 @@ let append_trace trace v = (* Dynamically check that an argument is a tactic *) let coerce_to_tactic loc id v = - let fail () = user_err ?loc + let fail () = user_err ?loc (str "Variable " ++ Id.print id ++ str " should be bound to a tactic.") in if has_type v (topwit wit_tacvalue) then @@ -472,8 +472,8 @@ let interp_fresh_id ist env sigma l = if List.is_empty l then default_fresh_id else let s = - String.concat "" (List.map (function - | ArgArg s -> s + String.concat "" (List.map (function + | ArgArg s -> s | ArgVar {v=id} -> Id.to_string (extract_ident ist env sigma id)) l) in let s = if CLexer.is_keyword s then s^"0" else s in Id.of_string s in @@ -694,7 +694,7 @@ let interp_red_expr ist env sigma = function sigma , Pattern l_interp | Simpl (f,o) -> sigma , Simpl (interp_flag ist env sigma f, - Option.map (interp_closed_typed_pattern_with_occurrences ist env sigma) o) + Option.map (interp_closed_typed_pattern_with_occurrences ist env sigma) o) | CbvVm o -> sigma , CbvVm (Option.map (interp_closed_typed_pattern_with_occurrences ist env sigma) o) | CbvNative o -> @@ -709,23 +709,23 @@ let interp_may_eval f ist env sigma = function redfun env sigma c_interp | ConstrContext ({loc;v=s},c) -> (try - let (sigma,ic) = f ist env sigma c in + let (sigma,ic) = f ist env sigma c in let ctxt = try_interp_ltac_var coerce_to_constr_context ist (Some (env, sigma)) (make ?loc s) in - let ctxt = EConstr.Unsafe.to_constr ctxt in + let ctxt = EConstr.Unsafe.to_constr ctxt in let ic = EConstr.Unsafe.to_constr ic in - let c = subst_meta [Constr_matching.special_meta,ic] ctxt in + let c = subst_meta [Constr_matching.special_meta,ic] ctxt in Typing.solve_evars env sigma (EConstr.of_constr c) with - | Not_found -> - user_err ?loc ~hdr:"interp_may_eval" - (str "Unbound context identifier" ++ Id.print s ++ str".")) + | Not_found -> + user_err ?loc ~hdr:"interp_may_eval" + (str "Unbound context identifier" ++ Id.print s ++ str".")) | ConstrTypeOf c -> let (sigma,c_interp) = f ist env sigma c in let (sigma, t) = Typing.type_of ~refresh:true env sigma c_interp in (sigma, t) | ConstrTerm c -> try - f ist env sigma c + f ist env sigma c with reraise -> let reraise = CErrors.push reraise in (* spiwack: to avoid unnecessary modifications of tacinterp, as this @@ -909,7 +909,7 @@ let interp_destruction_arg ist gl arg = end | keep,ElimOnAnonHyp n as x -> x | keep,ElimOnIdent {loc;v=id} -> - let error () = user_err ?loc + let error () = user_err ?loc (strbrk "Cannot coerce " ++ Id.print id ++ strbrk " neither to a quantified hypothesis nor to a term.") in @@ -941,10 +941,10 @@ let interp_destruction_arg ist gl arg = | None -> error () | Some c -> keep,ElimOnConstr (fun env sigma -> (sigma, (c,NoBindings))) with Not_found -> - (* We were in non strict (interactive) mode *) - if Tactics.is_quantified_hypothesis id gl then + (* We were in non strict (interactive) mode *) + if Tactics.is_quantified_hypothesis id gl then keep,ElimOnIdent (make ?loc id) - else + else let c = (DAst.make ?loc @@ GVar id,Some (make @@ CRef (qualid_of_ident ?loc id,None))) in let f env sigma = let (sigma,c) = interp_open_constr ist env sigma c in @@ -995,11 +995,11 @@ let rec read_match_goal_hyps lfun ist env sigma lidh = function | (Hyp ({loc;v=na} as locna,mp))::tl -> let lidh' = Name.fold_right cons_and_check_name na lidh in Hyp (locna,read_pattern lfun ist env sigma mp):: - (read_match_goal_hyps lfun ist env sigma lidh' tl) + (read_match_goal_hyps lfun ist env sigma lidh' tl) | (Def ({loc;v=na} as locna,mv,mp))::tl -> let lidh' = Name.fold_right cons_and_check_name na lidh in Def (locna,read_pattern lfun ist env sigma mv, read_pattern lfun ist env sigma mp):: - (read_match_goal_hyps lfun ist env sigma lidh' tl) + (read_match_goal_hyps lfun ist env sigma lidh' tl) | [] -> [] (* Reads the rules of a Match Context or a Match *) @@ -1060,7 +1060,7 @@ let rec val_interp ist ?(appl=UnnamedAppl) (tac:glob_tactic_expr) : Val.t Ftacti let ist = { ist with extra = TacStore.set ist.extra f_debug v } in value_interp ist >>= fun v -> return (name_vfun appl v) in - Tactic_debug.debug_prompt lev tac eval + Tactic_debug.debug_prompt lev tac eval | _ -> value_interp ist >>= fun v -> return (name_vfun appl v) @@ -1117,7 +1117,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with | TacThens (t1,tl) -> Tacticals.New.tclTHENS (interp_tactic ist t1) (List.map (interp_tactic ist) tl) | TacThens3parts (t1,tf,t,tl) -> Tacticals.New.tclTHENS3PARTS (interp_tactic ist t1) - (Array.map (interp_tactic ist) tf) (interp_tactic ist t) (Array.map (interp_tactic ist) tl) + (Array.map (interp_tactic ist) tf) (interp_tactic ist t) (Array.map (interp_tactic ist) tl) | TacDo (n,tac) -> Tacticals.New.tclDO (interp_int_or_var ist n) (interp_tactic ist tac) | TacTimeout (n,tac) -> Tacticals.New.tclTIMEOUT (interp_int_or_var ist n) (interp_tactic ist tac) | TacTime (s,tac) -> Tacticals.New.tclTIME s (interp_tactic ist tac) @@ -1276,9 +1276,9 @@ and interp_app loc ist fv largs : Val.t Ftactic.t = | (VFun(appl,trace,olfun,(_::_ as var),body) |VFun(appl,trace,olfun,([] as var), (TacFun _|TacLetIn _|TacMatchGoal _|TacMatch _| TacArg _ as body))) -> - let (extfun,lvar,lval)=head_with_value (var,largs) in + let (extfun,lvar,lval)=head_with_value (var,largs) in let fold accu (id, v) = Id.Map.add id v accu in - let newlfun = List.fold_left fold olfun extfun in + let newlfun = List.fold_left fold olfun extfun in if List.is_empty lvar then begin wrap_error begin @@ -1291,9 +1291,9 @@ and interp_app loc ist fv largs : Val.t Ftactic.t = (catch_error_tac trace (val_interp ist body)) >>= fun v -> Ftactic.return (name_vfun (push_appl appl largs) v) end - begin fun (e, info) -> + begin fun (e, info) -> Proofview.tclLIFT (debugging_exception_step ist false e (fun () -> str "evaluation")) <*> - Proofview.tclZERO ~info e + Proofview.tclZERO ~info e end end >>= fun v -> (* No errors happened, we propagate the trace *) @@ -1604,10 +1604,10 @@ and interp_atomic ist tac : unit Proofview.tactic = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in - let l = List.map (fun (k,c) -> + let l = List.map (fun (k,c) -> let loc, f = interp_open_constr_with_bindings_loc ist c in (k,(make ?loc f))) cb - in + in let sigma,tac = match cl with | None -> sigma, Tactics.apply_with_delayed_bindings_gen a ev l | Some cl -> @@ -1619,7 +1619,7 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacElim (ev,(keep,cb),cbo) -> Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = project gl in + let sigma = project gl in let sigma, cb = interp_open_constr_with_bindings ist env sigma cb in let sigma, cbo = Option.fold_left_map (interp_open_constr_with_bindings ist env) sigma cbo in let named_tac = @@ -1646,7 +1646,7 @@ and interp_atomic ist tac : unit Proofview.tactic = let env = pf_env gl in let f sigma (id,n,c) = let (sigma,c_interp) = interp_type ist env sigma c in - sigma , (interp_ident ist env sigma id,n,c_interp) in + sigma , (interp_ident ist env sigma id,n,c_interp) in let (sigma,l_interp) = Evd.MonadR.List.map_right (fun c sigma -> f sigma c) l (project gl) in @@ -1660,8 +1660,8 @@ and interp_atomic ist tac : unit Proofview.tactic = Proofview.Goal.enter begin fun gl -> let env = pf_env gl in let f sigma (id,c) = - let (sigma,c_interp) = interp_type ist env sigma c in - sigma , (interp_ident ist env sigma id,c_interp) in + let (sigma,c_interp) = interp_type ist env sigma c in + sigma , (interp_ident ist env sigma id,c_interp) in let (sigma,l_interp) = Evd.MonadR.List.map_right (fun c sigma -> f sigma c) l (project gl) in @@ -1728,7 +1728,7 @@ and interp_atomic ist tac : unit Proofview.tactic = let (sigma',c) = interp_pure_open_constr ist env sigma c in name_atomic ~env (TacLetTac(ev,na,c,clp,b,eqpat)) - (Tacticals.New.tclWITHHOLES ev + (Tacticals.New.tclWITHHOLES ev (let_pat_tac b (interp_name ist env sigma na) (sigma,c) clp eqpat) sigma') end @@ -1782,11 +1782,11 @@ and interp_atomic ist tac : unit Proofview.tactic = | _ -> false in let c_interp patvars env sigma = - let lfun' = Id.Map.fold (fun id c lfun -> - Id.Map.add id (Value.of_constr c) lfun) - patvars ist.lfun - in - let ist = { ist with lfun = lfun' } in + let lfun' = Id.Map.fold (fun id c lfun -> + Id.Map.add id (Value.of_constr c) lfun) + patvars ist.lfun + in + let ist = { ist with lfun = lfun' } in if is_onhyps && is_onconcl then interp_type ist env sigma c else interp_constr ist env sigma c @@ -1804,7 +1804,7 @@ and interp_atomic ist tac : unit Proofview.tactic = let to_catch = function Not_found -> true | e -> CErrors.is_anomaly e in let c_interp patvars env sigma = let lfun' = Id.Map.fold (fun id c lfun -> - Id.Map.add id (Value.of_constr c) lfun) + Id.Map.add id (Value.of_constr c) lfun) patvars ist.lfun in let env = ensure_freshness env in @@ -1826,7 +1826,7 @@ and interp_atomic ist tac : unit Proofview.tactic = let f env sigma = interp_open_constr_with_bindings ist env sigma c in - (b,m,keep,f)) l in + (b,m,keep,f)) l in let env = Proofview.Goal.env gl in let sigma = project gl in let cl = interp_clause ist env sigma cl in diff --git a/plugins/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml index bf5d49f678..e864d31da4 100644 --- a/plugins/ltac/tacsubst.ml +++ b/plugins/ltac/tacsubst.ml @@ -161,9 +161,9 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with (* Equality and inversion *) | TacRewrite (ev,l,cl,by) -> TacRewrite (ev, - List.map (fun (b,m,c) -> - b,m,subst_glob_with_bindings_arg subst c) l, - cl,Option.map (subst_tactic subst) by) + List.map (fun (b,m,c) -> + b,m,subst_glob_with_bindings_arg subst c) l, + cl,Option.map (subst_tactic subst) by) | TacInversion (DepInversion (k,c,l),hyp) -> TacInversion (DepInversion (k,Option.map (subst_glob_constr subst) c,l),hyp) | TacInversion (NonDepInversion _,_) as x -> x @@ -189,13 +189,13 @@ and subst_tactic subst (t:glob_tactic_expr) = match t with | TacDispatch tl -> TacDispatch (List.map (subst_tactic subst) tl) | TacExtendTac (tf,t,tl) -> TacExtendTac (Array.map (subst_tactic subst) tf, - subst_tactic subst t, + subst_tactic subst t, Array.map (subst_tactic subst) tl) | TacThens (t,tl) -> TacThens (subst_tactic subst t, List.map (subst_tactic subst) tl) | TacThens3parts (t1,tf,t2,tl) -> TacThens3parts (subst_tactic subst t1,Array.map (subst_tactic subst) tf, - subst_tactic subst t2,Array.map (subst_tactic subst) tl) + subst_tactic subst t2,Array.map (subst_tactic subst) tl) | TacDo (n,tac) -> TacDo (n,subst_tactic subst tac) | TacTimeout (n,tac) -> TacTimeout (n,subst_tactic subst tac) | TacTime (s,tac) -> TacTime (s,subst_tactic subst tac) diff --git a/plugins/ltac/tactic_matching.ml b/plugins/ltac/tactic_matching.ml index d008f9da1f..eabfe2f540 100644 --- a/plugins/ltac/tactic_matching.ml +++ b/plugins/ltac/tactic_matching.ml @@ -85,7 +85,7 @@ let is_empty_subst (ln,lm) = would ensure consistency. *) let equal_instances env sigma (ctx',c') (ctx,c) = (* How to compare instances? Do we want the terms to be convertible? - unifiable? Do we want the universe levels to be relevant? + unifiable? Do we want the universe levels to be relevant? (historically, conv_x is used) *) CList.equal Id.equal ctx ctx' && Reductionops.is_conv env sigma c' c @@ -230,11 +230,11 @@ module PatternMatching (E:StaticEnvironment) = struct (** [pattern_match_term refresh pat term lhs] returns the possible matchings of [term] with the pattern [pat => lhs]. If refresh is true, refreshes the universes of [term]. *) - let pattern_match_term refresh pat term lhs = + let pattern_match_term refresh pat term lhs = (* let term = if refresh then Termops.refresh_universes_strict term else term in *) match pat with | Term p -> - begin + begin try put_subst (Constr_matching.extended_matches E.env E.sigma p term) <*> return lhs diff --git a/plugins/ltac/tactic_option.ml b/plugins/ltac/tactic_option.ml index 21e02d4c04..da57f51ca3 100644 --- a/plugins/ltac/tactic_option.ml +++ b/plugins/ltac/tactic_option.ml @@ -34,19 +34,19 @@ let declare_tactic_option ?(default=Tacexpr.TacId []) name = let input : bool * Tacexpr.glob_tactic_expr -> obj = declare_object { (default_object name) with - cache_function = cache; - load_function = (fun _ -> load); - open_function = (fun _ -> load); - classify_function = (fun (local, tac) -> - if local then Dispose else Substitute (local, tac)); - subst_function = subst} + cache_function = cache; + load_function = (fun _ -> load); + open_function = (fun _ -> load); + classify_function = (fun (local, tac) -> + if local then Dispose else Substitute (local, tac)); + subst_function = subst} in let put local tac = set_default_tactic local tac; Lib.add_anonymous_leaf (input (local, tac)) in let get () = !locality, Tacinterp.eval_tactic !default_tactic in - let print () = + let print () = Pptactic.pr_glob_tactic (Global.env ()) !default_tactic_expr ++ (if !locality then str" (locally defined)" else str" (globally defined)") in diff --git a/plugins/ltac/tactic_option.mli b/plugins/ltac/tactic_option.mli index 637dd238fe..9705d225d4 100644 --- a/plugins/ltac/tactic_option.mli +++ b/plugins/ltac/tactic_option.mli @@ -11,7 +11,7 @@ open Tacexpr open Vernacexpr -val declare_tactic_option : ?default:Tacexpr.glob_tactic_expr -> string -> +val declare_tactic_option : ?default:Tacexpr.glob_tactic_expr -> string -> (* put *) (locality_flag -> glob_tactic_expr -> unit) * (* get *) (unit -> locality_flag * unit Proofview.tactic) * (* print *) (unit -> Pp.t) diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml index 24039c93c6..82c2be582b 100644 --- a/plugins/micromega/certificate.ml +++ b/plugins/micromega/certificate.ml @@ -96,7 +96,7 @@ let rec fixpoint f x = if (=) y' x then y' else fixpoint f y' -let rec_simpl_cone n_spec e = +let rec_simpl_cone n_spec e = let simpl_cone = Mc.simpl_cone n_spec.zero n_spec.unit n_spec.mult n_spec.eqb in @@ -107,21 +107,21 @@ let rec_simpl_cone n_spec e = simpl_cone (Mc.PsatzAdd (rec_simpl_cone t1, rec_simpl_cone t2)) | x -> simpl_cone x in rec_simpl_cone e - - + + let simplify_cone n_spec c = fixpoint (rec_simpl_cone n_spec) c -(* The binding with Fourier might be a bit obsolete +(* The binding with Fourier might be a bit obsolete -- how does it handle equalities ? *) (* Certificates are elements of the cone such that P = 0 *) (* To begin with, we search for certificates of the form: - a1.p1 + ... an.pn + b1.q1 +... + bn.qn + c = 0 + a1.p1 + ... an.pn + b1.q1 +... + bn.qn + c = 0 where pi >= 0 qi > 0 - ai >= 0 + ai >= 0 bi >= 0 Sum bi + c >= 1 This is a linear problem: each monomial is considered as a variable. @@ -135,7 +135,7 @@ let simplify_cone n_spec c = fixpoint (rec_simpl_cone n_spec) c let constrain_variable v l = let coeffs = List.fold_left (fun acc p -> (Vect.get v p.coeffs)::acc) [] l in { coeffs = Vect.from_list ((Big_int zero_big_int):: (Big_int zero_big_int):: (List.rev coeffs)) ; - op = Eq ; + op = Eq ; cst = Big_int zero_big_int } @@ -143,10 +143,10 @@ let constrain_variable v l = let constrain_constant l = let coeffs = List.fold_left (fun acc p -> minus_num p.cst ::acc) [] l in { coeffs = Vect.from_list ((Big_int zero_big_int):: (Big_int unit_big_int):: (List.rev coeffs)) ; - op = Eq ; + op = Eq ; cst = Big_int zero_big_int } -let positivity l = +let positivity l = let rec xpositivity i l = match l with | [] -> [] @@ -169,7 +169,7 @@ let cstr_of_poly (p,o) = let variables_of_cstr c = Vect.variables c.coeffs -(* If the certificate includes at least one strict inequality, +(* If the certificate includes at least one strict inequality, the obtained polynomial can also be 0 *) let build_dual_linear_system l = @@ -486,7 +486,7 @@ let square_of_var i = let x = LinPoly.var i in ((LinPoly.product x x,Ge),(ProofFormat.Square x)) - + (** [nlinear_preprocess sys] augments the system [sys] by performing some limited non-linear reasoning. For instance, it asserts that the x² ≥0 but also that if c₁ ≥ 0 ∈ sys and c₂ ≥ 0 ∈ sys then c₁ × c₂ ≥ 0. The resulting system is linearised. @@ -510,7 +510,7 @@ let nlinear_preprocess (sys:WithProof.t list) = let sys = ISet.fold (fun i acc -> square_of_var i :: acc) collect_vars sys in let sys = sys @ (all_pairs WithProof.product sys) in - + if debug then begin Printf.fprintf stdout "Preprocessed\n"; List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys; @@ -545,12 +545,12 @@ let linear_prover_with_cert prfdepth sys = | Some cert -> Prf (ProofFormat.cmpl_prf_rule Mc.normQ CamlToCoq.q (List.mapi (fun i e -> i) sys) cert) -(* The prover is (probably) incomplete -- +(* The prover is (probably) incomplete -- only searching for naive cutting planes *) open Sos_types -let rec scale_term t = +let rec scale_term t = match t with | Zero -> unit_big_int , Zero | Const n -> (denominator n) , Const (Big_int (numerator n)) @@ -564,7 +564,7 @@ let rec scale_term t = if Int.equal (compare_big_int e unit_big_int) 0 then (unit_big_int, Add (y1,y2)) else e, Add (Mul(Const (Big_int s2'), y1), - Mul (Const (Big_int s1'), y2)) + Mul (Const (Big_int s1'), y2)) | Sub _ -> failwith "scale term: not implemented" | Mul(y,z) -> let s1,y1 = scale_term y and s2,y2 = scale_term z in mult_big_int s1 s2 , Mul (y1, y2) @@ -615,14 +615,14 @@ let rec term_to_q_expr = function let term_to_q_pol e = Mc.norm_aux (Ml2C.q (Int 0)) (Ml2C.q (Int 1)) Mc.qplus Mc.qmult Mc.qminus Mc.qopp Mc.qeq_bool (term_to_q_expr e) -let rec product l = +let rec product l = match l with | [] -> Mc.PsatzZ | [i] -> Mc.PsatzIn (Ml2C.nat i) | i ::l -> Mc.PsatzMulE(Mc.PsatzIn (Ml2C.nat i), product l) -let q_cert_of_pos pos = +let q_cert_of_pos pos = let rec _cert_of_pos = function Axiom_eq i -> Mc.PsatzIn (Ml2C.nat i) | Axiom_le i -> Mc.PsatzIn (Ml2C.nat i) @@ -651,7 +651,7 @@ let rec term_to_z_expr = function let term_to_z_pol e = Mc.norm_aux (Ml2C.z 0) (Ml2C.z 1) Mc.Z.add Mc.Z.mul Mc.Z.sub Mc.Z.opp Mc.zeq_bool (term_to_z_expr e) -let z_cert_of_pos pos = +let z_cert_of_pos pos = let s,pos = (scale_certificate pos) in let rec _cert_of_pos = function Axiom_eq i -> Mc.PsatzIn (Ml2C.nat i) @@ -689,7 +689,7 @@ type prf_sys = (cstr * ProofFormat.prf_rule) list (** Proof generating pivoting over variable v *) -let pivot v (c1,p1) (c2,p2) = +let pivot v (c1,p1) (c2,p2) = let {coeffs = v1 ; op = op1 ; cst = n1} = c1 and {coeffs = v2 ; op = op2 ; cst = n2} = c2 in @@ -726,7 +726,7 @@ let pivot v (c1,p1) (c2,p2) = else None (* op2 could be Eq ... this might happen *) -let simpl_sys sys = +let simpl_sys sys = List.fold_left (fun acc (c,p) -> match check_int_sat (c,p) with | Tauto -> acc @@ -739,7 +739,7 @@ let simpl_sys sys = [ext_gcd a b = (x,y,g)] iff [ax+by=g] Source: http://en.wikipedia.org/wiki/Extended_Euclidean_algorithm *) -let rec ext_gcd a b = +let rec ext_gcd a b = if Int.equal (sign_big_int b) 0 then (unit_big_int,zero_big_int) else @@ -747,7 +747,7 @@ let rec ext_gcd a b = let (s,t) = ext_gcd b r in (t, sub_big_int s (mult_big_int q t)) -let extract_coprime (c1,p1) (c2,p2) = +let extract_coprime (c1,p1) (c2,p2) = if c1.op == Eq && c2.op == Eq then Vect.exists2 (fun n1 n2 -> Int.equal (compare_big_int (gcd_big_int (numerator n1) (numerator n2)) unit_big_int) 0) @@ -776,7 +776,7 @@ let extract_coprime_equation psys = let pivot_sys v pc psys = apply_and_normalise check_int_sat (pivot v pc) psys -let reduce_coprime psys = +let reduce_coprime psys = let oeq,sys = extract_coprime_equation psys in match oeq with | None -> None (* Nothing to do *) @@ -793,7 +793,7 @@ let reduce_coprime psys = Some (pivot_sys v (cstr,prf) ((c1,p1)::sys)) (** If there is an equation [eq] of the form 1.x + e = c, do a pivot over x with equation [eq] *) -let reduce_unary psys = +let reduce_unary psys = let is_unary_equation (cstr,prf) = if cstr.op == Eq then @@ -807,7 +807,7 @@ let reduce_unary psys = Some(pivot_sys v pc sys) -let reduce_var_change psys = +let reduce_var_change psys = let rec rel_prime vect = match Vect.choose vect with @@ -854,7 +854,7 @@ let reduction_equations psys = (** [get_bound sys] returns upon success an interval (lb,e,ub) with proofs *) -let get_bound sys = +let get_bound sys = let is_small (v,i) = match Itv.range i with | None -> false @@ -909,12 +909,12 @@ let get_bound sys = | None -> None -let check_sys sys = +let check_sys sys = List.for_all (fun (c,p) -> Vect.for_all (fun _ n -> sign_num n <> 0) c.coeffs) sys open ProofFormat -let xlia (can_enum:bool) reduction_equations sys = +let xlia (can_enum:bool) reduction_equations sys = let rec enum_proof (id:int) (sys:prf_sys) = @@ -979,9 +979,9 @@ let xlia (can_enum:bool) reduction_equations sys = end; let prf = compile_proof env prf in (*try - if Mc.zChecker sys' prf then Some prf else - raise Certificate.BadCertificate - with Failure s -> (Printf.printf "%s" s ; Some prf) + if Mc.zChecker sys' prf then Some prf else + raise Certificate.BadCertificate + with Failure s -> (Printf.printf "%s" s ; Some prf) *) Prf prf let xlia_simplex env red sys = @@ -1029,7 +1029,7 @@ let gen_bench (tac, prover) can_enum prfdepth sys = end); res -let lia (can_enum:bool) (prfdepth:int) sys = +let lia (can_enum:bool) (prfdepth:int) sys = let sys = develop_constraints prfdepth z_spec sys in if debug then begin Printf.fprintf stdout "Input problem\n"; @@ -1049,7 +1049,7 @@ let lia (can_enum:bool) (prfdepth:int) sys = let make_cstr_system sys = List.map (fun ((p,o),prf) -> (cstr_of_poly (p,o), prf)) sys -let nlia enum prfdepth sys = +let nlia enum prfdepth sys = let sys = develop_constraints prfdepth z_spec sys in let is_linear = List.for_all (fun ((p,_),_) -> LinPoly.is_linear p) sys in diff --git a/plugins/micromega/csdpcert.ml b/plugins/micromega/csdpcert.ml index cf5f60fb55..09e354957a 100644 --- a/plugins/micromega/csdpcert.ml +++ b/plugins/micromega/csdpcert.ml @@ -62,9 +62,9 @@ let partition_expr l = | Mc.Equal -> ((e,i)::eq,ge,neq) | Mc.NonStrict -> (eq,(e,Axiom_le i)::ge,neq) | Mc.Strict -> (* e > 0 == e >= 0 /\ e <> 0 *) - (eq, (e,Axiom_lt i)::ge,(e,Axiom_lt i)::neq) + (eq, (e,Axiom_lt i)::ge,(e,Axiom_lt i)::neq) | Mc.NonEqual -> (eq,ge,(e,Axiom_eq i)::neq) - (* Not quite sure -- Coq interface has changed *) + (* Not quite sure -- Coq interface has changed *) in f 0 l @@ -72,7 +72,7 @@ let rec sets_of_list l = match l with | [] -> [[]] | e::l -> let s = sets_of_list l in - s@(List.map (fun s0 -> e::s0) s) + s@(List.map (fun s0 -> e::s0) s) (* The exploration is probably not complete - for simple cases, it works... *) let real_nonlinear_prover d l = @@ -83,9 +83,9 @@ let real_nonlinear_prover d l = let rec elim_const = function [] -> [] | (x,y)::l -> let p = poly_of_term (expr_to_term x) in - if poly_isconst p - then elim_const l - else (p,y)::(elim_const l) in + if poly_isconst p + then elim_const l + else (p,y)::(elim_const l) in let eq = elim_const eq in let peq = List.map fst eq in @@ -104,7 +104,7 @@ let real_nonlinear_prover d l = let (cert_ideal, cert_cone,monoid) = deepen_until d (fun d -> tryfind (fun m -> let (ci,cc) = real_positivnullstellensatz_general false d peq pge (poly_neg (fst m) ) in - (ci,cc,snd m)) monoids) 0 in + (ci,cc,snd m)) monoids) 0 in let proofs_ideal = List.map2 (fun q i -> Eqmul(term_of_poly q,Axiom_eq i)) cert_ideal (List.map snd eq) in @@ -141,9 +141,9 @@ let pure_sos l = let plt = poly_neg (poly_of_term (expr_to_term (fst lt))) in let (n,polys) = sumofsquares plt in (* n * (ci * pi^2) *) let pos = Product (Rational_lt n, - List.fold_right (fun (c,p) rst -> Sum (Product (Rational_lt c, Square - (term_of_poly p)), rst)) - polys (Rational_lt (Int 0))) in + List.fold_right (fun (c,p) rst -> Sum (Product (Rational_lt c, Square + (term_of_poly p)), rst)) + polys (Rational_lt (Int 0))) in let proof = Sum(Axiom_lt i, pos) in (* let s,proof' = scale_certificate proof in let cert = snd (cert_of_pos proof') in *) diff --git a/plugins/micromega/g_micromega.mlg b/plugins/micromega/g_micromega.mlg index bcf546f059..edf8106f30 100644 --- a/plugins/micromega/g_micromega.mlg +++ b/plugins/micromega/g_micromega.mlg @@ -56,7 +56,7 @@ TACTIC EXTEND NQA END - + TACTIC EXTEND Sos_Z | [ "sos_Z" tactic(t) ] -> { (Coq_micromega.sos_Z (Tacinterp.tactic_of_value ist t)) } END diff --git a/plugins/micromega/mfourier.ml b/plugins/micromega/mfourier.ml index 943bcb384b..75cdfa24f1 100644 --- a/plugins/micromega/mfourier.ml +++ b/plugins/micromega/mfourier.ml @@ -71,13 +71,13 @@ exception SystemContradiction of proof let pp_cstr o (vect,bnd) = let (l,r) = bnd in (match l with - | None -> () - | Some n -> Printf.fprintf o "%s <= " (string_of_num n)) + | None -> () + | Some n -> Printf.fprintf o "%s <= " (string_of_num n)) ; Vect.pp o vect ; (match r with - | None -> output_string o"\n" - | Some n -> Printf.fprintf o "<=%s\n" (string_of_num n)) + | None -> output_string o"\n" + | Some n -> Printf.fprintf o "<=%s\n" (string_of_num n)) let pp_system o sys= @@ -96,7 +96,7 @@ let merge_cstr_info i1 i2 = match inter i1 i2 with | None -> None (* Could directly raise a system contradiction exception *) | Some bnd -> - Some { pos = p1 ; neg = n1 ; bound = bnd ; prf = And(prf1,prf2) } + Some { pos = p1 ; neg = n1 ; bound = bnd ; prf = And(prf1,prf2) } (** [xadd_cstr vect cstr_info] loads an constraint into the system. The constraint is neither redundant nor contradictory. @@ -107,14 +107,14 @@ let xadd_cstr vect cstr_info sys = try let info = System.find sys vect in match merge_cstr_info cstr_info !info with - | None -> raise (SystemContradiction (And(cstr_info.prf, (!info).prf))) - | Some info' -> info := info' + | None -> raise (SystemContradiction (And(cstr_info.prf, (!info).prf))) + | Some info' -> info := info' with - | Not_found -> System.replace sys vect (ref cstr_info) + | Not_found -> System.replace sys vect (ref cstr_info) exception TimeOut - -let xadd_cstr vect cstr_info sys = + +let xadd_cstr vect cstr_info sys = if debug && Int.equal (System.length sys mod 1000) 0 then (print_string "*" ; flush stdout) ; if System.length sys < !max_nb_cstr then xadd_cstr vect cstr_info sys @@ -122,11 +122,11 @@ let xadd_cstr vect cstr_info sys = type cstr_ext = | Contradiction (** The constraint is contradictory. - Typically, a [SystemContradiction] exception will be raised. *) + Typically, a [SystemContradiction] exception will be raised. *) | Redundant (** The constrain is redundant. - Typically, the constraint will be dropped *) + Typically, the constraint will be dropped *) | Cstr of vector * cstr_info (** Taken alone, the constraint is neither contradictory nor redundant. - Typically, it will be added to the constraint system. *) + Typically, it will be added to the constraint system. *) (** [normalise_cstr] : vector -> cstr_info -> cstr_ext *) let normalise_cstr vect cinfo = @@ -136,8 +136,8 @@ let normalise_cstr vect cinfo = match Vect.choose vect with | None -> if Itv.in_bound (l,r) (Int 0) then Redundant else Contradiction | Some (_,n,_) -> Cstr(Vect.div n vect, - let divn x = x // n in - if Int.equal (sign_num n) 1 + let divn x = x // n in + if Int.equal (sign_num n) 1 then{cinfo with bound = (Option.map divn l , Option.map divn r) } else {cinfo with pos = cinfo.neg ; neg = cinfo.pos ; bound = (Option.map divn r , Option.map divn l)}) @@ -157,11 +157,11 @@ let norm_cstr {coeffs = v ; op = o ; cst = c} idx = normalise_cstr v {pos = p ; neg = n ; bound = (match o with - | Eq -> Some c , Some c + | Eq -> Some c , Some c | Ge -> Some c , None | Gt -> raise Polynomial.Strict ) ; - prf = Assum idx } + prf = Assum idx } (** [load_system l] takes a list of constraints of type [cstr_compat] @@ -179,7 +179,7 @@ let load_system l = | Contradiction -> raise (SystemContradiction (Assum i)) | Redundant -> vrs | Cstr(vect,info) -> - xadd_cstr vect info sys ; + xadd_cstr vect info sys ; Vect.fold (fun s v _ -> ISet.add v s) vrs cstr.coeffs) ISet.empty li in {sys = sys ;vars = vars} @@ -218,7 +218,7 @@ let add (v1,c1) (v2,c2) = let split x (vect: vector) info (l,m,r) = match get x vect with | Int 0 -> (* The constraint does not mention [x], store it in m *) - (l,(vect,info)::m,r) + (l,(vect,info)::m,r) | vl -> (* otherwise *) let cons_bound lst bd = @@ -257,10 +257,10 @@ let project vr sys = List.iter(fun l_elem -> List.iter (fun r_elem -> let (vect,info) = elim l_elem r_elem in - match normalise_cstr vect info with - | Redundant -> () - | Contradiction -> raise (SystemContradiction info.prf) - | Cstr(vect,info) -> xadd_cstr vect info new_sys) r ) l; + match normalise_cstr vect info with + | Redundant -> () + | Contradiction -> raise (SystemContradiction info.prf) + | Cstr(vect,info) -> xadd_cstr vect info new_sys) r ) l; {sys = new_sys ; vars = ISet.remove vr sys.vars} @@ -277,20 +277,20 @@ let project_using_eq vr c vect bound prf (vect',info') = match get vr vect' with | Int 0 -> (vect',info') | c2 -> - let c1 = if c2 >=/ Int 0 then minus_num c else c in + let c1 = if c2 >=/ Int 0 then minus_num c else c in - let c2 = abs_num c2 in + let c2 = abs_num c2 in - let (vres,(n,p)) = add (vect,c1) (vect', c2) in + let (vres,(n,p)) = add (vect,c1) (vect', c2) in - let cst = bound // c1 in + let cst = bound // c1 in - let bndres = - let f x = cst +/ x // c2 in - let (l,r) = info'.bound in + let bndres = + let f x = cst +/ x // c2 in + let (l,r) = info'.bound in (Option.map f l , Option.map f r) in - (vres,{neg = n ; pos = p ; bound = bndres ; prf = Elim(vr,prf,info'.prf)}) + (vres,{neg = n ; pos = p ; bound = bndres ; prf = Elim(vr,prf,info'.prf)}) let elim_var_using_eq vr vect cst prf sys = @@ -302,10 +302,10 @@ let elim_var_using_eq vr vect cst prf sys = System.iter(fun vect iref -> let (vect',info') = elim_var (vect,!iref) in - match normalise_cstr vect' info' with - | Redundant -> () - | Contradiction -> raise (SystemContradiction info'.prf) - | Cstr(vect,info') -> xadd_cstr vect info' new_sys) sys.sys ; + match normalise_cstr vect' info' with + | Redundant -> () + | Contradiction -> raise (SystemContradiction info'.prf) + | Cstr(vect,info') -> xadd_cstr vect info' new_sys) sys.sys ; {sys = new_sys ; vars = ISet.remove vr sys.vars} @@ -337,8 +337,8 @@ let restrict_bound n sum (itv:interval) = let l,r = itv in match sign_num n with | 0 -> if in_bound itv sum - then (None,None) (* redundant *) - else failwith "SystemContradiction" + then (None,None) (* redundant *) + else failwith "SystemContradiction" | 1 -> Option.map f l , Option.map f r | _ -> Option.map f r , Option.map f l @@ -355,7 +355,7 @@ let bound_of_variable map v sys = Vect.pp vect (Num.string_of_num sum) Vect.pp rst ; Printf.fprintf stdout "current interval: %a\n" Itv.pp (!iref).bound; failwith "bound_of_variable: impossible" - | Some itv -> itv) sys (None,None) + | Some itv -> itv) sys (None,None) (** [pick_small_value bnd] picks a value being closed to zero within the interval *) @@ -365,10 +365,10 @@ let pick_small_value bnd = | None , Some i -> if (Int 0) <=/ (floor_num i) then Int 0 else floor_num i | Some i,None -> if i <=/ (Int 0) then Int 0 else ceiling_num i | Some i,Some j -> - if i <=/ Int 0 && Int 0 <=/ j - then Int 0 - else if ceiling_num i <=/ floor_num j - then ceiling_num i (* why not *) else i + if i <=/ Int 0 && Int 0 <=/ j + then Int 0 + else if ceiling_num i <=/ floor_num j + then ceiling_num i (* why not *) else i (** [solution s1 sys_l = Some(sn,\[(vn-1,sn-1);...; (v1,s1)\]\@sys_l)] @@ -385,20 +385,20 @@ let solve_sys black_v choose_eq choose_variable sys sys_l = let eqs = choose_eq sys in try - let (v,vect,cst,ln) = fst (List.find (fun ((v,_,_,_),_) -> v <> black_v) eqs) in - if debug then + let (v,vect,cst,ln) = fst (List.find (fun ((v,_,_,_),_) -> v <> black_v) eqs) in + if debug then (Printf.printf "\nE %a = %s variable %i\n" Vect.pp vect (string_of_num cst) v ; - flush stdout); - let sys' = elim_var_using_eq v vect cst ln sys in - solve_sys sys' ((v,sys)::sys_l) + flush stdout); + let sys' = elim_var_using_eq v vect cst ln sys in + solve_sys sys' ((v,sys)::sys_l) with Not_found -> let vars = choose_variable sys in - try - let (v,est) = (List.find (fun (v,_) -> v <> black_v) vars) in - if debug then (Printf.printf "\nV : %i estimate %f\n" v est ; flush stdout) ; - let sys' = project v sys in - solve_sys sys' ((v,sys)::sys_l) - with Not_found -> (* we are done *) Inl (sys,sys_l) in + try + let (v,est) = (List.find (fun (v,_) -> v <> black_v) vars) in + if debug then (Printf.printf "\nV : %i estimate %f\n" v est ; flush stdout) ; + let sys' = project v sys in + solve_sys sys' ((v,sys)::sys_l) + with Not_found -> (* we are done *) Inl (sys,sys_l) in solve_sys sys sys_l @@ -408,7 +408,7 @@ let solve black_v choose_eq choose_variable cstrs = try let sys = load_system cstrs in - if debug then Printf.printf "solve :\n %a" pp_system sys.sys ; + if debug then Printf.printf "solve :\n %a" pp_system sys.sys ; solve_sys black_v choose_eq choose_variable sys [] with SystemContradiction prf -> Inr prf @@ -430,20 +430,20 @@ struct match Vect.choose l1 with | None -> xpart rl ((Vect.null,info)::ltl) n (info.neg+info.pos+z) p | Some(vr, vl, rl1) -> - if Int.equal v vr - then - let cons_bound lst bd = - match bd with - | None -> lst - | Some bnd -> info.neg+info.pos::lst in - - let lb,rb = info.bound in - if Int.equal (sign_num vl) 1 - then xpart rl ((rl1,info)::ltl) (cons_bound n lb) z (cons_bound p rb) - else xpart rl ((rl1,info)::ltl) (cons_bound n rb) z (cons_bound p lb) - else - (* the variable is greater *) - xpart rl ((l1,info)::ltl) n (info.neg+info.pos+z) p + if Int.equal v vr + then + let cons_bound lst bd = + match bd with + | None -> lst + | Some bnd -> info.neg+info.pos::lst in + + let lb,rb = info.bound in + if Int.equal (sign_num vl) 1 + then xpart rl ((rl1,info)::ltl) (cons_bound n lb) z (cons_bound p rb) + else xpart rl ((rl1,info)::ltl) (cons_bound n rb) z (cons_bound p lb) + else + (* the variable is greater *) + xpart rl ((l1,info)::ltl) n (info.neg+info.pos+z) p in let (sys',n,z,p) = xpart l [] [] 0 [] in @@ -484,15 +484,15 @@ struct match Vect.choose l with | None -> (false,Vect.null) | Some(i,_,rl) -> if Int.equal i v - then (true,rl) - else if i < v then unroll_until v rl else (false,l) + then (true,rl) + else if i < v then unroll_until v rl else (false,l) - let rec choose_simple_equation eqs = + let rec choose_simple_equation eqs = match eqs with | [] -> None - | (vect,a,prf,ln)::eqs -> + | (vect,a,prf,ln)::eqs -> match Vect.choose vect with | Some(i,v,rst) -> if Vect.is_null rst then Some (i,vect,a,prf,ln) @@ -507,29 +507,29 @@ struct *) let is_primal_equation_var v = List.fold_left (fun nb_eq (vect,info) -> - if fst (unroll_until v vect) - then if itv_point info.bound then nb_eq + 1 else nb_eq - else nb_eq) 0 sys_l in + if fst (unroll_until v vect) + then if itv_point info.bound then nb_eq + 1 else nb_eq + else nb_eq) 0 sys_l in let rec find_var vect = match Vect.choose vect with | None -> None | Some(i,_,vect) -> - let nb_eq = is_primal_equation_var i in - if Int.equal nb_eq 2 - then Some i else find_var vect in + let nb_eq = is_primal_equation_var i in + if Int.equal nb_eq 2 + then Some i else find_var vect in let rec find_eq_var eqs = match eqs with - | [] -> None - | (vect,a,prf,ln)::l -> - match find_var vect with - | None -> find_eq_var l - | Some r -> Some (r,vect,a,prf,ln) + | [] -> None + | (vect,a,prf,ln)::l -> + match find_var vect with + | None -> find_eq_var l + | Some r -> Some (r,vect,a,prf,ln) in match choose_simple_equation eqs with - | None -> find_eq_var eqs - | Some res -> Some res + | None -> find_eq_var eqs + | Some res -> Some res @@ -539,43 +539,43 @@ struct let equalities = List.fold_left (fun l (vect,info) -> - match info.bound with - | Some a , Some b -> - if a =/ b then (* This an equation *) - (vect,a,info.prf,info.neg+info.pos)::l else l - | _ -> l + match info.bound with + | Some a , Some b -> + if a =/ b then (* This an equation *) + (vect,a,info.prf,info.neg+info.pos)::l else l + | _ -> l ) [] sys_l in let rec estimate_cost v ct sysl acc tlsys = match sysl with - | [] -> (acc,tlsys) - | (l,info)::rsys -> - let ln = info.pos + info.neg in - let (b,l) = unroll_until v l in - match b with - | true -> - if itv_point info.bound - then estimate_cost v ct rsys (acc+ln) ((l,info)::tlsys) (* this is free *) - else estimate_cost v ct rsys (acc+ln+ct) ((l,info)::tlsys) (* should be more ? *) - | false -> estimate_cost v ct rsys (acc+ln) ((l,info)::tlsys) in + | [] -> (acc,tlsys) + | (l,info)::rsys -> + let ln = info.pos + info.neg in + let (b,l) = unroll_until v l in + match b with + | true -> + if itv_point info.bound + then estimate_cost v ct rsys (acc+ln) ((l,info)::tlsys) (* this is free *) + else estimate_cost v ct rsys (acc+ln+ct) ((l,info)::tlsys) (* should be more ? *) + | false -> estimate_cost v ct rsys (acc+ln) ((l,info)::tlsys) in match choose_primal_equation equalities sys_l with - | None -> - let cost_eq eq const prf ln acc_costs = + | None -> + let cost_eq eq const prf ln acc_costs = - let rec cost_eq eqr sysl costs = + let rec cost_eq eqr sysl costs = match Vect.choose eqr with | None -> costs | Some(v,_,eqr) -> let (cst,tlsys) = estimate_cost v (ln-1) sysl 0 [] in - cost_eq eqr tlsys (((v,eq,const,prf),cst)::costs) in - cost_eq eq sys_l acc_costs in + cost_eq eqr tlsys (((v,eq,const,prf),cst)::costs) in + cost_eq eq sys_l acc_costs in - let all_costs = List.fold_left (fun all_costs (vect,const,prf,ln) -> cost_eq vect const prf ln all_costs) [] equalities in + let all_costs = List.fold_left (fun all_costs (vect,const,prf,ln) -> cost_eq vect const prf ln all_costs) [] equalities in - (* pp_list (fun o ((v,eq,_,_),cst) -> Printf.fprintf o "((%i,%a),%i)\n" v pp_vect eq cst) stdout all_costs ; *) + (* pp_list (fun o ((v,eq,_,_),cst) -> Printf.fprintf o "((%i,%a),%i)\n" v pp_vect eq cst) stdout all_costs ; *) - List.sort (fun x y -> Int.compare (snd x) (snd y) ) all_costs - | Some (v,vect, const,prf,_) -> [(v,vect,const,prf),0] + List.sort (fun x y -> Int.compare (snd x) (snd y) ) all_costs + | Some (v,vect, const,prf,_) -> [(v,vect,const,prf),0] end @@ -593,12 +593,12 @@ struct op = Eq ; cst = (Int 0)} in match solve fresh choose_equality_var choose_variable (cstr::l) with - | Inr prf -> None (* This is an unsatisfiability proof *) - | Inl (s,_) -> - try - Some (bound_of_variable IMap.empty fresh s.sys) - with x when CErrors.noncritical x -> - Printf.printf "optimise Exception : %s" (Printexc.to_string x); + | Inr prf -> None (* This is an unsatisfiability proof *) + | Inl (s,_) -> + try + Some (bound_of_variable IMap.empty fresh s.sys) + with x when CErrors.noncritical x -> + Printf.printf "optimise Exception : %s" (Printexc.to_string x); None @@ -608,16 +608,16 @@ struct | Inr prf -> Inr prf | Inl (_,l) -> - let rec rebuild_solution l map = - match l with - | [] -> map - | (v,e)::l -> - let itv = bound_of_variable map v e.sys in - let map = IMap.add v (pick_small_value itv) map in - rebuild_solution l map - in + let rec rebuild_solution l map = + match l with + | [] -> map + | (v,e)::l -> + let itv = bound_of_variable map v e.sys in + let map = IMap.add v (pick_small_value itv) map in + rebuild_solution l map + in - let map = rebuild_solution l IMap.empty in + let map = rebuild_solution l IMap.empty in let vect = IMap.fold (fun v i vect -> Vect.set v i vect) map Vect.null in if debug then Printf.printf "SOLUTION %a" Vect.pp vect ; let res = Inl vect in @@ -645,9 +645,9 @@ struct let forall_pairs f l1 l2 = List.fold_left (fun acc e1 -> List.fold_left (fun acc e2 -> - match f e1 e2 with - | None -> acc - | Some v -> v::acc) acc l2) [] l1 + match f e1 e2 with + | None -> acc + | Some v -> v::acc) acc l2) [] l1 let add_op x y = @@ -664,8 +664,8 @@ struct | Int 0 , _ | _ , Int 0 -> None | a , b -> if Int.equal ((sign_num a) * (sign_num b)) (-1) - then - Some (add (p1,abs_num a) (p2,abs_num b) , + then + Some (add (p1,abs_num a) (p2,abs_num b) , {coeffs = add (v1,abs_num a) (v2,abs_num b) ; op = add_op op1 op2 ; cst = n1 // (abs_num a) +/ n2 // (abs_num b) }) @@ -675,12 +675,12 @@ struct op = add_op op1 op2; cst = n1 // (minus_num (a// b)) +/ n2 // (Int 1)}) else if op2 == Eq - then - Some (add (p2,minus_num (b // a)) (p1,Int 1), + then + Some (add (p2,minus_num (b // a)) (p1,Int 1), {coeffs = add (v2,minus_num (b// a)) (v1 ,Int 1) ; op = add_op op1 op2; cst = n2 // (minus_num (b// a)) +/ n1 // (Int 1)}) - else None (* op2 could be Eq ... this might happen *) + else None (* op2 could be Eq ... this might happen *) let normalise_proofs l = @@ -752,10 +752,10 @@ let mk_proof hyps prf = match prfs with | Inr x -> [x] | Inl (oleft,oright) -> - match oleft , oright with - | None , None -> [] - | None , Some(prf,cstr,_) | Some(prf,cstr,_) , None -> [prf,cstr] - | Some(prf1,cstr1,_) , Some(prf2,cstr2,_) -> [prf1,cstr1;prf2,cstr2] in + match oleft , oright with + | None , None -> [] + | None , Some(prf,cstr,_) | Some(prf,cstr,_) , None -> [prf,cstr] + | Some(prf1,cstr1,_) , Some(prf2,cstr2,_) -> [prf1,cstr1;prf2,cstr2] in mk_proof prf diff --git a/plugins/micromega/mutils.ml b/plugins/micromega/mutils.ml index cca66c0719..a30e963f2a 100644 --- a/plugins/micromega/mutils.ml +++ b/plugins/micromega/mutils.ml @@ -66,7 +66,7 @@ let rec try_any l x = let all_pairs f l = let pair_with acc e l = List.fold_left (fun acc x -> (f e x) ::acc) acc l in - let rec xpairs acc l = + let rec xpairs acc l = match l with | [] -> acc | e::lx -> xpairs (pair_with acc e l) lx in @@ -77,20 +77,20 @@ let rec is_sublist f l1 l2 = | [] ,_ -> true | e::l1', [] -> false | e::l1' , e'::l2' -> - if f e e' then is_sublist f l1' l2' - else is_sublist f l1 l2' - -let extract pred l = - List.fold_left (fun (fd,sys) e -> - match fd with - | None -> - begin - match pred e with - | None -> fd, e::sys - | Some v -> Some(v,e) , sys - end - | _ -> (fd, e::sys) - ) (None,[]) l + if f e e' then is_sublist f l1' l2' + else is_sublist f l1 l2' + +let extract pred l = + List.fold_left (fun (fd,sys) e -> + match fd with + | None -> + begin + match pred e with + | None -> fd, e::sys + | Some v -> Some(v,e) , sys + end + | _ -> (fd, e::sys) + ) (None,[]) l let extract_best red lt l = let rec extractb c e rst l = @@ -338,7 +338,7 @@ struct end (** - * MODULE: Labels for atoms in propositional formulas. + * MODULE: Labels for atoms in propositional formulas. * Tags are used to identify unused atoms in CNFs, and propagate them back to * the original formula. The translation back to Coq then ignores these * superfluous items, which speeds the translation up a bit. @@ -406,26 +406,26 @@ let command exe_path args vl = finally (* Recover the result *) - (fun () -> - match status with - | Unix.WEXITED 0 -> - let inch = Unix.in_channel_of_descr stdout_read in - begin + (fun () -> + match status with + | Unix.WEXITED 0 -> + let inch = Unix.in_channel_of_descr stdout_read in + begin try Marshal.from_channel inch with any -> failwith (Printf.sprintf "command \"%s\" exited %s" exe_path (Printexc.to_string any)) end - | Unix.WEXITED i -> + | Unix.WEXITED i -> failwith (Printf.sprintf "command \"%s\" exited %i" exe_path i) - | Unix.WSIGNALED i -> + | Unix.WSIGNALED i -> failwith (Printf.sprintf "command \"%s\" killed %i" exe_path i) - | Unix.WSTOPPED i -> + | Unix.WSTOPPED i -> failwith (Printf.sprintf "command \"%s\" stopped %i" exe_path i)) (* Cleanup *) - (fun () -> - List.iter (fun x -> try Unix.close x with any -> ()) + (fun () -> + List.iter (fun x -> try Unix.close x with any -> ()) [stdin_read; stdin_write; stdout_read; stdout_write; stderr_read; stderr_write]) diff --git a/plugins/micromega/persistent_cache.ml b/plugins/micromega/persistent_cache.ml index 14e2e40846..28d8d5a020 100644 --- a/plugins/micromega/persistent_cache.ml +++ b/plugins/micromega/persistent_cache.ml @@ -49,9 +49,9 @@ struct type 'a t = { - outch : out_channel ; - mutable status : mode ; - htbl : 'a Table.t + outch : out_channel ; + mutable status : mode ; + htbl : 'a Table.t } @@ -72,49 +72,49 @@ let read_key_elem inch = | End_of_file -> None | e when CErrors.noncritical e -> raise InvalidTableFormat -(** +(** We used to only lock/unlock regions. - Is-it more robust/portable to lock/unlock a fixed region e.g. [0;1]? + Is-it more robust/portable to lock/unlock a fixed region e.g. [0;1]? In case of locking failure, the cache is not used. **) type lock_kind = Read | Write -let lock kd fd = - let pos = lseek fd 0 SEEK_CUR in - let success = - try +let lock kd fd = + let pos = lseek fd 0 SEEK_CUR in + let success = + try ignore (lseek fd 0 SEEK_SET); - let lk = match kd with - | Read -> F_RLOCK - | Write -> F_LOCK in + let lk = match kd with + | Read -> F_RLOCK + | Write -> F_LOCK in lockf fd lk 1; true with Unix.Unix_error(_,_,_) -> false in - ignore (lseek fd pos SEEK_SET) ; + ignore (lseek fd pos SEEK_SET) ; success -let unlock fd = +let unlock fd = let pos = lseek fd 0 SEEK_CUR in - try - ignore (lseek fd 0 SEEK_SET) ; + try + ignore (lseek fd 0 SEEK_SET) ; lockf fd F_ULOCK 1 - with - Unix.Unix_error(_,_,_) -> () - (* Here, this is really bad news -- + with + Unix.Unix_error(_,_,_) -> () + (* Here, this is really bad news -- there is a pending lock which could cause a deadlock. Should it be an anomaly or produce a warning ? *); - ignore (lseek fd pos SEEK_SET) + ignore (lseek fd pos SEEK_SET) (* We make the assumption that an acquired lock can always be released *) -let do_under_lock kd fd f = +let do_under_lock kd fd f = if lock kd fd then finally f (fun () -> unlock fd) else f () - + let open_in f = @@ -128,11 +128,11 @@ let open_in f = | None -> () | Some (key,elem) -> Table.add htbl key elem ; - xload () in + xload () in try (* Locking of the (whole) file while reading *) - do_under_lock Read finch xload ; - close_in_noerr inch ; + do_under_lock Read finch xload ; + close_in_noerr inch ; { outch = out_channel_of_descr (openfile f [O_WRONLY;O_APPEND;O_CREAT] 0o666) ; status = Open ; @@ -145,11 +145,11 @@ let open_in f = let flags = [O_WRONLY; O_TRUNC;O_CREAT] in let out = (openfile f flags 0o666) in let outch = out_channel_of_descr out in - do_under_lock Write out - (fun () -> - Table.iter - (fun k e -> Marshal.to_channel outch (k,e) [Marshal.No_sharing]) htbl; - flush outch) ; + do_under_lock Write out + (fun () -> + Table.iter + (fun k e -> Marshal.to_channel outch (k,e) [Marshal.No_sharing]) htbl; + flush outch) ; { outch = outch ; status = Open ; htbl = htbl @@ -165,8 +165,8 @@ let add t k e = let fd = descr_of_out_channel outch in begin Table.add tbl k e ; - do_under_lock Write fd - (fun _ -> + do_under_lock Write fd + (fun _ -> Marshal.to_channel outch (k,e) [Marshal.No_sharing] ; flush outch ) @@ -178,7 +178,7 @@ let find t k = then raise UnboundTable else let res = Table.find tbl k in - res + res let memo cache f = let tbl = lazy (try Some (open_in cache) with _ -> None) in @@ -186,13 +186,13 @@ let memo cache f = match Lazy.force tbl with | None -> f x | Some tbl -> - try - find tbl x - with - Not_found -> - let res = f x in - add tbl x res ; - res + try + find tbl x + with + Not_found -> + let res = f x in + add tbl x res ; + res let memo_cond cache cond f = let tbl = lazy (try Some (open_in cache) with _ -> None) in diff --git a/plugins/micromega/sos_lib.ml b/plugins/micromega/sos_lib.ml index 58d5d7ecf1..0a0ffc7947 100644 --- a/plugins/micromega/sos_lib.ml +++ b/plugins/micromega/sos_lib.ml @@ -525,11 +525,11 @@ let deepen_until limit f n = | 0 -> raise TooDeep | -1 -> deepen f n | _ -> - let rec d_until f n = - try(* if !debugging - then (print_string "Searching with depth limit "; - print_int n; print_newline()) ;*) f n - with Failure x -> - (*if !debugging then (Printf.printf "solver error : %s\n" x) ; *) - if n = limit then raise TooDeep else d_until f (n + 1) in - d_until f n + let rec d_until f n = + try(* if !debugging + then (print_string "Searching with depth limit "; + print_int n; print_newline()) ;*) f n + with Failure x -> + (*if !debugging then (Printf.printf "solver error : %s\n" x) ; *) + if n = limit then raise TooDeep else d_until f (n + 1) in + d_until f n diff --git a/plugins/nsatz/ideal.ml b/plugins/nsatz/ideal.ml index 7ea56b41ec..46685e6a63 100644 --- a/plugins/nsatz/ideal.ml +++ b/plugins/nsatz/ideal.ml @@ -87,13 +87,13 @@ let compare_mon (m : mon) (m' : mon) = (* degre lexicographique inverse *) match Int.compare m.(0) m'.(0) with | 0 -> (* meme degre total *) - let res=ref 0 in - let i=ref d in - while (!res=0) && (!i>=1) do - res:= - (Int.compare m.(!i) m'.(!i)); - i:=!i-1; - done; - !res + let res=ref 0 in + let i=ref d in + while (!res=0) && (!i>=1) do + res:= - (Int.compare m.(!i) m'.(!i)); + i:=!i-1; + done; + !res | x -> x) let div_mon m m' = @@ -135,13 +135,13 @@ let ppcm_mon m m' = (* returns a constant polynom ial with d variables *) let const_mon d = let m = Array.make (d+1) 0 in - let m = set_deg m in + let m = set_deg m in m let var_mon d i = let m = Array.make (d+1) 0 in m.(i) <- 1; - let m = set_deg m in + let m = set_deg m in m end @@ -174,7 +174,7 @@ type polynom = { (********************************************************************** Polynomials - list of (coefficient, monomial) decreasing order + list of (coefficient, monomial) decreasing order *) let repr p = p @@ -216,10 +216,10 @@ let string_of_pol zeroP hdP tlP coefterm monterm string_of_coef | e -> s:= (!s) @ [((getvar lvar (i-1)) ^ "^" ^ e)]); done; (match !s with - [] -> if coefone + [] -> if coefone then "1" else "" - | l -> if coefone + | l -> if coefone then (String.concat "*" l) else ( "*" ^ (String.concat "*" l))) @@ -233,26 +233,26 @@ let string_of_pol zeroP hdP tlP coefterm monterm string_of_coef | "-1" ->( "-" ^" "^(string_of_mon m true)) | c -> if (String.get c 0)='-' then ( "- "^ - (String.sub c 1 + (String.sub c 1 ((String.length c)-1))^ (string_of_mon m false)) else (match start with true -> ( c^(string_of_mon m false)) |false -> ( "+ "^ c^(string_of_mon m false))) - and stringP p start = + and stringP p start = if (zeroP p) - then (if start + then (if start then ("0") else "") else ((string_of_term (hdP p) start)^ " "^ (stringP (tlP p) false)) - in + in (stringP p true) let stringP metadata (p : poly) = - string_of_pol + string_of_pol (fun p -> match p with [] -> true | _ -> false) (fun p -> match p with (t::p) -> t |_ -> failwith "print_pol dans dansideal") (fun p -> match p with (t::p) -> p |_ -> failwith "print_pol dans dansideal") @@ -309,7 +309,7 @@ let coef_of_int x = P.of_num (Num.Int x) (* variable i *) let gen d i = - let m = var_mon d i in + let m = var_mon d i in [((coef_of_int 1),m)] let oppP p = @@ -349,7 +349,7 @@ let puisP p n= let q = multP q q in if n mod 2 = 0 then q else multP p q in puisP p n - + (*********************************************************************** Division of polynomials *) @@ -366,7 +366,7 @@ type table = { let pgcdpos a b = P.pgcdP a b let polynom0 = { pol = []; num = 0 } - + let ppol p = p.pol let lm p = snd (List.hd (ppol p)) @@ -390,7 +390,7 @@ let rec selectdiv m l = true -> q |false -> selectdiv m r -let div_pol p q a b m = +let div_pol p q a b m = plusP (emultP a p) (mult_t_pol b m q) let find_hmon table m = match table.hmon with @@ -424,15 +424,15 @@ let reduce2 table p l = match p with [] -> (coef1,[]) |t::p' -> - let (a,m)=t in + let (a,m)=t in let q = selectdiv table m l in match q with - [] -> if reduire_les_queues - then - let (c,r)=(reduce p') in + [] -> if reduire_les_queues + then + let (c,r)=(reduce p') in (c,((P.multP a c,m)::r)) - else (coef1,p) - |(b,m')::q' -> + else (coef1,p) + |(b,m')::q' -> let c=(pgcdpos a b) in let a'= (div_coef b c) in let b'=(P.oppP (div_coef a c)) in @@ -450,7 +450,7 @@ let coefpoldep_find table p q = let coefpoldep_set table p q c = Hashtbl.add table.coefpoldep (p.num,q.num) c -(* keeps trace in coefpoldep +(* keeps trace in coefpoldep divides without pseudodivisions *) let reduce2_trace table p l lcp = @@ -461,16 +461,16 @@ let reduce2_trace table p l lcp = match p with [] -> ([],[]) |t::p' -> - let (a,m)=t in + let (a,m)=t in let q = selectdiv table m l in match q with - [] -> - if reduire_les_queues - then - let (lq,r)=(reduce p') in + [] -> + if reduire_les_queues + then + let (lq,r)=(reduce p') in (lq,((a,m)::r)) - else ([],p) - |(b,m')::q' -> + else ([],p) + |(b,m')::q' -> let b'=(P.oppP (div_coef a b)) in let m''= div_mon m m' in let p1=plusP p' (mult_t_pol b' m'' q') in @@ -480,18 +480,18 @@ let reduce2_trace table p l lcp = (List.map2 (fun c0 q -> let c = - List.fold_left - (fun x (a,m,s) -> - if equal s (ppol q) - then - plusP x (mult_t_pol a m (polconst (nvar m) (coef_of_int 1))) - else x) - c0 - lq in + List.fold_left + (fun x (a,m,s) -> + if equal s (ppol q) + then + plusP x (mult_t_pol a m (polconst (nvar m) (coef_of_int 1))) + else x) + c0 + lq in c) lcp lp, - r) + r) (*********************************************************************** Completion @@ -511,12 +511,12 @@ let spol0 ps qs= let m1 = div_mon m'' m in let m2 = div_mon m'' m' in let fsp p' q' = - plusP - (mult_t_pol - (div_coef b c) - m1 p') - (mult_t_pol - (P.oppP (div_coef a c)) + plusP + (mult_t_pol + (div_coef b c) + m1 p') + (mult_t_pol + (P.oppP (div_coef a c)) m2 q') in let sp = fsp p' q' in let p0 = fsp (polconst (nvar m) (coef_of_int 1)) [] in @@ -564,7 +564,7 @@ end let ord i j = if i<j then (i,j) else (j,i) - + let cpair p q accu = if etrangers (ppol p) (ppol q) then accu else Heap.add (ord p.num q.num, ppcm_mon (lm p) (lm q)) accu @@ -582,14 +582,14 @@ let critere3 table ((i,j),m) lp lcp = (fun h -> h.num <> i && h.num <> j && (div_mon_test m (lm h)) - && (h.num < j - || not (m = ppcm_mon - (lm (table.allpol.(i))) - (lm h))) - && (h.num < i - || not (m = ppcm_mon - (lm (table.allpol.(j))) - (lm h)))) + && (h.num < j + || not (m = ppcm_mon + (lm (table.allpol.(i))) + (lm h))) + && (h.num < i + || not (m = ppcm_mon + (lm (table.allpol.(j))) + (lm h)))) lp let infobuch p q = @@ -668,18 +668,18 @@ let pbuchf table metadata cur_pb homogeneous (lp, lpc) p = infobuch lp lpc; match Heap.pop lpc with | None -> - test_dans_ideal cur_pb table metadata p lp len0 + test_dans_ideal cur_pb table metadata p lp len0 | Some (((i, j), m), lpc2) -> - if critere3 table ((i,j),m) lp lpc2 - then (sinfo "c"; pbuchf cur_pb (lp, lpc2)) - else - let (a0, p0, q0) = spol0 table.allpol.(i) table.allpol.(j) in - if homogeneous && a0 <>[] && deg_hom a0 > deg_hom cur_pb.cur_poly - then (sinfo "h"; pbuchf cur_pb (lp, lpc2)) - else + if critere3 table ((i,j),m) lp lpc2 + then (sinfo "c"; pbuchf cur_pb (lp, lpc2)) + else + let (a0, p0, q0) = spol0 table.allpol.(i) table.allpol.(j) in + if homogeneous && a0 <>[] && deg_hom a0 > deg_hom cur_pb.cur_poly + then (sinfo "h"; pbuchf cur_pb (lp, lpc2)) + else (* let sa = a.sugar in*) match reduce2 table a0 lp with - _, [] -> sinfo "0";pbuchf cur_pb (lp, lpc2) + _, [] -> sinfo "0";pbuchf cur_pb (lp, lpc2) | ca, _ :: _ -> (* info "pair reduced\n";*) let map q = @@ -692,22 +692,22 @@ let pbuchf table metadata cur_pb homogeneous (lp, lpc) p = let (lca, a0) = reduce2_trace table (emultP ca a0) lp lcp in (* info "paire re-reduced";*) let a = new_allpol table a0 in - List.iter2 (fun c q -> coefpoldep_set table a q c) lca lp; - let a0 = a in - info (fun () -> "new polynomial: "^(stringPcut metadata (ppol a0))); + List.iter2 (fun c q -> coefpoldep_set table a q c) lca lp; + let a0 = a in + info (fun () -> "new polynomial: "^(stringPcut metadata (ppol a0))); let nlp = addS a0 lp in - try test_dans_ideal cur_pb table metadata p nlp len0 - with NotInIdealUpdate cur_pb -> - let newlpc = cpairs1 a0 lp lpc2 in - pbuchf cur_pb (nlp, newlpc) + try test_dans_ideal cur_pb table metadata p nlp len0 + with NotInIdealUpdate cur_pb -> + let newlpc = cpairs1 a0 lp lpc2 in + pbuchf cur_pb (nlp, newlpc) in pbuchf cur_pb (lp, lpc) - + let is_homogeneous p = match p with | [] -> true | (a,m)::p1 -> let d = deg m in List.for_all (fun (b,m') -> deg m' =d) p1 - + (* returns c lp = [pn;...;p1] @@ -719,7 +719,7 @@ let is_homogeneous p = lc = [qn+m; ... q1] such that - c*p = sum qi*pi + c*p = sum qi*pi where pn+k = a(n+k,n+k-1)*pn+k-1 + ... + a(n+k,1)* p1 *) diff --git a/plugins/nsatz/nsatz.ml b/plugins/nsatz/nsatz.ml index 71a3132283..9ba83c0843 100644 --- a/plugins/nsatz/nsatz.ml +++ b/plugins/nsatz/nsatz.ml @@ -239,7 +239,7 @@ let rec parse_request lp = match Constr.kind lp with | App (_,[|_|]) -> [] | App (_,[|_;p;lp1|]) -> - (parse_term p)::(parse_request lp1) + (parse_term p)::(parse_request lp1) |_-> assert false let set_nvars_term nvars t = @@ -266,7 +266,7 @@ module Poly = Polynom.Make(Coef) module PIdeal = Ideal.Make(Poly) open PIdeal -(* term to sparse polynomial +(* term to sparse polynomial variables <=np are in the coefficients *) @@ -278,22 +278,22 @@ let term_pol_sparse nvars np t= match t with | Zero -> zeroP | Const r -> - if Num.eq_num r num_0 - then zeroP - else polconst d (Poly.Pint (Coef.of_num r)) + if Num.eq_num r num_0 + then zeroP + else polconst d (Poly.Pint (Coef.of_num r)) | Var v -> - let v = int_of_string v in - if v <= np - then polconst d (Poly.x v) - else gen d v + let v = int_of_string v in + if v <= np + then polconst d (Poly.x v) + else gen d v | Opp t1 -> oppP (aux t1) | Add (t1,t2) -> plusP (aux t1) (aux t2) | Sub (t1,t2) -> plusP (aux t1) (oppP (aux t2)) | Mul (t1,t2) -> multP (aux t1) (aux t2) | Pow (t1,n) -> puisP (aux t1) n - in + in (* info ("donne: "^(stringP res)^"\n");*) - res + res in let res= aux t in res @@ -321,25 +321,25 @@ let pol_sparse_to_term n2 p = let m = Ideal.Monomial.repr m in let n = (Array.length m)-1 in let (i0,e0) = - List.fold_left (fun (r,d) (a,m) -> + List.fold_left (fun (r,d) (a,m) -> let m = Ideal.Monomial.repr m in - let i0= ref 0 in - for k=1 to n do - if m.(k)>0 - then i0:=k - done; - if Int.equal !i0 0 - then (r,d) - else if !i0 > r - then (!i0, m.(!i0)) - else if Int.equal !i0 r && m.(!i0)<d - then (!i0, m.(!i0)) - else (r,d)) - (0,0) - p in + let i0= ref 0 in + for k=1 to n do + if m.(k)>0 + then i0:=k + done; + if Int.equal !i0 0 + then (r,d) + else if !i0 > r + then (!i0, m.(!i0)) + else if Int.equal !i0 r && m.(!i0)<d + then (!i0, m.(!i0)) + else (r,d)) + (0,0) + p in if Int.equal i0 0 then - let mp = polrec_to_term a in + let mp = polrec_to_term a in if List.is_empty p1 then mp else add (mp, aux p1) else let fold (p1, p2) (a, m) = @@ -352,11 +352,11 @@ let pol_sparse_to_term n2 p = (p1, (a, m) :: p2) in let (p1, p2) = List.fold_left fold ([], []) p in - let vm = - if Int.equal e0 1 - then Var (string_of_int (i0)) - else pow (Var (string_of_int (i0)),e0) in - add (mul(vm, aux (List.rev p1)), aux (List.rev p2)) + let vm = + if Int.equal e0 1 + then Var (string_of_int (i0)) + else pow (Var (string_of_int (i0)),e0) in + add (mul(vm, aux (List.rev p1)), aux (List.rev p2)) in (*info "-> pol_sparse_to_term\n";*) aux p @@ -410,34 +410,34 @@ open Ideal *) let clean_pol lp = let t = Hashpol.create 12 in - let find p = try Hashpol.find t p - with + let find p = try Hashpol.find t p + with Not_found -> Hashpol.add t p true; false in let rec aux lp = match lp with | [] -> [], [] - | p :: lp1 -> + | p :: lp1 -> let clp, lb = aux lp1 in - if equal p zeroP || find p then clp, true::lb + if equal p zeroP || find p then clp, true::lb else (p :: clp, false::lb) in aux lp -(* Expand the list of polynomials lp putting zeros where the list of - booleans lb indicates there is a missing element +(* Expand the list of polynomials lp putting zeros where the list of + booleans lb indicates there is a missing element Warning: the expansion is relative to the end of the list in reversed order lp cannot have less elements than lb *) let expand_pol lb lp = - let rec aux lb lp = + let rec aux lb lp = match lb with | [] -> lp | true :: lb1 -> zeroP :: aux lb1 lp | false :: lb1 -> match lp with [] -> assert false - | p :: lp1 -> p :: aux lb1 lp1 + | p :: lp1 -> p :: aux lb1 lp1 in List.rev (aux lb (List.rev lp)) let theoremedeszeros_termes lp = @@ -446,21 +446,21 @@ let theoremedeszeros_termes lp = | Const (Int sugarparam)::Const (Int nparam)::lp -> ((match sugarparam with |0 -> sinfo "computation without sugar"; - lexico:=false; + lexico:=false; |1 -> sinfo "computation with sugar"; - lexico:=false; + lexico:=false; |2 -> sinfo "ordre lexico computation without sugar"; - lexico:=true; + lexico:=true; |3 -> sinfo "ordre lexico computation with sugar"; - lexico:=true; + lexico:=true; |4 -> sinfo "computation without sugar, division by pairs"; - lexico:=false; + lexico:=false; |5 -> sinfo "computation with sugar, division by pairs"; - lexico:=false; + lexico:=false; |6 -> sinfo "ordre lexico computation without sugar, division by pairs"; - lexico:=true; + lexico:=true; |7 -> sinfo "ordre lexico computation with sugar, division by pairs"; - lexico:=true; + lexico:=true; | _ -> user_err Pp.(str "nsatz: bad parameter") ); let lvar = List.init nvars (fun i -> Printf.sprintf "x%i" (i + 1)) in @@ -471,32 +471,32 @@ let theoremedeszeros_termes lp = match lp with | [] -> assert false | p::lp1 -> - let lpol = List.rev lp1 in + let lpol = List.rev lp1 in (* preprocessing : we remove zero polynomials and duplicate that are not handled by in_ideal - lb is kept in order to fix the certificate in the post-processing + lb is kept in order to fix the certificate in the post-processing *) - let lpol, lb = clean_pol lpol in - let cert = theoremedeszeros metadata nvars lpol p in + let lpol, lb = clean_pol lpol in + let cert = theoremedeszeros metadata nvars lpol p in sinfo "cert ok"; - let lc = cert.last_comb::List.rev cert.gb_comb in - match remove_zeros lc with - | [] -> assert false - | (lq::lci) -> + let lc = cert.last_comb::List.rev cert.gb_comb in + match remove_zeros lc with + | [] -> assert false + | (lq::lci) -> (* post-processing : we apply the correction for the last line *) let lq = expand_pol lb lq in - (* lci commence par les nouveaux polynomes *) - let m = nvars in - let c = pol_sparse_to_term m (polconst m cert.coef) in - let r = Pow(Zero,cert.power) in - let lci = List.rev lci in + (* lci commence par les nouveaux polynomes *) + let m = nvars in + let c = pol_sparse_to_term m (polconst m cert.coef) in + let r = Pow(Zero,cert.power) in + let lci = List.rev lci in (* post-processing we apply the correction for the other lines *) - let lci = List.map (expand_pol lb) lci in - let lci = List.map (List.map (pol_sparse_to_term m)) lci in - let lq = List.map (pol_sparse_to_term m) lq in - info (fun () -> Printf.sprintf "number of parameters: %i" nparam); - sinfo "term computed"; - (c,r,lci,lq) + let lci = List.map (expand_pol lb) lci in + let lci = List.map (List.map (pol_sparse_to_term m)) lci in + let lq = List.map (pol_sparse_to_term m) lq in + info (fun () -> Printf.sprintf "number of parameters: %i" nparam); + sinfo "term computed"; + (c,r,lci,lq) ) |_ -> assert false @@ -526,13 +526,13 @@ let nsatz lpol = let res = List.fold_right (fun lt r -> - let ltterm = - List.fold_right - (fun t r -> - mkt_app lcons [mkt_app tpexpr [Lazy.force tz];t;r]) - lt - (mkt_app lnil [mkt_app tpexpr [Lazy.force tz]]) in - mkt_app lcons [tlp ();ltterm;r]) + let ltterm = + List.fold_right + (fun t r -> + mkt_app lcons [mkt_app tpexpr [Lazy.force tz];t;r]) + lt + (mkt_app lnil [mkt_app tpexpr [Lazy.force tz]]) in + mkt_app lcons [tlp ();ltterm;r]) res (mkt_app lnil [tlp ()]) in sinfo "term computed"; diff --git a/plugins/nsatz/polynom.ml b/plugins/nsatz/polynom.ml index 071c74ab9b..9a22f39f84 100644 --- a/plugins/nsatz/polynom.ml +++ b/plugins/nsatz/polynom.ml @@ -181,7 +181,7 @@ let norm p = match p with let d = (Array.length a -1) in let n = ref d in while !n>0 && (equal a.(!n) (Pint coef0)) do - n:=!n-1; + n:=!n-1; done; if !n<0 then Pint coef0 else if Int.equal !n 0 then a.(0) @@ -222,7 +222,7 @@ let coef v i p = let rec plusP p q = let res = (match (p,q) with - (Pint a,Pint b) -> Pint (C.plus a b) + (Pint a,Pint b) -> Pint (C.plus a b) |(Pint a, Prec (y,q1)) -> let q2=Array.map copyP q1 in q2.(0)<- plusP p q1.(0); Prec (y,q2) @@ -317,7 +317,7 @@ let deriv v p = else (let p2 = Array.make d (Pint coef0) in for i=0 to d-1 do - p2.(i)<- multP (Pint (coef_of_int (i+1))) p1.(i+1); + p2.(i)<- multP (Pint (coef_of_int (i+1))) p1.(i+1); done; Prec (x,p2)) | Prec(x,p1)-> Pint coef0 @@ -416,37 +416,37 @@ let rec string_of_Pcut p = for i=(Array.length t)-1 downto 1 do if (!nsP)<0 then (sp:="..."; - if not (!fin) then s:=(!s)^"+"^(!sp); - fin:=true) + if not (!fin) then s:=(!s)^"+"^(!sp); + fin:=true) else ( - let si=string_of_Pcut t.(i) in - sp:=""; - if Int.equal i 1 - then ( - if not (String.equal si "0") - then (nsP:=(!nsP)-1; - if String.equal si "1" - then sp:=v - else - (if (String.contains si '+') - then sp:="("^si^")*"^v - else sp:=si^"*"^v))) - else ( - if not (String.equal si "0") - then (nsP:=(!nsP)-1; - if String.equal si "1" - then sp:=v^"^"^(string_of_int i) - else (if (String.contains si '+') - then sp:="("^si^")*"^v^"^"^(string_of_int i) - else sp:=si^"*"^v^"^"^(string_of_int i)))); - if not (String.is_empty !sp) && not (!fin) - then (nsP:=(!nsP)-1; - if String.is_empty !s - then s:=!sp - else s:=(!s)^"+"^(!sp))); + let si=string_of_Pcut t.(i) in + sp:=""; + if Int.equal i 1 + then ( + if not (String.equal si "0") + then (nsP:=(!nsP)-1; + if String.equal si "1" + then sp:=v + else + (if (String.contains si '+') + then sp:="("^si^")*"^v + else sp:=si^"*"^v))) + else ( + if not (String.equal si "0") + then (nsP:=(!nsP)-1; + if String.equal si "1" + then sp:=v^"^"^(string_of_int i) + else (if (String.contains si '+') + then sp:="("^si^")*"^v^"^"^(string_of_int i) + else sp:=si^"*"^v^"^"^(string_of_int i)))); + if not (String.is_empty !sp) && not (!fin) + then (nsP:=(!nsP)-1; + if String.is_empty !s + then s:=!sp + else s:=(!s)^"+"^(!sp))); done; if String.is_empty !s then (nsP:=(!nsP)-1; - (s:="0")); + (s:="0")); !s let to_string p = @@ -471,10 +471,10 @@ let rec quo_rem_pol p q x = if Int.equal x 0 then (match (p,q) with |(Pint a, Pint b) -> - if C.equal (C.modulo a b) coef0 + if C.equal (C.modulo a b) coef0 then (Pint (C.div a b), cf0) else failwith "div_pol1" - |_ -> assert false) + |_ -> assert false) else let m = deg x q in let b = coefDom x q in @@ -483,14 +483,14 @@ let rec quo_rem_pol p q x = let s = ref cf0 in let continue =ref true in while (!continue) && (not (equal !r cf0)) do - let n = deg x !r in - if n<m - then continue:=false - else ( + let n = deg x !r in + if n<m + then continue:=false + else ( let a = coefDom x !r in let p1 = remP x !r in (* r = a*x^n+p1 *) let c = div_pol a b (x-1) in (* a = c*b *) - let s1 = c @@ ((monome x (n-m))) in + let s1 = c @@ ((monome x (n-m))) in s:= plusP (!s) s1; r:= p1 -- (s1 @@ q1); ) @@ -503,11 +503,11 @@ and div_pol p q x = if equal r cf0 then s else failwith ("div_pol:\n" - ^"p:"^(to_string p)^"\n" - ^"q:"^(to_string q)^"\n" - ^"r:"^(to_string r)^"\n" - ^"x:"^(string_of_int x)^"\n" - ) + ^"p:"^(to_string p)^"\n" + ^"q:"^(to_string q)^"\n" + ^"r:"^(to_string r)^"\n" + ^"x:"^(string_of_int x)^"\n" + ) let divP p q= let x = max (max_var_pol p) (max_var_pol q) in div_pol p q x @@ -534,29 +534,29 @@ let pseudo_div p q x = Pint _ -> (cf0, q,1, p) | Prec (v,q1) when not (Int.equal x v) -> (cf0, q,1, p) | Prec (v,q1) -> - ( - (* pr "pseudo_division: c^d*p = s*q + r";*) - let delta = ref 0 in - let r = ref p in - let c = coefDom x q in - let q1 = remP x q in - let d' = deg x q in - let s = ref cf0 in - while (deg x !r)>=(deg x q) do - let d = deg x !r in - let a = coefDom x !r in - let r1=remP x !r in - let u = a @@ ((monome x (d-d'))) in - r:=(c @@ r1) -- (u @@ q1); - s:=plusP (c @@ (!s)) u; - delta := (!delta) + 1; - done; - (* - pr ("deg d: "^(string_of_int (!delta))^", deg c: "^(string_of_int (deg_total c))); - pr ("deg r:"^(string_of_int (deg_total !r))); - *) - (!r,c,!delta, !s) - ) + ( + (* pr "pseudo_division: c^d*p = s*q + r";*) + let delta = ref 0 in + let r = ref p in + let c = coefDom x q in + let q1 = remP x q in + let d' = deg x q in + let s = ref cf0 in + while (deg x !r)>=(deg x q) do + let d = deg x !r in + let a = coefDom x !r in + let r1=remP x !r in + let u = a @@ ((monome x (d-d'))) in + r:=(c @@ r1) -- (u @@ q1); + s:=plusP (c @@ (!s)) u; + delta := (!delta) + 1; + done; + (* + pr ("deg d: "^(string_of_int (!delta))^", deg c: "^(string_of_int (deg_total c))); + pr ("deg r:"^(string_of_int (deg_total !r))); + *) + (!r,c,!delta, !s) + ) (* gcd with subresultants *) @@ -581,28 +581,28 @@ and pgcd_coef_pol c p x = and pgcd_pol_rec p q x = match (p,q) with - (Pint a,Pint b) -> Pint (C.pgcd (C.abs a) (C.abs b)) + (Pint a,Pint b) -> Pint (C.pgcd (C.abs a) (C.abs b)) |_ -> - if equal p cf0 - then q - else if equal q cf0 - then p - else if Int.equal (deg x q) 0 - then pgcd_coef_pol q p x - else if Int.equal (deg x p) 0 - then pgcd_coef_pol p q x - else ( - let a = content_pol p x in - let b = content_pol q x in - let c = pgcd_pol_rec a b (x-1) in - pr (string_of_int x); - let p1 = div_pol p c x in - let q1 = div_pol q c x in - let r = gcd_sub_res p1 q1 x in - let cr = content_pol r x in - let res = c @@ (div_pol r cr x) in - res - ) + if equal p cf0 + then q + else if equal q cf0 + then p + else if Int.equal (deg x q) 0 + then pgcd_coef_pol q p x + else if Int.equal (deg x p) 0 + then pgcd_coef_pol p q x + else ( + let a = content_pol p x in + let b = content_pol q x in + let c = pgcd_pol_rec a b (x-1) in + pr (string_of_int x); + let p1 = div_pol p c x in + let q1 = div_pol q c x in + let r = gcd_sub_res p1 q1 x in + let cr = content_pol r x in + let res = c @@ (div_pol r cr x) in + res + ) (* Sub-résultants: @@ -630,10 +630,10 @@ and gcd_sub_res p q x = if d<d' then gcd_sub_res q p x else - let delta = d-d' in - let c' = coefDom x q in - let r = snd (quo_rem_pol (((oppP c')^^(delta+1))@@p) (oppP q) x) in - gcd_sub_res_rec q r (c'^^delta) c' d' x + let delta = d-d' in + let c' = coefDom x q in + let r = snd (quo_rem_pol (((oppP c')^^(delta+1))@@p) (oppP q) x) in + gcd_sub_res_rec q r (c'^^delta) c' d' x and gcd_sub_res_rec p q s c d x = if equal q cf0 diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 00ea9b6a66..dcd85401d6 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -373,11 +373,11 @@ let mk_integer n = let rec loop n = if n =? one then Lazy.force coq_xH else mkApp((if n mod two =? zero then Lazy.force coq_xO else Lazy.force coq_xI), - [| loop (n/two) |]) + [| loop (n/two) |]) in if n =? zero then Lazy.force coq_Z0 else mkApp ((if n >? zero then Lazy.force coq_Zpos else Lazy.force coq_Zneg), - [| loop (abs n) |]) + [| loop (abs n) |]) type omega_constant = | Zplus | Zmult | Zminus | Zsucc | Zopp | Zpred @@ -494,11 +494,11 @@ let context sigma operation path (t : constr) = | (p, Cast (c,k,t)) -> mkCast (loop i p c,k,t) | ([], _) -> operation i t | ((P_APP n :: p), App (f,v)) -> - let v' = Array.copy v in - v'.(pred n) <- loop i p v'.(pred n); mkApp (f, v') + let v' = Array.copy v in + v'.(pred n) <- loop i p v'.(pred n); mkApp (f, v') | (p, Fix ((_,n as ln),(tys,lna,v))) -> - let l = Array.length v in - let v' = Array.copy v in + let l = Array.length v in + let v' = Array.copy v in v'.(n)<- loop (Util.(+) i l) p v.(n); (mkFix (ln,(tys,lna,v'))) | ((P_TYPE :: p), Prod (n,t,c)) -> (mkProd (n,loop i p t,c)) @@ -507,7 +507,7 @@ let context sigma operation path (t : constr) = | ((P_TYPE :: p), LetIn (n,b,t,c)) -> (mkLetIn (n,b,loop i p t,c)) | (p, _) -> - failwith ("abstract_path " ^ string_of_int(List.length p)) + failwith ("abstract_path " ^ string_of_int(List.length p)) in loop 1 path t @@ -521,7 +521,7 @@ let occurrence sigma path (t : constr) = | ((P_TYPE :: p), Lambda (n,term,c)) -> loop p term | ((P_TYPE :: p), LetIn (n,b,term,c)) -> loop p term | (p, _) -> - failwith ("occurrence " ^ string_of_int(List.length p)) + failwith ("occurrence " ^ string_of_int(List.length p)) in loop path t @@ -575,9 +575,9 @@ let compile name kind = let rec loop accu = function | Oplus(Otimes(Oatom v,Oz n),r) -> loop ({v=intern_id v; c=n} :: accu) r | Oz n -> - let id = new_id () in - tag_hypothesis name id; - {kind = kind; body = List.rev accu; constant = n; id = id} + let id = new_id () in + tag_hypothesis name id; + {kind = kind; body = List.rev accu; constant = n; id = id} | _ -> anomaly (Pp.str "compile_equation.") in loop [] @@ -608,9 +608,9 @@ let clever_rewrite_base_poly typ p result theorem = mkArrow typ Sorts.Relevant mkProp, mkLambda (make_annot (Name (Id.of_string "H")) Sorts.Relevant, - applist (mkRel 1,[result]), - mkApp (Lazy.force coq_eq_ind_r, - [| typ; result; mkRel 2; mkRel 1; occ; theorem |]))), + applist (mkRel 1,[result]), + mkApp (Lazy.force coq_eq_ind_r, + [| typ; result; mkRel 2; mkRel 1; occ; theorem |]))), [abstracted]) in let argt = mkApp (abstracted, [|result|]) in @@ -692,51 +692,51 @@ let simpl_coeffs path_init path_k = let rec shuffle p (t1,t2) = match t1,t2 with | Oplus(l1,r1), Oplus(l2,r2) -> - if weight l1 > weight l2 then + if weight l1 > weight l2 then let (tac,t') = shuffle (P_APP 2 :: p) (r1,t2) in (clever_rewrite p [[P_APP 1;P_APP 1]; - [P_APP 1; P_APP 2];[P_APP 2]] + [P_APP 1; P_APP 2];[P_APP 2]] (Lazy.force coq_fast_Zplus_assoc_reverse) :: tac, Oplus(l1,t')) - else - let (tac,t') = shuffle (P_APP 2 :: p) (t1,r2) in + else + let (tac,t') = shuffle (P_APP 2 :: p) (t1,r2) in (clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 1];[P_APP 2;P_APP 2]] (Lazy.force coq_fast_Zplus_permute) :: tac, Oplus(l2,t')) | Oplus(l1,r1), t2 -> - if weight l1 > weight t2 then + if weight l1 > weight t2 then let (tac,t') = shuffle (P_APP 2 :: p) (r1,t2) in clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]] (Lazy.force coq_fast_Zplus_assoc_reverse) :: tac, Oplus(l1, t') - else + else [clever_rewrite p [[P_APP 1];[P_APP 2]] - (Lazy.force coq_fast_Zplus_comm)], + (Lazy.force coq_fast_Zplus_comm)], Oplus(t2,t1) | t1,Oplus(l2,r2) -> - if weight l2 > weight t1 then + if weight l2 > weight t1 then let (tac,t') = shuffle (P_APP 2 :: p) (t1,r2) in clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 1];[P_APP 2;P_APP 2]] (Lazy.force coq_fast_Zplus_permute) :: tac, Oplus(l2,t') - else [],Oplus(t1,t2) + else [],Oplus(t1,t2) | Oz t1,Oz t2 -> - [focused_simpl p], Oz(Bigint.add t1 t2) + [focused_simpl p], Oz(Bigint.add t1 t2) | t1,t2 -> - if weight t1 < weight t2 then + if weight t1 < weight t2 then [clever_rewrite p [[P_APP 1];[P_APP 2]] - (Lazy.force coq_fast_Zplus_comm)], - Oplus(t2,t1) - else [],Oplus(t1,t2) + (Lazy.force coq_fast_Zplus_comm)], + Oplus(t2,t1) + else [],Oplus(t1,t2) let shuffle_mult p_init k1 e1 k2 e2 = let rec loop p = function | (({c=c1;v=v1}::l1) as l1'),(({c=c2;v=v2}::l2) as l2') -> - if Int.equal v1 v2 then + if Int.equal v1 v2 then let tac = clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1; P_APP 1]; [P_APP 1; P_APP 1; P_APP 1; P_APP 2]; @@ -746,15 +746,15 @@ let shuffle_mult p_init k1 e1 k2 e2 = [P_APP 1; P_APP 2]; [P_APP 2; P_APP 2]] (Lazy.force coq_fast_OMEGA10) - in + in if Bigint.add (Bigint.mult k1 c1) (Bigint.mult k2 c2) =? zero then let tac' = - clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] + clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] (Lazy.force coq_fast_Zred_factor5) in - tac :: focused_simpl (P_APP 2::P_APP 1:: p) :: tac' :: - loop p (l1,l2) + tac :: focused_simpl (P_APP 2::P_APP 1:: p) :: tac' :: + loop p (l1,l2) else tac :: loop (P_APP 2 :: p) (l1,l2) - else if v1 > v2 then + else if v1 > v2 then clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1; P_APP 1]; [P_APP 1; P_APP 1; P_APP 1; P_APP 2]; [P_APP 1; P_APP 1; P_APP 2]; @@ -762,7 +762,7 @@ let shuffle_mult p_init k1 e1 k2 e2 = [P_APP 1; P_APP 2]] (Lazy.force coq_fast_OMEGA11) :: loop (P_APP 2 :: p) (l1,l2') - else + else clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1]; [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; [P_APP 1]; @@ -793,7 +793,7 @@ let shuffle_mult p_init k1 e1 k2 e2 = let shuffle_mult_right p_init e1 k2 e2 = let rec loop p = function | (({c=c1;v=v1}::l1) as l1'),(({c=c2;v=v2}::l2) as l2') -> - if Int.equal v1 v2 then + if Int.equal v1 v2 then let tac = clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1]; @@ -803,20 +803,20 @@ let shuffle_mult_right p_init e1 k2 e2 = [P_APP 2; P_APP 1; P_APP 2]; [P_APP 2; P_APP 2]] (Lazy.force coq_fast_OMEGA15) - in + in if Bigint.add c1 (Bigint.mult k2 c2) =? zero then let tac' = clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] (Lazy.force coq_fast_Zred_factor5) - in + in tac :: focused_simpl (P_APP 2::P_APP 1:: p) :: tac' :: loop p (l1,l2) else tac :: loop (P_APP 2 :: p) (l1,l2) - else if v1 > v2 then + else if v1 > v2 then clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]] (Lazy.force coq_fast_Zplus_assoc_reverse) :: loop (P_APP 2 :: p) (l1,l2') - else + else clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1]; [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; [P_APP 1]; @@ -844,13 +844,13 @@ let rec shuffle_cancel p = function | [] -> [focused_simpl p] | ({c=c1}::l1) -> let tac = - clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1];[P_APP 1; P_APP 2]; + clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1];[P_APP 1; P_APP 2]; [P_APP 2; P_APP 2]; [P_APP 1; P_APP 1; P_APP 2; P_APP 1]] (if c1 >? zero then - (Lazy.force coq_fast_OMEGA13) - else - (Lazy.force coq_fast_OMEGA14)) + (Lazy.force coq_fast_OMEGA13) + else + (Lazy.force coq_fast_OMEGA14)) in tac :: shuffle_cancel p l1 @@ -875,7 +875,7 @@ let scalar_norm p_init = let rec loop p = function | [] -> [simpl_coeffs p_init p] | (_::l) -> - clever_rewrite p + clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1];[P_APP 1; P_APP 1; P_APP 2]; [P_APP 1; P_APP 2];[P_APP 2]] (Lazy.force coq_fast_OMEGA16) :: loop (P_APP 2 :: p) l @@ -886,9 +886,9 @@ let norm_add p_init = let rec loop p = function | [] -> [simpl_coeffs p_init p] | _:: l -> - clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]] + clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]] (Lazy.force coq_fast_Zplus_assoc_reverse) :: - loop (P_APP 2 :: p) l + loop (P_APP 2 :: p) l in loop p_init @@ -896,7 +896,7 @@ let scalar_norm_add p_init = let rec loop p = function | [] -> [simpl_coeffs p_init p] | _ :: l -> - clever_rewrite p + clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1; P_APP 1]; [P_APP 1; P_APP 1; P_APP 1; P_APP 2]; [P_APP 1; P_APP 1; P_APP 2]; [P_APP 2]; [P_APP 1; P_APP 2]] @@ -936,24 +936,24 @@ let rec transform sigma p t = in try match destructurate_term sigma t with | Kapp(Zplus,[t1;t2]) -> - let tac1,t1' = transform sigma (P_APP 1 :: p) t1 - and tac2,t2' = transform sigma (P_APP 2 :: p) t2 in - let tac,t' = shuffle p (t1',t2') in - tac1 @ tac2 @ tac, t' + let tac1,t1' = transform sigma (P_APP 1 :: p) t1 + and tac2,t2' = transform sigma (P_APP 2 :: p) t2 in + let tac,t' = shuffle p (t1',t2') in + tac1 @ tac2 @ tac, t' | Kapp(Zminus,[t1;t2]) -> - let tac,t = - transform sigma p - (mkApp (Lazy.force coq_Zplus, - [| t1; (mkApp (Lazy.force coq_Zopp, [| t2 |])) |])) in - unfold sp_Zminus :: tac,t + let tac,t = + transform sigma p + (mkApp (Lazy.force coq_Zplus, + [| t1; (mkApp (Lazy.force coq_Zopp, [| t2 |])) |])) in + unfold sp_Zminus :: tac,t | Kapp(Zsucc,[t1]) -> - let tac,t = transform sigma p (mkApp (Lazy.force coq_Zplus, - [| t1; mk_integer one |])) in - unfold sp_Zsucc :: tac,t + let tac,t = transform sigma p (mkApp (Lazy.force coq_Zplus, + [| t1; mk_integer one |])) in + unfold sp_Zsucc :: tac,t | Kapp(Zpred,[t1]) -> - let tac,t = transform sigma p (mkApp (Lazy.force coq_Zplus, - [| t1; mk_integer negone |])) in - unfold sp_Zpred :: tac,t + let tac,t = transform sigma p (mkApp (Lazy.force coq_Zplus, + [| t1; mk_integer negone |])) in + unfold sp_Zpred :: tac,t | Kapp(Zmult,[t1;t2]) -> let tac1,t1' = transform sigma (P_APP 1 :: p) t1 and tac2,t2' = transform sigma (P_APP 2 :: p) t2 in @@ -961,8 +961,8 @@ let rec transform sigma p t = | (_,Oz n) -> let tac,t' = scalar p n t1' in tac1 @ tac2 @ tac,t' | (Oz n,_) -> let sym = - clever_rewrite p [[P_APP 1];[P_APP 2]] - (Lazy.force coq_fast_Zmult_comm) in + clever_rewrite p [[P_APP 1];[P_APP 2]] + (Lazy.force coq_fast_Zmult_comm) in let tac,t' = scalar p n t2' in tac1 @ tac2 @ (sym :: tac),t' | _ -> default false t end @@ -981,26 +981,26 @@ let rec transform sigma p t = let shrink_pair p f1 f2 = match f1,f2 with | Oatom v,Oatom _ -> - let r = Otimes(Oatom v,Oz two) in - clever_rewrite p [[P_APP 1]] (Lazy.force coq_fast_Zred_factor1), r + let r = Otimes(Oatom v,Oz two) in + clever_rewrite p [[P_APP 1]] (Lazy.force coq_fast_Zred_factor1), r | Oatom v, Otimes(_,c2) -> - let r = Otimes(Oatom v,Oplus(c2,Oz one)) in - clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 2]] - (Lazy.force coq_fast_Zred_factor2), r + let r = Otimes(Oatom v,Oplus(c2,Oz one)) in + clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 2]] + (Lazy.force coq_fast_Zred_factor2), r | Otimes (v1,c1),Oatom v -> - let r = Otimes(Oatom v,Oplus(c1,Oz one)) in - clever_rewrite p [[P_APP 2];[P_APP 1;P_APP 2]] + let r = Otimes(Oatom v,Oplus(c1,Oz one)) in + clever_rewrite p [[P_APP 2];[P_APP 1;P_APP 2]] (Lazy.force coq_fast_Zred_factor3), r | Otimes (Oatom v,c1),Otimes (v2,c2) -> - let r = Otimes(Oatom v,Oplus(c1,c2)) in - clever_rewrite p + let r = Otimes(Oatom v,Oplus(c1,c2)) in + clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2];[P_APP 2;P_APP 2]] (Lazy.force coq_fast_Zred_factor4),r | t1,t2 -> - begin - oprint t1; print_newline (); oprint t2; print_newline (); + begin + oprint t1; print_newline (); oprint t2; print_newline (); flush stdout; CErrors.user_err Pp.(str "shrink.1") - end + end let reduce_factor p = function | Oatom v -> @@ -1010,8 +1010,8 @@ let reduce_factor p = function | Otimes(Oatom v,c) -> let rec compute = function | Oz n -> n - | Oplus(t1,t2) -> Bigint.add (compute t1) (compute t2) - | _ -> CErrors.user_err Pp.(str "condense.1") + | Oplus(t1,t2) -> Bigint.add (compute t1) (compute t2) + | _ -> CErrors.user_err Pp.(str "condense.1") in [focused_simpl (P_APP 2 :: p)], Otimes(Oatom v,Oz(compute c)) | t -> oprint t; CErrors.user_err Pp.(str "reduce_factor.1") @@ -1019,29 +1019,29 @@ let reduce_factor p = function let rec condense p = function | Oplus(f1,(Oplus(f2,r) as t)) -> if Int.equal (weight f1) (weight f2) then begin - let shrink_tac,t = shrink_pair (P_APP 1 :: p) f1 f2 in - let assoc_tac = + let shrink_tac,t = shrink_pair (P_APP 1 :: p) f1 f2 in + let assoc_tac = clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 1];[P_APP 2;P_APP 2]] (Lazy.force coq_fast_Zplus_assoc) in - let tac_list,t' = condense p (Oplus(t,r)) in - (assoc_tac :: shrink_tac :: tac_list), t' + let tac_list,t' = condense p (Oplus(t,r)) in + (assoc_tac :: shrink_tac :: tac_list), t' end else begin - let tac,f = reduce_factor (P_APP 1 :: p) f1 in - let tac',t' = condense (P_APP 2 :: p) t in - (tac @ tac'), Oplus(f,t') + let tac,f = reduce_factor (P_APP 1 :: p) f1 in + let tac',t' = condense (P_APP 2 :: p) t in + (tac @ tac'), Oplus(f,t') end | Oplus(f1,Oz n) -> let tac,f1' = reduce_factor (P_APP 1 :: p) f1 in tac,Oplus(f1',Oz n) | Oplus(f1,f2) -> if Int.equal (weight f1) (weight f2) then begin - let tac_shrink,t = shrink_pair p f1 f2 in - let tac,t' = condense p t in - tac_shrink :: tac,t' + let tac_shrink,t = shrink_pair p f1 f2 in + let tac,t' = condense p t in + tac_shrink :: tac,t' end else begin - let tac,f = reduce_factor (P_APP 1 :: p) f1 in - let tac',t' = condense (P_APP 2 :: p) f2 in - (tac @ tac'),Oplus(f,t') + let tac,f = reduce_factor (P_APP 1 :: p) f1 in + let tac',t' = condense (P_APP 2 :: p) f2 in + (tac @ tac'),Oplus(f,t') end | Oz _ as t -> [],t | t -> @@ -1053,8 +1053,8 @@ let rec condense p = function let rec clear_zero p = function | Oplus(Otimes(Oatom v,Oz n),r) when n =? zero -> let tac = - clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] - (Lazy.force coq_fast_Zred_factor5) in + clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] + (Lazy.force coq_fast_Zred_factor5) in let tac',t = clear_zero p r in tac :: tac',t | Oplus(f,r) -> @@ -1069,304 +1069,304 @@ let replay_history tactic_normalisation = let rec loop t : unit Proofview.tactic = match t with | HYP e :: l -> - begin - try - tclTHEN - (Id.List.assoc (hyp_of_tag e.id) tactic_normalisation) - (loop l) - with Not_found -> loop l end + begin + try + tclTHEN + (Id.List.assoc (hyp_of_tag e.id) tactic_normalisation) + (loop l) + with Not_found -> loop l end | NEGATE_CONTRADICT (e2,e1,b) :: l -> - let eq1 = decompile e1 - and eq2 = decompile e2 in - let id1 = hyp_of_tag e1.id - and id2 = hyp_of_tag e2.id in - let k = if b then negone else one in - let p_initial = [P_APP 1;P_TYPE] in - let tac= shuffle_mult_right p_initial e1.body k e2.body in - tclTHENLIST [ - generalize_tac - [mkApp (Lazy.force coq_OMEGA17, [| - val_of eq1; - val_of eq2; - mk_integer k; - mkVar id1; mkVar id2 |])]; - mk_then tac; - (intros_using [aux]); - resolve_id aux; + let eq1 = decompile e1 + and eq2 = decompile e2 in + let id1 = hyp_of_tag e1.id + and id2 = hyp_of_tag e2.id in + let k = if b then negone else one in + let p_initial = [P_APP 1;P_TYPE] in + let tac= shuffle_mult_right p_initial e1.body k e2.body in + tclTHENLIST [ + generalize_tac + [mkApp (Lazy.force coq_OMEGA17, [| + val_of eq1; + val_of eq2; + mk_integer k; + mkVar id1; mkVar id2 |])]; + mk_then tac; + (intros_using [aux]); + resolve_id aux; reflexivity ] | CONTRADICTION (e1,e2) :: l -> - let eq1 = decompile e1 - and eq2 = decompile e2 in - let p_initial = [P_APP 2;P_TYPE] in - let tac = shuffle_cancel p_initial e1.body in - let solve_le = + let eq1 = decompile e1 + and eq2 = decompile e2 in + let p_initial = [P_APP 2;P_TYPE] in + let tac = shuffle_cancel p_initial e1.body in + let solve_le = let not_sup_sup = mkApp (Lazy.force coq_eq, - [| - Lazy.force coq_comparison; - Lazy.force coq_Gt; - Lazy.force coq_Gt |]) - in + [| + Lazy.force coq_comparison; + Lazy.force coq_Gt; + Lazy.force coq_Gt |]) + in tclTHENS - (tclTHENLIST [ - unfold sp_Zle; - simpl_in_concl; - intro; - (absurd not_sup_sup) ]) - [ assumption ; reflexivity ] - in - let theorem = + (tclTHENLIST [ + unfold sp_Zle; + simpl_in_concl; + intro; + (absurd not_sup_sup) ]) + [ assumption ; reflexivity ] + in + let theorem = mkApp (Lazy.force coq_OMEGA2, [| - val_of eq1; val_of eq2; - mkVar (hyp_of_tag e1.id); - mkVar (hyp_of_tag e2.id) |]) - in - Proofview.tclTHEN (tclTHEN (generalize_tac [theorem]) (mk_then tac)) solve_le + val_of eq1; val_of eq2; + mkVar (hyp_of_tag e1.id); + mkVar (hyp_of_tag e2.id) |]) + in + Proofview.tclTHEN (tclTHEN (generalize_tac [theorem]) (mk_then tac)) solve_le | DIVIDE_AND_APPROX (e1,e2,k,d) :: l -> - let id = hyp_of_tag e1.id in - let eq1 = val_of(decompile e1) - and eq2 = val_of(decompile e2) in - let kk = mk_integer k - and dd = mk_integer d in - let rhs = mk_plus (mk_times eq2 kk) dd in - let state_eg = mk_eq eq1 rhs in - let tac = scalar_norm_add [P_APP 3] e2.body in - tclTHENS - (cut state_eg) - [ tclTHENS - (tclTHENLIST [ - (intros_using [aux]); - (generalize_tac - [mkApp (Lazy.force coq_OMEGA1, - [| eq1; rhs; mkVar aux; mkVar id |])]); - (clear [aux;id]); - (intros_using [id]); - (cut (mk_gt kk dd)) ]) - [ tclTHENS - (cut (mk_gt kk izero)) - [ tclTHENLIST [ - (intros_using [aux1; aux2]); - (generalize_tac - [mkApp (Lazy.force coq_Zmult_le_approx, - [| kk;eq2;dd;mkVar aux1;mkVar aux2; mkVar id |])]); - (clear [aux1;aux2;id]); - (intros_using [id]); - (loop l) ]; - tclTHENLIST [ - (unfold sp_Zgt); - simpl_in_concl; - reflexivity ] ]; - tclTHENLIST [ unfold sp_Zgt; simpl_in_concl; reflexivity ] + let id = hyp_of_tag e1.id in + let eq1 = val_of(decompile e1) + and eq2 = val_of(decompile e2) in + let kk = mk_integer k + and dd = mk_integer d in + let rhs = mk_plus (mk_times eq2 kk) dd in + let state_eg = mk_eq eq1 rhs in + let tac = scalar_norm_add [P_APP 3] e2.body in + tclTHENS + (cut state_eg) + [ tclTHENS + (tclTHENLIST [ + (intros_using [aux]); + (generalize_tac + [mkApp (Lazy.force coq_OMEGA1, + [| eq1; rhs; mkVar aux; mkVar id |])]); + (clear [aux;id]); + (intros_using [id]); + (cut (mk_gt kk dd)) ]) + [ tclTHENS + (cut (mk_gt kk izero)) + [ tclTHENLIST [ + (intros_using [aux1; aux2]); + (generalize_tac + [mkApp (Lazy.force coq_Zmult_le_approx, + [| kk;eq2;dd;mkVar aux1;mkVar aux2; mkVar id |])]); + (clear [aux1;aux2;id]); + (intros_using [id]); + (loop l) ]; + tclTHENLIST [ + (unfold sp_Zgt); + simpl_in_concl; + reflexivity ] ]; + tclTHENLIST [ unfold sp_Zgt; simpl_in_concl; reflexivity ] ]; - tclTHEN (mk_then tac) reflexivity ] + tclTHEN (mk_then tac) reflexivity ] | NOT_EXACT_DIVIDE (e1,k) :: l -> - let c = floor_div e1.constant k in - let d = Bigint.sub e1.constant (Bigint.mult c k) in - let e2 = {id=e1.id; kind=EQUA;constant = c; + let c = floor_div e1.constant k in + let d = Bigint.sub e1.constant (Bigint.mult c k) in + let e2 = {id=e1.id; kind=EQUA;constant = c; body = map_eq_linear (fun c -> c / k) e1.body } in - let eq2 = val_of(decompile e2) in - let kk = mk_integer k - and dd = mk_integer d in - let tac = scalar_norm_add [P_APP 2] e2.body in - tclTHENS - (cut (mk_gt dd izero)) - [ tclTHENS (cut (mk_gt kk dd)) - [tclTHENLIST [ - (intros_using [aux2;aux1]); - (generalize_tac - [mkApp (Lazy.force coq_OMEGA4, + let eq2 = val_of(decompile e2) in + let kk = mk_integer k + and dd = mk_integer d in + let tac = scalar_norm_add [P_APP 2] e2.body in + tclTHENS + (cut (mk_gt dd izero)) + [ tclTHENS (cut (mk_gt kk dd)) + [tclTHENLIST [ + (intros_using [aux2;aux1]); + (generalize_tac + [mkApp (Lazy.force coq_OMEGA4, [| dd;kk;eq2;mkVar aux1; mkVar aux2 |])]); - (clear [aux1;aux2]); - unfold sp_not; - (intros_using [aux]); - resolve_id aux; - mk_then tac; - assumption ] ; - tclTHENLIST [ - unfold sp_Zgt; - simpl_in_concl; - reflexivity ] ]; + (clear [aux1;aux2]); + unfold sp_not; + (intros_using [aux]); + resolve_id aux; + mk_then tac; + assumption ] ; + tclTHENLIST [ + unfold sp_Zgt; + simpl_in_concl; + reflexivity ] ]; tclTHENLIST [ - unfold sp_Zgt; + unfold sp_Zgt; simpl_in_concl; - reflexivity ] ] + reflexivity ] ] | EXACT_DIVIDE (e1,k) :: l -> - let id = hyp_of_tag e1.id in - let e2 = map_eq_afine (fun c -> c / k) e1 in - let eq1 = val_of(decompile e1) - and eq2 = val_of(decompile e2) in - let kk = mk_integer k in - let state_eq = mk_eq eq1 (mk_times eq2 kk) in - if e1.kind == DISE then + let id = hyp_of_tag e1.id in + let e2 = map_eq_afine (fun c -> c / k) e1 in + let eq1 = val_of(decompile e1) + and eq2 = val_of(decompile e2) in + let kk = mk_integer k in + let state_eq = mk_eq eq1 (mk_times eq2 kk) in + if e1.kind == DISE then let tac = scalar_norm [P_APP 3] e2.body in tclTHENS - (cut state_eq) - [tclTHENLIST [ - (intros_using [aux1]); - (generalize_tac - [mkApp (Lazy.force coq_OMEGA18, + (cut state_eq) + [tclTHENLIST [ + (intros_using [aux1]); + (generalize_tac + [mkApp (Lazy.force coq_OMEGA18, [| eq1;eq2;kk;mkVar aux1; mkVar id |])]); - (clear [aux1;id]); - (intros_using [id]); - (loop l) ]; - tclTHEN (mk_then tac) reflexivity ] - else + (clear [aux1;id]); + (intros_using [id]); + (loop l) ]; + tclTHEN (mk_then tac) reflexivity ] + else let tac = scalar_norm [P_APP 3] e2.body in tclTHENS (cut state_eq) - [ - tclTHENS - (cut (mk_gt kk izero)) - [tclTHENLIST [ - (intros_using [aux2;aux1]); - (generalize_tac - [mkApp (Lazy.force coq_OMEGA3, - [| eq1; eq2; kk; mkVar aux2; mkVar aux1;mkVar id|])]); - (clear [aux1;aux2;id]); - (intros_using [id]); - (loop l) ]; - tclTHENLIST [ - unfold sp_Zgt; + [ + tclTHENS + (cut (mk_gt kk izero)) + [tclTHENLIST [ + (intros_using [aux2;aux1]); + (generalize_tac + [mkApp (Lazy.force coq_OMEGA3, + [| eq1; eq2; kk; mkVar aux2; mkVar aux1;mkVar id|])]); + (clear [aux1;aux2;id]); + (intros_using [id]); + (loop l) ]; + tclTHENLIST [ + unfold sp_Zgt; simpl_in_concl; - reflexivity ] ]; - tclTHEN (mk_then tac) reflexivity ] + reflexivity ] ]; + tclTHEN (mk_then tac) reflexivity ] | (MERGE_EQ(e3,e1,e2)) :: l -> - let id = new_identifier () in - tag_hypothesis id e3; - let id1 = hyp_of_tag e1.id - and id2 = hyp_of_tag e2 in - let eq1 = val_of(decompile e1) - and eq2 = val_of (decompile (negate_eq e1)) in - let tac = - clever_rewrite [P_APP 3] [[P_APP 1]] - (Lazy.force coq_fast_Zopp_eq_mult_neg_1) :: + let id = new_identifier () in + tag_hypothesis id e3; + let id1 = hyp_of_tag e1.id + and id2 = hyp_of_tag e2 in + let eq1 = val_of(decompile e1) + and eq2 = val_of (decompile (negate_eq e1)) in + let tac = + clever_rewrite [P_APP 3] [[P_APP 1]] + (Lazy.force coq_fast_Zopp_eq_mult_neg_1) :: scalar_norm [P_APP 3] e1.body - in - tclTHENS - (cut (mk_eq eq1 (mk_inv eq2))) - [tclTHENLIST [ - (intros_using [aux]); - (generalize_tac [mkApp (Lazy.force coq_OMEGA8, - [| eq1;eq2;mkVar id1;mkVar id2; mkVar aux|])]); - (clear [id1;id2;aux]); - (intros_using [id]); - (loop l) ]; + in + tclTHENS + (cut (mk_eq eq1 (mk_inv eq2))) + [tclTHENLIST [ + (intros_using [aux]); + (generalize_tac [mkApp (Lazy.force coq_OMEGA8, + [| eq1;eq2;mkVar id1;mkVar id2; mkVar aux|])]); + (clear [id1;id2;aux]); + (intros_using [id]); + (loop l) ]; tclTHEN (mk_then tac) reflexivity] | STATE {st_new_eq=e;st_def=def;st_orig=orig;st_coef=m;st_var=v} :: l -> - let id = new_identifier () - and id2 = hyp_of_tag orig.id in - tag_hypothesis id e.id; - let eq1 = val_of(decompile def) - and eq2 = val_of(decompile orig) in - let vid = unintern_id v in - let theorem = + let id = new_identifier () + and id2 = hyp_of_tag orig.id in + tag_hypothesis id e.id; + let eq1 = val_of(decompile def) + and eq2 = val_of(decompile orig) in + let vid = unintern_id v in + let theorem = mkApp (Lazy.force coq_ex, [| - Lazy.force coq_Z; - mkLambda + Lazy.force coq_Z; + mkLambda (make_annot (Name vid) Sorts.Relevant, - Lazy.force coq_Z, - mk_eq (mkRel 1) eq1) |]) - in - let mm = mk_integer m in - let p_initial = [P_APP 2;P_TYPE] in - let tac = + Lazy.force coq_Z, + mk_eq (mkRel 1) eq1) |]) + in + let mm = mk_integer m in + let p_initial = [P_APP 2;P_TYPE] in + let tac = clever_rewrite (P_APP 1 :: P_APP 1 :: P_APP 2 :: p_initial) [[P_APP 1]] (Lazy.force coq_fast_Zopp_eq_mult_neg_1) :: shuffle_mult_right p_initial orig.body m ({c= negone;v= v}::def.body) in - tclTHENS - (cut theorem) - [tclTHENLIST [ - (intros_using [aux]); - (elim_id aux); - (clear [aux]); - (intros_using [vid; aux]); - (generalize_tac - [mkApp (Lazy.force coq_OMEGA9, - [| mkVar vid;eq2;eq1;mm; mkVar id2;mkVar aux |])]); - mk_then tac; - (clear [aux]); - (intros_using [id]); - (loop l) ]; + tclTHENS + (cut theorem) + [tclTHENLIST [ + (intros_using [aux]); + (elim_id aux); + (clear [aux]); + (intros_using [vid; aux]); + (generalize_tac + [mkApp (Lazy.force coq_OMEGA9, + [| mkVar vid;eq2;eq1;mm; mkVar id2;mkVar aux |])]); + mk_then tac; + (clear [aux]); + (intros_using [id]); + (loop l) ]; tclTHEN (exists_tac eq1) reflexivity ] | SPLIT_INEQ(e,(e1,act1),(e2,act2)) :: l -> - let id1 = new_identifier () - and id2 = new_identifier () in - tag_hypothesis id1 e1; tag_hypothesis id2 e2; - let id = hyp_of_tag e.id in - let tac1 = norm_add [P_APP 2;P_TYPE] e.body in - let tac2 = scalar_norm_add [P_APP 2;P_TYPE] e.body in - let eq = val_of(decompile e) in - tclTHENS - (simplest_elim (applist (Lazy.force coq_OMEGA19, [eq; mkVar id]))) - [tclTHENLIST [ mk_then tac1; (intros_using [id1]); (loop act1) ]; + let id1 = new_identifier () + and id2 = new_identifier () in + tag_hypothesis id1 e1; tag_hypothesis id2 e2; + let id = hyp_of_tag e.id in + let tac1 = norm_add [P_APP 2;P_TYPE] e.body in + let tac2 = scalar_norm_add [P_APP 2;P_TYPE] e.body in + let eq = val_of(decompile e) in + tclTHENS + (simplest_elim (applist (Lazy.force coq_OMEGA19, [eq; mkVar id]))) + [tclTHENLIST [ mk_then tac1; (intros_using [id1]); (loop act1) ]; tclTHENLIST [ mk_then tac2; (intros_using [id2]); (loop act2) ]] | SUM(e3,(k1,e1),(k2,e2)) :: l -> - let id = new_identifier () in - tag_hypothesis id e3; - let id1 = hyp_of_tag e1.id - and id2 = hyp_of_tag e2.id in - let eq1 = val_of(decompile e1) - and eq2 = val_of(decompile e2) in - if k1 =? one && e2.kind == EQUA then + let id = new_identifier () in + tag_hypothesis id e3; + let id1 = hyp_of_tag e1.id + and id2 = hyp_of_tag e2.id in + let eq1 = val_of(decompile e1) + and eq2 = val_of(decompile e2) in + if k1 =? one && e2.kind == EQUA then let tac_thm = match e1.kind with - | EQUA -> Lazy.force coq_OMEGA5 - | INEQ -> Lazy.force coq_OMEGA6 - | DISE -> Lazy.force coq_OMEGA20 - in + | EQUA -> Lazy.force coq_OMEGA5 + | INEQ -> Lazy.force coq_OMEGA6 + | DISE -> Lazy.force coq_OMEGA20 + in let kk = mk_integer k2 in let p_initial = if e1.kind == DISE then [P_APP 1; P_TYPE] else [P_APP 2; P_TYPE] in let tac = shuffle_mult_right p_initial e1.body k2 e2.body in tclTHENLIST [ - (generalize_tac + (generalize_tac [mkApp (tac_thm, [| eq1; eq2; kk; mkVar id1; mkVar id2 |])]); - mk_then tac; - (intros_using [id]); - (loop l) + mk_then tac; + (intros_using [id]); + (loop l) ] - else + else let kk1 = mk_integer k1 - and kk2 = mk_integer k2 in - let p_initial = [P_APP 2;P_TYPE] in - let tac= shuffle_mult p_initial k1 e1.body k2 e2.body in + and kk2 = mk_integer k2 in + let p_initial = [P_APP 2;P_TYPE] in + let tac= shuffle_mult p_initial k1 e1.body k2 e2.body in tclTHENS (cut (mk_gt kk1 izero)) - [tclTHENS - (cut (mk_gt kk2 izero)) - [tclTHENLIST [ - (intros_using [aux2;aux1]); - (generalize_tac - [mkApp (Lazy.force coq_OMEGA7, [| - eq1;eq2;kk1;kk2; - mkVar aux1;mkVar aux2; - mkVar id1;mkVar id2 |])]); - (clear [aux1;aux2]); - mk_then tac; - (intros_using [id]); - (loop l) ]; - tclTHENLIST [ - unfold sp_Zgt; + [tclTHENS + (cut (mk_gt kk2 izero)) + [tclTHENLIST [ + (intros_using [aux2;aux1]); + (generalize_tac + [mkApp (Lazy.force coq_OMEGA7, [| + eq1;eq2;kk1;kk2; + mkVar aux1;mkVar aux2; + mkVar id1;mkVar id2 |])]); + (clear [aux1;aux2]); + mk_then tac; + (intros_using [id]); + (loop l) ]; + tclTHENLIST [ + unfold sp_Zgt; simpl_in_concl; - reflexivity ] ]; - tclTHENLIST [ - unfold sp_Zgt; + reflexivity ] ]; + tclTHENLIST [ + unfold sp_Zgt; simpl_in_concl; - reflexivity ] ] + reflexivity ] ] | CONSTANT_NOT_NUL(e,k) :: l -> - tclTHEN ((generalize_tac [mkVar (hyp_of_tag e)])) Equality.discrConcl + tclTHEN ((generalize_tac [mkVar (hyp_of_tag e)])) Equality.discrConcl | CONSTANT_NUL(e) :: l -> - tclTHEN (resolve_id (hyp_of_tag e)) reflexivity + tclTHEN (resolve_id (hyp_of_tag e)) reflexivity | CONSTANT_NEG(e,k) :: l -> - tclTHENLIST [ - (generalize_tac [mkVar (hyp_of_tag e)]); + tclTHENLIST [ + (generalize_tac [mkVar (hyp_of_tag e)]); unfold sp_Zle; - simpl_in_concl; - unfold sp_not; - (intros_using [aux]); - resolve_id aux; - reflexivity + simpl_in_concl; + unfold sp_not; + (intros_using [aux]); + resolve_id aux; + reflexivity ] | _ -> Proofview.tclUNIT () in @@ -1401,29 +1401,29 @@ let destructure_omega env sigma tac_def (id,c) = try match destructurate_prop sigma c with | Kapp(Eq,[typ;t1;t2]) when begin match destructurate_type env sigma typ with Kapp(Z,[]) -> true | _ -> false end -> - let t = mk_plus t1 (mk_inv t2) in - normalize_equation sigma - id EQUA (Lazy.force coq_Zegal_left) 2 t t1 t2 tac_def + let t = mk_plus t1 (mk_inv t2) in + normalize_equation sigma + id EQUA (Lazy.force coq_Zegal_left) 2 t t1 t2 tac_def | Kapp(Zne,[t1;t2]) -> - let t = mk_plus t1 (mk_inv t2) in - normalize_equation sigma - id DISE (Lazy.force coq_Zne_left) 1 t t1 t2 tac_def + let t = mk_plus t1 (mk_inv t2) in + normalize_equation sigma + id DISE (Lazy.force coq_Zne_left) 1 t t1 t2 tac_def | Kapp(Zle,[t1;t2]) -> - let t = mk_plus t2 (mk_inv t1) in - normalize_equation sigma - id INEQ (Lazy.force coq_Zle_left) 2 t t1 t2 tac_def + let t = mk_plus t2 (mk_inv t1) in + normalize_equation sigma + id INEQ (Lazy.force coq_Zle_left) 2 t t1 t2 tac_def | Kapp(Zlt,[t1;t2]) -> - let t = mk_plus (mk_plus t2 (mk_integer negone)) (mk_inv t1) in - normalize_equation sigma - id INEQ (Lazy.force coq_Zlt_left) 2 t t1 t2 tac_def + let t = mk_plus (mk_plus t2 (mk_integer negone)) (mk_inv t1) in + normalize_equation sigma + id INEQ (Lazy.force coq_Zlt_left) 2 t t1 t2 tac_def | Kapp(Zge,[t1;t2]) -> - let t = mk_plus t1 (mk_inv t2) in - normalize_equation sigma - id INEQ (Lazy.force coq_Zge_left) 2 t t1 t2 tac_def + let t = mk_plus t1 (mk_inv t2) in + normalize_equation sigma + id INEQ (Lazy.force coq_Zge_left) 2 t t1 t2 tac_def | Kapp(Zgt,[t1;t2]) -> - let t = mk_plus (mk_plus t1 (mk_integer negone)) (mk_inv t2) in - normalize_equation sigma - id INEQ (Lazy.force coq_Zgt_left) 2 t t1 t2 tac_def + let t = mk_plus (mk_plus t1 (mk_integer negone)) (mk_inv t2) in + normalize_equation sigma + id INEQ (Lazy.force coq_Zgt_left) 2 t t1 t2 tac_def | _ -> tac_def with e when catchable_exception e -> tac_def @@ -1444,25 +1444,25 @@ let coq_omega = let prelude,sys = List.fold_left (fun (tac,sys) (t,(v,th,b)) -> - if b then + if b then let id = new_identifier () in let i = new_id () in tag_hypothesis id i; (tclTHENLIST [ - (simplest_elim (applist (Lazy.force coq_intro_Z, [t]))); - (intros_using [v; id]); - (elim_id id); - (clear [id]); - (intros_using [th;id]); - tac ]), + (simplest_elim (applist (Lazy.force coq_intro_Z, [t]))); + (intros_using [v; id]); + (elim_id id); + (clear [id]); + (intros_using [th;id]); + tac ]), {kind = INEQ; - body = [{v=intern_id v; c=one}]; + body = [{v=intern_id v; c=one}]; constant = zero; id = i} :: sys - else + else (tclTHENLIST [ - (simplest_elim (applist (Lazy.force coq_new_var, [t]))); - (intros_using [v;th]); - tac ]), + (simplest_elim (applist (Lazy.force coq_new_var, [t]))); + (intros_using [v;th]); + tac ]), sys) (Proofview.tclUNIT (),[]) (dump_tables ()) in @@ -1495,61 +1495,61 @@ let nat_inject = try match destructurate_term sigma t with | Kapp(Plus,[t1;t2]) -> tclTHENLIST [ - (clever_rewrite_gen p (mk_plus (mk_inj t1) (mk_inj t2)) + (clever_rewrite_gen p (mk_plus (mk_inj t1) (mk_inj t2)) ((Lazy.force coq_inj_plus),[t1;t2])); - (explore (P_APP 1 :: p) t1); - (explore (P_APP 2 :: p) t2) + (explore (P_APP 1 :: p) t1); + (explore (P_APP 2 :: p) t2) ] | Kapp(Mult,[t1;t2]) -> tclTHENLIST [ - (clever_rewrite_gen p (mk_times (mk_inj t1) (mk_inj t2)) + (clever_rewrite_gen p (mk_times (mk_inj t1) (mk_inj t2)) ((Lazy.force coq_inj_mult),[t1;t2])); - (explore (P_APP 1 :: p) t1); - (explore (P_APP 2 :: p) t2) + (explore (P_APP 1 :: p) t1); + (explore (P_APP 2 :: p) t2) ] | Kapp(Minus,[t1;t2]) -> let id = new_identifier () in tclTHENS (tclTHEN - (simplest_elim (applist (Lazy.force coq_le_gt_dec, [t2;t1]))) - (intros_using [id])) - [ - tclTHENLIST [ - (clever_rewrite_gen p - (mk_minus (mk_inj t1) (mk_inj t2)) + (simplest_elim (applist (Lazy.force coq_le_gt_dec, [t2;t1]))) + (intros_using [id])) + [ + tclTHENLIST [ + (clever_rewrite_gen p + (mk_minus (mk_inj t1) (mk_inj t2)) ((Lazy.force coq_inj_minus1),[t1;t2;mkVar id])); - (loop [id,mkApp (Lazy.force coq_le, [| t2;t1 |])]); - (explore (P_APP 1 :: p) t1); - (explore (P_APP 2 :: p) t2) ]; - (tclTHEN - (clever_rewrite_gen p (mk_integer zero) + (loop [id,mkApp (Lazy.force coq_le, [| t2;t1 |])]); + (explore (P_APP 1 :: p) t1); + (explore (P_APP 2 :: p) t2) ]; + (tclTHEN + (clever_rewrite_gen p (mk_integer zero) ((Lazy.force coq_inj_minus2),[t1;t2;mkVar id])) - (loop [id,mkApp (Lazy.force coq_gt, [| t2;t1 |])])) - ] + (loop [id,mkApp (Lazy.force coq_gt, [| t2;t1 |])])) + ] | Kapp(S,[t']) -> let rec is_number t = try match destructurate_term sigma t with - Kapp(S,[t]) -> is_number t + Kapp(S,[t]) -> is_number t | Kapp(O,[]) -> true | _ -> false with e when catchable_exception e -> false - in + in let rec loop p t : unit Proofview.tactic = try match destructurate_term sigma t with - Kapp(S,[t]) -> + Kapp(S,[t]) -> (tclTHEN (clever_rewrite_gen p - (mkApp (Lazy.force coq_Zsucc, [| mk_inj t |])) - ((Lazy.force coq_inj_S),[t])) - (loop (P_APP 1 :: p) t)) + (mkApp (Lazy.force coq_Zsucc, [| mk_inj t |])) + ((Lazy.force coq_inj_S),[t])) + (loop (P_APP 1 :: p) t)) | _ -> explore p t with e when catchable_exception e -> explore p t - in + in if is_number t' then focused_simpl p else loop p t | Kapp(Pred,[t]) -> let t_minus_one = - mkApp (Lazy.force coq_minus, [| t; - mkApp (Lazy.force coq_S, [| Lazy.force coq_O |]) |]) in + mkApp (Lazy.force coq_minus, [| t; + mkApp (Lazy.force coq_S, [| Lazy.force coq_O |]) |]) in tclTHEN (clever_rewrite_gen_nat (P_APP 1 :: p) t_minus_one ((Lazy.force coq_pred_of_minus),[t])) @@ -1562,65 +1562,65 @@ let nat_inject = | [] -> Proofview.tclUNIT () | (i,t)::lit -> Proofview.tclEVARMAP >>= fun sigma -> - begin try match destructurate_prop sigma t with + begin try match destructurate_prop sigma t with Kapp(Le,[t1;t2]) -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_inj_le, [| t1;t2;mkVar i |]) ]); - (explore [P_APP 1; P_TYPE] t1); - (explore [P_APP 2; P_TYPE] t2); - (reintroduce i); - (loop lit) + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_inj_le, [| t1;t2;mkVar i |]) ]); + (explore [P_APP 1; P_TYPE] t1); + (explore [P_APP 2; P_TYPE] t2); + (reintroduce i); + (loop lit) ] | Kapp(Lt,[t1;t2]) -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_inj_lt, [| t1;t2;mkVar i |]) ]); - (explore [P_APP 1; P_TYPE] t1); - (explore [P_APP 2; P_TYPE] t2); - (reintroduce i); - (loop lit) + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_inj_lt, [| t1;t2;mkVar i |]) ]); + (explore [P_APP 1; P_TYPE] t1); + (explore [P_APP 2; P_TYPE] t2); + (reintroduce i); + (loop lit) ] | Kapp(Ge,[t1;t2]) -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_inj_ge, [| t1;t2;mkVar i |]) ]); - (explore [P_APP 1; P_TYPE] t1); - (explore [P_APP 2; P_TYPE] t2); - (reintroduce i); - (loop lit) + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_inj_ge, [| t1;t2;mkVar i |]) ]); + (explore [P_APP 1; P_TYPE] t1); + (explore [P_APP 2; P_TYPE] t2); + (reintroduce i); + (loop lit) ] | Kapp(Gt,[t1;t2]) -> - tclTHENLIST [ - (generalize_tac + tclTHENLIST [ + (generalize_tac [mkApp (Lazy.force coq_inj_gt, [| t1;t2;mkVar i |]) ]); - (explore [P_APP 1; P_TYPE] t1); - (explore [P_APP 2; P_TYPE] t2); - (reintroduce i); - (loop lit) + (explore [P_APP 1; P_TYPE] t1); + (explore [P_APP 2; P_TYPE] t2); + (reintroduce i); + (loop lit) ] | Kapp(Neq,[t1;t2]) -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_inj_neq, [| t1;t2;mkVar i |]) ]); - (explore [P_APP 1; P_TYPE] t1); - (explore [P_APP 2; P_TYPE] t2); - (reintroduce i); - (loop lit) + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_inj_neq, [| t1;t2;mkVar i |]) ]); + (explore [P_APP 1; P_TYPE] t1); + (explore [P_APP 2; P_TYPE] t2); + (reintroduce i); + (loop lit) ] | Kapp(Eq,[typ;t1;t2]) -> - if is_conv typ (Lazy.force coq_nat) then + if is_conv typ (Lazy.force coq_nat) then tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_inj_eq, [| t1;t2;mkVar i |]) ]); - (explore [P_APP 2; P_TYPE] t1); - (explore [P_APP 3; P_TYPE] t2); - (reintroduce i); - (loop lit) + (generalize_tac + [mkApp (Lazy.force coq_inj_eq, [| t1;t2;mkVar i |]) ]); + (explore [P_APP 2; P_TYPE] t1); + (explore [P_APP 3; P_TYPE] t2); + (reintroduce i); + (loop lit) ] - else loop lit - | _ -> loop lit - with e when catchable_exception e -> loop lit end + else loop lit + | _ -> loop lit + with e when catchable_exception e -> loop lit end in let hyps_types = Tacmach.New.pf_hyps_types gl in loop (List.rev hyps_types) @@ -1661,17 +1661,17 @@ exception Undecidable let rec decidability env sigma t = match destructurate_prop sigma t with | Kapp(Or,[t1;t2]) -> - mkApp (Lazy.force coq_dec_or, [| t1; t2; + mkApp (Lazy.force coq_dec_or, [| t1; t2; decidability env sigma t1; decidability env sigma t2 |]) | Kapp(And,[t1;t2]) -> - mkApp (Lazy.force coq_dec_and, [| t1; t2; + mkApp (Lazy.force coq_dec_and, [| t1; t2; decidability env sigma t1; decidability env sigma t2 |]) | Kapp(Iff,[t1;t2]) -> - mkApp (Lazy.force coq_dec_iff, [| t1; t2; + mkApp (Lazy.force coq_dec_iff, [| t1; t2; decidability env sigma t1; decidability env sigma t2 |]) | Kimp(t1,t2) -> (* This is the only situation where it's not obvious that [t] - is in Prop. The recursive call on [t2] will ensure that. *) + is in Prop. The recursive call on [t2] will ensure that. *) mkApp (Lazy.force coq_dec_imp, [| t1; t2; decidability env sigma t1; decidability env sigma t2 |]) | Kapp(Not,[t1]) -> @@ -1681,10 +1681,10 @@ let rec decidability env sigma t = | Kapp(Z,[]) -> mkApp (Lazy.force coq_dec_eq, [| t1;t2 |]) | Kapp(Nat,[]) -> mkApp (Lazy.force coq_dec_eq_nat, [| t1;t2 |]) | _ -> raise Undecidable - end + end | Kapp(op,[t1;t2]) -> (try mkApp (Lazy.force (dec_binop op), [| t1; t2 |]) - with Not_found -> raise Undecidable) + with Not_found -> raise Undecidable) | Kapp(False,[]) -> Lazy.force coq_dec_False | Kapp(True,[]) -> Lazy.force coq_dec_True | _ -> raise Undecidable @@ -1736,8 +1736,8 @@ let destructure_hyps = | decl :: lit -> (* variable without body (or !letin_flag isn't set) *) let i = NamedDecl.get_id decl in Proofview.tclEVARMAP >>= fun sigma -> - begin try match destructurate_prop sigma (NamedDecl.get_type decl) with - | Kapp(False,[]) -> elim_id i + begin try match destructurate_prop sigma (NamedDecl.get_type decl) with + | Kapp(False,[]) -> elim_id i | Kapp((Zle|Zge|Zgt|Zlt|Zne),[t1;t2]) -> loop lit | Kapp(Or,[t1;t2]) -> (tclTHENS @@ -1746,125 +1746,125 @@ let destructure_hyps = onClearedName i (fun i -> (loop (LocalAssum (make_annot i Sorts.Relevant,t2)::lit))) ]) | Kapp(And,[t1;t2]) -> tclTHEN - (elim_id i) - (onClearedName2 i (fun i1 i2 -> + (elim_id i) + (onClearedName2 i (fun i1 i2 -> loop (LocalAssum (make_annot i1 Sorts.Relevant,t1) :: LocalAssum (make_annot i2 Sorts.Relevant,t2) :: lit))) | Kapp(Iff,[t1;t2]) -> - tclTHEN - (elim_id i) - (onClearedName2 i (fun i1 i2 -> + tclTHEN + (elim_id i) + (onClearedName2 i (fun i1 i2 -> loop (LocalAssum (make_annot i1 Sorts.Relevant,mkArrow t1 Sorts.Relevant t2) :: LocalAssum (make_annot i2 Sorts.Relevant,mkArrow t2 Sorts.Relevant t1) :: lit))) | Kimp(t1,t2) -> - (* t1 and t2 might be in Type rather than Prop. - For t1, the decidability check will ensure being Prop. *) + (* t1 and t2 might be in Type rather than Prop. + For t1, the decidability check will ensure being Prop. *) if Termops.is_Prop sigma (type_of t2) then - let d1 = decidability t1 in - tclTHENLIST [ - (generalize_tac [mkApp (Lazy.force coq_imp_simp, + let d1 = decidability t1 in + tclTHENLIST [ + (generalize_tac [mkApp (Lazy.force coq_imp_simp, [| t1; t2; d1; mkVar i|])]); - (onClearedName i (fun i -> + (onClearedName i (fun i -> (loop (LocalAssum (make_annot i Sorts.Relevant,mk_or (mk_not t1) t2) :: lit)))) ] else - loop lit + loop lit | Kapp(Not,[t]) -> begin match destructurate_prop sigma t with - Kapp(Or,[t1;t2]) -> + Kapp(Or,[t1;t2]) -> tclTHENLIST [ - (generalize_tac + (generalize_tac [mkApp (Lazy.force coq_not_or,[| t1; t2; mkVar i |])]); - (onClearedName i (fun i -> + (onClearedName i (fun i -> (loop (LocalAssum (make_annot i Sorts.Relevant,mk_and (mk_not t1) (mk_not t2)) :: lit)))) ] - | Kapp(And,[t1;t2]) -> - let d1 = decidability t1 in + | Kapp(And,[t1;t2]) -> + let d1 = decidability t1 in tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_not_and, - [| t1; t2; d1; mkVar i |])]); - (onClearedName i (fun i -> + (generalize_tac + [mkApp (Lazy.force coq_not_and, + [| t1; t2; d1; mkVar i |])]); + (onClearedName i (fun i -> (loop (LocalAssum (make_annot i Sorts.Relevant,mk_or (mk_not t1) (mk_not t2)) :: lit)))) ] - | Kapp(Iff,[t1;t2]) -> - let d1 = decidability t1 in - let d2 = decidability t2 in + | Kapp(Iff,[t1;t2]) -> + let d1 = decidability t1 in + let d2 = decidability t2 in tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_not_iff, - [| t1; t2; d1; d2; mkVar i |])]); - (onClearedName i (fun i -> + (generalize_tac + [mkApp (Lazy.force coq_not_iff, + [| t1; t2; d1; d2; mkVar i |])]); + (onClearedName i (fun i -> (loop (LocalAssum (make_annot i Sorts.Relevant,mk_or (mk_and t1 (mk_not t2)) - (mk_and (mk_not t1) t2)) :: lit)))) + (mk_and (mk_not t1) t2)) :: lit)))) ] - | Kimp(t1,t2) -> - (* t2 must be in Prop otherwise ~(t1->t2) wouldn't be ok. - For t1, being decidable implies being Prop. *) - let d1 = decidability t1 in + | Kimp(t1,t2) -> + (* t2 must be in Prop otherwise ~(t1->t2) wouldn't be ok. + For t1, being decidable implies being Prop. *) + let d1 = decidability t1 in tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_not_imp, - [| t1; t2; d1; mkVar i |])]); - (onClearedName i (fun i -> + (generalize_tac + [mkApp (Lazy.force coq_not_imp, + [| t1; t2; d1; mkVar i |])]); + (onClearedName i (fun i -> (loop (LocalAssum (make_annot i Sorts.Relevant,mk_and t1 (mk_not t2)) :: lit)))) ] - | Kapp(Not,[t]) -> - let d = decidability t in + | Kapp(Not,[t]) -> + let d = decidability t in tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_not_not, [| t; d; mkVar i |])]); + (generalize_tac + [mkApp (Lazy.force coq_not_not, [| t; d; mkVar i |])]); (onClearedName i (fun i -> (loop (LocalAssum (make_annot i Sorts.Relevant,t) :: lit)))) ] - | Kapp(op,[t1;t2]) -> - (try - let thm = not_binop op in + | Kapp(op,[t1;t2]) -> + (try + let thm = not_binop op in tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force thm, [| t1;t2;mkVar i|])]); - (onClearedName i (fun _ -> loop lit)) + (generalize_tac + [mkApp (Lazy.force thm, [| t1;t2;mkVar i|])]); + (onClearedName i (fun _ -> loop lit)) ] - with Not_found -> loop lit) - | Kapp(Eq,[typ;t1;t2]) -> + with Not_found -> loop lit) + | Kapp(Eq,[typ;t1;t2]) -> if !old_style_flag then begin match destructurate_type env sigma typ with - | Kapp(Nat,_) -> + | Kapp(Nat,_) -> tclTHENLIST [ - (simplest_elim - (mkApp + (simplest_elim + (mkApp (Lazy.force coq_not_eq, [|t1;t2;mkVar i|]))); - (onClearedName i (fun _ -> loop lit)) + (onClearedName i (fun _ -> loop lit)) ] - | Kapp(Z,_) -> + | Kapp(Z,_) -> tclTHENLIST [ - (simplest_elim - (mkApp - (Lazy.force coq_not_Zeq, [|t1;t2;mkVar i|]))); - (onClearedName i (fun _ -> loop lit)) + (simplest_elim + (mkApp + (Lazy.force coq_not_Zeq, [|t1;t2;mkVar i|]))); + (onClearedName i (fun _ -> loop lit)) ] - | _ -> loop lit + | _ -> loop lit end else begin match destructurate_type env sigma typ with - | Kapp(Nat,_) -> + | Kapp(Nat,_) -> (tclTHEN (Tactics.convert_hyp ~check:false ~reorder:false (NamedDecl.set_type (mkApp (Lazy.force coq_neq, [| t1;t2|])) decl)) - (loop lit)) - | Kapp(Z,_) -> + (loop lit)) + | Kapp(Z,_) -> (tclTHEN (Tactics.convert_hyp ~check:false ~reorder:false (NamedDecl.set_type (mkApp (Lazy.force coq_Zne, [| t1;t2|])) decl)) - (loop lit)) - | _ -> loop lit + (loop lit)) + | _ -> loop lit end - | _ -> loop lit + | _ -> loop lit end | _ -> loop lit - with - | Undecidable -> loop lit - | e when catchable_exception e -> loop lit - end + with + | Undecidable -> loop lit + | e when catchable_exception e -> loop lit + end in let hyps = Proofview.Goal.hyps gl in loop hyps @@ -1883,23 +1883,23 @@ let destructure_goal = match prop with | Kapp(Not,[t]) -> (tclTHEN - (tclTHEN (unfold sp_not) intro) - destructure_hyps) + (tclTHEN (unfold sp_not) intro) + destructure_hyps) | Kimp(a,b) -> (tclTHEN intro (loop b)) | Kapp(False,[]) -> destructure_hyps | _ -> - let goal_tac = - try - let dec = decidability t in - tclTHEN + let goal_tac = + try + let dec = decidability t in + tclTHEN (Proofview.Goal.enter begin fun gl -> - refine_app gl (mkApp (Lazy.force coq_dec_not_not, [| t; dec |])) - end) - intro - with Undecidable -> Tactics.elim_type (Lazy.force coq_False) - | e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e - in - tclTHEN goal_tac destructure_hyps + refine_app gl (mkApp (Lazy.force coq_dec_not_not, [| t; dec |])) + end) + intro + with Undecidable -> Tactics.elim_type (Lazy.force coq_False) + | e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e + in + tclTHEN goal_tac destructure_hyps in (loop concl) end diff --git a/plugins/omega/omega.ml b/plugins/omega/omega.ml index 05c31062fc..355e61deb9 100644 --- a/plugins/omega/omega.ml +++ b/plugins/omega/omega.ml @@ -130,14 +130,14 @@ let display_eq print_var (l,e) = let _ = List.fold_left (fun not_first f -> - print_string - (if f.c <? zero then "- " else if not_first then "+ " else ""); - let c = abs f.c in - if c =? one then - Printf.printf "%s " (print_var f.v) - else - Printf.printf "%s %s " (string_of_bigint c) (print_var f.v); - true) + print_string + (if f.c <? zero then "- " else if not_first then "+ " else ""); + let c = abs f.c in + if c =? one then + Printf.printf "%s " (print_var f.v) + else + Printf.printf "%s %s " (string_of_bigint c) (print_var f.v); + true) false l in if e >? zero then @@ -148,7 +148,7 @@ let display_eq print_var (l,e) = let rec trace_length l = let action_length accu = function | SPLIT_INEQ (_,(_,l1),(_,l2)) -> - accu + one + trace_length l1 + trace_length l2 + accu + one + trace_length l1 + trace_length l2 | _ -> accu + one in List.fold_left action_length zero l @@ -263,12 +263,12 @@ let rec sum p0 p1 = match (p0,p1) with | ([], l) -> l | (l, []) -> l | (((x1::l1) as l1'), ((x2::l2) as l2')) -> if x1.v = x2.v then - let c = x1.c + x2.c in - if c =? zero then sum l1 l2 else {v=x1.v;c=c} :: sum l1 l2 + let c = x1.c + x2.c in + if c =? zero then sum l1 l2 else {v=x1.v;c=c} :: sum l1 l2 else if x1.v > x2.v then - x1 :: sum l1 l2' + x1 :: sum l1 l2' else - x2 :: sum l1' l2 + x2 :: sum l1' l2 let sum_afine new_eq_id eq1 eq2 = { kind = eq1.kind; id = new_eq_id (); @@ -351,7 +351,7 @@ let banerjee_step (new_eq_id,new_var_id,print_var) original l1 l2 = original.body; id = new_eq_id (); kind = EQUA } in add_event (STATE {st_new_eq = new_eq; st_def = definition; - st_orig = original; st_coef = m; st_var = sigma}); + st_orig = original; st_coef = m; st_var = sigma}); let new_eq = List.hd (normalize new_eq) in let eliminated_var, def = chop_var var new_eq.body in let other_equations = @@ -395,8 +395,8 @@ let rec banerjee ((_,_,print_var) as new_ids) (sys_eq,sys_ineq) = add_event (CONSTANT_NOT_NUL(eq.id,eq.constant)); raise UNSOLVABLE end else - banerjee new_ids - (eliminate_one_equation new_ids (eq,other,sys_ineq)) + banerjee new_ids + (eliminate_one_equation new_ids (eq,other,sys_ineq)) type kind = INVERTED | NORMAL @@ -501,7 +501,7 @@ let product new_eq_id dark_shadow low high = (map_eq_afine (fun c -> c * a) eq2) in add_event(SUM(eq.id,(b,eq1),(a,eq2))); match normalize eq with - | [eq] -> + | [eq] -> let final_eq = if dark_shadow then let delta = (a - one) * (b - one) in @@ -549,43 +549,43 @@ let simplify ((new_eq_id,new_var_id,print_var) as new_ids) dark_shadow system = let rec depend relie_on accu = function | act :: l -> begin match act with - | DIVIDE_AND_APPROX (e,_,_,_) -> + | DIVIDE_AND_APPROX (e,_,_,_) -> if Int.List.mem e.id relie_on then depend relie_on (act::accu) l else depend relie_on accu l - | EXACT_DIVIDE (e,_) -> + | EXACT_DIVIDE (e,_) -> if Int.List.mem e.id relie_on then depend relie_on (act::accu) l else depend relie_on accu l - | WEAKEN (e,_) -> + | WEAKEN (e,_) -> if Int.List.mem e relie_on then depend relie_on (act::accu) l else depend relie_on accu l - | SUM (e,(_,e1),(_,e2)) -> + | SUM (e,(_,e1),(_,e2)) -> if Int.List.mem e relie_on then - depend (e1.id::e2.id::relie_on) (act::accu) l + depend (e1.id::e2.id::relie_on) (act::accu) l else - depend relie_on accu l - | STATE {st_new_eq=e;st_orig=o} -> + depend relie_on accu l + | STATE {st_new_eq=e;st_orig=o} -> if Int.List.mem e.id relie_on then depend (o.id::relie_on) (act::accu) l else depend relie_on accu l - | HYP e -> + | HYP e -> if Int.List.mem e.id relie_on then depend relie_on (act::accu) l else depend relie_on accu l - | FORGET_C _ -> depend relie_on accu l - | FORGET _ -> depend relie_on accu l - | FORGET_I _ -> depend relie_on accu l - | MERGE_EQ (e,e1,e2) -> + | FORGET_C _ -> depend relie_on accu l + | FORGET _ -> depend relie_on accu l + | FORGET_I _ -> depend relie_on accu l + | MERGE_EQ (e,e1,e2) -> if Int.List.mem e relie_on then - depend (e1.id::e2::relie_on) (act::accu) l + depend (e1.id::e2::relie_on) (act::accu) l else - depend relie_on accu l - | NOT_EXACT_DIVIDE (e,_) -> depend (e.id::relie_on) (act::accu) l - | CONTRADICTION (e1,e2) -> - depend (e1.id::e2.id::relie_on) (act::accu) l - | CONSTANT_NOT_NUL (e,_) -> depend (e::relie_on) (act::accu) l - | CONSTANT_NEG (e,_) -> depend (e::relie_on) (act::accu) l - | CONSTANT_NUL e -> depend (e::relie_on) (act::accu) l - | NEGATE_CONTRADICT (e1,e2,_) -> + depend relie_on accu l + | NOT_EXACT_DIVIDE (e,_) -> depend (e.id::relie_on) (act::accu) l + | CONTRADICTION (e1,e2) -> depend (e1.id::e2.id::relie_on) (act::accu) l - | SPLIT_INEQ _ -> failwith "depend" + | CONSTANT_NOT_NUL (e,_) -> depend (e::relie_on) (act::accu) l + | CONSTANT_NEG (e,_) -> depend (e::relie_on) (act::accu) l + | CONSTANT_NUL e -> depend (e::relie_on) (act::accu) l + | NEGATE_CONTRADICT (e1,e2,_) -> + depend (e1.id::e2.id::relie_on) (act::accu) l + | SPLIT_INEQ _ -> failwith "depend" end | [] -> relie_on, accu @@ -602,9 +602,9 @@ let negation (eqs,ineqs) = assert (e.kind = EQUA); let {body=ne;constant=c},kind = normal e in try - let (kind',e') = Hashtbl.find table (ne,c) in - add_event (NEGATE_CONTRADICT (e,e',kind=kind')); - raise UNSOLVABLE + let (kind',e') = Hashtbl.find table (ne,c) in + add_event (NEGATE_CONTRADICT (e,e',kind=kind')); + raise UNSOLVABLE with Not_found -> ()) eqs exception FULL_SOLUTION of action list * int list @@ -631,20 +631,20 @@ let simplify_strong ((new_eq_id,new_var_id,print_var) as new_ids) system = in let rec explode_diseq = function | (de::diseq,ineqs,expl_map) -> - let id1 = new_eq_id () - and id2 = new_eq_id () in - let e1 = + let id1 = new_eq_id () + and id2 = new_eq_id () in + let e1 = {id = id1; kind=INEQ; body = de.body; constant = de.constant -one} in - let e2 = - {id = id2; kind=INEQ; body = map_eq_linear neg de.body; + let e2 = + {id = id2; kind=INEQ; body = map_eq_linear neg de.body; constant = neg de.constant - one} in - let new_sys = + let new_sys = List.map (fun (what,sys) -> ((de.id,id1,true)::what, e1::sys)) - ineqs @ + ineqs @ List.map (fun (what,sys) -> ((de.id,id2,false)::what,e2::sys)) - ineqs - in - explode_diseq (diseq,new_sys,(de.id,(de,id1,id2))::expl_map) + ineqs + in + explode_diseq (diseq,new_sys,(de.id,(de,id1,id2))::expl_map) | ([],ineqs,expl_map) -> ineqs,expl_map in try @@ -673,19 +673,19 @@ let simplify_strong ((new_eq_id,new_var_id,print_var) as new_ids) system = let tbl = Hashtbl.create 7 in let augment x = try incr (Hashtbl.find tbl x) - with Not_found -> Hashtbl.add tbl x (ref 1) in + with Not_found -> Hashtbl.add tbl x (ref 1) in let eq = ref (-1) and c = ref 0 in List.iter (function - | ([],r_on,_,path) -> raise (FULL_SOLUTION (path,r_on)) + | ([],r_on,_,path) -> raise (FULL_SOLUTION (path,r_on)) | (l,_,_,_) -> List.iter augment l) sys; Hashtbl.iter (fun x v -> if !v > !c then begin eq := x; c := !v end) tbl; !eq in let rec solve systems = try - let id = max_count systems in + let id = max_count systems in let rec sign = function - | ((id',_,b)::l) -> if id=id' then b else sign l + | ((id',_,b)::l) -> if id=id' then b else sign l | [] -> failwith "solve" in let s1,s2 = List.partition (fun (_,_,decomp,_) -> sign decomp) systems in @@ -695,9 +695,9 @@ let simplify_strong ((new_eq_id,new_var_id,print_var) as new_ids) system = let s1' = List.map remove_int s1 in let s2' = List.map remove_int s2 in let (r1,relie1) = solve s1' - and (r2,relie2) = solve s2' in - let (eq,id1,id2) = Int.List.assoc id explode_map in - [SPLIT_INEQ(eq,(id1,r1),(id2, r2))], + and (r2,relie2) = solve s2' in + let (eq,id1,id2) = Int.List.assoc id explode_map in + [SPLIT_INEQ(eq,(id1,r1),(id2, r2))], eq.id :: Util.List.union Int.equal relie1 relie2 with FULL_SOLUTION (x0,x1) -> (x0,x1) in diff --git a/plugins/rtauto/proof_search.ml b/plugins/rtauto/proof_search.ml index 13da8220f4..4cc32cfb26 100644 --- a/plugins/rtauto/proof_search.ml +++ b/plugins/rtauto/proof_search.ml @@ -102,7 +102,7 @@ type sequent = let add_one_arrow i f1 f2 m= try Fmap.add f1 ((i,f2)::(Fmap.find f1 m)) m with Not_found -> - Fmap.add f1 [i,f2] m + Fmap.add f1 [i,f2] m type proof = Ax of int @@ -174,7 +174,7 @@ let project = function let pop n prf = let nprf= match prf.dep_it with - Pop (i,p) -> Pop (i+n,p) + Pop (i,p) -> Pop (i+n,p) | p -> Pop(n,p) in {prf with dep_it = nprf} @@ -182,71 +182,71 @@ let rec fill stack proof = match stack with [] -> Complete proof.dep_it | slice::super -> - if - !pruning && - List.is_empty slice.proofs_done && - not (slice.changes_goal && proof.dep_goal) && - not (Int.Set.exists - (fun i -> Int.Set.mem i proof.dep_hyps) - slice.creates_hyps) - then - begin - s_info.pruned_steps<-s_info.pruned_steps+1; - s_info.pruned_branches<- s_info.pruned_branches + - List.length slice.proofs_todo; - let created_here=Int.Set.cardinal slice.creates_hyps in - s_info.pruned_hyps<-s_info.pruned_hyps+ - List.fold_left - (fun sum dseq -> sum + Int.Set.cardinal dseq.dep_hyps) - created_here slice.proofs_todo; - fill super (pop (Int.Set.cardinal slice.creates_hyps) proof) - end - else - let dep_hyps= - Int.Set.union slice.needs_hyps - (Int.Set.diff proof.dep_hyps slice.creates_hyps) in - let dep_goal= - slice.needs_goal || - ((not slice.changes_goal) && proof.dep_goal) in - let proofs_done= - proof.dep_it::slice.proofs_done in - match slice.proofs_todo with - [] -> - fill super {dep_it = - add_step slice.step (List.rev proofs_done); - dep_goal = dep_goal; - dep_hyps = dep_hyps} - | current::next -> - let nslice= - {proofs_done=proofs_done; - proofs_todo=next; - step=slice.step; - needs_goal=dep_goal; - needs_hyps=dep_hyps; - changes_goal=current.dep_goal; - creates_hyps=current.dep_hyps} in - Incomplete (current.dep_it,nslice::super) + if + !pruning && + List.is_empty slice.proofs_done && + not (slice.changes_goal && proof.dep_goal) && + not (Int.Set.exists + (fun i -> Int.Set.mem i proof.dep_hyps) + slice.creates_hyps) + then + begin + s_info.pruned_steps<-s_info.pruned_steps+1; + s_info.pruned_branches<- s_info.pruned_branches + + List.length slice.proofs_todo; + let created_here=Int.Set.cardinal slice.creates_hyps in + s_info.pruned_hyps<-s_info.pruned_hyps+ + List.fold_left + (fun sum dseq -> sum + Int.Set.cardinal dseq.dep_hyps) + created_here slice.proofs_todo; + fill super (pop (Int.Set.cardinal slice.creates_hyps) proof) + end + else + let dep_hyps= + Int.Set.union slice.needs_hyps + (Int.Set.diff proof.dep_hyps slice.creates_hyps) in + let dep_goal= + slice.needs_goal || + ((not slice.changes_goal) && proof.dep_goal) in + let proofs_done= + proof.dep_it::slice.proofs_done in + match slice.proofs_todo with + [] -> + fill super {dep_it = + add_step slice.step (List.rev proofs_done); + dep_goal = dep_goal; + dep_hyps = dep_hyps} + | current::next -> + let nslice= + {proofs_done=proofs_done; + proofs_todo=next; + step=slice.step; + needs_goal=dep_goal; + needs_hyps=dep_hyps; + changes_goal=current.dep_goal; + creates_hyps=current.dep_hyps} in + Incomplete (current.dep_it,nslice::super) let append stack (step,subgoals) = s_info.created_steps<-s_info.created_steps+1; match subgoals with [] -> - s_info.branch_successes<-s_info.branch_successes+1; - fill stack {dep_it=add_step step.dep_it []; - dep_goal=step.dep_goal; - dep_hyps=step.dep_hyps} + s_info.branch_successes<-s_info.branch_successes+1; + fill stack {dep_it=add_step step.dep_it []; + dep_goal=step.dep_goal; + dep_hyps=step.dep_hyps} | hd :: next -> - s_info.created_branches<- - s_info.created_branches+List.length next; - let slice= - {proofs_done=[]; - proofs_todo=next; - step=step.dep_it; - needs_goal=step.dep_goal; - needs_hyps=step.dep_hyps; - changes_goal=hd.dep_goal; - creates_hyps=hd.dep_hyps} in - Incomplete(hd.dep_it,slice::stack) + s_info.created_branches<- + s_info.created_branches+List.length next; + let slice= + {proofs_done=[]; + proofs_todo=next; + step=step.dep_it; + needs_goal=step.dep_goal; + needs_hyps=step.dep_hyps; + changes_goal=hd.dep_goal; + creates_hyps=hd.dep_hyps} in + Incomplete(hd.dep_it,slice::stack) let embed seq= {dep_it=seq; @@ -266,59 +266,59 @@ let add_hyp seqwd f= let cnx,right= try let l=Fmap.find f seq.right in - List.fold_right (fun (i,f0) l0 -> (num,i,f,f0)::l0) l seq.cnx, - Fmap.remove f seq.right + List.fold_right (fun (i,f0) l0 -> (num,i,f,f0)::l0) l seq.cnx, + Fmap.remove f seq.right with Not_found -> seq.cnx,seq.right in let nseq= match f with - Bot -> - {seq with - left=left; - right=right; - size=num; - abs=Some num; - cnx=cnx} + Bot -> + {seq with + left=left; + right=right; + size=num; + abs=Some num; + cnx=cnx} | Atom _ -> - {seq with - size=num; - left=left; - right=right; - cnx=cnx} + {seq with + size=num; + left=left; + right=right; + cnx=cnx} | Conjunct (_,_) | Disjunct (_,_) -> - {seq with - rev_hyps=Int.Map.add num f seq.rev_hyps; - size=num; - left=left; - right=right; - cnx=cnx} + {seq with + rev_hyps=Int.Map.add num f seq.rev_hyps; + size=num; + left=left; + right=right; + cnx=cnx} | Arrow (f1,f2) -> - let ncnx,nright= - try - let i = Fmap.find f1 seq.left in - (i,num,f1,f2)::cnx,right - with Not_found -> - cnx,(add_one_arrow num f1 f2 right) in - match f1 with - Conjunct (_,_) | Disjunct (_,_) -> - {seq with - rev_hyps=Int.Map.add num f seq.rev_hyps; - size=num; - left=left; - right=nright; - cnx=ncnx} - | Arrow(_,_) -> - {seq with - norev_hyps=Int.Map.add num f seq.norev_hyps; - size=num; - left=left; - right=nright; - cnx=ncnx} - | _ -> - {seq with - size=num; - left=left; - right=nright; - cnx=ncnx} in + let ncnx,nright= + try + let i = Fmap.find f1 seq.left in + (i,num,f1,f2)::cnx,right + with Not_found -> + cnx,(add_one_arrow num f1 f2 right) in + match f1 with + Conjunct (_,_) | Disjunct (_,_) -> + {seq with + rev_hyps=Int.Map.add num f seq.rev_hyps; + size=num; + left=left; + right=nright; + cnx=ncnx} + | Arrow(_,_) -> + {seq with + norev_hyps=Int.Map.add num f seq.norev_hyps; + size=num; + left=left; + right=nright; + cnx=ncnx} + | _ -> + {seq with + size=num; + left=left; + right=nright; + cnx=ncnx} in {seqwd with dep_it=nseq; dep_hyps=Int.Set.add num seqwd.dep_hyps} @@ -336,33 +336,33 @@ let choose m= let search_or seq= match seq.gl with Disjunct (f1,f2) -> - [{dep_it = SI_Or_l; - dep_goal = true; - dep_hyps = Int.Set.empty}, - [change_goal (embed seq) f1]; - {dep_it = SI_Or_r; - dep_goal = true; - dep_hyps = Int.Set.empty}, - [change_goal (embed seq) f2]] + [{dep_it = SI_Or_l; + dep_goal = true; + dep_hyps = Int.Set.empty}, + [change_goal (embed seq) f1]; + {dep_it = SI_Or_r; + dep_goal = true; + dep_hyps = Int.Set.empty}, + [change_goal (embed seq) f2]] | _ -> [] let search_norev seq= let goals=ref (search_or seq) in let add_one i f= match f with - Arrow (Arrow (f1,f2),f3) -> - let nseq = - {seq with norev_hyps=Int.Map.remove i seq.norev_hyps} in - goals:= - ({dep_it=SD_Arrow(i); - dep_goal=false; - dep_hyps=Int.Set.singleton i}, - [add_hyp - (add_hyp - (change_goal (embed nseq) f2) - (Arrow(f2,f3))) - f1; - add_hyp (embed nseq) f3]):: !goals + Arrow (Arrow (f1,f2),f3) -> + let nseq = + {seq with norev_hyps=Int.Map.remove i seq.norev_hyps} in + goals:= + ({dep_it=SD_Arrow(i); + dep_goal=false; + dep_hyps=Int.Set.singleton i}, + [add_hyp + (add_hyp + (change_goal (embed nseq) f2) + (Arrow(f2,f3))) + f1; + add_hyp (embed nseq) f3]):: !goals | _ -> anomaly ~label:"search_no_rev" (Pp.str "can't happen.") in Int.Map.iter add_one seq.norev_hyps; List.rev !goals @@ -376,76 +376,76 @@ let search_in_rev_hyps seq= dep_hyps=Int.Set.singleton i} in let nseq={seq with rev_hyps=Int.Map.remove i seq.rev_hyps} in match f with - Conjunct (f1,f2) -> - [make_step (SE_And(i)), - [add_hyp (add_hyp (embed nseq) f1) f2]] - | Disjunct (f1,f2) -> - [make_step (SE_Or(i)), - [add_hyp (embed nseq) f1;add_hyp (embed nseq) f2]] - | Arrow (Conjunct (f1,f2),f0) -> - [make_step (SD_And(i)), - [add_hyp (embed nseq) (Arrow (f1,Arrow (f2,f0)))]] - | Arrow (Disjunct (f1,f2),f0) -> - [make_step (SD_Or(i)), - [add_hyp (add_hyp (embed nseq) (Arrow(f1,f0))) (Arrow (f2,f0))]] - | _ -> anomaly ~label:"search_in_rev_hyps" (Pp.str "can't happen.") + Conjunct (f1,f2) -> + [make_step (SE_And(i)), + [add_hyp (add_hyp (embed nseq) f1) f2]] + | Disjunct (f1,f2) -> + [make_step (SE_Or(i)), + [add_hyp (embed nseq) f1;add_hyp (embed nseq) f2]] + | Arrow (Conjunct (f1,f2),f0) -> + [make_step (SD_And(i)), + [add_hyp (embed nseq) (Arrow (f1,Arrow (f2,f0)))]] + | Arrow (Disjunct (f1,f2),f0) -> + [make_step (SD_Or(i)), + [add_hyp (add_hyp (embed nseq) (Arrow(f1,f0))) (Arrow (f2,f0))]] + | _ -> anomaly ~label:"search_in_rev_hyps" (Pp.str "can't happen.") with Not_found -> search_norev seq let search_rev seq= match seq.cnx with (i,j,f1,f2)::next -> - let nseq= - match f1 with - Conjunct (_,_) | Disjunct (_,_) -> - {seq with cnx=next; - rev_hyps=Int.Map.remove j seq.rev_hyps} - | Arrow (_,_) -> - {seq with cnx=next; - norev_hyps=Int.Map.remove j seq.norev_hyps} - | _ -> - {seq with cnx=next} in - [{dep_it=SE_Arrow(i,j); - dep_goal=false; - dep_hyps=Int.Set.add i (Int.Set.singleton j)}, - [add_hyp (embed nseq) f2]] + let nseq= + match f1 with + Conjunct (_,_) | Disjunct (_,_) -> + {seq with cnx=next; + rev_hyps=Int.Map.remove j seq.rev_hyps} + | Arrow (_,_) -> + {seq with cnx=next; + norev_hyps=Int.Map.remove j seq.norev_hyps} + | _ -> + {seq with cnx=next} in + [{dep_it=SE_Arrow(i,j); + dep_goal=false; + dep_hyps=Int.Set.add i (Int.Set.singleton j)}, + [add_hyp (embed nseq) f2]] | [] -> - match seq.gl with - Arrow (f1,f2) -> - [{dep_it=SI_Arrow; - dep_goal=true; - dep_hyps=Int.Set.empty}, - [add_hyp (change_goal (embed seq) f2) f1]] - | Conjunct (f1,f2) -> - [{dep_it=SI_And; - dep_goal=true; - dep_hyps=Int.Set.empty},[change_goal (embed seq) f1; - change_goal (embed seq) f2]] - | _ -> search_in_rev_hyps seq + match seq.gl with + Arrow (f1,f2) -> + [{dep_it=SI_Arrow; + dep_goal=true; + dep_hyps=Int.Set.empty}, + [add_hyp (change_goal (embed seq) f2) f1]] + | Conjunct (f1,f2) -> + [{dep_it=SI_And; + dep_goal=true; + dep_hyps=Int.Set.empty},[change_goal (embed seq) f1; + change_goal (embed seq) f2]] + | _ -> search_in_rev_hyps seq let search_all seq= match seq.abs with Some i -> - [{dep_it=SE_False (i); - dep_goal=false; - dep_hyps=Int.Set.singleton i},[]] + [{dep_it=SE_False (i); + dep_goal=false; + dep_hyps=Int.Set.singleton i},[]] | None -> - try - let ax = Fmap.find seq.gl seq.left in - [{dep_it=SAx (ax); - dep_goal=true; - dep_hyps=Int.Set.singleton ax},[]] - with Not_found -> search_rev seq + try + let ax = Fmap.find seq.gl seq.left in + [{dep_it=SAx (ax); + dep_goal=true; + dep_hyps=Int.Set.singleton ax},[]] + with Not_found -> search_rev seq let bare_sequent = embed - {rev_hyps=Int.Map.empty; - norev_hyps=Int.Map.empty; - size=0; - left=Fmap.empty; - right=Fmap.empty; - cnx=[]; - abs=None; - gl=Bot} + {rev_hyps=Int.Map.empty; + norev_hyps=Int.Map.empty; + size=0; + left=Fmap.empty; + right=Fmap.empty; + cnx=[]; + abs=None; + gl=Bot} let init_state hyps gl= let init = change_goal bare_sequent gl in @@ -461,11 +461,11 @@ let branching = function Control.check_for_interrupt (); let successors = search_all seq in let _ = - match successors with - [] -> s_info.branch_failures<-s_info.branch_failures+1 - | _::next -> - s_info.nd_branching<-s_info.nd_branching+List.length next in - List.map (append stack) successors + match successors with + [] -> s_info.branch_failures<-s_info.branch_failures+1 + | _::next -> + s_info.nd_branching<-s_info.nd_branching+List.length next in + List.map (append stack) successors | Complete prf -> anomaly (Pp.str "already succeeded.") open Pp @@ -492,7 +492,7 @@ let pr_form f = pp_form f let pp_intmap map = let pp=ref (str "") in Int.Map.iter (fun i obj -> pp:= (!pp ++ - pp_form obj ++ cut ())) map; + pp_form obj ++ cut ())) map; str "{ " ++ v 0 (!pp) ++ str " }" let pp_list pp_obj l= @@ -503,20 +503,20 @@ let pp=ref (str "") in let pp_mapint map = let pp=ref (str "") in Fmap.iter (fun obj l -> pp:= (!pp ++ - pp_form obj ++ str " => " ++ - pp_list (fun (i,f) -> pp_form f) l ++ - cut ()) ) map; + pp_form obj ++ str " => " ++ + pp_list (fun (i,f) -> pp_form f) l ++ + cut ()) ) map; str "{ " ++ hv 0 (!pp ++ str " }") let pp_connect (i,j,f1,f2) = pp_form f1 ++ str " => " ++ pp_form f2 let pp_gl gl= cut () ++ str "{ " ++ hv 0 ( - begin - match gl.abs with - None -> str "" - | Some i -> str "ABSURD" ++ cut () - end ++ + begin + match gl.abs with + None -> str "" + | Some i -> str "ABSURD" ++ cut () + end ++ str "rev =" ++ pp_intmap gl.rev_hyps ++ cut () ++ str "norev =" ++ pp_intmap gl.norev_hyps ++ cut () ++ str "arrows=" ++ pp_mapint gl.right ++ cut () ++ @@ -531,31 +531,31 @@ let pp = let pp_info () = let count_info = if !pruning then - str "Proof steps : " ++ - int s_info.created_steps ++ str " created / " ++ - int s_info.pruned_steps ++ str " pruned" ++ fnl () ++ - str "Proof branches : " ++ - int s_info.created_branches ++ str " created / " ++ - int s_info.pruned_branches ++ str " pruned" ++ fnl () ++ - str "Hypotheses : " ++ - int s_info.created_hyps ++ str " created / " ++ - int s_info.pruned_hyps ++ str " pruned" ++ fnl () + str "Proof steps : " ++ + int s_info.created_steps ++ str " created / " ++ + int s_info.pruned_steps ++ str " pruned" ++ fnl () ++ + str "Proof branches : " ++ + int s_info.created_branches ++ str " created / " ++ + int s_info.pruned_branches ++ str " pruned" ++ fnl () ++ + str "Hypotheses : " ++ + int s_info.created_hyps ++ str " created / " ++ + int s_info.pruned_hyps ++ str " pruned" ++ fnl () else - str "Pruning is off" ++ fnl () ++ - str "Proof steps : " ++ - int s_info.created_steps ++ str " created" ++ fnl () ++ - str "Proof branches : " ++ - int s_info.created_branches ++ str " created" ++ fnl () ++ - str "Hypotheses : " ++ - int s_info.created_hyps ++ str " created" ++ fnl () in + str "Pruning is off" ++ fnl () ++ + str "Proof steps : " ++ + int s_info.created_steps ++ str " created" ++ fnl () ++ + str "Proof branches : " ++ + int s_info.created_branches ++ str " created" ++ fnl () ++ + str "Hypotheses : " ++ + int s_info.created_hyps ++ str " created" ++ fnl () in Feedback.msg_info ( str "Proof-search statistics :" ++ fnl () ++ - count_info ++ - str "Branch ends: " ++ - int s_info.branch_successes ++ str " successes / " ++ - int s_info.branch_failures ++ str " failures" ++ fnl () ++ - str "Non-deterministic choices : " ++ - int s_info.nd_branching ++ str " branches") + count_info ++ + str "Branch ends: " ++ + int s_info.branch_successes ++ str " successes / " ++ + int s_info.branch_failures ++ str " failures" ++ fnl () ++ + str "Non-deterministic choices : " ++ + int s_info.nd_branching ++ str " branches") diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml index df27c9c9d7..0c155c9d0a 100644 --- a/plugins/rtauto/refl_tauto.ml +++ b/plugins/rtauto/refl_tauto.ml @@ -156,9 +156,9 @@ let rec decal k = function [] -> k | (start,delta)::rest -> if k>start then - k - delta + k - delta else - decal k rest + decal k rest let add_pop size d pops= match pops with @@ -168,57 +168,57 @@ let add_pop size d pops= let rec build_proof pops size = function Ax i -> - mkApp (force step_count l_Ax, - [|build_pos (decal i pops)|]) + mkApp (force step_count l_Ax, + [|build_pos (decal i pops)|]) | I_Arrow p -> - mkApp (force step_count l_I_Arrow, - [|build_proof pops (size + 1) p|]) + mkApp (force step_count l_I_Arrow, + [|build_proof pops (size + 1) p|]) | E_Arrow(i,j,p) -> - mkApp (force step_count l_E_Arrow, - [|build_pos (decal i pops); - build_pos (decal j pops); - build_proof pops (size + 1) p|]) + mkApp (force step_count l_E_Arrow, + [|build_pos (decal i pops); + build_pos (decal j pops); + build_proof pops (size + 1) p|]) | D_Arrow(i,p1,p2) -> - mkApp (force step_count l_D_Arrow, - [|build_pos (decal i pops); - build_proof pops (size + 2) p1; - build_proof pops (size + 1) p2|]) + mkApp (force step_count l_D_Arrow, + [|build_pos (decal i pops); + build_proof pops (size + 2) p1; + build_proof pops (size + 1) p2|]) | E_False i -> - mkApp (force step_count l_E_False, - [|build_pos (decal i pops)|]) + mkApp (force step_count l_E_False, + [|build_pos (decal i pops)|]) | I_And(p1,p2) -> - mkApp (force step_count l_I_And, - [|build_proof pops size p1; - build_proof pops size p2|]) + mkApp (force step_count l_I_And, + [|build_proof pops size p1; + build_proof pops size p2|]) | E_And(i,p) -> - mkApp (force step_count l_E_And, - [|build_pos (decal i pops); - build_proof pops (size + 2) p|]) + mkApp (force step_count l_E_And, + [|build_pos (decal i pops); + build_proof pops (size + 2) p|]) | D_And(i,p) -> - mkApp (force step_count l_D_And, - [|build_pos (decal i pops); - build_proof pops (size + 1) p|]) + mkApp (force step_count l_D_And, + [|build_pos (decal i pops); + build_proof pops (size + 1) p|]) | I_Or_l(p) -> - mkApp (force step_count l_I_Or_l, - [|build_proof pops size p|]) + mkApp (force step_count l_I_Or_l, + [|build_proof pops size p|]) | I_Or_r(p) -> - mkApp (force step_count l_I_Or_r, - [|build_proof pops size p|]) + mkApp (force step_count l_I_Or_r, + [|build_proof pops size p|]) | E_Or(i,p1,p2) -> - mkApp (force step_count l_E_Or, - [|build_pos (decal i pops); - build_proof pops (size + 1) p1; - build_proof pops (size + 1) p2|]) + mkApp (force step_count l_E_Or, + [|build_pos (decal i pops); + build_proof pops (size + 1) p1; + build_proof pops (size + 1) p2|]) | D_Or(i,p) -> - mkApp (force step_count l_D_Or, - [|build_pos (decal i pops); - build_proof pops (size + 2) p|]) + mkApp (force step_count l_D_Or, + [|build_pos (decal i pops); + build_proof pops (size + 2) p|]) | Pop(d,p) -> - build_proof (add_pop size d pops) size p + build_proof (add_pop size d pops) size p let build_env gamma= List.fold_right (fun (p,_) e -> - mkApp(force node_count l_push,[|mkProp;p;e|])) + mkApp(force node_count l_push,[|mkProp;p;e|])) gamma.env (mkApp (force node_count l_empty,[|mkProp|])) open Goptions diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index e3e787df2c..f1dc63dd9e 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -41,12 +41,12 @@ type protect_flag = Eval|Prot|Rec type protection = Evd.evar_map -> EConstr.t -> GlobRef.t -> (Int.t -> protect_flag) option -let global_head_of_constr sigma c = +let global_head_of_constr sigma c = let f, args = decompose_app sigma c in try fst (Termops.global_of_constr sigma f) with Not_found -> CErrors.anomaly (str "global_head_of_constr.") -let global_of_constr_nofail c = +let global_of_constr_nofail c = try global_of_constr c with Not_found -> GlobRef.VarRef (Id.of_string "dummy") @@ -163,7 +163,7 @@ let ltac_call tac (args:glob_tactic_arg list) = TacArg(CAst.make @@ TacCall (CAst.make (ArgArg(Loc.tag @@ Lazy.force tac),args))) let dummy_goal env sigma = - let (gl,_,sigma) = + let (gl,_,sigma) = Goal.V82.mk_goal sigma (named_context_val env) EConstr.mkProp in {Evd.it = gl; Evd.sigma = sigma} @@ -428,9 +428,9 @@ let op_smorph r add mul req m1 m2 = let ring_equality env evd (r,add,mul,opp,req) = match EConstr.kind !evd req with | App (f, [| _ |]) when eq_constr_nounivs !evd f (Lazy.force coq_eq) -> - let setoid = plapp evd coq_eq_setoid [|r|] in - let op_morph = - match opp with + let setoid = plapp evd coq_eq_setoid [|r|] in + let op_morph = + match opp with Some opp -> plapp evd coq_eq_morph [|r;add;mul;opp|] | None -> plapp evd coq_eq_smorph [|r;add;mul|] in let sigma = !evd in @@ -439,41 +439,41 @@ let ring_equality env evd (r,add,mul,opp,req) = evd := sigma; (setoid,op_morph) | _ -> - let setoid = setoid_of_relation (Global.env ()) evd r req in - let signature = [Some (r,Some req);Some (r,Some req)],Some(r,Some req) in - let add_m, add_m_lem = - try Rewrite.default_morphism signature add + let setoid = setoid_of_relation (Global.env ()) evd r req in + let signature = [Some (r,Some req);Some (r,Some req)],Some(r,Some req) in + let add_m, add_m_lem = + try Rewrite.default_morphism signature add with Not_found -> error "ring addition should be declared as a morphism" in - let mul_m, mul_m_lem = + let mul_m, mul_m_lem = try Rewrite.default_morphism signature mul with Not_found -> error "ring multiplication should be declared as a morphism" in let op_morph = match opp with | Some opp -> - (let opp_m,opp_m_lem = - try Rewrite.default_morphism ([Some(r,Some req)],Some(r,Some req)) opp - with Not_found -> + (let opp_m,opp_m_lem = + try Rewrite.default_morphism ([Some(r,Some req)],Some(r,Some req)) opp + with Not_found -> error "ring opposite should be declared as a morphism" in - let op_morph = - op_morph r add mul opp req add_m_lem mul_m_lem opp_m_lem in - Flags.if_verbose - Feedback.msg_info + let op_morph = + op_morph r add mul opp req add_m_lem mul_m_lem opp_m_lem in + Flags.if_verbose + Feedback.msg_info (str"Using setoid \""++ pr_econstr_env env !evd req++str"\""++spc()++ str"and morphisms \""++pr_econstr_env env !evd add_m_lem ++ str"\","++spc()++ str"\""++pr_econstr_env env !evd mul_m_lem++ str"\""++spc()++str"and \""++pr_econstr_env env !evd opp_m_lem++ - str"\""); - op_morph) + str"\""); + op_morph) | None -> - (Flags.if_verbose - Feedback.msg_info + (Flags.if_verbose + Feedback.msg_info (str"Using setoid \""++pr_econstr_env env !evd req ++str"\"" ++ spc() ++ str"and morphisms \""++pr_econstr_env env !evd add_m_lem ++ - str"\""++spc()++str"and \""++ + str"\""++spc()++str"and \""++ pr_econstr_env env !evd mul_m_lem++str"\""); - op_smorph r add mul req add_m_lem mul_m_lem) in + op_smorph r add mul req add_m_lem mul_m_lem) in (setoid,op_morph) let build_setoid_params env evd r add mul opp req eqth = @@ -519,11 +519,11 @@ let make_hyp env evd c = let make_hyp_list env evdref lH = let evd, carrier = Evarutil.new_global !evdref (Lazy.force coq_hypo) in evdref := evd; - let l = + let l = List.fold_right (fun c l -> plapp evdref coq_cons [|carrier; (make_hyp env evdref c); l|]) lH (plapp evdref coq_nil [|carrier|]) - in + in let sigma, l' = Typing.solve_evars env !evdref l in evdref := sigma; let l' = EConstr.Unsafe.to_constr l' in @@ -609,7 +609,7 @@ let add_theory0 name (sigma, rth) eqth morphth cst_tac (pre,post) power sign div ring_morph = params.(2); ring_th = params.(0); ring_cst_tac = cst_tac; - ring_pow_tac = pow_tac; + ring_pow_tac = pow_tac; ring_lemma1 = lemma1; ring_lemma2 = lemma2; ring_pre_tac = pretac; @@ -867,13 +867,13 @@ let field_equality evd r inv req = let c = EConstr.of_constr c in mkApp(c,[|r;r;inv|]) | _ -> - let _setoid = setoid_of_relation (Global.env ()) evd r req in - let signature = [Some (r,Some req)],Some(r,Some req) in - let inv_m, inv_m_lem = - try Rewrite.default_morphism signature inv + let _setoid = setoid_of_relation (Global.env ()) evd r req in + let signature = [Some (r,Some req)],Some(r,Some req) in + let inv_m, inv_m_lem = + try Rewrite.default_morphism signature inv with Not_found -> error "field inverse should be declared as a morphism" in - inv_m_lem + inv_m_lem let add_field_theory0 name fth eqth morphth cst_tac inj (pre,post) power sign odiv = let open Constr in @@ -904,13 +904,13 @@ let add_field_theory0 name fth eqth morphth cst_tac inj (pre,post) power sign od | None -> params.(7) in let lemma1 = decl_constant (Id.to_string name^"_field_lemma1") ctx lemma1 in - let lemma2 = decl_constant (Id.to_string name^"_field_lemma2") + let lemma2 = decl_constant (Id.to_string name^"_field_lemma2") ctx lemma2 in - let lemma3 = decl_constant (Id.to_string name^"_field_lemma3") + let lemma3 = decl_constant (Id.to_string name^"_field_lemma3") ctx lemma3 in - let lemma4 = decl_constant (Id.to_string name^"_field_lemma4") + let lemma4 = decl_constant (Id.to_string name^"_field_lemma4") ctx lemma4 in - let cond_lemma = decl_constant (Id.to_string name^"_lemma5") + let cond_lemma = decl_constant (Id.to_string name^"_lemma5") ctx cond_lemma in let cst_tac = interp_cst_tac env sigma morphth kind (zero,one,add,mul,opp) cst_tac in diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index dbb60e6712..de3c660938 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -270,7 +270,7 @@ let of_ftactic ftac gl = in (sigma, ans) -let interp_wit wit ist gl x = +let interp_wit wit ist gl x = let globarg = in_gen (glbwit wit) x in let arg = Tacinterp.interp_genarg ist globarg in let (sigma, arg) = of_ftactic arg gl in @@ -350,7 +350,7 @@ let same_prefix s t n = let rec loop i = i = n || s.[i] = t.[i] && loop (i + 1) in loop 0 let skip_digits s = - let n = String.length s in + let n = String.length s in let rec loop i = if i < n && is_digit s.[i] then loop (i + 1) else i in loop let mk_tagged_id t i = Id.of_string (Printf.sprintf "%s%d_" t i) @@ -368,7 +368,7 @@ let wildcard_tag = "_the_" let wildcard_post = "_wildcard_" let mk_wildcard_id i = Id.of_string (Printf.sprintf "%s%s%s" wildcard_tag (CString.ordinal i) wildcard_post) -let has_wildcard_tag s = +let has_wildcard_tag s = let n = String.length s in let m = String.length wildcard_tag in let m' = String.length wildcard_post in n < m + m' + 2 && same_prefix s wildcard_tag m && @@ -440,7 +440,7 @@ let inc_safe n = if n = 0 then n else n + 1 let rec safe_depth s c = match EConstr.kind s c with | LetIn ({binder_name=Name x}, _, _, c') when is_discharged_id x -> safe_depth s c' + 1 | LetIn (_, _, _, c') | Prod (_, _, c') -> inc_safe (safe_depth s c') -| _ -> 0 +| _ -> 0 let red_safe (r : Reductionops.reduction_function) e s c0 = let rec red_to e c n = match EConstr.kind s c with @@ -518,7 +518,7 @@ let resolve_typeclasses ~where ~fail env sigma = sigma -let nf_evar sigma t = +let nf_evar sigma t = EConstr.Unsafe.to_constr (Evarutil.nf_evar sigma (EConstr.of_constr t)) let pf_abs_evars2 gl rigid (sigma, c0) = @@ -535,7 +535,7 @@ let pf_abs_evars2 gl rigid (sigma, c0) = let t = Context.Named.fold_inside abs_dc ~init:concl dc in nf_evar sigma t in let rec put evlist c = match Constr.kind c with - | Evar (k, a) -> + | Evar (k, a) -> if List.mem_assoc k evlist || Evd.mem sigma0 k || List.mem k rigid then evlist else let n = max 0 (Array.length a - nenv) in let t = abs_evar n k in (k, (n, t)) :: put evlist t @@ -561,11 +561,11 @@ let pf_abs_evars gl t = pf_abs_evars2 gl [] t (* As before but if (?i : T(?j)) and (?j : P : Prop), then the lambda for i - * looks like (fun evar_i : (forall pi : P. T(pi))) thanks to "loopP" and all + * looks like (fun evar_i : (forall pi : P. T(pi))) thanks to "loopP" and all * occurrences of evar_i are replaced by (evar_i evar_j) thanks to "app". * * If P can be solved by ssrautoprop (that defaults to trivial), then - * the corresponding lambda looks like (fun evar_i : T(c)) where c is + * the corresponding lambda looks like (fun evar_i : T(c)) where c is * the solution found by ssrautoprop. *) let ssrautoprop_tac = ref (fun gl -> assert false) @@ -596,11 +596,11 @@ let pf_abs_evars_pirrel gl (sigma, c0) = let t = Context.Named.fold_inside abs_dc ~init:concl dc in nf_evar sigma0 (nf_evar sigma t) in let rec put evlist c = match Constr.kind c with - | Evar (k, a) -> + | Evar (k, a) -> if List.mem_assoc k evlist || Evd.mem sigma0 k then evlist else let n = max 0 (Array.length a - nenv) in - let k_ty = - Retyping.get_sort_family_of + let k_ty = + Retyping.get_sort_family_of (pf_env gl) sigma (Evd.evar_concl (Evd.find sigma k)) in let is_prop = k_ty = InProp in let t = abs_evar n k in (k, (n, t, is_prop)) :: put evlist t @@ -610,23 +610,23 @@ let pf_abs_evars_pirrel gl (sigma, c0) = let pr_constr t = Printer.pr_econstr_env (pf_env gl) sigma (Reductionops.nf_beta (pf_env gl) (project gl) (EConstr.of_constr t)) in pp(lazy(str"evlist=" ++ pr_list (fun () -> str";") (fun (k,_) -> Evar.print k) evlist)); - let evplist = - let depev = List.fold_left (fun evs (_,(_,t,_)) -> + let evplist = + let depev = List.fold_left (fun evs (_,(_,t,_)) -> let t = EConstr.of_constr t in Intset.union evs (Evarutil.undefined_evars_of_term sigma t)) Intset.empty evlist in List.filter (fun (i,(_,_,b)) -> b && Intset.mem i depev) evlist in - let evlist, evplist, sigma = + let evlist, evplist, sigma = if evplist = [] then evlist, [], sigma else List.fold_left (fun (ev, evp, sigma) (i, (_,t,_) as p) -> - try + try let ng, sigma = call_on_evar !ssrautoprop_tac i sigma in if (ng <> []) then errorstrm (str "Should we tell the user?"); List.filter (fun (j,_) -> j <> i) ev, evp, sigma with _ -> ev, p::evp, sigma) (evlist, [], sigma) (List.rev evplist) in let c0 = nf_evar sigma c0 in - let evlist = + let evlist = List.map (fun (x,(y,t,z)) -> x,(y,nf_evar sigma t,z)) evlist in - let evplist = + let evplist = List.map (fun (x,(y,t,z)) -> x,(y,nf_evar sigma t,z)) evplist in pp(lazy(str"c0= " ++ pr_constr c0)); let rec lookup k i = function @@ -646,7 +646,7 @@ let pf_abs_evars_pirrel gl (sigma, c0) = let rec loopP evlist c i = function | (_, (n, t, _)) :: evl -> let t = get evlist (i - 1) t in - let n = Name (Id.of_string (ssr_anon_hyp ^ string_of_int n)) in + let n = Name (Id.of_string (ssr_anon_hyp ^ string_of_int n)) in loopP evlist (mkProd (make_annot n Sorts.Relevant, t, c)) (i - 1) evl | [] -> c in let rec loop c i = function @@ -655,8 +655,8 @@ let pf_abs_evars_pirrel gl (sigma, c0) = let t_evplist = List.filter (fun (k,_) -> Intset.mem k evs) evplist in let t = loopP t_evplist (get t_evplist 1 t) 1 t_evplist in let t = get evlist (i - 1) t in - let extra_args = - List.map (fun (k,_) -> mkRel (fst (lookup k i evlist))) + let extra_args = + List.map (fun (k,_) -> mkRel (fst (lookup k i evlist))) (List.rev t_evplist) in let c = if extra_args = [] then c else app extra_args 1 c in loop (mkLambda (make_annot (mk_evar_name n) Sorts.Relevant, t, c)) (i - 1) evl @@ -755,7 +755,7 @@ let pf_abs_prod name gl c cl = pf_mkprod gl c ~name (Termops.subst_term (project (** look up a name in the ssreflect internals module *) let ssrdirpath = DirPath.make [Id.of_string "ssreflect"] -let ssrqid name = Libnames.make_qualid ssrdirpath (Id.of_string name) +let ssrqid name = Libnames.make_qualid ssrdirpath (Id.of_string name) let mkSsrRef name = let qn = Format.sprintf "plugins.ssreflect.%s" name in if Coqlib.has_ref qn then Coqlib.lib_ref qn else @@ -858,7 +858,7 @@ let top_id = mk_internal_id "top assumption" let ssr_n_tac seed n gl = let name = if n = -1 then seed else ("ssr" ^ seed ^ string_of_int n) in let fail msg = CErrors.user_err (Pp.str msg) in - let tacname = + let tacname = try Tacenv.locate_tactic (Libnames.qualid_of_ident (Id.of_string name)) with Not_found -> try Tacenv.locate_tactic (ssrqid name) with Not_found -> @@ -927,13 +927,13 @@ let pf_interp_ty ?(resolve_typeclasses=false) ist gl ty = (* TASSI: given (c : ty), generates (c ??? : ty[???/...]) with m evars *) exception NotEnoughProducts -let saturate ?(beta=false) ?(bi_types=false) env sigma c ?(ty=Retyping.get_type_of env sigma c) m +let saturate ?(beta=false) ?(bi_types=false) env sigma c ?(ty=Retyping.get_type_of env sigma c) m = - let rec loop ty args sigma n = - if n = 0 then + let rec loop ty args sigma n = + if n = 0 then let args = List.rev args in (if beta then Reductionops.whd_beta sigma else fun x -> x) - (EConstr.mkApp (c, Array.of_list (List.map snd args))), ty, args, sigma + (EConstr.mkApp (c, Array.of_list (List.map snd args))), ty, args, sigma else match EConstr.kind_of_type sigma ty with | ProdType (_, src, tgt) -> let sigma = create_evar_defs sigma in @@ -941,7 +941,7 @@ let saturate ?(beta=false) ?(bi_types=false) env sigma c ?(ty=Retyping.get_type_ Evarutil.new_evar env sigma (if bi_types then Reductionops.nf_betaiota env sigma src else src) in loop (EConstr.Vars.subst1 x tgt) ((m - n,x) :: args) sigma (n-1) - | CastType (t, _) -> loop t args sigma n + | CastType (t, _) -> loop t args sigma n | LetInType (_, v, _, t) -> loop (EConstr.Vars.subst1 v t) args sigma n | SortType _ -> assert false | AtomicType _ -> @@ -953,10 +953,10 @@ let saturate ?(beta=false) ?(bi_types=false) env sigma c ?(ty=Retyping.get_type_ in loop ty [] sigma m -let pf_saturate ?beta ?bi_types gl c ?ty m = +let pf_saturate ?beta ?bi_types gl c ?ty m = let env, sigma, si = pf_env gl, project gl, sig_it gl in let t, ty, args, sigma = saturate ?beta ?bi_types env sigma c ?ty m in - t, ty, args, re_sig si sigma + t, ty, args, re_sig si sigma let pf_partial_solution gl t evl = let sigma, g = project gl, sig_it gl in @@ -973,7 +973,7 @@ let dependent_apply_error = * is just like apply, but with a user-provided number n of implicits. * * Refine.refine function that handles type classes and evars but fails to - * handle "dependently typed higher order evars". + * handle "dependently typed higher order evars". * * Refiner.refiner that does not handle metas with a non ground type but works * with dependently typed higher order metas. *) @@ -998,7 +998,7 @@ let applyn ~with_evars ?beta ?(with_shelve=false) ?(first_goes_last=false) n t g let t, gl = if n = 0 then t, gl else let sigma, si = project gl, sig_it gl in let rec loop sigma bo args = function (* saturate with metas *) - | 0 -> EConstr.mkApp (t, Array.of_list (List.rev args)), re_sig si sigma + | 0 -> EConstr.mkApp (t, Array.of_list (List.rev args)), re_sig si sigma | n -> match EConstr.kind sigma bo with | Lambda (_, ty, bo) -> if not (EConstr.Vars.closed0 sigma ty) then @@ -1041,7 +1041,7 @@ let introid ?(orig=ref Anonymous) name = tclTHEN (fun gl -> let g, env = Tacmach.pf_concl gl, pf_env gl in let sigma = project gl in match EConstr.kind sigma g with - | App (hd, _) when EConstr.isLambda sigma hd -> + | App (hd, _) when EConstr.isLambda sigma hd -> Proofview.V82.of_tactic (convert_concl_no_check (Reductionops.whd_beta sigma g)) gl | _ -> tclIDTAC gl) (Proofview.V82.of_tactic @@ -1066,9 +1066,9 @@ let is_pf_var sigma c = let hyp_of_var sigma v = SsrHyp (Loc.tag @@ EConstr.destVar sigma v) let interp_clr sigma = function -| Some clr, (k, c) +| Some clr, (k, c) when (k = xNoFlag || k = xWithAt) && is_pf_var sigma c -> - hyp_of_var sigma c :: clr + hyp_of_var sigma c :: clr | Some clr, _ -> clr | None, _ -> [] @@ -1091,7 +1091,7 @@ let tclDO n tac = let prefix i = str"At iteration " ++ int i ++ str": " in let tac_err_at i gl = try tac gl - with + with | CErrors.UserError (l, s) as e -> let _, info = CErrors.push e in let e' = CErrors.UserError (l, prefix i ++ s) in @@ -1123,7 +1123,7 @@ let pf_interp_gen_aux gl to_ind ((oclr, occ), t) = let pat = interp_cpattern gl t None in (* UGLY API *) let gl = pf_merge_uc_of (fst pat) gl in let cl, env, sigma = Tacmach.pf_concl gl, pf_env gl, project gl in - let (c, ucst), cl = + let (c, ucst), cl = try fill_occ_pattern ~raise_NoMatch:true env sigma (EConstr.Unsafe.to_constr cl) pat occ 1 with NoMatch -> redex_of_pattern env pat, (EConstr.Unsafe.to_constr cl) in let gl = pf_merge_uc ucst gl in @@ -1131,9 +1131,9 @@ let pf_interp_gen_aux gl to_ind ((oclr, occ), t) = let cl = EConstr.of_constr cl in let clr = interp_clr sigma (oclr, (tag_of_cpattern t, c)) in if not(occur_existential sigma c) then - if tag_of_cpattern t = xWithAt then + if tag_of_cpattern t = xWithAt then if not (EConstr.isVar sigma c) then - errorstrm (str "@ can be used with variables only") + errorstrm (str "@ can be used with variables only") else match Tacmach.pf_get_hyp gl (EConstr.destVar sigma c) with | NamedDecl.LocalAssum _ -> errorstrm (str "@ can be used with let-ins only") | NamedDecl.LocalDef (name, b, ty) -> true, pat, EConstr.mkLetIn (map_annot Name.mk_name name,b,ty,cl),c,clr,ucst,gl @@ -1186,7 +1186,7 @@ let gen_tmp_ids push_ctxs ctx (tclTHENLIST (List.map (fun (id,orig_ref) -> - tclTHEN + tclTHEN (gentac ((None,Some(false,[])),cpattern_of_id id)) (rename_hd_prod orig_ref)) ctx.tmp_ids) gl) @@ -1210,7 +1210,7 @@ let pfLIFT f = Proofview.tclUNIT x ;; -(* TASSI: This version of unprotects inlines the unfold tactic definition, +(* TASSI: This version of unprotects inlines the unfold tactic definition, * since we don't want to wipe out let-ins, and it seems there is no flag * to change that behaviour in the standard unfold code *) let unprotecttac gl = @@ -1219,8 +1219,8 @@ let unprotecttac gl = Tacticals.onClause (fun idopt -> let hyploc = Option.map (fun id -> id, InHyp) idopt in Proofview.V82.of_tactic (Tactics.reduct_option ~check:false - (Reductionops.clos_norm_flags - (CClosure.RedFlags.mkflags + (Reductionops.clos_norm_flags + (CClosure.RedFlags.mkflags [CClosure.RedFlags.fBETA; CClosure.RedFlags.fCONST prot; CClosure.RedFlags.fMATCH; @@ -1253,7 +1253,7 @@ let abs_wgen keep_let f gen (gl,args,c) = let x' = make_annot (Name (f x)) (NamedDecl.get_relevance hyp) in let prod = EConstr.mkProd (x', NamedDecl.get_type hyp, EConstr.Vars.subst_var x c) in gl, EConstr.mkVar x :: args, prod - | _, Some ((x, "@"), Some p) -> + | _, Some ((x, "@"), Some p) -> let x = hoi_id x in let cp = interp_cpattern gl p None in let gl = pf_merge_uc_of (fst cp) gl in diff --git a/plugins/ssr/ssrcommon.mli b/plugins/ssr/ssrcommon.mli index db1d2d456e..741db9a6c2 100644 --- a/plugins/ssr/ssrcommon.mli +++ b/plugins/ssr/ssrcommon.mli @@ -38,7 +38,7 @@ val hoi_id : ssrhyp_or_id -> Id.t (******************************* hints ***********************************) -val mk_hint : 'a -> 'a ssrhint +val mk_hint : 'a -> 'a ssrhint val mk_orhint : 'a -> bool * 'a val nullhint : bool * 'a list val nohint : 'a ssrhint @@ -122,7 +122,7 @@ val mkCLambda : ?loc:Loc.t -> Name.t -> constr_expr -> constr_expr -> constr_e val isCHoles : constr_expr list -> bool val isCxHoles : (constr_expr * 'a option) list -> bool -val intern_term : +val intern_term : Tacinterp.interp_sign -> env -> ssrterm -> Glob_term.glob_constr @@ -152,7 +152,7 @@ val pf_e_type_of : Goal.goal Evd.sigma -> EConstr.constr -> Goal.goal Evd.sigma * EConstr.types -val splay_open_constr : +val splay_open_constr : Goal.goal Evd.sigma -> evar_map * EConstr.t -> (Names.Name.t Context.binder_annot * EConstr.t) list * EConstr.t @@ -181,7 +181,7 @@ val mk_evar_name : int -> Name.t val ssr_anon_hyp : string val pf_type_id : Goal.goal Evd.sigma -> EConstr.types -> Id.t -val pf_abs_evars : +val pf_abs_evars : Goal.goal Evd.sigma -> evar_map * EConstr.t -> int * EConstr.t * Evar.t list * @@ -235,7 +235,7 @@ val is_discharged_id : Id.t -> bool val mk_discharged_id : Id.t -> Id.t val is_tagged : string -> string -> bool val has_discharged_tag : string -> bool -val ssrqid : string -> Libnames.qualid +val ssrqid : string -> Libnames.qualid val new_tmp_id : tac_ctx -> (Names.Id.t * Name.t ref) * tac_ctx val mk_anon_id : string -> Id.t list -> Id.t @@ -244,7 +244,7 @@ val pf_abs_evars_pirrel : evar_map * Constr.constr -> int * Constr.constr val nbargs_open_constr : Goal.goal Evd.sigma -> Evd.evar_map * EConstr.t -> int val pf_nbargs : Goal.goal Evd.sigma -> EConstr.t -> int -val gen_tmp_ids : +val gen_tmp_ids : ?ist:Geninterp.interp_sign -> (Goal.goal * tac_ctx) Evd.sigma -> (Goal.goal * tac_ctx) list Evd.sigma diff --git a/plugins/ssr/ssrelim.ml b/plugins/ssr/ssrelim.ml index d0426c86b9..26962ee87b 100644 --- a/plugins/ssr/ssrelim.ml +++ b/plugins/ssr/ssrelim.ml @@ -36,7 +36,7 @@ module RelDecl = Context.Rel.Declaration * checks if the eliminator is recursive or not *) let analyze_eliminator elimty env sigma = let rec loop ctx t = match EConstr.kind_of_type sigma t with - | AtomicType (hd, args) when EConstr.isRel sigma hd -> + | AtomicType (hd, args) when EConstr.isRel sigma hd -> ctx, EConstr.destRel sigma hd, not (EConstr.Vars.noccurn sigma 1 t), Array.length args, t | CastType (t, _) -> loop ctx t | ProdType (x, ty, t) -> loop (RelDecl.LocalAssum (x, ty) :: ctx) t @@ -50,7 +50,7 @@ let analyze_eliminator elimty env sigma = str"the eliminator's"++Pp.cut()++str"type:"++spc()++pr_econstr_env env' sigma elimty) in let ctx, pred_id, elim_is_dep, n_pred_args,concl = loop [] elimty in let n_elim_args = Context.Rel.nhyps ctx in - let is_rec_elim = + let is_rec_elim = let count_occurn n term = let count = ref 0 in let rec occur_rec n c = match EConstr.kind sigma c with @@ -59,7 +59,7 @@ let analyze_eliminator elimty env sigma = in occur_rec n term; !count in let occurr2 n t = count_occurn n t > 1 in - not (List.for_all_i + not (List.for_all_i (fun i (_,rd) -> pred_id <= i || not (occurr2 (pred_id - i) rd)) 1 (assums_of_rel_context ctx)) in @@ -68,7 +68,7 @@ let analyze_eliminator elimty env sigma = let subgoals_tys sigma (relctx, concl) = let rec aux cur_depth acc = function - | hd :: rest -> + | hd :: rest -> let ty = Context.Rel.Declaration.get_type hd in if EConstr.Vars.noccurn sigma cur_depth concl && List.for_all_i (fun i -> function @@ -94,7 +94,7 @@ let subgoals_tys sigma (relctx, concl) = * 1. find the eliminator if not given as ~elim and analyze it * 2. build the patterns to be matched against the conclusion, looking at * (occ, c), deps and the pattern inferred from the type of the eliminator - * 3. build the new predicate matching the patterns, and the tactic to + * 3. build the new predicate matching the patterns, and the tactic to * generalize the equality in case eqid is not None * 4. build the tactic handle instructions and clears as required in ipats and * by eqid *) @@ -131,7 +131,7 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = let is_undef_pat = function | sigma, T t -> EConstr.isEvar sigma (EConstr.of_constr t) | _ -> false in - let match_pat env p occ h cl = + let match_pat env p occ h cl = let sigma0 = project orig_gl in ppdebug(lazy Pp.(str"matching: " ++ pr_occ occ ++ pp_pattern env p)); let (c,ucst), cl = @@ -139,11 +139,11 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = ppdebug(lazy Pp.(str" got: " ++ pr_constr_env env sigma0 c)); c, EConstr.of_constr cl, ucst in let mkTpat gl t = (* takes a term, refreshes it and makes a T pattern *) - let n, t, _, ucst = pf_abs_evars orig_gl (project gl, fire_subst gl t) in + let n, t, _, ucst = pf_abs_evars orig_gl (project gl, fire_subst gl t) in let t, _, _, sigma = saturate ~beta:true env (project gl) t n in Evd.merge_universe_context sigma ucst, T (EConstr.Unsafe.to_constr t) in let unif_redex gl (sigma, r as p) t = (* t is a hint for the redex of p *) - let n, t, _, ucst = pf_abs_evars orig_gl (project gl, fire_subst gl t) in + let n, t, _, ucst = pf_abs_evars orig_gl (project gl, fire_subst gl t) in let t, _, _, sigma = saturate ~beta:true env sigma t n in let sigma = Evd.merge_universe_context sigma ucst in match r with @@ -317,11 +317,11 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = (* if we are the index for the equation we do not clear *) let clr_t = if deps = [] && eqid <> None then [] else clr_t in let p = if is_undef_pat p then mkTpat gl inf_t else p in - loop (patterns @ [i, p, inf_t, occ]) + loop (patterns @ [i, p, inf_t, occ]) (clr_t @ clr) (i+1) (deps, inf_deps) - | [], c :: inf_deps -> + | [], c :: inf_deps -> ppdebug(lazy Pp.(str"adding inf pattern " ++ pr_econstr_pat env (project gl) c)); - loop (patterns @ [i, mkTpat gl c, c, allocc]) + loop (patterns @ [i, mkTpat gl c, c, allocc]) clr (i+1) ([], inf_deps) | _::_, [] -> errorstrm Pp.(str "Too many dependent abstractions") in let deps, head_p, inf_deps_r = match what, c_is_head_p, cty with @@ -332,7 +332,7 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = let occ = if occ = None then allocc else occ in let inf_p, inf_deps_r = List.hd inf_deps_r, List.tl inf_deps_r in deps, [1, pc, inf_p, occ], inf_deps_r in - let patterns, clr, gl = + let patterns, clr, gl = loop [] orig_clr (List.length head_p+1) (List.rev deps, inf_deps_r) in head_p @ patterns, Util.List.uniquize clr, gl in @@ -340,7 +340,7 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = ppdebug(lazy Pp.(pp_concat (str"inf. patterns=") (List.map (pp_inf_pat gl) patterns))); (* Predicate generation, and (if necessary) tactic to generalize the * equation asked by the user *) - let elim_pred, gen_eq_tac, clr, gl = + let elim_pred, gen_eq_tac, clr, gl = let error gl t inf_t = errorstrm Pp.(str"The given pattern matches the term"++ spc()++pp_term gl t++spc()++str"while the inferred pattern"++ spc()++pr_econstr_pat env (project gl) (fire_subst gl inf_t)++spc()++ str"doesn't") in @@ -356,19 +356,19 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = let gl = try pf_unify_HO gl inf_t c with exn when CErrors.noncritical exn -> error gl c inf_t in cl, gl, post - with + with | NoMatch | NoProgress -> let e, ucst = redex_of_pattern env p in let gl = pf_merge_uc ucst gl in let e = EConstr.of_constr e in let n, e, _, _ucst = pf_abs_evars gl (fst p, e) in - let e, _, _, gl = pf_saturate ~beta:true gl e n in + let e, _, _, gl = pf_saturate ~beta:true gl e n in let gl = try pf_unify_HO gl inf_t e with exn when CErrors.noncritical exn -> error gl e inf_t in cl, gl, post - in + in let rec match_all concl gl patterns = - let concl, gl, postponed = + let concl, gl, postponed = List.fold_left match_or_postpone (concl, gl, []) patterns in if postponed = [] then concl, gl else if List.length postponed = List.length patterns then @@ -377,8 +377,8 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = else match_all concl gl postponed in let concl, gl = match_all concl gl patterns in let pred_rctx, _ = EConstr.decompose_prod_assum (project gl) (fire_subst gl predty) in - let concl, gen_eq_tac, clr, gl = match eqid with - | Some (IPatId _) when not is_rec -> + let concl, gen_eq_tac, clr, gl = match eqid with + | Some (IPatId _) when not is_rec -> let k = List.length deps in let c = fire_subst gl (List.assoc (n_elim_args - k - 1) elim_args) in let gl, t = pfe_type_of gl c in @@ -405,7 +405,7 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = | _ -> concl, Tacticals.tclIDTAC, clr, gl in let mk_lam t r = EConstr.mkLambda_or_LetIn r t in let concl = List.fold_left mk_lam concl pred_rctx in - let gl, concl = + let gl, concl = if eqid <> None && is_rec then let gl, concls = pfe_type_of gl concl in let concl, gl = mkProt concls concl gl in @@ -421,10 +421,10 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = let gl = pf_resolve_typeclasses ~where:elim ~fail:false gl in let gl, _ = pf_e_type_of gl elim in (* check that the patterns do not contain non instantiated dependent metas *) - let () = + let () = let evars_of_term = Evarutil.undefined_evars_of_term (project gl) in let patterns = List.map (fun (_,_,t,_) -> fire_subst gl t) patterns in - let patterns_ev = List.map evars_of_term patterns in + let patterns_ev = List.map evars_of_term patterns in let ev = List.fold_left Evar.Set.union Evar.Set.empty patterns_ev in let ty_ev = Evar.Set.fold (fun i e -> let ex = i in @@ -441,7 +441,7 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = end in (* the elim tactic, with the eliminator and the predicated we computed *) - let elim = project gl, elim in + let elim = project gl, elim in let seed = Array.map (fun ty -> let ctx,_ = EConstr.decompose_prod_assum (project gl) ty in @@ -517,7 +517,7 @@ let perform_injection c gl = let cl1 = EConstr.mkLambda EConstr.(make_annot Anonymous Sorts.Relevant, mkArrow eqt Sorts.Relevant cl, mkApp (mkRel 1, [|c_eq|])) in let id = injecteq_id in let id_with_ebind = (EConstr.mkVar id, NoBindings) in - let injtac = Tacticals.tclTHEN (introid id) (injectidl2rtac id id_with_ebind) in + let injtac = Tacticals.tclTHEN (introid id) (injectidl2rtac id id_with_ebind) in Tacticals.tclTHENLAST (Proofview.V82.of_tactic (Tactics.apply (EConstr.compose_lam dc cl1))) injtac gl let ssrscase_or_inj_tac c = Proofview.V82.tactic ~nf_evars:false (fun gl -> diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index 742890637a..cdda84a18d 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -125,8 +125,8 @@ let newssrcongrtac arg ist gl = | Some gl_c -> tclTHEN (Proofview.V82.of_tactic (convert_concl ~check:true (fs gl_c c))) (t_ok (proj gl_c)) gl - | None -> t_fail () gl in - let mk_evar gl ty = + | None -> t_fail () gl in + let mk_evar gl ty = let env, sigma, si = pf_env gl, project gl, sig_it gl in let sigma = Evd.create_evar_defs sigma in let (sigma, x) = Evarutil.new_evar env sigma ty in @@ -174,7 +174,7 @@ let nodocc = mkclr [] let is_rw_cut = function RWred (Cut _) -> true | _ -> false -let mk_rwarg (d, (n, _ as m)) ((clr, occ as docc), rx) (rt, _ as r) : ssrrwarg = +let mk_rwarg (d, (n, _ as m)) ((clr, occ as docc), rx) (rt, _ as r) : ssrrwarg = if rt <> RWeq then begin if rt = RWred Nop && not (m = nomult && occ = None && rx = None) && (clr = None || clr = Some []) then @@ -190,7 +190,7 @@ let mk_rwarg (d, (n, _ as m)) ((clr, occ as docc), rx) (rt, _ as r) : ssrrwarg = let norwmult = L2R, nomult let norwocc = noclr, None -let simplintac occ rdx sim gl = +let simplintac occ rdx sim gl = let simptac m gl = if m <> ~-1 then begin if rdx <> None then @@ -219,7 +219,7 @@ let rec get_evalref env sigma c = match EConstr.kind sigma c with (* Strip a pattern generated by a prenex implicit to its constant. *) let strip_unfold_term _ ((sigma, t) as p) kt = match EConstr.kind sigma t with - | App (f, a) when kt = xNoFlag && Array.for_all (EConstr.isEvar sigma) a && EConstr.isConst sigma f -> + | App (f, a) when kt = xNoFlag && Array.for_all (EConstr.isEvar sigma) a && EConstr.isConst sigma f -> (sigma, f), true | Const _ | Var _ -> p, true | Proj _ -> p, true @@ -235,7 +235,7 @@ let all_ok _ _ = true let fake_pmatcher_end () = mkProp, L2R, (Evd.empty, UState.empty, mkProp) -let unfoldintac occ rdx t (kt,_) gl = +let unfoldintac occ rdx t (kt,_) gl = let fs sigma x = Reductionops.nf_evar sigma x in let sigma0, concl0, env0 = project gl, pf_concl gl, pf_env gl in let (sigma, t), const = strip_unfold_term env0 t kt in @@ -250,18 +250,18 @@ let unfoldintac occ rdx t (kt,_) gl = let ise, u = mk_tpattern env0 sigma0 (ise,EConstr.Unsafe.to_constr t) all_ok L2R (EConstr.Unsafe.to_constr t) in let find_T, end_T = mk_tpattern_matcher ~raise_NoMatch:true sigma0 occ (ise,[u]) in - (fun env c _ h -> + (fun env c _ h -> try find_T env c h ~k:(fun env c _ _ -> EConstr.Unsafe.to_constr (body env t (EConstr.of_constr c))) with NoMatch when easy -> c | NoMatch | NoProgress -> errorstrm Pp.(str"No occurrence of " ++ pr_econstr_pat env sigma0 t ++ spc() ++ str "in " ++ Printer.pr_constr_env env sigma c)), - (fun () -> try end_T () with - | NoMatch when easy -> fake_pmatcher_end () + (fun () -> try end_T () with + | NoMatch when easy -> fake_pmatcher_end () | NoMatch -> anomaly "unfoldintac") - | _ -> + | _ -> (fun env (c as orig_c) _ h -> if const then - let rec aux c = + let rec aux c = match EConstr.kind sigma0 c with | Const _ when EConstr.eq_constr sigma0 c t -> body env t t | App (f,a) when EConstr.eq_constr sigma0 f t -> EConstr.mkApp (body env f f,a) @@ -282,15 +282,15 @@ let unfoldintac occ rdx t (kt,_) gl = with _ -> errorstrm Pp.(str "The term " ++ pr_constr_env env sigma c ++spc()++ str "does not unify with " ++ pr_econstr_pat env sigma t)), fake_pmatcher_end in - let concl = + let concl = let concl0 = EConstr.Unsafe.to_constr concl0 in - try beta env0 (EConstr.of_constr (eval_pattern env0 sigma0 concl0 rdx occ unfold)) + try beta env0 (EConstr.of_constr (eval_pattern env0 sigma0 concl0 rdx occ unfold)) with Option.IsNone -> errorstrm Pp.(str"Failed to unfold " ++ pr_econstr_pat env0 sigma t) in let _ = conclude () in Proofview.V82.of_tactic (convert_concl ~check:true concl) gl ;; -let foldtac occ rdx ft gl = +let foldtac occ rdx ft gl = let sigma0, concl0, env0 = project gl, pf_concl gl, pf_env gl in let sigma, t = ft in let t = EConstr.to_constr ~abort_on_undefined_evars:false sigma t in @@ -303,7 +303,7 @@ let foldtac occ rdx ft gl = mk_tpattern_matcher ~raise_NoMatch:true sigma0 occ (ise,[ut]) in (fun env c _ h -> try find_T env c h ~k:(fun env t _ _ -> t) with NoMatch ->c), (fun () -> try end_T () with NoMatch -> fake_pmatcher_end ()) - | _ -> + | _ -> (fun env c _ h -> try let sigma = unify_HO env sigma (EConstr.of_constr c) (EConstr.of_constr t) in @@ -371,12 +371,12 @@ let pirrel_rewrite ?(under=false) ?(map_redex=id_map_redex) pred rdx rdx_ty new_ in ppdebug(lazy Pp.(str"pirrel_rewrite: proof term: " ++ pr_econstr_env env sigma proof)); ppdebug(lazy Pp.(str"pirrel_rewrite of type: " ++ pr_econstr_env env sigma proof_ty)); - try refine_with + try refine_with ~first_goes_last:(not !ssroldreworder || under) ~with_evars:under (sigma, proof) gl - with _ -> + with _ -> (* we generate a msg like: "Unable to find an instance for the variable" *) let hd_ty, miss = match EConstr.kind sigma c with - | App (hd, args) -> + | App (hd, args) -> let hd_ty = Retyping.get_type_of env sigma hd in let names = let rec aux t = function 0 -> [] | n -> let t = Reductionops.whd_all env sigma t in @@ -409,7 +409,7 @@ let rwcltac ?under ?map_redex cl rdx dir sr gl = (* ppdebug(lazy(str"sigma@rwcltac=" ++ pr_evar_map None (fst sr))); *) ppdebug(lazy Pp.(str"r@rwcltac=" ++ pr_econstr_env (pf_env gl) (project gl) (snd sr))); let cvtac, rwtac, gl = - if EConstr.Vars.closed0 (project gl) r' then + if EConstr.Vars.closed0 (project gl) r' then let env, sigma, c, c_eq = pf_env gl, fst sr, snd sr, Coqlib.(lib_ref "core.eq.type") in let sigma, c_ty = Typing.type_of env sigma c in ppdebug(lazy Pp.(str"c_ty@rwcltac=" ++ pr_econstr_env env sigma c_ty)); @@ -417,14 +417,14 @@ let rwcltac ?under ?map_redex cl rdx dir sr gl = | AtomicType(e, a) when Ssrcommon.is_ind_ref sigma e c_eq -> let new_rdx = if dir = L2R then a.(2) else a.(1) in pirrel_rewrite ?under ?map_redex cl rdx rdxt new_rdx dir (sigma,c) c_ty, tclIDTAC, gl - | _ -> + | _ -> let cl' = EConstr.mkApp (EConstr.mkNamedLambda (make_annot pattern_id Sorts.Relevant) rdxt cl, [|rdx|]) in let sigma, _ = Typing.type_of env sigma cl' in let gl = pf_merge_uc_of sigma gl in Proofview.V82.of_tactic (convert_concl ~check:true cl'), rewritetac ?under dir r', gl else let dc, r2 = EConstr.decompose_lam_n_assum (project gl) n r' in - let r3, _, r3t = + let r3, _, r3t = try EConstr.destCast (project gl) r2 with _ -> errorstrm Pp.(str "no cast from " ++ pr_econstr_pat (pf_env gl) (project gl) (snd sr) ++ str " to " ++ pr_econstr_env (pf_env gl) (project gl) r2) in @@ -471,7 +471,7 @@ let ssr_is_setoid env = | None -> fun _ _ _ -> false | Some srel -> fun sigma r args -> - Rewrite.is_applied_rewrite_relation env + Rewrite.is_applied_rewrite_relation env sigma [] (EConstr.mkApp (r, args)) <> None let closed0_check cl p gl = @@ -585,7 +585,7 @@ let rwrxtac ?under ?map_redex occ rdx_pat dir rule gl = sigma, pats @ [pat] in let rpats = List.fold_left (rpat env0 sigma0) (r_sigma,[]) rules in let find_R, end_R = mk_tpattern_matcher sigma0 occ ~upats_origin rpats in - (fun e c _ i -> find_R ~k:(fun _ _ _ h -> mkRel h) e c i), + (fun e c _ i -> find_R ~k:(fun _ _ _ h -> mkRel h) e c i), fun cl -> let rdx,d,r = end_R () in closed0_check cl rdx gl; (d,r),rdx | Some(_, (T e | X_In_T (_,e) | E_As_X_In_T (e,_,_) | E_In_X_In_T (e,_,_))) -> let r = ref None in @@ -633,7 +633,7 @@ let rwargtac ?under ?map_redex ist ((dir, mult), (((oclr, occ), grx), (kind, gt) let interp gc gl = try interp_term ist gl gc with _ when snd mult = May -> fail := true; (project gl, EConstr.mkProp) in - let rwtac gl = + let rwtac gl = let rx = Option.map (interp_rpattern gl) grx in let gl = match rx with | None -> gl @@ -672,6 +672,6 @@ let unlocktac ist args gl = let locked, gl = pf_mkSsrConst "locked" gl in let key, gl = pf_mkSsrConst "master_key" gl in let ktacs = [ - (fun gl -> unfoldtac None None (project gl,locked) xInParens gl); + (fun gl -> unfoldtac None None (project gl,locked) xInParens gl); Proofview.V82.of_tactic (Ssrelim.casetac key (fun ?seed:_ k -> k)) ] in tclTHENLIST (List.map utac args @ ktacs) gl diff --git a/plugins/ssr/ssrfwd.ml b/plugins/ssr/ssrfwd.ml index b0f56c423f..f486d1e457 100644 --- a/plugins/ssr/ssrfwd.ml +++ b/plugins/ssr/ssrfwd.ml @@ -42,7 +42,7 @@ let ssrsettac id ((_, (pat, pty)), (_, occ)) gl = (mkRHole, Some body), ist) pty in let pat = interp_cpattern gl pat pty in let cl, sigma, env = pf_concl gl, project gl, pf_env gl in - let (c, ucst), cl = + let (c, ucst), cl = let cl = EConstr.Unsafe.to_constr cl in try fill_occ_pattern ~raise_NoMatch:true env sigma cl pat occ 1 with NoMatch -> redex_of_pattern ~resolve_typeclasses:true env pat, cl in @@ -77,8 +77,8 @@ let () = }) -open Constrexpr -open Glob_term +open Constrexpr +open Glob_term let combineCG t1 t2 f g = match t1, t2 with | (x, (t1, None)), (_, (t2, None)) -> x, (g t1 t2, None) @@ -96,7 +96,7 @@ let introstac ipats = Proofview.V82.of_tactic (tclIPAT ipats) let havetac ist (transp,((((clr, orig_pats), binders), simpl), (((fk, _), t), hint))) - suff namefst gl + suff namefst gl = let concl = pf_concl gl in let pats = tclCompileIPats orig_pats in @@ -195,7 +195,7 @@ let havetac ist | _,false,true -> let _, ty, uc = interp_ty gl fixtc cty in let gl = pf_merge_uc uc gl in gl, EConstr.mkArrow ty Sorts.Relevant concl, hint, id, itac_c - | _, false, false -> + | _, false, false -> let n, cty, uc = interp_ty gl fixtc cty in let gl = pf_merge_uc uc gl in gl, cty, Tacticals.tclTHEN (binderstac n) hint, id, Tacticals.tclTHEN itac_c simpltac | _, true, false -> assert false in @@ -260,7 +260,7 @@ let wlogtac ist (((clr0, pats),_),_) (gens, ((_, ct))) hint suff ghave gl = | _ -> CErrors.anomaly(str"SSR: wlog: pired: " ++ pr_econstr_env env sigma c) in c, args, pired c args, pf_merge_uc uc gl in let tacipat pats = introstac pats in - let tacigens = + let tacigens = Tacticals.tclTHEN (Tacticals.tclTHENLIST(List.rev(List.fold_right mkclr gens [old_cleartac clr0]))) (introstac (List.fold_right mkpats gens [])) in diff --git a/plugins/ssr/ssrparser.mlg b/plugins/ssr/ssrparser.mlg index a1f707ffa8..22325f3fc3 100644 --- a/plugins/ssr/ssrparser.mlg +++ b/plugins/ssr/ssrparser.mlg @@ -167,7 +167,7 @@ let pr_name = function Name id -> pr_id id | Anonymous -> str "_" let pr_spc () = str " " let pr_list = prlist_with_sep -(**************************** ssrhyp **************************************) +(**************************** ssrhyp **************************************) let pr_ssrhyp _ _ _ = pr_hyp @@ -279,7 +279,7 @@ let negate_parser f tok x = let rc = try Some (f tok x) with Stream.Failure -> None in match rc with | None -> () - | Some _ -> raise Stream.Failure + | Some _ -> raise Stream.Failure let test_not_ssrslashnum = Pcoq.Entry.of_parser @@ -612,10 +612,10 @@ let ipat_of_intro_pattern p = Tactypes.( | IntroAction IntroWildcard -> IPatAnon Drop | IntroAction (IntroOrAndPattern (IntroOrPattern iorpat)) -> IPatCase (Regular( - List.map (List.map ipat_of_intro_pattern) - (List.map (List.map remove_loc) iorpat))) + List.map (List.map ipat_of_intro_pattern) + (List.map (List.map remove_loc) iorpat))) | IntroAction (IntroOrAndPattern (IntroAndPattern iandpat)) -> - IPatCase + IPatCase (Regular [List.map ipat_of_intro_pattern (List.map remove_loc iandpat)]) | IntroNaming IntroAnonymous -> IPatAnon (One None) | IntroAction (IntroRewrite b) -> IPatRewrite (allocc, if b then L2R else R2L) @@ -688,7 +688,7 @@ let rec add_intro_pattern_hyps ipat hyps = | IntroAction (IntroRewrite _) -> hyps | IntroAction (IntroInjection ips) -> List.fold_right add_intro_pattern_hyps ips hyps | IntroAction (IntroApplyOn (c,pat)) -> add_intro_pattern_hyps pat hyps - | IntroForthcoming _ -> + | IntroForthcoming _ -> (* As in ipat_of_intro_pattern, was unable to determine which kind of ipat interp_introid could return [HH] *) assert false @@ -890,12 +890,12 @@ let check_ssrhpats loc w_binders ipats = let err_loc s = CErrors.user_err ~loc ~hdr:"ssreflect" s in let clr, ipats = let opt_app = function None -> fun l -> Some l - | Some l1 -> fun l2 -> Some (l1 @ l2) in + | Some l1 -> fun l2 -> Some (l1 @ l2) in let rec aux clr = function | IPatClear cl :: tl -> aux (opt_app clr cl) tl | tl -> clr, tl in aux None ipats in - let simpl, ipats = + let simpl, ipats = match List.rev ipats with | IPatSimpl _ as s :: tl -> [s], List.rev tl | _ -> [], ipats in @@ -906,7 +906,7 @@ let check_ssrhpats loc w_binders ipats = | [] -> ipat, [] | ( IPatId _| IPatAnon _| IPatCase _ | IPatDispatch _ | IPatRewrite _ as i) :: tl -> if w_binders then - if simpl <> [] && tl <> [] then + if simpl <> [] && tl <> [] then err_loc(str"binders XOR s-item allowed here: "++pr_ipats(tl@simpl)) else if not (List.for_all (function IPatId _ -> true | _ -> false) tl) then err_loc (str "Only binders allowed here: " ++ pr_ipats tl) @@ -939,7 +939,7 @@ ARGUMENT EXTEND ssrhpats_wtransp | [ ssripats(i) "@" ssripats(j) ] -> { true,check_ssrhpats loc true (i @ j) } END -ARGUMENT EXTEND ssrhpats_nobs +ARGUMENT EXTEND ssrhpats_nobs TYPED AS (((ssrclear option * ssripats) * ssripats) * ssripats) PRINTED BY { pr_ssrhpats } | [ ssripats(i) ] -> { check_ssrhpats loc false i } END @@ -1019,7 +1019,7 @@ GRAMMAR EXTEND Gram ssrfwdid: [[ test_ssrfwdid; id = Prim.ident -> { id } ]]; END - + (* by *) (** Tactical arguments. *) @@ -1109,7 +1109,7 @@ END open Ssrmatching_plugin.Ssrmatching open Ssrmatching_plugin.G_ssrmatching -let pr_wgen = function +let pr_wgen = function | (clr, Some((id,k),None)) -> spc() ++ pr_clear mt clr ++ str k ++ pr_hoi id | (clr, Some((id,k),Some p)) -> spc() ++ pr_clear mt clr ++ str"(" ++ str k ++ pr_hoi id ++ str ":=" ++ @@ -1152,7 +1152,7 @@ let pr_ssrclausehyps _ _ _ = pr_clausehyps } -ARGUMENT EXTEND ssrclausehyps +ARGUMENT EXTEND ssrclausehyps TYPED AS ssrwgen list PRINTED BY { pr_ssrclausehyps } | [ ssrwgen(hyp) "," ssrclausehyps(hyps) ] -> { hyp :: hyps } | [ ssrwgen(hyp) ssrclausehyps(hyps) ] -> { hyp :: hyps } @@ -1163,7 +1163,7 @@ END (* type ssrclauses = ssrahyps * ssrclseq *) -let pr_clauses (hyps, clseq) = +let pr_clauses (hyps, clseq) = if clseq = InGoal then mt () else str "in " ++ pr_clausehyps hyps ++ pr_clseq clseq let pr_ssrclauses _ _ _ = pr_clauses @@ -1215,7 +1215,7 @@ let rec format_local_binders h0 bl0 = match h0, bl0 with | BFdef :: h, CLocalDef ({CAst.v=x}, v, oty) :: bl -> Bdef (x, oty, v) :: format_local_binders h bl | _ -> [] - + let rec format_constr_expr h0 c0 = let open CAst in match h0, c0 with | BFvar :: h, { v = CLambdaN ([CLocalAssum([{CAst.v=x}], _, _)], c) } -> let bs, c' = format_constr_expr h c in @@ -1228,11 +1228,11 @@ let rec format_constr_expr h0 c0 = let open CAst in match h0, c0 with Bdef (x, oty, v) :: bs, c' | [BFcast], { v = CCast (c, Glob_term.CastConv t) } -> [Bcast t], c - | BFrec (has_str, has_cast) :: h, + | BFrec (has_str, has_cast) :: h, { v = CFix ( _, [_, Some {CAst.v = CStructRec locn}, bl, t, c]) } -> let bs = format_local_binders h bl in let bstr = if has_str then [Bstruct (Name locn.CAst.v)] else [] in - bs @ bstr @ (if has_cast then [Bcast t] else []), c + bs @ bstr @ (if has_cast then [Bcast t] else []), c | BFrec (_, has_cast) :: h, { v = CCoFix ( _, [_, bl, t, c]) } -> format_local_binders h bl @ (if has_cast then [Bcast t] else []), c | _, c -> @@ -1516,7 +1516,7 @@ END { -let intro_id_to_binder = List.map (function +let intro_id_to_binder = List.map (function | IPatId id -> let { CAst.loc=xloc } as x = bvar_lname (mkCVar id) in (FwdPose, [BFvar]), @@ -1687,7 +1687,7 @@ let ssr_null_entry = Pcoq.Entry.of_parser "ssr_null" (fun _ _ -> ()) } -GRAMMAR EXTEND Gram +GRAMMAR EXTEND Gram GLOBAL: Prim.ident; Prim.ident: [[ s = IDENT; ssr_null_entry -> { ssr_id_of_string loc s } ]]; END @@ -1756,8 +1756,8 @@ END { let ssrautoprop gl = - try - let tacname = + try + let tacname = try Tacenv.locate_tactic (qualid_of_ident (Id.of_string "ssrautoprop")) with Not_found -> Tacenv.locate_tactic (ssrqid "ssrautoprop") in let tacexpr = CAst.make @@ Tacexpr.Reference (ArgArg (Loc.tag @@ tacname)) in @@ -2168,7 +2168,7 @@ let pr_ssraarg _ _ _ (view, (dgens, ipats)) = } -ARGUMENT EXTEND ssrapplyarg +ARGUMENT EXTEND ssrapplyarg TYPED AS (ssrbwdview * (ssragens * ssrintros)) PRINTED BY { pr_ssraarg } | [ ":" ssragen(gen) ssragens(dgens) ssrintros(intros) ] -> @@ -2567,7 +2567,7 @@ ARGUMENT EXTEND ssrwlogfwd TYPED AS (ssrwgen list * ssrfwd) | [ ":" ssrwgen_list(gens) "/" ast_closure_lterm(t) ] -> { gens, mkFwdHint "/" t} END - + TACTIC EXTEND ssrwlog | [ "wlog" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> { V82.tactic (wlogtac ist pats fwd hint false `NoGen) } @@ -2589,13 +2589,13 @@ TACTIC EXTEND ssrwithoutloss END TACTIC EXTEND ssrwithoutlosss -| [ "without" "loss" "suff" +| [ "without" "loss" "suff" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> { V82.tactic (wlogtac ist pats fwd hint true `NoGen) } END TACTIC EXTEND ssrwithoutlossss -| [ "without" "loss" "suffices" +| [ "without" "loss" "suffices" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ]-> { V82.tactic (wlogtac ist pats fwd hint true `NoGen) } END @@ -2627,7 +2627,7 @@ let test_idcomma = Pcoq.Entry.of_parser "test_idcomma" accept_idcomma GRAMMAR EXTEND Gram GLOBAL: ssr_idcomma; - ssr_idcomma: [ [ test_idcomma; + ssr_idcomma: [ [ test_idcomma; ip = [ id = IDENT -> { Some (Id.of_string id) } | "_" -> { None } ]; "," -> { Some ip } ] ]; diff --git a/plugins/ssr/ssrprinters.mli b/plugins/ssr/ssrprinters.mli index e4df7399e1..240b1a5476 100644 --- a/plugins/ssr/ssrprinters.mli +++ b/plugins/ssr/ssrprinters.mli @@ -17,7 +17,7 @@ val pp_term : val pr_spc : unit -> Pp.t val pr_bar : unit -> Pp.t -val pr_list : +val pr_list : (unit -> Pp.t) -> ('a -> Pp.t) -> 'a list -> Pp.t val pp_concat : diff --git a/plugins/ssr/ssrtacticals.ml b/plugins/ssr/ssrtacticals.ml index cd2448d764..0fc05f58d3 100644 --- a/plugins/ssr/ssrtacticals.ml +++ b/plugins/ssr/ssrtacticals.ml @@ -109,7 +109,7 @@ let endclausestac id_map clseq gl_id cl0 gl = EConstr.mkLetIn ({na with binder_name=Name (orig_id id)}, unmark v, unmark t, unmark c') | _ -> EConstr.map (project gl) unmark c in let utac hyp = - Proofview.V82.of_tactic + Proofview.V82.of_tactic (Tactics.convert_hyp ~check:false ~reorder:false (NamedDecl.map_constr unmark hyp)) in let utacs = List.map utac (pf_hyps gl) in let ugtac gl' = diff --git a/plugins/ssr/ssrvernac.mlg b/plugins/ssr/ssrvernac.mlg index 064ea0a3e3..9f6fe0e651 100644 --- a/plugins/ssr/ssrvernac.mlg +++ b/plugins/ssr/ssrvernac.mlg @@ -104,7 +104,7 @@ GRAMMAR EXTEND Gram [ "if"; c = operconstr LEVEL "200"; "is"; db1 = ssr_dthen; b2 = ssr_else -> { let b1, ct, rt = db1 in CAst.make ~loc @@ CCases (MatchStyle, rt, [mk_pat c ct], [b1; b2]) } | "if"; c = operconstr LEVEL "200";"isn't";db1 = ssr_dthen; b2 = ssr_else -> - { let b1, ct, rt = db1 in + { let b1, ct, rt = db1 in let b1, b2 = let open CAst in let {loc=l1; v=(p1, r1)}, {loc=l2; v=(p2, r2)} = b1, b2 in (make ?loc:l1 (p1, r2), make ?loc:l2 (p2, r1)) @@ -147,7 +147,7 @@ END let declare_one_prenex_implicit locality f = let fref = - try Smartlocate.global_with_alias f + try Smartlocate.global_with_alias f with _ -> errorstrm (pr_qualid f ++ str " is not declared") in let rec loop = function | a :: args' when Impargs.is_status_implicit a -> @@ -340,7 +340,7 @@ END (* Main type conclusion pattern filter *) -let rec splay_search_pattern na = function +let rec splay_search_pattern na = function | Pattern.PApp (fp, args) -> splay_search_pattern (na + Array.length args) fp | Pattern.PLetIn (_, _, _, bp) -> splay_search_pattern na bp | Pattern.PRef hr -> hr, na @@ -364,11 +364,11 @@ let coerce_search_pattern_to_sort hpat = if np < na then CErrors.user_err (Pp.str "too many arguments in head search pattern") else let hpat' = if np = na then hpat else mkPApp hpat (np - na) [||] in let warn () = - Feedback.msg_warning (str "Listing only lemmas with conclusion matching " ++ + Feedback.msg_warning (str "Listing only lemmas with conclusion matching " ++ pr_constr_pattern_env env sigma hpat') in if EConstr.isSort sigma ht then begin warn (); true, hpat' end else let filter_head, coe_path = - try + try let _, cp = Classops.lookup_path_to_sort_from (push_rels_assum dc env) sigma ht in warn (); diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index 9682487a22..6cb464918a 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -310,7 +310,7 @@ let pf_unify_HO gl t1 t2 = (* This is what the definition of iter_constr should be... *) let iter_constr_LR f c = match kind c with | Evar (k, a) -> Array.iter f a - | Cast (cc, _, t) -> f cc; f t + | Cast (cc, _, t) -> f cc; f t | Prod (_, t, b) | Lambda (_, t, b) -> f t; f b | LetIn (_, v, t, b) -> f v; f t; f b | App (cf, a) -> f cf; Array.iter f a @@ -423,10 +423,10 @@ let mk_tpattern ?p_origin ?(hack=false) env sigma0 (ise, t) ok dir p = | Var _ | Ind _ | Construct _ -> KpatFixed, f, a | Evar (k, _) -> if Evd.mem sigma0 k then KpatEvar k, f, a else - if a <> [] then KpatFlex, f, a else + if a <> [] then KpatFlex, f, a else (match p_origin with None -> CErrors.user_err Pp.(str "indeterminate pattern") | Some (dir, rule) -> - errorstrm (str "indeterminate " ++ pr_dir_side dir + errorstrm (str "indeterminate " ++ pr_dir_side dir ++ str " in " ++ pr_constr_pat env ise rule)) | LetIn (_, v, _, b) -> if b <> mkRel 1 then KpatLet, f, a else KpatFlex, v, a @@ -435,7 +435,7 @@ let mk_tpattern ?p_origin ?(hack=false) env sigma0 (ise, t) ok dir p = let aa = Array.of_list a in let ise', p' = evars_for_FO ~hack env sigma0 ise (mkApp (f, aa)) in ise', - { up_k = k; up_FO = p'; up_f = f; + { up_k = k; up_FO = p'; up_f = f; up_a = aa; up_ok = ok; up_dir = dir; up_t = t} (* Specialize a pattern after a successful match: assign a precise head *) @@ -462,7 +462,7 @@ let nb_cs_proj_args pc f u = try match kind f with | Prod _ -> na Prod_cs | Sort s -> na (Sort_cs (Sorts.family s)) - | Const (c',_) when Constant.equal c' pc -> nargs_of_proj u.up_f + | Const (c',_) when Constant.equal c' pc -> nargs_of_proj u.up_f | Proj (c',_) when Constant.equal (Projection.constant c') pc -> nargs_of_proj u.up_f | Var _ | Ind _ | Construct _ | Const _ -> na (Const_cs (global_of_constr f)) | _ -> -1 @@ -636,15 +636,15 @@ let match_upats_HO ~on_instance upats env sigma0 ise c = let fixed_upat evd = function -| {up_k = KpatFlex | KpatEvar _ | KpatProj _} -> false +| {up_k = KpatFlex | KpatEvar _ | KpatProj _} -> false | {up_t = t} -> not (occur_existential evd (EConstr.of_constr t)) (** FIXME *) let do_once r f = match !r with Some _ -> () | None -> r := Some (f ()) -let assert_done r = +let assert_done r = match !r with Some x -> x | None -> CErrors.anomaly (str"do_once never called.") -let assert_done_multires r = +let assert_done_multires r = match !r with | None -> CErrors.anomaly (str"do_once never called.") | Some (e, n, xs) -> @@ -652,7 +652,7 @@ let assert_done_multires r = try List.nth xs n with Failure _ -> raise NoMatch type subst = Environ.env -> constr -> constr -> int -> constr -type find_P = +type find_P = Environ.env -> constr -> int -> k:subst -> constr @@ -677,7 +677,7 @@ let mk_tpattern_matcher ?(all_instances=false) if !nocc = max_occ then skip_occ := use_occ; if !nocc <= max_occ then occ_set.(!nocc - 1) else not use_occ in let upat_that_matched = ref None in - let match_EQ env sigma u = + let match_EQ env sigma u = match u.up_k with | KpatLet -> let x, pv, t, pb = destLetIn u.up_f in @@ -693,14 +693,14 @@ let mk_tpattern_matcher ?(all_instances=false) | Lambda _ -> unif_EQ env sigma u.up_f c | _ -> false) | _ -> unif_EQ env sigma u.up_f in -let p2t p = mkApp(p.up_f,p.up_a) in +let p2t p = mkApp(p.up_f,p.up_a) in let source env = match upats_origin, upats with - | None, [p] -> + | None, [p] -> (if fixed_upat ise p then str"term " else str"partial term ") ++ pr_constr_pat env ise (p2t p) ++ spc() - | Some (dir,rule), [p] -> str"The " ++ pr_dir_side dir ++ str" of " ++ + | Some (dir,rule), [p] -> str"The " ++ pr_dir_side dir ++ str" of " ++ pr_constr_pat env ise rule ++ fnl() ++ ws 4 ++ pr_constr_pat env ise (p2t p) ++ fnl() - | Some (dir,rule), _ -> str"The " ++ pr_dir_side dir ++ str" of " ++ + | Some (dir,rule), _ -> str"The " ++ pr_dir_side dir ++ str" of " ++ pr_constr_pat env ise rule ++ spc() | _, [] | None, _::_::_ -> CErrors.anomaly (str"mk_tpattern_matcher with no upats_origin.") in @@ -724,8 +724,8 @@ let rec uniquize = function equal f f1 && CArray.for_all2 equal a a1) in x :: uniquize (List.filter neq xs) in -((fun env c h ~k -> - do_once upat_that_matched (fun () -> +((fun env c h ~k -> + do_once upat_that_matched (fun () -> let failed_because_of_TC = ref false in try if not all_instances then match_upats_FO upats env sigma0 ise c; @@ -789,14 +789,14 @@ let rec uniquize = function ws 4 ++ pr_constr_pat env sigma p' ++ fnl () ++ str"of " ++ pr_constr_pat env sigma rule)) : conclude) -type ('ident, 'term) ssrpattern = +type ('ident, 'term) ssrpattern = | T of 'term | In_T of 'term - | X_In_T of 'ident * 'term - | In_X_In_T of 'ident * 'term - | E_In_X_In_T of 'term * 'ident * 'term - | E_As_X_In_T of 'term * 'ident * 'term - + | X_In_T of 'ident * 'term + | In_X_In_T of 'ident * 'term + | E_In_X_In_T of 'term * 'ident * 'term + | E_As_X_In_T of 'term * 'ident * 'term + let pr_pattern = function | T t -> prl_term t | In_T t -> str "in " ++ prl_term t @@ -944,7 +944,7 @@ let of_ftactic ftac gl = in (sigma, ans) -let interp_wit wit ist gl x = +let interp_wit wit ist gl x = let globarg = in_gen (glbwit wit) x in let arg = interp_genarg ist globarg in let (sigma, arg) = of_ftactic arg gl in @@ -1026,9 +1026,9 @@ let interp_pattern ?wit_ssrpatternarg gl red redty = | Evar (k,_) -> if k = h_k || List.mem k acc || Evd.mem sigma0 k then acc else (update k; k::acc) - | _ -> CoqConstr.fold aux acc t in + | _ -> CoqConstr.fold aux acc t in aux [] (nf_evar sigma rp) in - let sigma = + let sigma = List.fold_left (fun sigma e -> if Evd.is_defined sigma e then sigma else (* clear may be recursive *) if Option.is_empty !to_clean then sigma else @@ -1128,7 +1128,7 @@ let eval_pattern ?raise_NoMatch env0 sigma0 concl0 pattern occ do_subst = str " did not instantiate ?" ++ int (Evar.repr e) ++ spc () ++ str "Does the variable bound by the \"in\" construct occur "++ str "in the pattern?") in - let sigma = + let sigma = Evd.add (Evd.remove sigma e) e {e_def with Evd.evar_body = Evar_empty} in sigma, e_body in let ex_value hole = @@ -1138,7 +1138,7 @@ let eval_pattern ?raise_NoMatch env0 sigma0 concl0 pattern occ do_subst = sigma, [pat] in match pattern with | None -> do_subst env0 concl0 concl0 1, UState.empty - | Some (sigma, (T rp | In_T rp)) -> + | Some (sigma, (T rp | In_T rp)) -> let rp = fs sigma rp in let ise = create_evar_defs sigma in let occ = match pattern with Some (_, T _) -> occ | _ -> noindex in @@ -1159,7 +1159,7 @@ let eval_pattern ?raise_NoMatch env0 sigma0 concl0 pattern occ do_subst = let concl = find_T env0 concl0 1 ~k:(fun env c _ h -> let p_sigma = unify_HO env (create_evar_defs sigma) (EConstr.of_constr c) (EConstr.of_constr p) in let sigma, e_body = pop_evar p_sigma ex p in - fs p_sigma (find_X env (fs sigma p) h + fs p_sigma (find_X env (fs sigma p) h ~k:(fun env _ -> do_subst env e_body))) in let _ = end_X () in let _, _, (_, us, _) = end_T () in concl, us @@ -1183,7 +1183,7 @@ let eval_pattern ?raise_NoMatch env0 sigma0 concl0 pattern occ do_subst = | Some (sigma, E_As_X_In_T (e, hole, p)) -> let p, e = fs sigma p, fs sigma e in let ex = ex_value hole in - let rp = + let rp = let e_sigma = unify_HO env0 sigma (EConstr.of_constr hole) (EConstr.of_constr e) in e_sigma, fs e_sigma p in let rp = mk_upat_for ~hack:true env0 sigma0 rp all_ok in @@ -1227,7 +1227,7 @@ let fill_occ_pattern ?raise_NoMatch env sigma cl pat occ h = ;; (* clenup interface for external use *) -let mk_tpattern ?p_origin env sigma0 sigma_t f dir c = +let mk_tpattern ?p_origin env sigma0 sigma_t f dir c = mk_tpattern ?p_origin env sigma0 sigma_t f dir c ;; @@ -1275,7 +1275,7 @@ let is_wildcard ((_, (l, r), _) : cpattern) : bool = match DAst.get l, r with (* "ssrpattern" *) let pr_rpattern = pr_pattern - + let pf_merge_uc uc gl = re_sig (sig_it gl) (Evd.merge_universe_context (project gl) uc) diff --git a/plugins/ssrmatching/ssrmatching.mli b/plugins/ssrmatching/ssrmatching.mli index c6b85738ec..b6ccb4cc6e 100644 --- a/plugins/ssrmatching/ssrmatching.mli +++ b/plugins/ssrmatching/ssrmatching.mli @@ -20,7 +20,7 @@ open Genintern (** Pattern parsing *) -(** The type of context patterns, the patterns of the [set] tactic and +(** The type of context patterns, the patterns of the [set] tactic and [:] tactical. These are patterns that identify a precise subterm. *) type cpattern val pr_cpattern : cpattern -> Pp.t @@ -78,10 +78,10 @@ type occ = (bool * int list) option type subst = env -> constr -> constr -> int -> constr (** [eval_pattern b env sigma t pat occ subst] maps [t] calling [subst] on every - [occ] occurrence of [pat]. The [int] argument is the number of + [occ] occurrence of [pat]. The [int] argument is the number of binders traversed. If [pat] is [None] then then subst is called on [t]. - [t] must live in [env] and [sigma], [pat] must have been interpreted in - (an extension of) [sigma]. + [t] must live in [env] and [sigma], [pat] must have been interpreted in + (an extension of) [sigma]. @raise NoMatch if [pat] has no occurrence and [b] is [true] (default [false]) @return [t] where all [occ] occurrences of [pat] have been mapped using [subst] *) @@ -91,12 +91,12 @@ val eval_pattern : pattern option -> occ -> subst -> constr -(** [fill_occ_pattern b env sigma t pat occ h] is a simplified version of - [eval_pattern]. - It replaces all [occ] occurrences of [pat] in [t] with Rel [h]. - [t] must live in [env] and [sigma], [pat] must have been interpreted in - (an extension of) [sigma]. - @raise NoMatch if [pat] has no occurrence and [b] is [true] (default [false]) +(** [fill_occ_pattern b env sigma t pat occ h] is a simplified version of + [eval_pattern]. + It replaces all [occ] occurrences of [pat] in [t] with Rel [h]. + [t] must live in [env] and [sigma], [pat] must have been interpreted in + (an extension of) [sigma]. + @raise NoMatch if [pat] has no occurrence and [b] is [true] (default [false]) @return the instance of the redex of [pat] that was matched and [t] transformed as described above. *) val fill_occ_pattern : @@ -107,7 +107,7 @@ val fill_occ_pattern : (** *************************** Low level APIs ****************************** *) -(* The primitive matching facility. It matches of a term with holes, like +(* The primitive matching facility. It matches of a term with holes, like the T pattern above, and calls a continuation on its occurrences. *) type ssrdir = L2R | R2L @@ -116,7 +116,7 @@ val pr_dir_side : ssrdir -> Pp.t (** a pattern for a term with wildcards *) type tpattern -(** [mk_tpattern env sigma0 sigma_p ok p_origin dir t] compiles a term [t] +(** [mk_tpattern env sigma0 sigma_p ok p_origin dir t] compiles a term [t] living in [env] [sigma] (an extension of [sigma0]) intro a [tpattern]. The [tpattern] can hold a (proof) term [p] and a diction [dir]. The [ok] callback is used to filter occurrences. @@ -130,14 +130,14 @@ val mk_tpattern : ssrdir -> constr -> evar_map * tpattern -(** [findP env t i k] is a stateful function that finds the next occurrence - of a tpattern and calls the callback [k] to map the subterm matched. - The [int] argument passed to [k] is the number of binders traversed so far - plus the initial value [i]. - @return [t] where the subterms identified by the selected occurrences of +(** [findP env t i k] is a stateful function that finds the next occurrence + of a tpattern and calls the callback [k] to map the subterm matched. + The [int] argument passed to [k] is the number of binders traversed so far + plus the initial value [i]. + @return [t] where the subterms identified by the selected occurrences of the patter have been mapped using [k] @raise NoMatch if the raise_NoMatch flag given to [mk_tpattern_matcher] is - [true] and if the pattern did not match + [true] and if the pattern did not match @raise UserEerror if the raise_NoMatch flag given to [mk_tpattern_matcher] is [false] and if the pattern did not match *) type find_P = @@ -150,11 +150,11 @@ type find_P = type conclude = unit -> constr * ssrdir * (evar_map * UState.t * constr) -(** [mk_tpattern_matcher b o sigma0 occ sigma_tplist] creates a pair +(** [mk_tpattern_matcher b o sigma0 occ sigma_tplist] creates a pair a function [find_P] and [conclude] with the behaviour explained above. The flag [b] (default [false]) changes the error reporting behaviour of [find_P] if none of the [tpattern] matches. The argument [o] can - be passed to tune the [UserError] eventually raised (useful if the + be passed to tune the [UserError] eventually raised (useful if the pattern is coming from the LHS/RHS of an equation) *) val mk_tpattern_matcher : ?all_instances:bool -> @@ -163,24 +163,24 @@ val mk_tpattern_matcher : evar_map -> occ -> evar_map * tpattern list -> find_P * conclude -(** Example of [mk_tpattern_matcher] to implement +(** Example of [mk_tpattern_matcher] to implement [rewrite \{occ\}\[in t\]rules]. - It first matches "in t" (called [pat]), then in all matched subterms + It first matches "in t" (called [pat]), then in all matched subterms it matches the LHS of the rules using [find_R]. [concl0] is the initial goal, [concl] will be the goal where some terms are replaced by a De Bruijn index. The [rw_progress] extra check selects only occurrences that are not rewritten to themselves (e.g. - an occurrence "x + x" rewritten with the commutativity law of addition + an occurrence "x + x" rewritten with the commutativity law of addition is skipped) {[ let find_R, conclude = match pat with | Some (_, In_T _) -> let aux (sigma, pats) (d, r, lhs, rhs) = - let sigma, pat = + let sigma, pat = mk_tpattern env0 sigma0 (sigma, r) (rw_progress rhs) d lhs in sigma, pats @ [pat] in let rpats = List.fold_left aux (r_sigma, []) rules in let find_R, end_R = mk_tpattern_matcher sigma0 occ rpats in - find_R ~k:(fun _ _ h -> mkRel h), + find_R ~k:(fun _ _ h -> mkRel h), fun cl -> let rdx, d, r = end_R () in (d,r),rdx | _ -> ... in let concl = eval_pattern env0 sigma0 concl0 pat occ find_R in @@ -194,7 +194,7 @@ val pf_fill_occ_term : goal sigma -> occ -> evar_map * EConstr.t -> EConstr.t * (* It may be handy to inject a simple term into the first form of cpattern *) val cpattern_of_term : char * glob_constr_and_expr -> Geninterp.interp_sign -> cpattern -(** Helpers to make stateful closures. Example: a [find_P] function may be +(** Helpers to make stateful closures. Example: a [find_P] function may be called many times, but the pattern instantiation phase is performed only the first time. The corresponding [conclude] has to return the instantiated pattern redex. Since it is up to [find_P] to raise [NoMatch] if the pattern diff --git a/pretyping/arguments_renaming.ml b/pretyping/arguments_renaming.ml index a86d237164..36f35a67c3 100644 --- a/pretyping/arguments_renaming.ml +++ b/pretyping/arguments_renaming.ml @@ -38,14 +38,14 @@ let classify_rename_args = function | ReqLocal, _ -> Dispose | ReqGlobal _, _ as o -> Substitute o -let subst_rename_args (subst, (_, (r, names as orig))) = +let subst_rename_args (subst, (_, (r, names as orig))) = ReqLocal, - let r' = fst (subst_global subst r) in + let r' = fst (subst_global subst r) in if r==r' then orig else (r', names) let discharge_rename_args = function | _, (ReqGlobal (c, names), _ as req) when not (isVarRef c && Lib.is_in_section c) -> - (try + (try let vars = Lib.variable_section_segment_of_reference c in let var_names = List.map (NamedDecl.get_id %> Name.mk_name) vars in let names' = var_names @ names in @@ -66,7 +66,7 @@ let inRenameArgs = declare_object { (default_object "RENAME-ARGUMENTS" ) with let rename_arguments local r names = let req = if local then ReqLocal else ReqGlobal (r, names) in - Lib.add_anonymous_leaf (inRenameArgs (req, (r, names))) + Lib.add_anonymous_leaf (inRenameArgs (req, (r, names))) let arguments_names r = GlobRef.Map.find r !name_table diff --git a/pretyping/cases.ml b/pretyping/cases.ml index a562204b54..aa6ec1c941 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -77,8 +77,8 @@ let list_try_compile f l = | h::t -> try f h with UserError _ | TypeError _ | PretypeError _ | PatternMatchingError _ as e -> - let e = CErrors.push e in - aux (e::errors) t in + let e = CErrors.push e in + aux (e::errors) t in aux [] l let force_name = @@ -183,7 +183,7 @@ and build_glob_pattern args = function | Top -> args | MakeConstructor (pci, rh) -> glob_pattern_of_partial_history - [DAst.make @@ PatCstr (pci, args, Anonymous)] rh + [DAst.make @@ PatCstr (pci, args, Anonymous)] rh let complete_history = glob_pattern_of_partial_history [] @@ -292,15 +292,15 @@ let inductive_template env sigma tmloc ind = let (sigma, _, evarl, _) = List.fold_right (fun decl (sigma, subst, evarl, n) -> - match decl with + match decl with | LocalAssum (na,ty) -> let ty = EConstr.of_constr ty in - let ty' = substl subst ty in + let ty' = substl subst ty in let sigma, e = Evarutil.new_evar env ~src:(hole_source n) ~typeclass_candidate:false sigma ty' in (sigma, e::subst,e::evarl,n+1) - | LocalDef (na,b,ty) -> + | LocalDef (na,b,ty) -> let b = EConstr.of_constr b in (sigma, substl subst b::subst,evarl,n+1)) arsign (sigma, [], [], 1) in @@ -431,11 +431,11 @@ let adjust_tomatch_to_pattern ~program_mode sigma pb ((current,typ),deps,dep) = let sigma, indt = inductive_template !!(pb.env) sigma None ind in let sigma, current = if List.is_empty deps && isEvar sigma typ then - (* Don't insert coercions if dependent; only solve evars *) + (* Don't insert coercions if dependent; only solve evars *) match Evarconv.unify_leq_delay !!(pb.env) sigma indt typ with | exception Evarconv.UnableToUnify _ -> sigma, current | sigma -> sigma, current - else + else let sigma, j = Coercion.inh_conv_coerce_to ?loc ~program_mode true !!(pb.env) sigma (make_judge current typ) indt in sigma, j.uj_val in @@ -464,9 +464,9 @@ let current_pattern eqn = let remove_current_pattern eqn = match eqn.patterns with | pat::pats -> - { eqn with - patterns = pats; - alias_stack = alias_of_pat pat :: eqn.alias_stack } + { eqn with + patterns = pats; + alias_stack = alias_of_pat pat :: eqn.alias_stack } | [] -> anomaly (Pp.str "Empty list of patterns.") let push_current_pattern ~program_mode sigma (cur,ty) eqn = @@ -475,9 +475,9 @@ let push_current_pattern ~program_mode sigma (cur,ty) eqn = | pat::pats -> let r = Sorts.Relevant in (* TODO relevance *) let _,rhs_env = push_rel ~hypnaming sigma (LocalDef (make_annot (alias_of_pat pat) r,cur,ty)) eqn.rhs.rhs_env in - { eqn with + { eqn with rhs = { eqn.rhs with rhs_env = rhs_env }; - patterns = pats } + patterns = pats } | [] -> anomaly (Pp.str "Empty list of patterns.") (* spiwack: like [push_current_pattern] but does not introduce an @@ -515,22 +515,22 @@ let check_and_adjust_constructor env ind cstrs pat = match DAst.get pat with (* Check it is constructor of the right type *) let ind' = inductive_of_constructor cstr in if eq_ind ind' ind then - (* Check the constructor has the right number of args *) - let ci = cstrs.(i-1) in - let nb_args_constr = ci.cs_nargs in - if Int.equal (List.length args) nb_args_constr then pat - else - try - let args' = adjust_local_defs ?loc (args, List.rev ci.cs_args) - in DAst.make ?loc @@ PatCstr (cstr, args', alias) - with NotAdjustable -> - error_wrong_numarg_constructor ?loc env cstr nb_args_constr + (* Check the constructor has the right number of args *) + let ci = cstrs.(i-1) in + let nb_args_constr = ci.cs_nargs in + if Int.equal (List.length args) nb_args_constr then pat + else + try + let args' = adjust_local_defs ?loc (args, List.rev ci.cs_args) + in DAst.make ?loc @@ PatCstr (cstr, args', alias) + with NotAdjustable -> + error_wrong_numarg_constructor ?loc env cstr nb_args_constr else - (* Try to insert a coercion *) - try - Coercion.inh_pattern_coerce_to ?loc env pat ind' ind - with Not_found -> - error_bad_constructor ?loc env cstr ind + (* Try to insert a coercion *) + try + Coercion.inh_pattern_coerce_to ?loc env pat ind' ind + with Not_found -> + error_bad_constructor ?loc env cstr ind let check_all_variables env sigma typ mat = List.iter @@ -540,7 +540,7 @@ let check_all_variables env sigma typ mat = | PatVar id -> () | PatCstr (cstr_sp,_,_) -> let loc = pat.CAst.loc in - error_bad_pattern ?loc env sigma cstr_sp typ) + error_bad_pattern ?loc env sigma cstr_sp typ) mat let check_unused_pattern env eqn = @@ -553,7 +553,7 @@ let extract_rhs pb = match pb.mat with | [] -> user_err ~hdr:"build_leaf" (msg_may_need_inversion()) | eqn::_ -> - set_used_pattern eqn; + set_used_pattern eqn; eqn.rhs (**********************************************************************) @@ -762,14 +762,14 @@ let get_names avoid env sigma sign eqns = let names3,_ = List.fold_left2 (fun (l,avoid) d na -> - let na = - merge_name + let na = + merge_name (fun decl -> let na = get_name decl in let t = get_type decl in Name (next_name_away (named_hd env sigma t na) avoid)) - d na - in + d na + in (na::l,Id.Set.add (Name.get_id na) avoid)) ([],allvars) (List.rev sign) names2 in names3,aliasname @@ -1012,9 +1012,9 @@ let add_assert_false_case pb tomatch = in [ { patterns = pats; rhs = { rhs_env = pb.env; - rhs_vars = Id.Set.empty; - avoid_ids = Id.Set.empty; - it = None }; + rhs_vars = Id.Set.empty; + avoid_ids = Id.Set.empty; + it = None }; alias_stack = Anonymous::aliasnames; eqn_loc = None; used = ref false } ] @@ -1226,20 +1226,20 @@ let group_equations pb ind current cstrs mat = let _ = List.fold_right (* To be sure it's from bottom to top *) (fun eqn () -> - let rest = remove_current_pattern eqn in - let pat = current_pattern eqn in + let rest = remove_current_pattern eqn in + let pat = current_pattern eqn in match DAst.get (check_and_adjust_constructor !!(pb.env) ind cstrs pat) with - | PatVar name -> - (* This is a default clause that we expand *) - for i=1 to Array.length cstrs do - let args = make_anonymous_patvars cstrs.(i-1).cs_nargs in - brs.(i-1) <- (args, name, rest) :: brs.(i-1) - done; - if !only_default == None then only_default := Some true - | PatCstr (((_,i)),args,name) -> - (* This is a regular clause *) - only_default := Some false; - brs.(i-1) <- (args, name, rest) :: brs.(i-1)) mat () in + | PatVar name -> + (* This is a default clause that we expand *) + for i=1 to Array.length cstrs do + let args = make_anonymous_patvars cstrs.(i-1).cs_nargs in + brs.(i-1) <- (args, name, rest) :: brs.(i-1) + done; + if !only_default == None then only_default := Some true + | PatCstr (((_,i)),args,name) -> + (* This is a regular clause *) + only_default := Some false; + brs.(i-1) <- (args, name, rest) :: brs.(i-1)) mat () in (brs,Option.default false !only_default) (************************************************************************) @@ -1254,7 +1254,7 @@ let rec generalize_problem names sigma pb = function begin match d with | LocalDef ({binder_name=Anonymous},_,_) -> pb', deps | _ -> - (* for better rendering *) + (* for better rendering *) let d = RelDecl.map_type (fun c -> whd_betaiota sigma c) d in let tomatch = lift_tomatch_stack 1 pb'.tomatch in let tomatch = relocate_index_tomatch sigma (i+1) 1 tomatch in @@ -1342,12 +1342,12 @@ let build_branch ~program_mode initial current realargs deps (realnames,curname) List.map2 (fun (tm, (tmtyp,_), decl) deps -> let na = RelDecl.get_name decl in - let na = match curname, na with - | Name _, Anonymous -> curname - | Name _, Name _ -> na - | Anonymous, _ -> - if List.is_empty deps && pred_is_not_dep then Anonymous else force_name na in - ((tm,tmtyp),deps,na)) + let na = match curname, na with + | Name _, Anonymous -> curname + | Name _, Name _ -> na + | Anonymous, _ -> + if List.is_empty deps && pred_is_not_dep then Anonymous else force_name na in + ((tm,tmtyp),deps,na)) typs' (List.rev dep_sign) in (* Do the specialization for the predicate *) @@ -1417,24 +1417,24 @@ let compile ~program_mode sigma pb = check_all_variables !!(pb.env) sigma typ pb.mat; compile_all_variables initial tomatch sigma pb | IsInd (_,(IndType(indf,realargs) as indt),names) -> - let mind,_ = dest_ind_family indf in + let mind,_ = dest_ind_family indf in let mind = Tacred.check_privacy !!(pb.env) mind in let cstrs = get_constructors !!(pb.env) indf in let arsign, _ = get_arity !!(pb.env) indf in - let eqns,onlydflt = group_equations pb (fst mind) current cstrs pb.mat in + let eqns,onlydflt = group_equations pb (fst mind) current cstrs pb.mat in let no_cstr = Int.equal (Array.length cstrs) 0 in - if (not no_cstr || not (List.is_empty pb.mat)) && onlydflt then + if (not no_cstr || not (List.is_empty pb.mat)) && onlydflt then compile_all_variables initial tomatch sigma pb - else - (* We generalize over terms depending on current term to match *) + else + (* We generalize over terms depending on current term to match *) let pb,deps = generalize_problem (names,dep) sigma pb deps in - (* We compile branches *) + (* We compile branches *) let fold_br sigma eqn cstr = compile_branch initial current realargs (names,dep) deps sigma pb arsign eqn cstr in let sigma, brvals = Array.fold_left2_map fold_br sigma eqns cstrs in - (* We build the (elementary) case analysis *) + (* We build the (elementary) case analysis *) let depstocheck = current::binding_vars_of_inductive sigma typ in let brvals,tomatch,pred,inst = postprocess_dependencies sigma depstocheck @@ -1597,8 +1597,8 @@ let matx_of_eqns env eqns = let rhs = { rhs_env = env; rhs_vars = free_glob_vars initial_rhs; - avoid_ids = avoid; - it = Some initial_rhs } in + avoid_ids = avoid; + it = Some initial_rhs } in { patterns = initial_lpat; alias_stack = []; eqn_loc = loc; @@ -1707,8 +1707,8 @@ let abstract_tycon ?loc env sigma subst tycon extenv t = let ty = get_type_of !!env sigma t in let sigma, ty = refresh_universes (Some false) !!env sigma ty in let inst = - List.map_i - (fun i _ -> + List.map_i + (fun i _ -> try list_assoc_in_triple i subst0 with Not_found -> mkRel i) 1 (rel_context !!env) in let sigma, ev' = Evarutil.new_evar ~src ~typeclass_candidate:false !!env sigma ty in @@ -1726,7 +1726,7 @@ let abstract_tycon ?loc env sigma subst tycon extenv t = map_constr_with_full_binders sigma (push_binder sigma) aux x t | (_, _, u) :: _ -> (* u is in extenv *) let vl = List.map pi1 good in - let ty = + let ty = let ty = get_type_of !!env sigma t in let sigma, res = refresh_universes (Some false) !!env !evdref ty in evdref := sigma; res @@ -1736,8 +1736,8 @@ let abstract_tycon ?loc env sigma subst tycon extenv t = let sigma = !evdref in let depvl = free_rels sigma ty in let inst = - List.map_i - (fun i _ -> if Int.List.mem i vl then u else mkRel i) 1 + List.map_i + (fun i _ -> if Int.List.mem i vl then u else mkRel i) 1 (rel_context !!extenv) in let map a = match EConstr.kind sigma a with | Rel n -> not (noccurn sigma n u) || Int.Set.mem n depvl @@ -1759,7 +1759,7 @@ let abstract_tycon ?loc env sigma subst tycon extenv t = let build_tycon ?loc env tycon_env s subst tycon extenv sigma t = let sigma, t, tt = match t with | None -> - (* This is the situation we are building a return predicate and + (* This is the situation we are building a return predicate and we are in an impossible branch *) let n = Context.Rel.length (rel_context !!env) in let n' = Context.Rel.length (rel_context !!tycon_env) in @@ -1795,26 +1795,26 @@ let build_inversion_problem ~program_mode loc env sigma tms t = match EConstr.kind sigma (whd_all !!env sigma t) with | Construct (cstr,u) -> DAst.make (PatCstr (cstr,[],Anonymous)), acc | App (f,v) when isConstruct sigma f -> - let cstr,u = destConstruct sigma f in + let cstr,u = destConstruct sigma f in let n = constructor_nrealargs !!env cstr in - let l = List.lastn n (Array.to_list v) in - let l,acc = List.fold_right_map reveal_pattern l acc in - DAst.make (PatCstr (cstr,l,Anonymous)), acc + let l = List.lastn n (Array.to_list v) in + let l,acc = List.fold_right_map reveal_pattern l acc in + DAst.make (PatCstr (cstr,l,Anonymous)), acc | _ -> make_patvar t acc in let rec aux n env acc_sign tms acc = match tms with | [] -> [], acc_sign, acc | (t, IsInd (_,IndType(indf,realargs),_)) :: tms -> - let patl,acc = List.fold_right_map reveal_pattern realargs acc in - let pat,acc = make_patvar t acc in - let indf' = lift_inductive_family n indf in + let patl,acc = List.fold_right_map reveal_pattern realargs acc in + let pat,acc = make_patvar t acc in + let indf' = lift_inductive_family n indf in let sign = make_arity_signature !!env sigma true indf' in let patl = pat :: List.rev patl in let patl,sign = recover_and_adjust_alias_names acc patl sign in - let p = List.length patl in + let p = List.length patl in let _,env' = push_rel_context ~hypnaming:KeepUserNameAndRenameExistingButSectionNames sigma sign env in - let patl',acc_sign,acc = aux (n+p) env' (sign@acc_sign) tms acc in - List.rev_append patl patl',acc_sign,acc + let patl',acc_sign,acc = aux (n+p) env' (sign@acc_sign) tms acc in + List.rev_append patl patl',acc_sign,acc | (t, NotInd (bo,typ)) :: tms -> let pat,acc = make_patvar t acc in let d = LocalAssum (annotR (alias_of_pat pat),typ) in @@ -1861,10 +1861,10 @@ let build_inversion_problem ~program_mode loc env sigma tms t = used = ref false; rhs = { rhs_env = pb_env; (* we assume all vars are used; in practice we discard dependent - vars so that the field rhs_vars is normally not used *) + vars so that the field rhs_vars is normally not used *) rhs_vars = List.fold_left (fun accu (id, _) -> Id.Set.add id accu) Id.Set.empty subst; avoid_ids = avoid; - it = Some (lift n t) } } in + it = Some (lift n t) } } in (* [catch_all] is a catch-all default clause of the auxiliary pattern-matching, if needed: it will catch the clauses of the original pattern-matching problem Xi whose type @@ -1881,8 +1881,8 @@ let build_inversion_problem ~program_mode loc env sigma tms t = used = ref false; rhs = { rhs_env = pb_env; rhs_vars = Id.Set.empty; - avoid_ids = avoid0; - it = None } } ] in + avoid_ids = avoid0; + it = None } } ] in (* [pb] is the auxiliary pattern-matching serving as skeleton for the return type of the original problem Xi *) let s' = Retyping.get_sort_of !!env sigma t in @@ -1917,7 +1917,7 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = let get_one_sign n tm (na,t) = match tm with | NotInd (bo,typ) -> - (match t with + (match t with | None -> let r = Sorts.Relevant in (* TODO relevance *) let sign = match bo with @@ -1928,19 +1928,19 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = (str"Unexpected type annotation for a term of non inductive type.")) | IsInd (term,IndType(indf,realargs),_) -> let indf' = if dolift then lift_inductive_family n indf else indf in - let ((ind,u),_) = dest_ind_family indf' in + let ((ind,u),_) = dest_ind_family indf' in let nrealargs_ctxt = inductive_nrealdecls env0 ind in let arsign, inds = get_arity env0 indf' in - let arsign = List.map (fun d -> map_rel_decl EConstr.of_constr d) arsign in + let arsign = List.map (fun d -> map_rel_decl EConstr.of_constr d) arsign in let realnal = - match t with + match t with | Some {CAst.loc;v=(ind',realnal)} -> - if not (eq_ind ind ind') then - user_err ?loc (str "Wrong inductive type."); - if not (Int.equal nrealargs_ctxt (List.length realnal)) then - anomaly (Pp.str "Ill-formed 'in' clause in cases."); + if not (eq_ind ind ind') then + user_err ?loc (str "Wrong inductive type."); + if not (Int.equal nrealargs_ctxt (List.length realnal)) then + anomaly (Pp.str "Ill-formed 'in' clause in cases."); List.rev realnal - | None -> + | None -> List.make nrealargs_ctxt Anonymous in let r = Sorts.relevance_of_sort_family inds in let t = EConstr.of_constr (build_dependent_inductive env0 indf') in @@ -1948,7 +1948,7 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = let rec buildrec n = function | [],[] -> [] | (_,tm)::ltm, (_,x)::tmsign -> - let l = get_one_sign n tm x in + let l = get_one_sign n tm x in l :: buildrec (n + List.length l) (ltm,tmsign) | _ -> assert false in List.rev (buildrec 0 (tomatchl,tmsign)) @@ -1978,41 +1978,41 @@ let prepare_predicate_from_arsign_tycon ~program_mode env sigma loc tomatchs ars let (rel_subst,var_subst), len = List.fold_right2 (fun (tm, tmtype) sign (subst, len) -> let signlen = List.length sign in - match EConstr.kind sigma tm with + match EConstr.kind sigma tm with | Rel _ | Var _ when Int.equal signlen 1 && dependent_rel_or_var sigma tm c (* The term to match is not of a dependent type itself *) -> (add_subst sigma tm len subst, len - signlen) | Rel _ | Var _ when signlen > 1 (* The term is of a dependent type, - maybe some variable in its type appears in the tycon. *) -> - (match tmtype with - NotInd _ -> (subst, len - signlen) - | IsInd (_, IndType(indf,realargs),_) -> - let subst, len = - List.fold_left - (fun (subst, len) arg -> - match EConstr.kind sigma arg with + maybe some variable in its type appears in the tycon. *) -> + (match tmtype with + NotInd _ -> (subst, len - signlen) + | IsInd (_, IndType(indf,realargs),_) -> + let subst, len = + List.fold_left + (fun (subst, len) arg -> + match EConstr.kind sigma arg with | Rel _ | Var _ when dependent_rel_or_var sigma arg c -> (add_subst sigma arg len subst, pred len) - | _ -> (subst, pred len)) - (subst, len) realargs - in - let subst = + | _ -> (subst, pred len)) + (subst, len) realargs + in + let subst = if dependent_rel_or_var sigma tm c && List.for_all (fun c -> isRel sigma c || isVar sigma c) realargs then add_subst sigma tm len subst else subst - in (subst, pred len)) - | _ -> (subst, len - signlen)) + in (subst, pred len)) + | _ -> (subst, len - signlen)) (List.rev tomatchs) arsign (([],[]), nar) in let rec predicate lift c = match EConstr.kind sigma c with | Rel n when n > lift -> - (try - (* Make the predicate dependent on the matched variable *) + (try + (* Make the predicate dependent on the matched variable *) let idx = Int.List.assoc (n - lift) rel_subst in - mkRel (idx + lift) - with Not_found -> + mkRel (idx + lift) + with Not_found -> (* A variable that is not matched, lift over the arsign *) - mkRel (n + nar)) + mkRel (n + nar)) | Var id -> (try (* Make the predicate dependent on the matched variable *) @@ -2022,7 +2022,7 @@ let prepare_predicate_from_arsign_tycon ~program_mode env sigma loc tomatchs ars (* A variable that is not matched *) c) | _ -> - EConstr.map_with_binders sigma succ predicate lift c + EConstr.map_with_binders sigma succ predicate lift c in assert (len == 0); let p = predicate 0 c in @@ -2146,52 +2146,52 @@ let constr_of_pat env sigma arsign pat avoid = let loc = pat.CAst.loc in match DAst.get pat with | PatVar name -> - let name, avoid = match name with - Name n -> name, avoid - | Anonymous -> - let previd, id = prime avoid (Name (Id.of_string "wildcard")) in - Name id, Id.Set.add id avoid + let name, avoid = match name with + Name n -> name, avoid + | Anonymous -> + let previd, id = prime avoid (Name (Id.of_string "wildcard")) in + Name id, Id.Set.add id avoid in let r = Sorts.Relevant in (* TODO relevance *) (sigma, (DAst.make ?loc @@ PatVar name), [LocalAssum (make_annot name r, ty)] @ realargs, mkRel 1, ty, (List.map (fun x -> mkRel 1) realargs), 1, avoid) | PatCstr (((_, i) as cstr),args,alias) -> - let cind = inductive_of_constructor cstr in - let IndType (indf, _) = + let cind = inductive_of_constructor cstr in + let IndType (indf, _) = try find_rectype env sigma (lift (-(List.length realargs)) ty) with Not_found -> error_case_not_inductive env sigma {uj_val = ty; uj_type = Typing.unsafe_type_of env sigma ty} - in - let (ind,u), params = dest_ind_family indf in - let params = List.map EConstr.of_constr params in - if not (eq_ind ind cind) then error_bad_constructor ?loc env cstr ind; - let cstrs = get_constructors env indf in - let ci = cstrs.(i-1) in - let nb_args_constr = ci.cs_nargs in - assert (Int.equal nb_args_constr (List.length args)); + in + let (ind,u), params = dest_ind_family indf in + let params = List.map EConstr.of_constr params in + if not (eq_ind ind cind) then error_bad_constructor ?loc env cstr ind; + let cstrs = get_constructors env indf in + let ci = cstrs.(i-1) in + let nb_args_constr = ci.cs_nargs in + assert (Int.equal nb_args_constr (List.length args)); let sigma, patargs, args, sign, env, n, m, avoid = - List.fold_right2 + List.fold_right2 (fun decl ua (sigma, patargs, args, sign, env, n, m, avoid) -> let t = EConstr.of_constr (RelDecl.get_type decl) in let sigma, pat', sign', arg', typ', argtypargs, n', avoid = - let liftt = liftn (List.length sign) (succ (List.length args)) t in + let liftt = liftn (List.length sign) (succ (List.length args)) t in typ env sigma (substl args liftt, []) ua avoid - in - let args' = arg' :: List.map (lift n') args in + in + let args' = arg' :: List.map (lift n') args in let env' = EConstr.push_rel_context sign' env in (sigma, pat' :: patargs, args', sign' @ sign, env', n' + n, succ m, avoid)) ci.cs_args (List.rev args) (sigma, [], [], [], env, 0, 0, avoid) - in - let args = List.rev args in - let patargs = List.rev patargs in - let pat' = DAst.make ?loc @@ PatCstr (cstr, patargs, alias) in - let cstr = mkConstructU (on_snd EInstance.make ci.cs_cstr) in - let app = applist (cstr, List.map (lift (List.length sign)) params) in - let app = applist (app, args) in + in + let args = List.rev args in + let patargs = List.rev patargs in + let pat' = DAst.make ?loc @@ PatCstr (cstr, patargs, alias) in + let cstr = mkConstructU (on_snd EInstance.make ci.cs_cstr) in + let app = applist (cstr, List.map (lift (List.length sign)) params) in + let app = applist (app, args) in let apptype = Retyping.get_type_of env sigma app in let IndType (indf, realargs) = find_rectype env sigma apptype in - match alias with - Anonymous -> + match alias with + Anonymous -> sigma, pat', sign, app, apptype, realargs, n, avoid | Name id -> let _, inds = get_arity env indf in @@ -2199,19 +2199,19 @@ let constr_of_pat env sigma arsign pat avoid = let sign = LocalAssum (make_annot alias r, lift m ty) :: sign in let avoid = Id.Set.add id avoid in let sigma, sign, i, avoid = - try + try let env = EConstr.push_rel_context sign env in let sigma = unify_leq_delay (EConstr.push_rel_context sign env) sigma (lift (succ m) ty) (lift 1 apptype) in let sigma, eq_t = mk_eq sigma (lift (succ m) ty) - (mkRel 1) (* alias *) - (lift 1 app) (* aliased term *) - in + (mkRel 1) (* alias *) + (lift 1 app) (* aliased term *) + in let neq = eq_id avoid id in (* if we ever allow using a SProp-typed coq_eq_ind this relevance will be wrong *) sigma, LocalDef (nameR neq, mkRel 0, eq_t) :: sign, 2, Id.Set.add neq avoid with Evarconv.UnableToUnify _ -> sigma, sign, 1, avoid - in + in (* Mark the equality as a hole *) sigma, pat', sign, lift i app, lift i apptype, realargs, n + i, avoid in @@ -2233,23 +2233,23 @@ match EConstr.kind sigma t with let rels_of_patsign sigma = List.map (fun decl -> - match decl with + match decl with | LocalDef (na,t',t) when is_topvar sigma t' -> LocalAssum (na,t) - | _ -> decl) + | _ -> decl) let vars_of_ctx sigma ctx = let _, y = List.fold_right (fun decl (prev, vars) -> match decl with | LocalDef (na,t',t) when is_topvar sigma t' -> - prev, - (DAst.make @@ GApp ( - (DAst.make @@ GRef (delayed_force coq_eq_refl_ref, None)), + prev, + (DAst.make @@ GApp ( + (DAst.make @@ GRef (delayed_force coq_eq_refl_ref, None)), [hole na.binder_name; DAst.make @@ GVar prev])) :: vars - | _ -> - match RelDecl.get_name decl with - Anonymous -> invalid_arg "vars_of_ctx" - | Name n -> n, (DAst.make @@ GVar n) :: vars) + | _ -> + match RelDecl.get_name decl with + Anonymous -> invalid_arg "vars_of_ctx" + | Name n -> n, (DAst.make @@ GVar n) :: vars) ctx (Id.of_string "vars_of_ctx_error", []) in List.rev y @@ -2258,13 +2258,13 @@ let rec is_included x y = | PatVar _, _ -> true | _, PatVar _ -> true | PatCstr ((_, i), args, alias), PatCstr ((_, i'), args', alias') -> - if Int.equal i i' then List.for_all2 is_included args args' - else false + if Int.equal i i' then List.for_all2 is_included args args' + else false let lift_rel_context n l = map_rel_context_with_binders (liftn n) l -(* liftsign is the current pattern's complete signature length. +(* liftsign is the current pattern's complete signature length. Hence pats is already typed in its full signature. However prevpatterns are in the original one signature per pattern form. *) @@ -2273,38 +2273,38 @@ let build_ineqs sigma prevpatterns pats liftsign = List.fold_left (fun (sigma, c) eqnpats -> let sigma, acc = List.fold_left2 - (* ppat is the pattern we are discriminating against, curpat is the current one. *) + (* ppat is the pattern we are discriminating against, curpat is the current one. *) (fun (sigma, acc) (ppat_sign, ppat_c, (ppat_ty, ppat_tyargs), ppat) - (curpat_sign, curpat_c, (curpat_ty, curpat_tyargs), curpat) -> - match acc with + (curpat_sign, curpat_c, (curpat_ty, curpat_tyargs), curpat) -> + match acc with None -> sigma, None - | Some (sign, len, n, c) -> (* FixMe: do not work with ppat_args *) - if is_included curpat ppat then - (* Length of previous pattern's signature *) - let lens = List.length ppat_sign in - (* Accumulated length of previous pattern's signatures *) - let len' = lens + len in + | Some (sign, len, n, c) -> (* FixMe: do not work with ppat_args *) + if is_included curpat ppat then + (* Length of previous pattern's signature *) + let lens = List.length ppat_sign in + (* Accumulated length of previous pattern's signatures *) + let len' = lens + len in let sigma, c' = papp sigma coq_eq_ind [| lift (len' + liftsign) curpat_ty; liftn (len + liftsign) (succ lens) ppat_c ; lift len' curpat_c |] in - let acc = - ((* Jump over previous prevpat signs *) - lift_rel_context len ppat_sign @ sign, - len', - succ n, (* nth pattern *) + let acc = + ((* Jump over previous prevpat signs *) + lift_rel_context len ppat_sign @ sign, + len', + succ n, (* nth pattern *) c' :: List.map (lift lens (* Jump over this prevpat signature *)) c) in sigma, Some acc else sigma, None) (sigma, Some ([], 0, 0, [])) eqnpats pats - in match acc with + in match acc with None -> sigma, c - | Some (sign, len, _, c') -> + | Some (sign, len, _, c') -> let sigma, conj = mk_coq_and sigma c' in let sigma, neg = mk_coq_not sigma conj in - let conj = it_mkProd_or_LetIn neg (lift_rel_context liftsign sign) in + let conj = it_mkProd_or_LetIn neg (lift_rel_context liftsign sign) in sigma, conj :: c) (sigma, []) prevpatterns in match diffs with [] -> sigma, None @@ -2316,78 +2316,78 @@ let constrs_of_pats typing_fun env sigma eqns tomatchs sign neqs arity = List.fold_left (fun (sigma, branches, eqns, prevpatterns) eqn -> let sigma, _, newpatterns, pats = - List.fold_left2 + List.fold_left2 (fun (sigma, idents, newpatterns, pats) pat arsign -> let sigma, pat', cpat, idents = constr_of_pat !!env sigma arsign pat idents in (sigma, idents, pat' :: newpatterns, cpat :: pats)) (sigma, Id.Set.empty, [], []) eqn.patterns sign - in - let newpatterns = List.rev newpatterns and opats = List.rev pats in - let rhs_rels, pats, signlen = - List.fold_left - (fun (renv, pats, n) (sign,c, (s, args), p) -> - (* Recombine signatures and terms of all of the row's patterns *) - let sign' = lift_rel_context n sign in - let len = List.length sign' in - (sign' @ renv, - (* lift to get outside of previous pattern's signatures. *) - (sign', liftn n (succ len) c, - (s, List.map (liftn n (succ len)) args), p) :: pats, - len + n)) - ([], [], 0) opats in - let pats, _ = List.fold_left - (* lift to get outside of past patterns to get terms in the combined environment. *) - (fun (pats, n) (sign, c, (s, args), p) -> - let len = List.length sign in + in + let newpatterns = List.rev newpatterns and opats = List.rev pats in + let rhs_rels, pats, signlen = + List.fold_left + (fun (renv, pats, n) (sign,c, (s, args), p) -> + (* Recombine signatures and terms of all of the row's patterns *) + let sign' = lift_rel_context n sign in + let len = List.length sign' in + (sign' @ renv, + (* lift to get outside of previous pattern's signatures. *) + (sign', liftn n (succ len) c, + (s, List.map (liftn n (succ len)) args), p) :: pats, + len + n)) + ([], [], 0) opats in + let pats, _ = List.fold_left + (* lift to get outside of past patterns to get terms in the combined environment. *) + (fun (pats, n) (sign, c, (s, args), p) -> + let len = List.length sign in ((rels_of_patsign sigma sign, lift n c, - (s, List.map (lift n) args), p) :: pats, len + n)) - ([], 0) pats - in + (s, List.map (lift n) args), p) :: pats, len + n)) + ([], 0) pats + in let sigma, ineqs = build_ineqs sigma prevpatterns pats signlen in let rhs_rels' = rels_of_patsign sigma rhs_rels in let _signenv,_ = push_rel_context ~hypnaming:ProgramNaming sigma rhs_rels' env in - let arity = - let args, nargs = - List.fold_right (fun (sign, c, (_, args), _) (allargs,n) -> - (args @ c :: allargs, List.length args + succ n)) - pats ([], 0) - in - let args = List.rev args in - substl args (liftn signlen (succ nargs) arity) - in + let arity = + let args, nargs = + List.fold_right (fun (sign, c, (_, args), _) (allargs,n) -> + (args @ c :: allargs, List.length args + succ n)) + pats ([], 0) + in + let args = List.rev args in + substl args (liftn signlen (succ nargs) arity) + in let r = Sorts.Relevant in (* TODO relevance *) let rhs_rels', tycon = - let neqs_rels, arity = - match ineqs with - | None -> [], arity - | Some ineqs -> + let neqs_rels, arity = + match ineqs with + | None -> [], arity + | Some ineqs -> [LocalAssum (make_annot Anonymous r, ineqs)], lift 1 arity - in + in let eqs_rels, arity = decompose_prod_n_assum sigma neqs arity in - eqs_rels @ neqs_rels @ rhs_rels', arity - in + eqs_rels @ neqs_rels @ rhs_rels', arity + in let _,rhs_env = push_rel_context ~hypnaming:ProgramNaming sigma rhs_rels' env in let sigma, j = typing_fun (mk_tycon tycon) rhs_env sigma eqn.rhs.it in - let bbody = it_mkLambda_or_LetIn j.uj_val rhs_rels' - and btype = it_mkProd_or_LetIn j.uj_type rhs_rels' in + let bbody = it_mkLambda_or_LetIn j.uj_val rhs_rels' + and btype = it_mkProd_or_LetIn j.uj_type rhs_rels' in let sigma, _btype = Typing.type_of !!env sigma bbody in - let branch_name = Id.of_string ("program_branch_" ^ (string_of_int !i)) in + let branch_name = Id.of_string ("program_branch_" ^ (string_of_int !i)) in let branch_decl = LocalDef (make_annot (Name branch_name) r, lift !i bbody, lift !i btype) in - let branch = - let bref = DAst.make @@ GVar branch_name in + let branch = + let bref = DAst.make @@ GVar branch_name in match vars_of_ctx sigma rhs_rels with - [] -> bref - | l -> DAst.make @@ GApp (bref, l) - in - let branch = match ineqs with - Some _ -> DAst.make @@ GApp (branch, [ hole Anonymous ]) - | None -> branch - in - incr i; - let rhs = { eqn.rhs with it = Some branch } in + [] -> bref + | l -> DAst.make @@ GApp (bref, l) + in + let branch = match ineqs with + Some _ -> DAst.make @@ GApp (branch, [ hole Anonymous ]) + | None -> branch + in + incr i; + let rhs = { eqn.rhs with it = Some branch } in (sigma, branch_decl :: branches, - { eqn with patterns = newpatterns; rhs = rhs } :: eqns, - opats :: prevpatterns)) + { eqn with patterns = newpatterns; rhs = rhs } :: eqns, + opats :: prevpatterns)) (sigma, [], [], []) eqns in sigma, x, y @@ -2404,8 +2404,8 @@ let constrs_of_pats typing_fun env sigma eqns tomatchs sign neqs arity = let lift_ctx n ctx = let ctx', _ = - List.fold_right (fun (c, t) (ctx, n') -> - (liftn n n' c, liftn_tomatch_type n n' t) :: ctx, succ n') + List.fold_right (fun (c, t) (ctx, n') -> + (liftn n n' c, liftn_tomatch_type n n' t) :: ctx, succ n') ctx ([], 0) in ctx' @@ -2414,17 +2414,17 @@ let abstract_tomatch env sigma tomatchs tycon = let prev, ctx, names, tycon = List.fold_left (fun (prev, ctx, names, tycon) (c, t) -> - let lenctx = List.length ctx in - match EConstr.kind sigma c with - Rel n -> (lift lenctx c, lift_tomatch_type lenctx t) :: prev, ctx, names, tycon - | _ -> - let tycon = Option.map - (fun t -> subst_term sigma (lift 1 c) (lift 1 t)) tycon in + let lenctx = List.length ctx in + match EConstr.kind sigma c with + Rel n -> (lift lenctx c, lift_tomatch_type lenctx t) :: prev, ctx, names, tycon + | _ -> + let tycon = Option.map + (fun t -> subst_term sigma (lift 1 c) (lift 1 t)) tycon in let name = next_ident_away (Id.of_string "filtered_var") names in let r = Sorts.Relevant in (* TODO relevance *) - (mkRel 1, lift_tomatch_type (succ lenctx) t) :: lift_ctx 1 prev, + (mkRel 1, lift_tomatch_type (succ lenctx) t) :: lift_ctx 1 prev, LocalDef (make_annot (Name name) r, lift lenctx c, lift lenctx $ type_of_tomatch t) :: ctx, - Id.Set.add name names, tycon) + Id.Set.add name names, tycon) ([], [], Id.Set.empty, tycon) tomatchs in List.rev prev, ctx, tycon @@ -2436,26 +2436,26 @@ let build_dependent_signature env sigma avoid tomatchs arsign = let sigma, eqs, neqs, refls, slift, arsign' = List.fold_left2 (fun (sigma, eqs, neqs, refl_args, slift, arsigns) (tm, ty) arsign -> - (* The accumulator: - previous eqs, - number of previous eqs, - lift to get outside eqs and in the introduced variables ('as' and 'in'), - new arity signatures - *) - match ty with - | IsInd (ty, IndType (indf, args), _) when List.length args > 0 -> - (* Build the arity signature following the names in matched terms - as much as possible *) - let argsign = List.tl arsign in (* arguments in inverse application order *) - let app_decl = List.hd arsign in (* The matched argument *) - let appn = RelDecl.get_name app_decl in - let appt = RelDecl.get_type app_decl in - let argsign = List.rev argsign in (* arguments in application order *) + (* The accumulator: + previous eqs, + number of previous eqs, + lift to get outside eqs and in the introduced variables ('as' and 'in'), + new arity signatures + *) + match ty with + | IsInd (ty, IndType (indf, args), _) when List.length args > 0 -> + (* Build the arity signature following the names in matched terms + as much as possible *) + let argsign = List.tl arsign in (* arguments in inverse application order *) + let app_decl = List.hd arsign in (* The matched argument *) + let appn = RelDecl.get_name app_decl in + let appt = RelDecl.get_type app_decl in + let argsign = List.rev argsign in (* arguments in application order *) let sigma, env', nargeqs, argeqs, refl_args, slift, argsign' = - List.fold_left2 + List.fold_left2 (fun (sigma, env, nargeqs, argeqs, refl_args, slift, argsign') arg decl -> - let name = RelDecl.get_name decl in - let t = RelDecl.get_type decl in + let name = RelDecl.get_name decl in + let t = RelDecl.get_type decl in let argt = Retyping.get_type_of env sigma arg in let sigma, eq, refl_arg = if Reductionops.is_conv env sigma argt t then @@ -2466,7 +2466,7 @@ let build_dependent_signature env sigma avoid tomatchs arsign = in let sigma, refl = mk_eq_refl sigma argt arg in sigma, eq, refl - else + else let sigma, eq = mk_JMeq sigma (lift (nargeqs + slift) t) (mkRel (nargeqs + slift)) @@ -2475,43 +2475,43 @@ let build_dependent_signature env sigma avoid tomatchs arsign = in let sigma, refl = mk_JMeq_refl sigma argt arg in (sigma, eq, refl) - in - let previd, id = - let name = + in + let previd, id = + let name = match EConstr.kind sigma arg with - Rel n -> RelDecl.get_name (lookup_rel n env) - | _ -> name - in - make_prime avoid name - in + Rel n -> RelDecl.get_name (lookup_rel n env) + | _ -> name + in + make_prime avoid name + in (sigma, env, succ nargeqs, (LocalAssum (make_annot (Name (eq_id avoid previd)) Sorts.Relevant, eq)) :: argeqs, refl_arg :: refl_args, - pred slift, - RelDecl.set_name (Name id) decl :: argsign')) + pred slift, + RelDecl.set_name (Name id) decl :: argsign')) (sigma, env, neqs, [], [], slift, []) args argsign - in + in let sigma, eq = mk_JMeq sigma (lift (nargeqs + slift) appt) (mkRel (nargeqs + slift)) (lift (nargeqs + nar) ty) (lift (nargeqs + nar) tm) - in + in let sigma, refl_eq = mk_JMeq_refl sigma ty tm in - let previd, id = make_prime avoid appn in + let previd, id = make_prime avoid appn in (sigma, (LocalAssum (make_annot (Name (eq_id avoid previd)) Sorts.Relevant, eq) :: argeqs) :: eqs, succ nargeqs, - refl_eq :: refl_args, - pred slift, - ((RelDecl.set_name (Name id) app_decl :: argsign') :: arsigns)) - - | _ -> (* Non dependent inductive or not inductive, just use a regular equality *) - let decl = match arsign with [x] -> x | _ -> assert(false) in - let name = RelDecl.get_name decl in - let previd, id = make_prime avoid name in - let arsign' = RelDecl.set_name (Name id) decl in - let tomatch_ty = type_of_tomatch ty in + refl_eq :: refl_args, + pred slift, + ((RelDecl.set_name (Name id) app_decl :: argsign') :: arsigns)) + + | _ -> (* Non dependent inductive or not inductive, just use a regular equality *) + let decl = match arsign with [x] -> x | _ -> assert(false) in + let name = RelDecl.get_name decl in + let previd, id = make_prime avoid name in + let arsign' = RelDecl.set_name (Name id) decl in + let tomatch_ty = type_of_tomatch ty in let sigma, eq = mk_eq sigma (lift nar tomatch_ty) (mkRel slift) (lift nar tm) @@ -2555,7 +2555,7 @@ let compile_program_cases ?loc style (typing_function, sigma) tycon env (* The arity signature *) let arsign = extract_arity_signature ~dolift:false !!env tomatchs tomatchl in (* Build the dependent arity signature, the equalities which makes - the first part of the predicate and their instantiations. *) + the first part of the predicate and their instantiations. *) let avoid = Id.Set.empty in build_dependent_signature !!env sigma avoid tomatchs arsign @@ -2603,12 +2603,12 @@ let compile_program_cases ?loc style (typing_function, sigma) tycon env let typs = List.map (fun (c,d) -> (c,extract_inductive_data !!env sigma d,d)) typs in - + let dep_sign = find_dependencies_signature sigma (List.make (List.length typs) true) typs in - + let typs' = List.map3 (fun (tm,tmt) deps (na,realnames) -> @@ -2616,9 +2616,9 @@ let compile_program_cases ?loc style (typing_function, sigma) tycon env let tmt = set_tomatch_realnames realnames tmt in ((tm,tmt),deps,na)) tomatchs dep_sign nal in - + let initial_pushed = List.map (fun x -> Pushed (true,x)) typs' in - + let typing_function tycon env sigma = function | Some t -> typing_function tycon env sigma t | None -> use_unit_judge env sigma in @@ -2672,8 +2672,8 @@ let compile_cases ?loc ~program_mode style (typing_fun, sigma) tycon env (predop (* TODO relevance *) let out_tmt na = function NotInd (None,t) -> LocalAssum (na,t) - | NotInd (Some b,t) -> LocalDef (na,b,t) - | IsInd (typ,_,_) -> LocalAssum (na,typ) in + | NotInd (Some b,t) -> LocalDef (na,b,t) + | IsInd (typ,_,_) -> LocalAssum (na,typ) in let typs = List.map2 (fun (na,_) (tm,tmt) -> (tm,out_tmt (make_annot na Sorts.Relevant) tmt)) nal tomatchs in let typs = @@ -2701,13 +2701,13 @@ let compile_cases ?loc ~program_mode style (typing_fun, sigma) tycon env (predop let pb = { env = env; - pred = pred; - tomatch = initial_pushed; - history = start_history (List.length initial_pushed); - mat = matx; - caseloc = loc; - casestyle = style; - typing_function = typing_fun } in + pred = pred; + tomatch = initial_pushed; + history = start_history (List.length initial_pushed); + mat = matx; + caseloc = loc; + casestyle = style; + typing_function = typing_fun } in let sigma, j = compile ~program_mode sigma pb in diff --git a/pretyping/cases.mli b/pretyping/cases.mli index 59cb1ca4ab..3db019d827 100644 --- a/pretyping/cases.mli +++ b/pretyping/cases.mli @@ -46,7 +46,7 @@ val compile_cases : GlobEnv.t -> glob_constr option * tomatch_tuples * cases_clauses -> evar_map * unsafe_judgment -val constr_of_pat : +val constr_of_pat : Environ.env -> Evd.evar_map -> rel_context -> diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml index c78f791a5a..2b7ccbbcad 100644 --- a/pretyping/cbv.ml +++ b/pretyping/cbv.ml @@ -384,7 +384,7 @@ and apply_env env t = (* The main recursive functions * - * Go under applications and cases/projections (pushed in the stack), + * Go under applications and cases/projections (pushed in the stack), * expand head constants or substitued de Bruijn, and try to a make a * constructor, a lambda or a fixp appear in the head. If not, it is a value * and is completely computed here. The head redexes are NOT reduced: @@ -403,16 +403,16 @@ let rec norm_head info env t stack = norm_head info env head (stack_app nargs stack) | Case (ci,p,c,v) -> norm_head info env c (CASE(p,v,ci,env,stack)) | Cast (ct,_,_) -> norm_head info env ct stack - - | Proj (p, c) -> + + | Proj (p, c) -> let p' = if red_set info.reds (fCONST (Projection.constant p)) && red_set info.reds fBETA then Projection.unfold p else p - in + in norm_head info env c (PROJ (p', stack)) - + (* constants, axioms * the first pattern is CRUCIAL, n=0 happens very often: * when reducing closed terms, n is always 0 *) @@ -437,10 +437,10 @@ let rec norm_head info env t stack = (* New rule: for Cbv, Delta does not apply to locally bound variables or red_set info.reds fDELTA *) - let env' = subs_cons ([|cbv_stack_term info TOP env b|],env) in + let env' = subs_cons ([|cbv_stack_term info TOP env b|],env) in norm_head info env' c stack else - (CBN(t,env), stack) (* Should we consider a commutative cut ? *) + (CBN(t,env), stack) (* Should we consider a commutative cut ? *) | Evar ev -> (match Reductionops.safe_evar_value info.sigma ev with @@ -517,7 +517,7 @@ and cbv_stack_value info env = function (* constructor in a Case -> IOTA *) | (CONSTR(((sp,n),u),[||]), APP(args,CASE(_,br,ci,env,stk))) when red_set info.reds fMATCH -> - let cargs = + let cargs = Array.sub args ci.ci_npar (Array.length args - ci.ci_npar) in cbv_stack_term info (stack_app cargs stk) env br.(n-1) @@ -530,7 +530,7 @@ and cbv_stack_value info env = function | (CONSTR(((sp,n),u),[||]), APP(args,PROJ(p,stk))) when red_set info.reds fMATCH && Projection.unfolded p -> let arg = args.(Projection.npars p + Projection.arg p) in - cbv_stack_value info env (strip_appl arg stk) + cbv_stack_value info env (strip_appl arg stk) (* may be reduced later by application *) | (FIXP(fix,env,[||]), APP(appl,TOP)) -> FIXP(fix,env,appl) @@ -601,7 +601,7 @@ let rec apply_stack info t = function | CASE (ty,br,ci,env,st) -> apply_stack info (mkCase (ci, cbv_norm_term info env ty, t, - Array.map (cbv_norm_term info env) br)) + Array.map (cbv_norm_term info env) br)) st | PROJ (p, st) -> apply_stack info (mkProj (p, t)) st @@ -630,15 +630,15 @@ and cbv_norm_value info = function (* reduction under binders *) (mkFix (lij, (names, Array.map (cbv_norm_term info env) lty, - Array.map (cbv_norm_term info - (subs_liftn (Array.length lty) env)) bds)), + Array.map (cbv_norm_term info + (subs_liftn (Array.length lty) env)) bds)), Array.map (cbv_norm_value info) args) | COFIXP ((j,(names,lty,bds)),env,args) -> mkApp (mkCoFix (j, (names,Array.map (cbv_norm_term info env) lty, - Array.map (cbv_norm_term info - (subs_liftn (Array.length lty) env)) bds)), + Array.map (cbv_norm_term info + (subs_liftn (Array.length lty) env)) bds)), Array.map (cbv_norm_value info) args) | CONSTR (c,args) -> mkApp(mkConstructU c, Array.map (cbv_norm_value info) args) diff --git a/pretyping/classops.ml b/pretyping/classops.ml index 57dbfb2580..c12a236d8e 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -195,7 +195,7 @@ let subst_cl_typ subst ct = match ct with pi1 (find_class_type Evd.empty (EConstr.of_constr t.Univ.univ_abstracted_value))) | CL_IND i -> let i' = subst_ind subst i in - if i' == i then ct else CL_IND i' + if i' == i then ct else CL_IND i' (*CSC: here we should change the datatype for coercions: it should be possible to declare any term as a coercion *) @@ -267,7 +267,7 @@ let lookup_path_between env sigma (s,t) = let (s,(t,p)) = apply_on_class_of env sigma s (fun i -> apply_on_class_of env sigma t (fun j -> - lookup_path_between_class (i,j))) in + lookup_path_between_class (i,j))) in (s,t,p) let lookup_path_to_fun_from env sigma s = @@ -323,7 +323,7 @@ let warn_ambiguous_path = let different_class_params env i = let ci = class_info_from_index i in if (snd ci).cl_param > 0 then true - else + else match fst ci with | CL_IND i -> Environ.is_polymorphic env (GlobRef.IndRef i) | CL_CONST c -> Environ.is_polymorphic env (GlobRef.ConstRef c) @@ -351,16 +351,16 @@ let add_coercion_in_graph env sigma (ic,source,target) = ClPairMap.iter (fun (s,t) p -> if not (Bijint.Index.equal s t) then begin - if Bijint.Index.equal t source then begin + if Bijint.Index.equal t source then begin try_add_new_path1 (s,target) (p@[ic]); ClPairMap.iter - (fun (u,v) q -> + (fun (u,v) q -> if not (Bijint.Index.equal u v) && Bijint.Index.equal u target && not (List.equal coe_info_typ_equal p q) then - try_add_new_path1 (s,v) (p@[ic]@q)) + try_add_new_path1 (s,v) (p@[ic]@q)) old_inheritance_graph end; if Bijint.Index.equal s target then try_add_new_path1 (source,t) (ic::p) - end) + end) old_inheritance_graph end; match !ambig_paths with [] -> () | _ -> warn_ambiguous_path !ambig_paths diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 3c71871968..e07fec6b43 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -115,18 +115,18 @@ let disc_subset sigma x = | App (c, l) -> (match EConstr.kind sigma c with Ind (i,_) -> - let len = Array.length l in - let sigty = delayed_force sig_typ in - if Int.equal len 2 && eq_ind i (Globnames.destIndRef sigty) - then - let (a, b) = pair_of_array l in - Some (a, b) - else None + let len = Array.length l in + let sigty = delayed_force sig_typ in + if Int.equal len 2 && eq_ind i (Globnames.destIndRef sigty) + then + let (a, b) = pair_of_array l in + Some (a, b) + else None | _ -> None) | _ -> None exception NoSubtacCoercion - + let hnf env evd c = whd_all env evd c let hnf_nodelta env evd c = whd_betaiota evd c @@ -142,12 +142,12 @@ let mu env evdref t = let v' = hnf env !evdref v in match disc_subset !evdref v' with | Some (u, p) -> - let f, ct = aux u in - let p = hnf_nodelta env !evdref p in - (Some (fun x -> - app_opt env evdref - f (papp evdref sig_proj1 [| u; p; x |])), - ct) + let f, ct = aux u in + let p = hnf_nodelta env !evdref p in + (Some (fun x -> + app_opt env evdref + f (papp evdref sig_proj1 [| u; p; x |])), + ct) | None -> (None, v) in aux t @@ -159,7 +159,7 @@ and coerce ?loc env evdref (x : EConstr.constr) (y : EConstr.constr) let x = hnf env !evdref x and y = hnf env !evdref y in try evdref := Evarconv.unify_leq_delay env !evdref x y; - None + None with UnableToUnify _ -> coerce' env x y and coerce' env x y : (EConstr.constr -> EConstr.constr) option = let subco () = subset_coerce env evdref x y in @@ -171,162 +171,162 @@ and coerce ?loc env evdref (x : EConstr.constr) (y : EConstr.constr) let coerce_application typ typ' c c' l l' = let len = Array.length l in let rec aux tele typ typ' i co = - if i < len then - let hdx = l.(i) and hdy = l'.(i) in + if i < len then + let hdx = l.(i) and hdy = l'.(i) in try evdref := unify_leq_delay env !evdref hdx hdy; - let (n, eqT), restT = dest_prod typ in - let (n', eqT'), restT' = dest_prod typ' in + let (n, eqT), restT = dest_prod typ in + let (n', eqT'), restT' = dest_prod typ' in aux (hdx :: tele) (subst1 hdx restT) (subst1 hdy restT') (succ i) co - with UnableToUnify _ -> + with UnableToUnify _ -> let (n, eqT), restT = dest_prod typ in - let (n', eqT'), restT' = dest_prod typ' in + let (n', eqT'), restT' = dest_prod typ' in let () = try evdref := unify_leq_delay env !evdref eqT eqT' with UnableToUnify _ -> raise NoSubtacCoercion in - (* Disallow equalities on arities *) - if Reductionops.is_arity env !evdref eqT then raise NoSubtacCoercion; - let restargs = lift_args 1 - (List.rev (Array.to_list (Array.sub l (succ i) (len - (succ i))))) - in - let args = List.rev (restargs @ mkRel 1 :: List.map (lift 1) tele) in + (* Disallow equalities on arities *) + if Reductionops.is_arity env !evdref eqT then raise NoSubtacCoercion; + let restargs = lift_args 1 + (List.rev (Array.to_list (Array.sub l (succ i) (len - (succ i))))) + in + let args = List.rev (restargs @ mkRel 1 :: List.map (lift 1) tele) in let pred = mkLambda (n, eqT, applist (lift 1 c, args)) in - let eq = papp evdref coq_eq_ind [| eqT; hdx; hdy |] in + let eq = papp evdref coq_eq_ind [| eqT; hdx; hdy |] in let evar = make_existential ?loc n.binder_name env evdref eq in - let eq_app x = papp evdref coq_eq_rect - [| eqT; hdx; pred; x; hdy; evar|] - in - aux (hdy :: tele) (subst1 hdx restT) - (subst1 hdy restT') (succ i) (fun x -> eq_app (co x)) - else Some (fun x -> - let term = co x in + let eq_app x = papp evdref coq_eq_rect + [| eqT; hdx; pred; x; hdy; evar|] + in + aux (hdy :: tele) (subst1 hdx restT) + (subst1 hdy restT') (succ i) (fun x -> eq_app (co x)) + else Some (fun x -> + let term = co x in let sigma, term = Typing.solve_evars env !evdref term in evdref := sigma; term) in - if isEvar !evdref c || isEvar !evdref c' || not (Program.is_program_generalized_coercion ()) then - (* Second-order unification needed. *) - raise NoSubtacCoercion; - aux [] typ typ' 0 (fun x -> x) + if isEvar !evdref c || isEvar !evdref c' || not (Program.is_program_generalized_coercion ()) then + (* Second-order unification needed. *) + raise NoSubtacCoercion; + aux [] typ typ' 0 (fun x -> x) in match (EConstr.kind !evdref x, EConstr.kind !evdref y) with | Sort s, Sort s' -> (match ESorts.kind !evdref s, ESorts.kind !evdref s' with | Prop, Prop | Set, Set -> None | (Prop | Set), Type _ -> None - | Type x, Type y when Univ.Universe.equal x y -> None (* false *) - | _ -> subco ()) + | Type x, Type y when Univ.Universe.equal x y -> None (* false *) + | _ -> subco ()) | Prod (name, a, b), Prod (name', a', b') -> - let name' = + let name' = {name' with binder_name = Name (Namegen.next_ident_away Namegen.default_dependent_ident (Termops.vars_of_env env))} in let env' = push_rel (LocalAssum (name', a')) env in - let c1 = coerce_unify env' (lift 1 a') (lift 1 a) in - (* env, x : a' |- c1 : lift 1 a' > lift 1 a *) - let coec1 = app_opt env' evdref c1 (mkRel 1) in - (* env, x : a' |- c1[x] : lift 1 a *) - let c2 = coerce_unify env' (subst1 coec1 (liftn 1 2 b)) b' in - (* env, x : a' |- c2 : b[c1[x]/x]] > b' *) - (match c1, c2 with - | None, None -> None - | _, _ -> - Some - (fun f -> + let c1 = coerce_unify env' (lift 1 a') (lift 1 a) in + (* env, x : a' |- c1 : lift 1 a' > lift 1 a *) + let coec1 = app_opt env' evdref c1 (mkRel 1) in + (* env, x : a' |- c1[x] : lift 1 a *) + let c2 = coerce_unify env' (subst1 coec1 (liftn 1 2 b)) b' in + (* env, x : a' |- c2 : b[c1[x]/x]] > b' *) + (match c1, c2 with + | None, None -> None + | _, _ -> + Some + (fun f -> mkLambda (name', a', - app_opt env' evdref c2 - (mkApp (lift 1 f, [| coec1 |]))))) + app_opt env' evdref c2 + (mkApp (lift 1 f, [| coec1 |]))))) | App (c, l), App (c', l') -> - (match EConstr.kind !evdref c, EConstr.kind !evdref c' with - Ind (i, u), Ind (i', u') -> (* Inductive types *) - let len = Array.length l in - let sigT = delayed_force sigT_typ in - let prod = delayed_force prod_typ in - (* Sigma types *) - if Int.equal len (Array.length l') && Int.equal len 2 && eq_ind i i' - && (eq_ind i (destIndRef sigT) || eq_ind i (destIndRef prod)) - then - if eq_ind i (destIndRef sigT) - then - begin - let (a, pb), (a', pb') = - pair_of_array l, pair_of_array l' - in - let c1 = coerce_unify env a a' in - let remove_head a c = - match EConstr.kind !evdref c with + (match EConstr.kind !evdref c, EConstr.kind !evdref c' with + Ind (i, u), Ind (i', u') -> (* Inductive types *) + let len = Array.length l in + let sigT = delayed_force sigT_typ in + let prod = delayed_force prod_typ in + (* Sigma types *) + if Int.equal len (Array.length l') && Int.equal len 2 && eq_ind i i' + && (eq_ind i (destIndRef sigT) || eq_ind i (destIndRef prod)) + then + if eq_ind i (destIndRef sigT) + then + begin + let (a, pb), (a', pb') = + pair_of_array l, pair_of_array l' + in + let c1 = coerce_unify env a a' in + let remove_head a c = + match EConstr.kind !evdref c with | Lambda (n, t, t') -> c, t' - | Evar (k, args) -> - let (evs, t) = Evardefine.define_evar_as_lambda env !evdref (k,args) in - evdref := evs; + | Evar (k, args) -> + let (evs, t) = Evardefine.define_evar_as_lambda env !evdref (k,args) in + evdref := evs; let (n, dom, rng) = destLambda !evdref t in - if isEvar !evdref dom then - let (domk, args) = destEvar !evdref dom in + if isEvar !evdref dom then + let (domk, args) = destEvar !evdref dom in evdref := define domk a !evdref; - else (); - t, rng - | _ -> raise NoSubtacCoercion - in + else (); + t, rng + | _ -> raise NoSubtacCoercion + in let (pb, b), (pb', b') = remove_head a pb, remove_head a' pb' in let ra = Retyping.relevance_of_type env !evdref a in let env' = push_rel (LocalAssum (make_annot (Name Namegen.default_dependent_ident) ra, a)) env in - let c2 = coerce_unify env' b b' in - match c1, c2 with - | None, None -> None - | _, _ -> - Some - (fun x -> - let x, y = - app_opt env' evdref c1 (papp evdref sigT_proj1 - [| a; pb; x |]), - app_opt env' evdref c2 (papp evdref sigT_proj2 - [| a; pb; x |]) - in - papp evdref sigT_intro [| a'; pb'; x ; y |]) - end - else - begin - let (a, b), (a', b') = - pair_of_array l, pair_of_array l' - in - let c1 = coerce_unify env a a' in - let c2 = coerce_unify env b b' in - match c1, c2 with - | None, None -> None - | _, _ -> - Some - (fun x -> - let x, y = - app_opt env evdref c1 (papp evdref prod_proj1 - [| a; b; x |]), - app_opt env evdref c2 (papp evdref prod_proj2 - [| a; b; x |]) - in - papp evdref prod_intro [| a'; b'; x ; y |]) - end - else - if eq_ind i i' && Int.equal len (Array.length l') then - let evm = !evdref in - (try subco () - with NoSubtacCoercion -> - let typ = Typing.unsafe_type_of env evm c in - let typ' = Typing.unsafe_type_of env evm c' in - coerce_application typ typ' c c' l l') - else - subco () - | x, y when EConstr.eq_constr !evdref c c' -> - if Int.equal (Array.length l) (Array.length l') then - let evm = !evdref in - let lam_type = Typing.unsafe_type_of env evm c in - let lam_type' = Typing.unsafe_type_of env evm c' in - coerce_application lam_type lam_type' c c' l l' - else subco () - | _ -> subco ()) + let c2 = coerce_unify env' b b' in + match c1, c2 with + | None, None -> None + | _, _ -> + Some + (fun x -> + let x, y = + app_opt env' evdref c1 (papp evdref sigT_proj1 + [| a; pb; x |]), + app_opt env' evdref c2 (papp evdref sigT_proj2 + [| a; pb; x |]) + in + papp evdref sigT_intro [| a'; pb'; x ; y |]) + end + else + begin + let (a, b), (a', b') = + pair_of_array l, pair_of_array l' + in + let c1 = coerce_unify env a a' in + let c2 = coerce_unify env b b' in + match c1, c2 with + | None, None -> None + | _, _ -> + Some + (fun x -> + let x, y = + app_opt env evdref c1 (papp evdref prod_proj1 + [| a; b; x |]), + app_opt env evdref c2 (papp evdref prod_proj2 + [| a; b; x |]) + in + papp evdref prod_intro [| a'; b'; x ; y |]) + end + else + if eq_ind i i' && Int.equal len (Array.length l') then + let evm = !evdref in + (try subco () + with NoSubtacCoercion -> + let typ = Typing.unsafe_type_of env evm c in + let typ' = Typing.unsafe_type_of env evm c' in + coerce_application typ typ' c c' l l') + else + subco () + | x, y when EConstr.eq_constr !evdref c c' -> + if Int.equal (Array.length l) (Array.length l') then + let evm = !evdref in + let lam_type = Typing.unsafe_type_of env evm c in + let lam_type' = Typing.unsafe_type_of env evm c' in + coerce_application lam_type lam_type' c c' l l' + else subco () + | _ -> subco ()) | _, _ -> subco () and subset_coerce env evdref x y = @@ -334,20 +334,20 @@ and coerce ?loc env evdref (x : EConstr.constr) (y : EConstr.constr) Some (u, p) -> let c = coerce_unify env u y in let f x = - app_opt env evdref c (papp evdref sig_proj1 [| u; p; x |]) + app_opt env evdref c (papp evdref sig_proj1 [| u; p; x |]) in Some f | None -> - match disc_subset !evdref y with - Some (u, p) -> - let c = coerce_unify env x u in - Some - (fun x -> - let cx = app_opt env evdref c x in - let evar = make_existential ?loc Anonymous env evdref (mkApp (p, [| cx |])) - in - (papp evdref sig_intro [| u; p; cx; evar |])) - | None -> - raise NoSubtacCoercion + match disc_subset !evdref y with + Some (u, p) -> + let c = coerce_unify env x u in + Some + (fun x -> + let cx = app_opt env evdref c x in + let evar = make_existential ?loc Anonymous env evdref (mkApp (p, [| cx |])) + in + (papp evdref sig_intro [| u; p; cx; evar |])) + | None -> + raise NoSubtacCoercion in coerce_unify env x y let app_coercion env evdref coercion v = @@ -371,7 +371,7 @@ let saturate_evd env evd = (* Apply coercion path from p to hj; raise NoCoercion if not applicable *) let apply_coercion env sigma p hj typ_cl = try - let j,t,evd = + let j,t,evd = List.fold_left (fun (ja,typ_cl,sigma) i -> let isid = i.coe_is_identity in @@ -379,15 +379,15 @@ let apply_coercion env sigma p hj typ_cl = let sigma, c = new_global sigma i.coe_value in let typ = Retyping.get_type_of env sigma c in let fv = make_judge c typ in - let argl = (class_args_of env sigma typ_cl)@[ja.uj_val] in - let sigma, jres = - apply_coercion_args env sigma true isproj argl fv - in - (if isid then - { uj_val = ja.uj_val; uj_type = jres.uj_type } - else - jres), - jres.uj_type,sigma) + let argl = (class_args_of env sigma typ_cl)@[ja.uj_val] in + let sigma, jres = + apply_coercion_args env sigma true isproj argl fv + in + (if isid then + { uj_val = ja.uj_val; uj_type = jres.uj_type } + else + jres), + jres.uj_type,sigma) (hj,typ_cl,sigma) p in evd, j with NoCoercion as e -> raise e @@ -399,11 +399,11 @@ let inh_app_fun_core ~program_mode env evd j = | Prod _ -> (evd,j) | Evar ev -> let (evd',t) = Evardefine.define_evar_as_product env evd ev in - (evd',{ uj_val = j.uj_val; uj_type = t }) + (evd',{ uj_val = j.uj_val; uj_type = t }) | _ -> - try let t,p = - lookup_path_to_fun_from env evd j.uj_type in - apply_coercion env evd p j t + try let t,p = + lookup_path_to_fun_from env evd j.uj_type in + apply_coercion env evd p j t with Not_found | NoCoercion -> if program_mode then try @@ -444,10 +444,10 @@ let inh_coerce_to_sort ?loc env evd j = match EConstr.kind evd typ with | Sort s -> (evd,{ utj_val = j.uj_val; utj_type = ESorts.kind evd s }) | Evar ev -> - let (evd',s) = Evardefine.define_evar_as_sort env evd ev in - (evd',{ utj_val = j.uj_val; utj_type = s }) + let (evd',s) = Evardefine.define_evar_as_sort env evd ev in + (evd',{ utj_val = j.uj_val; utj_type = s }) | _ -> - inh_tosort_force ?loc env evd j + inh_tosort_force ?loc env evd j let inh_coerce_to_base ?loc ~program_mode env evd j = if program_mode then @@ -455,7 +455,7 @@ let inh_coerce_to_base ?loc ~program_mode env evd j = let ct, typ' = mu env evdref j.uj_type in let res = { uj_val = (app_coercion env evdref ct j.uj_val); - uj_type = typ' } + uj_type = typ' } in !evdref, res else (evd, j) @@ -473,14 +473,14 @@ let inh_coerce_to_fail flags env evd rigidonly v t c1 = else let evd, v', t' = try - let t2,t1,p = lookup_path_between env evd (t,c1) in - match v with - | Some v -> - let evd,j = - apply_coercion env evd p - {uj_val = v; uj_type = t} t2 in - evd, Some j.uj_val, j.uj_type - | None -> evd, None, t + let t2,t1,p = lookup_path_between env evd (t,c1) in + match v with + | Some v -> + let evd,j = + apply_coercion env evd p + {uj_val = v; uj_type = t} t2 in + evd, Some j.uj_val, j.uj_type + | None -> evd, None, t with Not_found -> raise NoCoercion in try (unify_leq_delay ~flags env evd t' c1, v') @@ -501,24 +501,24 @@ let rec inh_conv_coerce_to_fail ?loc env evd ?(flags=default_flags_of env) rigid | Prod (name,t1,t2), Prod (_,u1,u2) -> (* Conversion did not work, we may succeed with a coercion. *) (* We eta-expand (hence possibly modifying the original term!) *) - (* and look for a coercion c:u1->t1 s.t. fun x:u1 => v' (c x)) *) - (* has type forall (x:u1), u2 (with v' recursively obtained) *) + (* and look for a coercion c:u1->t1 s.t. fun x:u1 => v' (c x)) *) + (* has type forall (x:u1), u2 (with v' recursively obtained) *) (* Note: we retype the term because template polymorphism may have *) (* weakened its type *) let name = map_annot (function - | Anonymous -> Name Namegen.default_dependent_ident + | Anonymous -> Name Namegen.default_dependent_ident | na -> na) name in - let open Context.Rel.Declaration in + let open Context.Rel.Declaration in let env1 = push_rel (LocalAssum (name,u1)) env in - let (evd', v1) = - inh_conv_coerce_to_fail ?loc env1 evd rigidonly + let (evd', v1) = + inh_conv_coerce_to_fail ?loc env1 evd rigidonly (Some (mkRel 1)) (lift 1 u1) (lift 1 t1) in let v1 = Option.get v1 in - let v2 = Option.map (fun v -> beta_applist evd' (lift 1 v,[v1])) v in - let t2 = match v2 with - | None -> subst_term evd' v1 t2 - | Some v2 -> Retyping.get_type_of env1 evd' v2 in - let (evd'',v2') = inh_conv_coerce_to_fail ?loc env1 evd' rigidonly v2 t2 u2 in + let v2 = Option.map (fun v -> beta_applist evd' (lift 1 v,[v1])) v in + let t2 = match v2 with + | None -> subst_term evd' v1 t2 + | Some v2 -> Retyping.get_type_of env1 evd' v2 in + let (evd'',v2') = inh_conv_coerce_to_fail ?loc env1 evd' rigidonly v2 t2 u2 in (evd'', Option.map (fun v2' -> mkLambda (name, u1, v2')) v2') | _ -> raise (NoCoercionNoUnifier (best_failed_evd,e)) @@ -530,20 +530,20 @@ let inh_conv_coerce_to_gen ?loc ~program_mode resolve_tc rigidonly flags env evd with NoCoercionNoUnifier (best_failed_evd,e) -> try if program_mode then - coerce_itf ?loc env evd (Some cj.uj_val) cj.uj_type t - else raise NoSubtacCoercion + coerce_itf ?loc env evd (Some cj.uj_val) cj.uj_type t + else raise NoSubtacCoercion with | NoSubtacCoercion when not resolve_tc || not (get_use_typeclasses_for_conversion ()) -> - error_actual_type ?loc env best_failed_evd cj t e + error_actual_type ?loc env best_failed_evd cj t e | NoSubtacCoercion -> - let evd' = saturate_evd env evd in - try - if evd' == evd then - error_actual_type ?loc env best_failed_evd cj t e - else - inh_conv_coerce_to_fail ?loc env evd' rigidonly (Some cj.uj_val) cj.uj_type t - with NoCoercionNoUnifier (_evd,_error) -> - error_actual_type ?loc env best_failed_evd cj t e + let evd' = saturate_evd env evd in + try + if evd' == evd then + error_actual_type ?loc env best_failed_evd cj t e + else + inh_conv_coerce_to_fail ?loc env evd' rigidonly (Some cj.uj_val) cj.uj_type t + with NoCoercionNoUnifier (_evd,_error) -> + error_actual_type ?loc env best_failed_evd cj t e in let val' = match val' with Some v -> v | None -> assert(false) in (evd',{ uj_val = val'; uj_type = t }) @@ -558,4 +558,4 @@ let inh_conv_coerces_to ?loc env evd ?(flags=default_flags_of env) t t' = fst (inh_conv_coerce_to_fail ?loc env evd ~flags true None t t') with NoCoercion -> evd (* Maybe not enough information to unify *) - + diff --git a/pretyping/coercion.mli b/pretyping/coercion.mli index 0dc8208786..3b24bcec8b 100644 --- a/pretyping/coercion.mli +++ b/pretyping/coercion.mli @@ -40,7 +40,7 @@ val inh_coerce_to_base : ?loc:Loc.t -> program_mode:bool -> val inh_coerce_to_prod : ?loc:Loc.t -> program_mode:bool -> env -> evar_map -> types -> evar_map * types -(** [inh_conv_coerce_to resolve_tc Loc.t env isevars j t] coerces [j] to an +(** [inh_conv_coerce_to resolve_tc Loc.t env isevars j t] coerces [j] to an object of type [t]; i.e. it inserts a coercion into [j], if needed, in such a way [t] and [j.uj_type] are convertible; it fails if no coercion is applicable. resolve_tc=false disables resolving type classes (as the last diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index d1cc21d82f..7d1bb5e3b1 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -291,46 +291,46 @@ let matches_core env sigma allow_bound_rels (let diff = Array.length args2 - Array.length args1 in if diff >= 0 then let args21, args22 = Array.chop diff args2 in - let c = mkApp(c2,args21) in + let c = mkApp(c2,args21) in let subst = match meta with | None -> subst | Some n -> merge_binding sigma allow_bound_rels ctx n c subst in Array.fold_left2 (sorec ctx env) subst args1 args22 else (* Might be a projection on the right *) - match EConstr.kind sigma c2 with - | Proj (pr, c) when not (Projection.unfolded pr) -> - (try let term = Retyping.expand_projection env sigma pr c (Array.to_list args2) in - sorec ctx env subst p term - with Retyping.RetypeError _ -> raise PatternMatchingFailure) - | _ -> raise PatternMatchingFailure) - + match EConstr.kind sigma c2 with + | Proj (pr, c) when not (Projection.unfolded pr) -> + (try let term = Retyping.expand_projection env sigma pr c (Array.to_list args2) in + sorec ctx env subst p term + with Retyping.RetypeError _ -> raise PatternMatchingFailure) + | _ -> raise PatternMatchingFailure) + | PApp (c1,arg1), App (c2,arg2) -> - (match c1, EConstr.kind sigma c2 with + (match c1, EConstr.kind sigma c2 with | PRef (GlobRef.ConstRef r), Proj (pr,c) when not (Constant.equal r (Projection.constant pr)) - || Projection.unfolded pr -> - raise PatternMatchingFailure - | PProj (pr1,c1), Proj (pr,c) -> - if Projection.equal pr1 pr then - try Array.fold_left2 (sorec ctx env) (sorec ctx env subst c1 c) arg1 arg2 - with Invalid_argument _ -> raise PatternMatchingFailure - else raise PatternMatchingFailure - | _, Proj (pr,c) when not (Projection.unfolded pr) -> - (try let term = Retyping.expand_projection env sigma pr c (Array.to_list arg2) in - sorec ctx env subst p term - with Retyping.RetypeError _ -> raise PatternMatchingFailure) - | _, _ -> + || Projection.unfolded pr -> + raise PatternMatchingFailure + | PProj (pr1,c1), Proj (pr,c) -> + if Projection.equal pr1 pr then + try Array.fold_left2 (sorec ctx env) (sorec ctx env subst c1 c) arg1 arg2 + with Invalid_argument _ -> raise PatternMatchingFailure + else raise PatternMatchingFailure + | _, Proj (pr,c) when not (Projection.unfolded pr) -> + (try let term = Retyping.expand_projection env sigma pr c (Array.to_list arg2) in + sorec ctx env subst p term + with Retyping.RetypeError _ -> raise PatternMatchingFailure) + | _, _ -> try Array.fold_left2 (sorec ctx env) (sorec ctx env subst c1 c2) arg1 arg2 with Invalid_argument _ -> raise PatternMatchingFailure) - + | PApp (PRef (GlobRef.ConstRef c1), _), Proj (pr, c2) - when Projection.unfolded pr || not (Constant.equal c1 (Projection.constant pr)) -> - raise PatternMatchingFailure - + when Projection.unfolded pr || not (Constant.equal c1 (Projection.constant pr)) -> + raise PatternMatchingFailure + | PApp (c, args), Proj (pr, c2) -> - (try let term = Retyping.expand_projection env sigma pr c2 [] in - sorec ctx env subst p term - with Retyping.RetypeError _ -> raise PatternMatchingFailure) + (try let term = Retyping.expand_projection env sigma pr c2 [] in + sorec ctx env subst p term + with Retyping.RetypeError _ -> raise PatternMatchingFailure) | PProj (p1,c1), Proj (p2,c2) when Projection.equal p1 p2 -> sorec ctx env subst c1 c2 @@ -352,23 +352,23 @@ let matches_core env sigma allow_bound_rels (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2 | PIf (a1,b1,b1'), Case (ci,_,a2,[|b2;b2'|]) -> - let ctx_b2,b2 = decompose_lam_n_decls sigma ci.ci_cstr_ndecls.(0) b2 in - let ctx_b2',b2' = decompose_lam_n_decls sigma ci.ci_cstr_ndecls.(1) b2' in - let n = Context.Rel.length ctx_b2 in + let ctx_b2,b2 = decompose_lam_n_decls sigma ci.ci_cstr_ndecls.(0) b2 in + let ctx_b2',b2' = decompose_lam_n_decls sigma ci.ci_cstr_ndecls.(1) b2' in + let n = Context.Rel.length ctx_b2 in let n' = Context.Rel.length ctx_b2' in - if Vars.noccur_between sigma 1 n b2 && Vars.noccur_between sigma 1 n' b2' then + if Vars.noccur_between sigma 1 n b2 && Vars.noccur_between sigma 1 n' b2' then let f l (LocalAssum (na,t) | LocalDef (na,_,t)) = push_binder Anonymous na t l in - let ctx_br = List.fold_left f ctx ctx_b2 in - let ctx_br' = List.fold_left f ctx ctx_b2' in - let b1 = lift_pattern n b1 and b1' = lift_pattern n' b1' in - sorec ctx_br' (push_rel_context ctx_b2' env) - (sorec ctx_br (push_rel_context ctx_b2 env) + let ctx_br = List.fold_left f ctx ctx_b2 in + let ctx_br' = List.fold_left f ctx ctx_b2' in + let b1 = lift_pattern n b1 and b1' = lift_pattern n' b1' in + sorec ctx_br' (push_rel_context ctx_b2' env) + (sorec ctx_br (push_rel_context ctx_b2 env) (sorec ctx env subst a1 a2) b1 b2) b1' b2' else raise PatternMatchingFailure | PCase (ci1,p1,a1,br1), Case (ci2,p2,a2,br2) -> - let n2 = Array.length br2 in + let n2 = Array.length br2 in let () = match ci1.cip_ind with | None -> () | Some ind1 -> @@ -380,14 +380,14 @@ let matches_core env sigma allow_bound_rels if not ci1.cip_extensible && not (Int.equal (List.length br1) n2) then raise PatternMatchingFailure in - let chk_branch subst (j,n,c) = - (* (ind,j+1) is normally known to be a correct constructor - and br2 a correct match over the same inductive *) - assert (j < n2); - sorec ctx env subst c br2.(j) - in - let chk_head = sorec ctx env (sorec ctx env subst a1 a2) p1 p2 in - List.fold_left chk_branch chk_head br1 + let chk_branch subst (j,n,c) = + (* (ind,j+1) is normally known to be a correct constructor + and br2 a correct match over the same inductive *) + assert (j < n2); + sorec ctx env subst c br2.(j) + in + let chk_head = sorec ctx env (sorec ctx env subst a1 a2) p1 p2 in + List.fold_left chk_branch chk_head br1 | PFix ((ln1,i1),(lna1,tl1,bl1)), Fix ((ln2,i2),(lna2,tl2,bl2)) when Array.equal Int.equal ln1 ln2 && i1 = i2 -> diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 5dd4772bcc..862865bd90 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -133,8 +133,8 @@ let add_name na b t (nenv, env) = add_name na nenv, push_rel (match b with | None -> LocalAssum (make_annot na r,t) | Some b -> LocalDef (make_annot na r,b,t) - ) - env + ) + env let add_name_opt na b t (nenv, env) = match t with @@ -199,7 +199,7 @@ module PrintingCasesIf = let member_message s b = str "Cases on elements of " ++ s ++ str - (if b then " are printed using a `if' form" + (if b then " are printed using a `if' form" else " are not printed using a `if' form") end) @@ -212,7 +212,7 @@ module PrintingCasesLet = let member_message s b = str "Cases on elements of " ++ s ++ str - (if b then " are printed using a `let' form" + (if b then " are printed using a `let' form" else " are not printed using a `let' form") end) @@ -227,11 +227,11 @@ let wildcard_value = ref true let force_wildcard () = !wildcard_value let () = declare_bool_option - { optdepr = false; - optname = "forced wildcard"; - optkey = ["Printing";"Wildcard"]; - optread = force_wildcard; - optwrite = (:=) wildcard_value } + { optdepr = false; + optname = "forced wildcard"; + optkey = ["Printing";"Wildcard"]; + optread = force_wildcard; + optwrite = (:=) wildcard_value } let fast_name_generation = ref false @@ -247,33 +247,33 @@ let synth_type_value = ref true let synthetize_type () = !synth_type_value let () = declare_bool_option - { optdepr = false; - optname = "pattern matching return type synthesizability"; - optkey = ["Printing";"Synth"]; - optread = synthetize_type; - optwrite = (:=) synth_type_value } + { optdepr = false; + optname = "pattern matching return type synthesizability"; + optkey = ["Printing";"Synth"]; + optread = synthetize_type; + optwrite = (:=) synth_type_value } let reverse_matching_value = ref true let reverse_matching () = !reverse_matching_value let () = declare_bool_option - { optdepr = false; - optname = "pattern-matching reversibility"; - optkey = ["Printing";"Matching"]; - optread = reverse_matching; - optwrite = (:=) reverse_matching_value } + { optdepr = false; + optname = "pattern-matching reversibility"; + optkey = ["Printing";"Matching"]; + optread = reverse_matching; + optwrite = (:=) reverse_matching_value } let print_primproj_params_value = ref false let print_primproj_params () = !print_primproj_params_value let () = declare_bool_option - { optdepr = false; - optname = "printing of primitive projection parameters"; - optkey = ["Printing";"Primitive";"Projection";"Parameters"]; - optread = print_primproj_params; - optwrite = (:=) print_primproj_params_value } + { optdepr = false; + optname = "printing of primitive projection parameters"; + optkey = ["Printing";"Primitive";"Projection";"Parameters"]; + optread = print_primproj_params; + optwrite = (:=) print_primproj_params_value } + - (* Auxiliary function for MutCase printing *) (* [computable] tries to tell if the predicate typing the result is inferable*) @@ -304,11 +304,11 @@ let lookup_name_as_displayed env sigma t s = | Prod (name,_,c') -> (match compute_displayed_name_in sigma RenamingForGoal avoid name.binder_name c' with | (Name id,avoid') -> if Id.equal id s then Some n else lookup avoid' (n+1) c' - | (Anonymous,avoid') -> lookup avoid' (n+1) (pop c')) + | (Anonymous,avoid') -> lookup avoid' (n+1) (pop c')) | LetIn (name,_,_,c') -> (match Namegen.compute_displayed_name_in sigma RenamingForGoal avoid name.binder_name c' with | (Name id,avoid') -> if Id.equal id s then Some n else lookup avoid' (n+1) c' - | (Anonymous,avoid') -> lookup avoid' (n+1) (pop c')) + | (Anonymous,avoid') -> lookup avoid' (n+1) (pop c')) | Cast (c,_,_) -> lookup avoid n c | _ -> None in lookup (Environ.ids_of_named_context_val (Environ.named_context_val env)) 1 t @@ -319,23 +319,23 @@ let lookup_index_as_renamed env sigma t n = (match Namegen.compute_displayed_name_in sigma RenamingForGoal Id.Set.empty name.binder_name c' with (Name _,_) -> lookup n (d+1) c' | (Anonymous,_) -> - if Int.equal n 0 then - Some (d-1) - else if Int.equal n 1 then - Some d - else - lookup (n-1) (d+1) c') + if Int.equal n 0 then + Some (d-1) + else if Int.equal n 1 then + Some d + else + lookup (n-1) (d+1) c') | LetIn (name,_,_,c') -> (match Namegen.compute_displayed_name_in sigma RenamingForGoal Id.Set.empty name.binder_name c' with | (Name _,_) -> lookup n (d+1) c' | (Anonymous,_) -> - if Int.equal n 0 then - Some (d-1) - else if Int.equal n 1 then - Some d - else - lookup (n-1) (d+1) c' - ) + if Int.equal n 0 then + Some (d-1) + else if Int.equal n 1 then + Some d + else + lookup (n-1) (d+1) c' + ) | Cast (c,_,_) -> lookup n d c | _ -> if Int.equal n 0 then Some (d-1) else None in lookup n 1 t @@ -444,10 +444,10 @@ let rec decomp_branch tags nal flags (avoid,env as e) sigma c = | Lambda (na,t,c),false -> na.binder_name,c,true,None,Some t | LetIn (na,b,t,c),true -> na.binder_name,c,false,Some b,Some t - | _, false -> - Name default_dependent_ident,(applist (lift 1 c, [mkRel 1])), + | _, false -> + Name default_dependent_ident,(applist (lift 1 c, [mkRel 1])), false,None,None - | _, true -> + | _, true -> Anonymous,lift 1 c,false,None,None in let na',avoid' = compute_name sigma ~let_in ~pattern:true flags avoid env na c in @@ -468,14 +468,14 @@ and align_tree nal isgoal (e,c as rhs) sigma = match nal with | Case (ci,p,c,cl) when eq_constr sigma c (mkRel (List.index Name.equal na (fst (snd e)))) && not (Int.equal (Array.length cl) 0) - && (* don't contract if p dependent *) - computable sigma p (List.length ci.ci_pp_info.ind_tags) (* FIXME: can do better *) -> - let clauses = build_tree na isgoal e sigma ci cl in - List.flatten + && (* don't contract if p dependent *) + computable sigma p (List.length ci.ci_pp_info.ind_tags) (* FIXME: can do better *) -> + let clauses = build_tree na isgoal e sigma ci cl in + List.flatten (List.map (fun (ids,pat,rhs) -> - let lines = align_tree nal isgoal rhs sigma in + let lines = align_tree nal isgoal rhs sigma in List.map (fun (ids',hd,rest) -> Id.Set.fold Id.Set.add ids ids',pat::hd,rest) lines) - clauses) + clauses) | _ -> let na = update_name sigma na rhs in let pat = DAst.make @@ PatVar na in @@ -518,15 +518,15 @@ let it_destRLambda_or_LetIn_names l c = | _, true::l -> (* let-expansion *) aux l (Anonymous :: nal) c | _, false::l -> (* eta-expansion *) - let next l = - let x = next_ident_away default_dependent_ident l in - (* Not efficient but unusual and no function to get free glob_vars *) + let next l = + let x = next_ident_away default_dependent_ident l in + (* Not efficient but unusual and no function to get free glob_vars *) (* if occur_glob_constr x c then next (x::l) else x in *) - x - in - let x = next (free_glob_vars c) in - let a = DAst.make @@ GVar x in - aux l (Name x :: nal) + x + in + let x = next (free_glob_vars c) in + let a = DAst.make @@ GVar x in + aux l (Name x :: nal) (match DAst.get c with | GApp (p,l) -> DAst.make ?loc:c.CAst.loc @@ GApp (p,l@[a]) | _ -> DAst.make @@ GApp (c,[a])) @@ -557,13 +557,13 @@ let detype_case computable detype detype_eqns testdep avoid data p c bl = if !Flags.raw_print then RegularStyle else if st == LetPatternStyle then - st + st else if PrintingLet.active indsp then - LetStyle + LetStyle else if PrintingIf.active indsp then - IfStyle + IfStyle else - st + st with Not_found -> st in match tag, aliastyp with @@ -574,13 +574,13 @@ let detype_case computable detype detype_eqns testdep avoid data p c bl = | IfStyle, None -> let bl' = Array.map detype bl in let nondepbrs = - Array.map3 (extract_nondep_branches testdep) bl bl' constagsl in + Array.map3 (extract_nondep_branches testdep) bl bl' constagsl in if Array.for_all ((!=) None) nondepbrs then - GIf (tomatch,(alias,pred), + GIf (tomatch,(alias,pred), Option.get nondepbrs.(0),Option.get nondepbrs.(1)) else - let eqnl = detype_eqns constructs constagsl bl in - GCases (tag,pred,[tomatch,(alias,aliastyp)],eqnl) + let eqnl = detype_eqns constructs constagsl bl in + GCases (tag,pred,[tomatch,(alias,aliastyp)],eqnl) | _ -> let eqnl = detype_eqns constructs constagsl bl in GCases (tag,pred,[tomatch,(alias,aliastyp)],eqnl) @@ -712,7 +712,7 @@ let detype_level sigma l = let l = hack_qualid_of_univ_level sigma l in UNamed (GType l) -let detype_instance sigma l = +let detype_instance sigma l = let l = EInstance.kind sigma l in if Univ.Instance.is_empty l then None else Some (List.map (detype_level sigma) (Array.to_list (Univ.Instance.to_array l))) @@ -737,37 +737,37 @@ and detype_r d flags avoid env sigma t = let s = "_UNBOUND_REL_"^(string_of_int n) in GVar (Id.of_string s)) | Meta n -> - (* Meta in constr are not user-parsable and are mapped to Evar *) + (* Meta in constr are not user-parsable and are mapped to Evar *) if n = Constr_matching.special_meta then (* Using a dash to be unparsable *) - GEvar (Id.of_string_soft "CONTEXT-HOLE", []) + GEvar (Id.of_string_soft "CONTEXT-HOLE", []) else - GEvar (Id.of_string_soft ("M" ^ string_of_int n), []) + GEvar (Id.of_string_soft ("M" ^ string_of_int n), []) | Var id -> (* Discriminate between section variable and non-section variable *) (try let _ = Global.lookup_named id in GRef (GlobRef.VarRef id, None) - with Not_found -> GVar id) + with Not_found -> GVar id) | Sort s -> GSort (detype_sort sigma (ESorts.kind sigma s)) | Cast (c1,REVERTcast,c2) when not !Flags.raw_print -> DAst.get (detype d flags avoid env sigma c1) | Cast (c1,k,c2) -> let d1 = detype d flags avoid env sigma c1 in - let d2 = detype d flags avoid env sigma c2 in + let d2 = detype d flags avoid env sigma c2 in let cast = match k with | VMcast -> CastVM d2 | NATIVEcast -> CastNative d2 | _ -> CastConv d2 in - GCast(d1,cast) + GCast(d1,cast) | Prod (na,ty,c) -> detype_binder d flags BProd avoid env sigma na None ty c | Lambda (na,ty,c) -> detype_binder d flags BLambda avoid env sigma na None ty c | LetIn (na,b,ty,c) -> detype_binder d flags BLetIn avoid env sigma na (Some b) ty c | App (f,args) -> - let mkapp f' args' = - match DAst.get f' with - | GApp (f',args'') -> - GApp (f',args''@args') - | _ -> GApp (f',args') + let mkapp f' args' = + match DAst.get f' with + | GApp (f',args'') -> + GApp (f',args''@args') + | _ -> GApp (f',args') in mkapp (detype d flags avoid env sigma f) (Array.map_to_list (detype d flags avoid env sigma) args) @@ -781,12 +781,12 @@ and detype_r d flags avoid env sigma t = (args @ [detype d flags avoid env sigma c])) in if flags.flg_lax || !Flags.in_debugger || !Flags.in_toplevel then - try noparams () - with _ -> - (* lax mode, used by debug printers only *) + try noparams () + with _ -> + (* lax mode, used by debug printers only *) GApp (DAst.make @@ GRef (GlobRef.ConstRef (Projection.constant p), None), - [detype d flags avoid env sigma c]) - else + [detype d flags avoid env sigma c]) + else if print_primproj_params () then try let c = Retyping.expand_projection (snd env) sigma p c [] in @@ -800,7 +800,7 @@ and detype_r d flags avoid env sigma t = | LocalDef _ -> true | LocalAssum (id,_) -> try let n = List.index Name.equal (Name id.binder_name) (fst env) in - isRelN sigma n c + isRelN sigma n c with Not_found -> isVarId sigma id.binder_name c in let id,l = @@ -824,12 +824,12 @@ and detype_r d flags avoid env sigma t = | Construct (cstr_sp,u) -> GRef (GlobRef.ConstructRef cstr_sp, detype_instance sigma u) | Case (ci,p,c,bl) -> - let comp = computable sigma p (List.length (ci.ci_pp_info.ind_tags)) in - detype_case comp (detype d flags avoid env sigma) - (detype_eqns d flags avoid env sigma ci comp) - (is_nondep_branch sigma) avoid - (ci.ci_ind,ci.ci_pp_info.style, - ci.ci_pp_info.cstr_tags,ci.ci_pp_info.ind_tags) + let comp = computable sigma p (List.length (ci.ci_pp_info.ind_tags)) in + detype_case comp (detype d flags avoid env sigma) + (detype_eqns d flags avoid env sigma ci comp) + (is_nondep_branch sigma) avoid + (ci.ci_ind,ci.ci_pp_info.style, + ci.ci_pp_info.cstr_tags,ci.ci_pp_info.ind_tags) p c bl | Fix (nvn,recdef) -> detype_fix (detype d) flags avoid env sigma nvn recdef | CoFix (n,recdef) -> detype_cofix (detype d) flags avoid env sigma n recdef @@ -870,20 +870,20 @@ and detype_eqn d flags avoid env sigma constr construct_nargs branch = buildrec new_ids (pat::patlist) new_avoid new_env l b' | Cast (c,_,_), l -> (* Oui, il y a parfois des cast *) - buildrec ids patlist avoid env l c + buildrec ids patlist avoid env l c | _, true::l -> - let pat = DAst.make @@ PatVar Anonymous in + let pat = DAst.make @@ PatVar Anonymous in buildrec ids (pat::patlist) avoid env l b | _, false::l -> (* eta-expansion : n'arrivera plus lorsque tous les termes seront construits à partir de la syntaxe Cases *) (* nommage de la nouvelle variable *) - let new_b = applist (lift 1 b, [mkRel 1]) in + let new_b = applist (lift 1 b, [mkRel 1]) in let pat,new_avoid,new_env,new_ids = - make_pat Anonymous avoid env new_b None mkProp ids in - buildrec new_ids (pat::patlist) new_avoid new_env l new_b + make_pat Anonymous avoid env new_b None mkProp ids in + buildrec new_ids (pat::patlist) new_avoid new_env l new_b in buildrec Id.Set.empty [] avoid env construct_nargs branch @@ -912,13 +912,13 @@ let detype_rel_context d flags where avoid env sigma sign = let na = get_name decl in let t = get_type decl in let na',avoid' = - match where with - | None -> na,avoid - | Some c -> + match where with + | None -> na,avoid + | Some c -> compute_name sigma ~let_in:(is_local_def decl) ~pattern:false flags avoid env na c in let b = match decl with - | LocalAssum _ -> None + | LocalAssum _ -> None | LocalDef (_,b,_) -> Some b in let b' = Option.map (detype d flags avoid env sigma) b in @@ -926,7 +926,7 @@ let detype_rel_context d flags where avoid env sigma sign = (na',Explicit,b',t') :: aux avoid' (add_name na' b t env) rest in aux avoid env (List.rev sign) -let detype_names isgoal avoid nenv env sigma t = +let detype_names isgoal avoid nenv env sigma t = let flags = { flg_isgoal = isgoal; flg_lax = false } in let avoid = Avoid.make ~fast:!fast_name_generation avoid in detype Now flags avoid (nenv,env) sigma t @@ -1008,8 +1008,8 @@ let rec subst_cases_pattern subst = DAst.map (function | PatCstr (((kn,i),j),cpl,n) as pat -> let kn' = subst_mind subst kn and cpl' = List.Smart.map (subst_cases_pattern subst) cpl in - if kn' == kn && cpl' == cpl then pat else - PatCstr (((kn',i),j),cpl',n) + if kn' == kn && cpl' == cpl then pat else + PatCstr (((kn',i),j),cpl',n) ) let (f_subst_genarg, subst_genarg_hook) = Hook.make () @@ -1034,25 +1034,25 @@ let rec subst_glob_constr env subst = DAst.map (function | GApp (r,rl) as raw -> let r' = subst_glob_constr env subst r and rl' = List.Smart.map (subst_glob_constr env subst) rl in - if r' == r && rl' == rl then raw else - GApp(r',rl') + if r' == r && rl' == rl then raw else + GApp(r',rl') | GLambda (n,bk,r1,r2) as raw -> let r1' = subst_glob_constr env subst r1 and r2' = subst_glob_constr env subst r2 in - if r1' == r1 && r2' == r2 then raw else - GLambda (n,bk,r1',r2') + if r1' == r1 && r2' == r2 then raw else + GLambda (n,bk,r1',r2') | GProd (n,bk,r1,r2) as raw -> let r1' = subst_glob_constr env subst r1 and r2' = subst_glob_constr env subst r2 in - if r1' == r1 && r2' == r2 then raw else - GProd (n,bk,r1',r2') + if r1' == r1 && r2' == r2 then raw else + GProd (n,bk,r1',r2') | GLetIn (n,r1,t,r2) as raw -> let r1' = subst_glob_constr env subst r1 in let r2' = subst_glob_constr env subst r2 in let t' = Option.Smart.map (subst_glob_constr env subst) t in - if r1' == r1 && t == t' && r2' == r2 then raw else - GLetIn (n,r1',t',r2') + if r1' == r1 && t == t' && r2' == r2 then raw else + GLetIn (n,r1',t',r2') | GCases (sty,rtno,rl,branches) as raw -> let open CAst in @@ -1067,21 +1067,21 @@ let rec subst_glob_constr env subst = DAst.map (function if a == a' && topt == topt' then y else (a',(n,topt'))) rl and branches' = List.Smart.map (fun ({loc;v=(idl,cpl,r)} as branch) -> - let cpl' = + let cpl' = List.Smart.map (subst_cases_pattern subst) cpl and r' = subst_glob_constr env subst r in - if cpl' == cpl && r' == r then branch else + if cpl' == cpl && r' == r then branch else CAst.(make ?loc (idl,cpl',r'))) - branches + branches in - if rtno' == rtno && rl' == rl && branches' == branches then raw else - GCases (sty,rtno',rl',branches') + if rtno' == rtno && rl' == rl && branches' == branches then raw else + GCases (sty,rtno',rl',branches') | GLetTuple (nal,(na,po),b,c) as raw -> let po' = Option.Smart.map (subst_glob_constr env subst) po and b' = subst_glob_constr env subst b and c' = subst_glob_constr env subst c in - if po' == po && b' == b && c' == c then raw else + if po' == po && b' == b && c' == c then raw else GLetTuple (nal,(na,po'),b',c') | GIf (c,(na,po),b1,b2) as raw -> @@ -1089,7 +1089,7 @@ let rec subst_glob_constr env subst = DAst.map (function and b1' = subst_glob_constr env subst b1 and b2' = subst_glob_constr env subst b2 and c' = subst_glob_constr env subst c in - if c' == c && po' == po && b1' == b1 && b2' == b2 then raw else + if c' == c && po' == po && b1' == b1 && b2' == b2 then raw else GIf (c',(na,po'),b1',b2') | GRec (fix,ida,bl,ra1,ra2) as raw -> @@ -1101,8 +1101,8 @@ let rec subst_glob_constr env subst = DAst.map (function let obd' = Option.Smart.map (subst_glob_constr env subst) obd in if ty'==ty && obd'==obd then dcl else (na,k,obd',ty'))) bl in - if ra1' == ra1 && ra2' == ra2 && bl'==bl then raw else - GRec (fix,ida,bl',ra1',ra2') + if ra1' == ra1 && ra2' == ra2 && bl'==bl then raw else + GRec (fix,ida,bl',ra1',ra2') | GHole (knd, naming, solve) as raw -> let nknd = match knd with diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli index 9eb014aa62..21957b4775 100644 --- a/pretyping/detyping.mli +++ b/pretyping/detyping.mli @@ -41,9 +41,9 @@ val subst_glob_constr : env -> substitution -> glob_constr -> glob_constr val factorize_eqns : 'a cases_clauses_g -> 'a disjunctive_cases_clauses_g -(** [detype isgoal avoid ctx c] turns a closed [c], into a glob_constr - de Bruijn indexes are turned to bound names, avoiding names in [avoid] - [isgoal] tells if naming must avoid global-level synonyms as intro does +(** [detype isgoal avoid ctx c] turns a closed [c], into a glob_constr + de Bruijn indexes are turned to bound names, avoiding names in [avoid] + [isgoal] tells if naming must avoid global-level synonyms as intro does [ctx] gives the names of the free variables *) val detype_names : bool -> Id.Set.t -> names_context -> env -> evar_map -> constr -> glob_constr @@ -52,7 +52,7 @@ val detype : 'a delay -> ?lax:bool -> bool -> Id.Set.t -> env -> evar_map -> con val detype_sort : evar_map -> Sorts.t -> glob_sort -val detype_rel_context : 'a delay -> ?lax:bool -> constr option -> Id.Set.t -> (names_context * env) -> +val detype_rel_context : 'a delay -> ?lax:bool -> constr option -> Id.Set.t -> (names_context * env) -> evar_map -> rel_context -> 'a glob_decl_g list val share_pattern_names : diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 73d0c6f821..2130d4ce90 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -96,7 +96,7 @@ let unfold_projection env evd ts p c = if TransparentState.is_transparent_constant ts cst then Some (mkProj (Projection.unfold p, c)) else None - + let eval_flexible_term ts env evd c = match EConstr.kind evd c with | Const (c, u) -> @@ -111,12 +111,12 @@ let eval_flexible_term ts env evd c = | Var id -> (try if TransparentState.is_transparent_variable ts id then - env |> lookup_named id |> NamedDecl.get_value - else None + env |> lookup_named id |> NamedDecl.get_value + else None with Not_found -> None) | LetIn (_,b,_,c) -> Some (subst1 b c) | Lambda _ -> Some c - | Proj (p, c) -> + | Proj (p, c) -> if Projection.unfolded p then assert false else unfold_projection env evd ts p c | _ -> assert false @@ -227,7 +227,7 @@ let occur_rigidly flags env evd (evk,_) t = | Normal b -> b | Reducible -> false -(* [check_conv_record env sigma (t1,stack1) (t2,stack2)] tries to decompose +(* [check_conv_record env sigma (t1,stack1) (t2,stack2)] tries to decompose the problem (t1 stack1) = (t2 stack2) into a problem stack1 = params1@[c1]@extra_args1 @@ -256,12 +256,12 @@ let check_conv_record env sigma (t1,sk1) (t2,sk2) = let _, a, b = destProd sigma t2 in if noccurn sigma 1 b then lookup_canonical_conversion (proji, Prod_cs), - (Stack.append_app [|a;pop b|] Stack.empty) + (Stack.append_app [|a;pop b|] Stack.empty) else raise Not_found | Sort s -> let s = ESorts.kind sigma s in - lookup_canonical_conversion - (proji, Sort_cs (Sorts.family s)),[] + lookup_canonical_conversion + (proji, Sort_cs (Sorts.family s)),[] | Proj (p, c) -> let c2 = GlobRef.ConstRef (Projection.constant p) in let c = Retyping.expand_projection env sigma p c [] in @@ -269,11 +269,11 @@ let check_conv_record env sigma (t1,sk1) (t2,sk2) = let sk2 = Stack.append_app args sk2 in lookup_canonical_conversion (proji, Const_cs c2), sk2 | _ -> - let (c2, _) = Termops.global_of_constr sigma t2 in - lookup_canonical_conversion (proji, Const_cs c2),sk2 + let (c2, _) = Termops.global_of_constr sigma t2 in + lookup_canonical_conversion (proji, Const_cs c2),sk2 with Not_found -> - let (c, cs) = lookup_canonical_conversion (proji,Default_cs) in - (c,cs),[] + let (c, cs) = lookup_canonical_conversion (proji,Default_cs) in + (c,cs),[] in let t', { o_DEF = c; o_CTX = ctx; o_INJ=n; o_TABS = bs; o_TPARAMS = params; o_NPARAMS = nparams; o_TCOMPS = us } = canon_s in @@ -283,9 +283,9 @@ let check_conv_record env sigma (t1,sk1) (t2,sk2) = match arg with | Some c -> (* A primitive projection applied to c *) let ty = Retyping.get_type_of ~lax:true env sigma c in - let (i,u), ind_args = - try Inductiveops.find_mrectype env sigma ty - with _ -> raise Not_found + let (i,u), ind_args = + try Inductiveops.find_mrectype env sigma ty + with _ -> raise Not_found in Stack.append_app_list ind_args Stack.empty, c, sk1 | None -> match Stack.strip_n_app nparams sk1 with @@ -338,8 +338,8 @@ let ise_and evd l = | [f] -> f i | f1::l -> match f1 i with - | Success i' -> ise_and i' l - | UnifFailure _ as x -> x in + | Success i' -> ise_and i' l + | UnifFailure _ as x -> x in ise_and evd l let ise_exact ise x1 x2 = @@ -353,8 +353,8 @@ let ise_array2 evd f v1 v2 = | -1 -> Success i | n -> match f i v1.(n) v2.(n) with - | Success i' -> allrec i' (n-1) - | UnifFailure _ as x -> x in + | Success i' -> allrec i' (n-1) + | UnifFailure _ as x -> x in let lv1 = Array.length v1 in if Int.equal lv1 (Array.length v2) then allrec evd (pred lv1) else UnifFailure (evd,NotSameArgSize) @@ -367,8 +367,8 @@ let rec ise_app_stack2 env f evd sk1 sk2 = let (t1,l1) = Stack.decomp_node_last node1 q1 in let (t2,l2) = Stack.decomp_node_last node2 q2 in begin match ise_app_stack2 env f evd l1 l2 with - |(_,UnifFailure _) as x -> x - |x,Success i' -> x,f env i' CONV t1 t2 + |(_,UnifFailure _) as x -> x + |x,Success i' -> x,f env i' CONV t1 t2 end | _, _ -> (sk1,sk2), Success evd @@ -385,8 +385,8 @@ let ise_stack2 no_app env evd f sk1 sk2 = | Stack.Case (_,t1,c1,_)::q1, Stack.Case (_,t2,c2,_)::q2 -> (match f env i CONV t1 t2 with | Success i' -> - (match ise_array2 i' (fun ii -> f env ii CONV) c1 c2 with - | Success i'' -> ise_stack2 true i'' q1 q2 + (match ise_array2 i' (fun ii -> f env ii CONV) c1 c2 with + | Success i'' -> ise_stack2 true i'' q1 q2 | UnifFailure _ as x -> fail x) | UnifFailure _ as x -> fail x) | Stack.Proj (p1,_)::q1, Stack.Proj (p2,_)::q2 -> @@ -397,18 +397,18 @@ let ise_stack2 no_app env evd f sk1 sk2 = Stack.Fix (((li2, i2),(_,tys2,bds2)),a2,_)::q2 -> if Int.equal i1 i2 && Array.equal Int.equal li1 li2 then match ise_and i [ - (fun i -> ise_array2 i (fun ii -> f env ii CONV) tys1 tys2); - (fun i -> ise_array2 i (fun ii -> f (push_rec_types recdef1 env) ii CONV) bds1 bds2); - (fun i -> ise_exact (ise_stack2 false i) a1 a2)] with + (fun i -> ise_array2 i (fun ii -> f env ii CONV) tys1 tys2); + (fun i -> ise_array2 i (fun ii -> f (push_rec_types recdef1 env) ii CONV) bds1 bds2); + (fun i -> ise_exact (ise_stack2 false i) a1 a2)] with | Success i' -> ise_stack2 true i' q1 q2 | UnifFailure _ as x -> fail x else fail (UnifFailure (i,NotSameHead)) | Stack.App _ :: _, Stack.App _ :: _ -> if no_app && deep then fail ((*dummy*)UnifFailure(i,NotSameHead)) else - begin match ise_app_stack2 env f i sk1 sk2 with - |_,(UnifFailure _ as x) -> fail x - |(l1, l2), Success i' -> ise_stack2 true i' l1 l2 - end + begin match ise_app_stack2 env f i sk1 sk2 with + |_,(UnifFailure _ as x) -> fail x + |(l1, l2), Success i' -> ise_stack2 true i' l1 l2 + end |_, _ -> fail (UnifFailure (i,(* Maybe improve: *) NotSameHead)) in ise_stack2 false evd (List.rev sk1) (List.rev sk2) @@ -425,21 +425,21 @@ let exact_ise_stack2 env evd f sk1 sk2 = | Stack.Fix (((li1, i1),(_,tys1,bds1 as recdef1)),a1,_)::q1, Stack.Fix (((li2, i2),(_,tys2,bds2)),a2,_)::q2 -> if Int.equal i1 i2 && Array.equal Int.equal li1 li2 then - ise_and i [ - (fun i -> ise_stack2 i q1 q2); - (fun i -> ise_array2 i (fun ii -> f env ii CONV) tys1 tys2); - (fun i -> ise_array2 i (fun ii -> f (push_rec_types recdef1 env) ii CONV) bds1 bds2); - (fun i -> ise_stack2 i a1 a2)] + ise_and i [ + (fun i -> ise_stack2 i q1 q2); + (fun i -> ise_array2 i (fun ii -> f env ii CONV) tys1 tys2); + (fun i -> ise_array2 i (fun ii -> f (push_rec_types recdef1 env) ii CONV) bds1 bds2); + (fun i -> ise_stack2 i a1 a2)] else UnifFailure (i,NotSameHead) | Stack.Proj (p1,_)::q1, Stack.Proj (p2,_)::q2 -> if Projection.Repr.equal (Projection.repr p1) (Projection.repr p2) then ise_stack2 i q1 q2 else (UnifFailure (i, NotSameHead)) | Stack.App _ :: _, Stack.App _ :: _ -> - begin match ise_app_stack2 env f i sk1 sk2 with - |_,(UnifFailure _ as x) -> x - |(l1, l2), Success i' -> ise_stack2 i' l1 l2 - end + begin match ise_app_stack2 env f i sk1 sk2 with + |_,(UnifFailure _ as x) -> x + |(l1, l2), Success i' -> ise_stack2 i' l1 l2 + end |_, _ -> UnifFailure (i,(* Maybe improve: *) NotSameHead) in if Reductionops.Stack.compare_shape sk1 sk2 then @@ -482,23 +482,23 @@ let rec evar_conv_x flags env evd pbty term1 term2 = | None -> UnifFailure (evd, ConversionFailed (env,term1,term2)) | exception Univ.UniverseInconsistency e -> UnifFailure (evd, UnifUnivInconsistency e) in - match e with - | UnifFailure (evd, e) when not (is_ground_env evd env) -> None - | _ -> Some e) + match e with + | UnifFailure (evd, e) when not (is_ground_env evd env) -> None + | _ -> Some e) else None in match ground_test with | Some result -> result | None -> (* Until pattern-unification is used consistently, use nohdbeta to not - destroy beta-redexes that can be used for 1st-order unification *) + destroy beta-redexes that can be used for 1st-order unification *) let term1 = apprec_nohdbeta flags env evd term1 in let term2 = apprec_nohdbeta flags env evd term2 in - let default () = + let default () = evar_eqappr_x flags env evd pbty (whd_nored_state evd (term1,Stack.empty)) (whd_nored_state evd (term2,Stack.empty)) - in + in begin match EConstr.kind evd term1, EConstr.kind evd term2 with | Evar ev, _ when Evd.is_undefined evd (fst ev) && not (is_frozen flags ev) -> (match solve_simple_eqn (conv_fun evar_conv_x) flags env evd @@ -510,7 +510,7 @@ let rec evar_conv_x flags env evd pbty term1 term2 = NotClean: pruning in solve_simple_eqn is incomplete wrt Miller patterns *) default () - | x -> x) + | x -> x) | _, Evar ev when Evd.is_undefined evd (fst ev) && not (is_frozen flags ev) -> (match solve_simple_eqn (conv_fun evar_conv_x) flags env evd (position_problem false pbty,ev,term1) with @@ -520,7 +520,7 @@ let rec evar_conv_x flags env evd pbty term1 term2 = NotClean: pruning in solve_simple_eqn is incomplete wrt Miller patterns *) default () - | x -> x) + | x -> x) | _ -> default () end @@ -533,10 +533,10 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty match is_unification_pattern_evar env evd ev lF tM with | None -> fallback () | Some l1' -> (* Miller-Pfenning's patterns unification *) - let t2 = tM in - let t2 = solve_pattern_eqn env evd l1' t2 in + let t2 = tM in + let t2 = solve_pattern_eqn env evd l1' t2 in solve_simple_eqn (conv_fun evar_conv_x) flags env evd - (position_problem on_left pbty,ev,t2) + (position_problem on_left pbty,ev,t2) in let consume_stack on_left (termF,skF) (termO,skO) evd = let switch f a b = if on_left then f a b else f b a in @@ -628,12 +628,12 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty let not_only_app = Stack.not_purely_applicative skM in match Stack.list_of_app_stack skF with | None -> quick_fail evd - | Some lF -> + | Some lF -> let tM = Stack.zip evd apprM in - miller_pfenning on_left - (fun () -> if not_only_app then (* Postpone the use of an heuristic *) + miller_pfenning on_left + (fun () -> if not_only_app then (* Postpone the use of an heuristic *) switch (fun x y -> Success (Evarutil.add_unification_pb (pbty,env,x,y) i)) (Stack.zip evd apprF) tM - else quick_fail i) + else quick_fail i) ev lF tM i in let flex_maybeflex on_left ev (termF,skF as apprF) (termM, skM as apprM) vM = @@ -641,36 +641,36 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty let delta i = switch (evar_eqappr_x flags env i pbty) apprF (whd_betaiota_deltazeta_for_iota_state flags.open_ts env i (vM,skM)) - in + in let default i = ise_try i [miller on_left ev apprF apprM; consume on_left apprF apprM; delta] in match EConstr.kind evd termM with | Proj (p, c) when not (Stack.is_empty skF) -> - (* Might be ?X args = p.c args', and we have to eta-expand the - primitive projection if |args| >= |args'|+1. *) - let nargsF = Stack.args_size skF and nargsM = Stack.args_size skM in - begin - (* ?X argsF' ~= (p.c ..) argsM' -> ?X ~= (p.c ..), no need to expand *) - if nargsF <= nargsM then default evd - else - let f = - try - let termM' = Retyping.expand_projection env evd p c [] in + (* Might be ?X args = p.c args', and we have to eta-expand the + primitive projection if |args| >= |args'|+1. *) + let nargsF = Stack.args_size skF and nargsM = Stack.args_size skM in + begin + (* ?X argsF' ~= (p.c ..) argsM' -> ?X ~= (p.c ..), no need to expand *) + if nargsF <= nargsM then default evd + else + let f = + try + let termM' = Retyping.expand_projection env evd p c [] in let apprM' = whd_betaiota_deltazeta_for_iota_state flags.open_ts env evd (termM',skM) - in - let delta' i = + in + let delta' i = switch (evar_eqappr_x flags env i pbty) apprF apprM' - in + in fun i -> ise_try i [miller on_left ev apprF apprM'; consume on_left apprF apprM'; delta'] - with Retyping.RetypeError _ -> - (* Happens thanks to w_unify building ill-typed terms *) - default - in f evd - end + with Retyping.RetypeError _ -> + (* Happens thanks to w_unify building ill-typed terms *) + default + in f evd + end | _ -> default evd in let flex_rigid on_left ev (termF, skF as apprF) (termR, skR as apprR) = @@ -772,17 +772,17 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty let app_empty = match sk1, sk2 with [], [] -> true | _ -> false in (* Evar must be undefined since we have flushed evars *) let () = if !debug_unification then - let open Pp in + let open Pp in Feedback.msg_debug (v 0 (pr_state env evd appr1 ++ cut () ++ pr_state env evd appr2 ++ cut ())) in match (flex_kind_of_term flags env evd term1 sk1, flex_kind_of_term flags env evd term2 sk2) with | Flexible (sp1,al1), Flexible (sp2,al2) -> (* sk1[?ev1] =? sk2[?ev2] *) let f1 i = first_order env i term1 term2 sk1 sk2 - and f2 i = + and f2 i = if Evar.equal sp1 sp2 then match ise_stack2 false env i (evar_conv_x flags) sk1 sk2 with - |None, Success i' -> + |None, Success i' -> Success (solve_refl (fun flags p env i pbty a1 a2 -> let flags = match p with @@ -791,7 +791,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty in is_success (evar_conv_x flags env i pbty a1 a2)) flags env i' (position_problem true pbty) sp1 al1 al2) - |_, (UnifFailure _ as x) -> x + |_, (UnifFailure _ as x) -> x |Some _, _ -> UnifFailure (i,NotSameArgSize) else UnifFailure (i,NotSameHead) and f3 i = miller true (sp1,al1) appr1 appr2 i @@ -810,7 +810,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty | Flexible ev1, MaybeFlexible v2 -> flex_maybeflex true ev1 appr1 appr2 v2 - | MaybeFlexible v1, Flexible ev2 -> + | MaybeFlexible v1, Flexible ev2 -> flex_maybeflex false ev2 appr2 appr1 v1 | MaybeFlexible v1, MaybeFlexible v2 -> begin @@ -822,9 +822,9 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty [(fun i -> evar_conv_x flags env i CUMUL t1 t2); (fun i -> evar_conv_x flags env i CUMUL t2 t1)]); (fun i -> evar_conv_x flags env i CONV b1 b2); - (fun i -> - let b = nf_evar i b1 in - let t = nf_evar i t1 in + (fun i -> + let b = nf_evar i b1 in + let t = nf_evar i t1 in let na = Nameops.Name.pick_annot na1 na2 in evar_conv_x flags (push_rel (RelDecl.LocalDef (na,b,t)) env) i pbty c'1 c'2); (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk1 sk2)] @@ -832,105 +832,105 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty let out1 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i (v1,sk1) and out2 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i (v2,sk2) in evar_eqappr_x flags env i pbty out1 out2 - in - ise_try evd [f1; f2] + in + ise_try evd [f1; f2] | Proj (p, c), Proj (p', c') when Projection.repr_equal p p' -> - let f1 i = - ise_and i + let f1 i = + ise_and i [(fun i -> evar_conv_x flags env i CONV c c'); (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk1 sk2)] - and f2 i = + and f2 i = let out1 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i (v1,sk1) and out2 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i (v2,sk2) in evar_eqappr_x flags env i pbty out1 out2 - in - ise_try evd [f1; f2] - - (* Catch the p.c ~= p c' cases *) - | Proj (p,c), Const (p',u) when Constant.equal (Projection.constant p) p' -> - let res = - try Some (destApp evd (Retyping.expand_projection env evd p c [])) - with Retyping.RetypeError _ -> None - in - (match res with - | Some (f1,args1) -> + in + ise_try evd [f1; f2] + + (* Catch the p.c ~= p c' cases *) + | Proj (p,c), Const (p',u) when Constant.equal (Projection.constant p) p' -> + let res = + try Some (destApp evd (Retyping.expand_projection env evd p c [])) + with Retyping.RetypeError _ -> None + in + (match res with + | Some (f1,args1) -> evar_eqappr_x flags env evd pbty (f1,Stack.append_app args1 sk1) appr2 - | None -> UnifFailure (evd,NotSameHead)) - - | Const (p,u), Proj (p',c') when Constant.equal p (Projection.constant p') -> - let res = - try Some (destApp evd (Retyping.expand_projection env evd p' c' [])) - with Retyping.RetypeError _ -> None - in - (match res with - | Some (f2,args2) -> + | None -> UnifFailure (evd,NotSameHead)) + + | Const (p,u), Proj (p',c') when Constant.equal p (Projection.constant p') -> + let res = + try Some (destApp evd (Retyping.expand_projection env evd p' c' [])) + with Retyping.RetypeError _ -> None + in + (match res with + | Some (f2,args2) -> evar_eqappr_x flags env evd pbty appr1 (f2,Stack.append_app args2 sk2) - | None -> UnifFailure (evd,NotSameHead)) - - | _, _ -> - let f1 i = - (* Gather the universe constraints that would make term1 and term2 equal. - If these only involve unifications of flexible universes to other universes, - allow this identification (first-order unification of universes). Otherwise - fallback to unfolding. - *) + | None -> UnifFailure (evd,NotSameHead)) + + | _, _ -> + let f1 i = + (* Gather the universe constraints that would make term1 and term2 equal. + If these only involve unifications of flexible universes to other universes, + allow this identification (first-order unification of universes). Otherwise + fallback to unfolding. + *) let univs = EConstr.eq_constr_universes env evd term1 term2 in match univs with | Some univs -> - ise_and i [(fun i -> - try Success (Evd.add_universe_constraints i univs) - with UniversesDiffer -> UnifFailure (i,NotSameHead) - | Univ.UniverseInconsistency p -> UnifFailure (i, UnifUnivInconsistency p)); + ise_and i [(fun i -> + try Success (Evd.add_universe_constraints i univs) + with UniversesDiffer -> UnifFailure (i,NotSameHead) + | Univ.UniverseInconsistency p -> UnifFailure (i, UnifUnivInconsistency p)); (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk1 sk2)] | None -> UnifFailure (i,NotSameHead) - and f2 i = - (try + and f2 i = + (try if not flags.with_cs then raise Not_found else conv_record flags env i (try check_conv_record env i appr1 appr2 - with Not_found -> check_conv_record env i appr2 appr1) + with Not_found -> check_conv_record env i appr2 appr1) with Not_found -> UnifFailure (i,NoCanonicalStructure)) - and f3 i = + and f3 i = (* heuristic: unfold second argument first, exception made if the first argument is a beta-redex (expand a constant only if necessary) or the second argument is potentially usable as a canonical projection or canonical value *) let rec is_unnamed (hd, args) = match EConstr.kind i hd with | (Var _|Construct _|Ind _|Const _|Prod _|Sort _|Int _ |Float _) -> - Stack.not_purely_applicative args + Stack.not_purely_applicative args | (CoFix _|Meta _|Rel _)-> true | Evar _ -> Stack.not_purely_applicative args - (* false (* immediate solution without Canon Struct *)*) + (* false (* immediate solution without Canon Struct *)*) | Lambda _ -> assert (match args with [] -> true | _ -> false); true | LetIn (_,b,_,c) -> is_unnamed (whd_betaiota_deltazeta_for_iota_state flags.open_ts env i (subst1 b c, args)) - | Fix _ -> true (* Partially applied fix can be the result of a whd call *) - | Proj (p, _) -> Projection.unfolded p || Stack.not_purely_applicative args + | Fix _ -> true (* Partially applied fix can be the result of a whd call *) + | Proj (p, _) -> Projection.unfolded p || Stack.not_purely_applicative args | Case _ | App _| Cast _ -> assert false in let rhs_is_stuck_and_unnamed () = - let applicative_stack = fst (Stack.strip_app sk2) in - is_unnamed + let applicative_stack = fst (Stack.strip_app sk2) in + is_unnamed (whd_betaiota_deltazeta_for_iota_state flags.open_ts env i (v2, applicative_stack)) in let rhs_is_already_stuck = rhs_is_already_stuck || rhs_is_stuck_and_unnamed () in - if (EConstr.isLambda i term1 || rhs_is_already_stuck) - && (not (Stack.not_purely_applicative sk1)) then + if (EConstr.isLambda i term1 || rhs_is_already_stuck) + && (not (Stack.not_purely_applicative sk1)) then evar_eqappr_x ~rhs_is_already_stuck flags env i pbty - (whd_betaiota_deltazeta_for_iota_state + (whd_betaiota_deltazeta_for_iota_state flags.open_ts env i(v1,sk1)) appr2 - else + else evar_eqappr_x flags env i pbty appr1 - (whd_betaiota_deltazeta_for_iota_state + (whd_betaiota_deltazeta_for_iota_state flags.open_ts env i (v2,sk2)) - in - ise_try evd [f1; f2; f3] + in + ise_try evd [f1; f2; f3] end | Rigid, Rigid when EConstr.isLambda evd term1 && EConstr.isLambda evd term2 -> @@ -939,7 +939,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty ise_and evd [(fun i -> evar_conv_x flags env i CONV c1 c2); (fun i -> - let c = nf_evar i c1 in + let c = nf_evar i c1 in let na = Nameops.Name.pick_annot na1 na2 in evar_conv_x flags (push_rel (RelDecl.LocalAssum (na,c)) env) i CONV c'1 c'2); (* When in modulo_betaiota = false case, lambda's are not reduced *) @@ -949,31 +949,31 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty | Rigid, Flexible ev2 -> flex_rigid false ev2 appr2 appr1 | MaybeFlexible v1, Rigid -> - let f3 i = - (try + let f3 i = + (try if not flags.with_cs then raise Not_found else conv_record flags env i (check_conv_record env i appr1 appr2) with Not_found -> UnifFailure (i,NoCanonicalStructure)) - and f4 i = + and f4 i = evar_eqappr_x flags env i pbty - (whd_betaiota_deltazeta_for_iota_state + (whd_betaiota_deltazeta_for_iota_state flags.open_ts env i (v1,sk1)) appr2 - in - ise_try evd [f3; f4] + in + ise_try evd [f3; f4] | Rigid, MaybeFlexible v2 -> - let f3 i = - (try + let f3 i = + (try if not flags.with_cs then raise Not_found else conv_record flags env i (check_conv_record env i appr2 appr1) with Not_found -> UnifFailure (i,NoCanonicalStructure)) - and f4 i = + and f4 i = evar_eqappr_x flags env i pbty appr1 - (whd_betaiota_deltazeta_for_iota_state + (whd_betaiota_deltazeta_for_iota_state flags.open_ts env i (v2,sk2)) - in - ise_try evd [f3; f4] + in + ise_try evd [f3; f4] (* Eta-expansion *) | Rigid, _ when isLambda evd term1 && (* if ever ill-typed: *) List.is_empty sk1 -> @@ -985,39 +985,39 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty | Rigid, Rigid -> begin match EConstr.kind evd term1, EConstr.kind evd term2 with - | Sort s1, Sort s2 when app_empty -> - (try + | Sort s1, Sort s2 when app_empty -> + (try let s1 = ESorts.kind evd s1 in let s2 = ESorts.kind evd s2 in - let evd' = - if pbty == CONV - then Evd.set_eq_sort env evd s1 s2 - else Evd.set_leq_sort env evd s1 s2 - in Success evd' - with Univ.UniverseInconsistency p -> + let evd' = + if pbty == CONV + then Evd.set_eq_sort env evd s1 s2 + else Evd.set_leq_sort env evd s1 s2 + in Success evd' + with Univ.UniverseInconsistency p -> UnifFailure (evd,UnifUnivInconsistency p) - | e when CErrors.noncritical e -> UnifFailure (evd,NotSameHead)) + | e when CErrors.noncritical e -> UnifFailure (evd,NotSameHead)) | Prod (n1,c1,c'1), Prod (n2,c2,c'2) when app_empty -> ise_and evd [(fun i -> evar_conv_x flags env i CONV c1 c2); (fun i -> - let c = nf_evar i c1 in + let c = nf_evar i c1 in let na = Nameops.Name.pick_annot n1 n2 in evar_conv_x flags (push_rel (RelDecl.LocalAssum (na,c)) env) i pbty c'1 c'2)] - | Rel x1, Rel x2 -> - if Int.equal x1 x2 then + | Rel x1, Rel x2 -> + if Int.equal x1 x2 then exact_ise_stack2 env evd (evar_conv_x flags) sk1 sk2 else UnifFailure (evd,NotSameHead) - | Var var1, Var var2 -> - if Id.equal var1 var2 then + | Var var1, Var var2 -> + if Id.equal var1 var2 then exact_ise_stack2 env evd (evar_conv_x flags) sk1 sk2 else UnifFailure (evd,NotSameHead) - | Const _, Const _ - | Ind _, Ind _ + | Const _, Const _ + | Ind _, Ind _ | Construct _, Construct _ | Int _, Int _ | Float _, Float _ -> @@ -1032,19 +1032,19 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty |Some _, _ -> UnifFailure (evd,NotSameArgSize) else UnifFailure (evd,NotSameHead) - | Construct u, _ -> + | Construct u, _ -> eta_constructor flags env evd sk1 u sk2 term2 - - | _, Construct u -> + + | _, Construct u -> eta_constructor flags env evd sk2 u sk1 term1 | Fix ((li1, i1),(_,tys1,bds1 as recdef1)), Fix ((li2, i2),(_,tys2,bds2)) -> (* Partially applied fixs *) - if Int.equal i1 i2 && Array.equal Int.equal li1 li2 then + if Int.equal i1 i2 && Array.equal Int.equal li1 li2 then ise_and evd [ (fun i -> ise_array2 i (fun i' -> evar_conv_x flags env i' CONV) tys1 tys2); (fun i -> ise_array2 i (fun i' -> evar_conv_x flags (push_rec_types recdef1 env) i' CONV) bds1 bds2); (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk1 sk2)] - else UnifFailure (evd, NotSameHead) + else UnifFailure (evd, NotSameHead) | CoFix (i1,(_,tys1,bds1 as recdef1)), CoFix (i2,(_,tys2,bds2)) -> if Int.equal i1 i2 then @@ -1053,20 +1053,20 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty (fun i -> evar_conv_x flags env i CONV) tys1 tys2); (fun i -> ise_array2 i (fun i -> evar_conv_x flags (push_rec_types recdef1 env) i CONV) - bds1 bds2); + bds1 bds2); (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk1 sk2)] else UnifFailure (evd,NotSameHead) - | (Meta _, _) | (_, Meta _) -> + | (Meta _, _) | (_, Meta _) -> begin match ise_stack2 true env evd (evar_conv_x flags) sk1 sk2 with - |_, (UnifFailure _ as x) -> x + |_, (UnifFailure _ as x) -> x |None, Success i' -> evar_conv_x flags env i' CONV term1 term2 |Some (sk1',sk2'), Success i' -> evar_conv_x flags env i' CONV (Stack.zip i' (term1,sk1')) (Stack.zip i' (term2,sk2')) - end + end | (Ind _ | Sort _ | Prod _ | CoFix _ | Fix _ | Rel _ | Var _ | Const _ | Int _ | Float _ | Evar _ | Lambda _), _ -> - UnifFailure (evd,NotSameHead) + UnifFailure (evd,NotSameHead) | _, (Ind _ | Sort _ | Prod _ | CoFix _ | Fix _ | Rel _ | Var _ | Const _ | Int _ | Evar _ | Lambda _) -> UnifFailure (evd,NotSameHead) | Case _, _ -> UnifFailure (evd,NotSameHead) @@ -1103,32 +1103,32 @@ and conv_record flags env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk if Reductionops.Stack.compare_shape sk1 sk2 then let (evd',ks,_,test) = List.fold_left - (fun (i,ks,m,test) b -> - if match n with Some n -> Int.equal m n | None -> false then - let ty = Retyping.get_type_of env i t2 in + (fun (i,ks,m,test) b -> + if match n with Some n -> Int.equal m n | None -> false then + let ty = Retyping.get_type_of env i t2 in let test i = evar_conv_x flags env i CUMUL ty (substl ks b) in - (i,t2::ks, m-1, test) - else - let dloc = Loc.tag Evar_kinds.InternalHole in + (i,t2::ks, m-1, test) + else + let dloc = Loc.tag Evar_kinds.InternalHole in let (i', ev) = Evarutil.new_evar env i ~src:dloc (substl ks b) in - (i', ev :: ks, m - 1,test)) - (evd,[],List.length bs,fun i -> Success i) bs + (i', ev :: ks, m - 1,test)) + (evd,[],List.length bs,fun i -> Success i) bs in let app = mkApp (c, Array.rev_of_list ks) in ise_and evd' [(fun i -> - exact_ise_stack2 env i + exact_ise_stack2 env i (fun env' i' cpb x1 x -> evar_conv_x flags env' i' cpb x1 (substl ks x)) params1 params); (fun i -> - exact_ise_stack2 env i + exact_ise_stack2 env i (fun env' i' cpb u1 u -> evar_conv_x flags env' i' cpb u1 (substl ks u)) us2 us); (fun i -> evar_conv_x flags env i CONV c1 app); (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk1 sk2); test; (fun i -> evar_conv_x flags env i CONV h2 - (fst (decompose_app_vect i (substl ks h))))] + (fst (decompose_app_vect i (substl ks h))))] else UnifFailure(evd,(*dummy*)NotSameHead) and eta_constructor flags env evd sk1 ((ind, i), u) sk2 term2 = @@ -1137,18 +1137,18 @@ and eta_constructor flags env evd sk1 ((ind, i), u) sk2 term2 = match get_projections env ind with | Some projs when mib.mind_finite == BiFinite -> let pars = mib.mind_nparams in - (try - let l1' = Stack.tail pars sk1 in - let l2' = - let term = Stack.zip evd (term2,sk2) in - List.map (fun p -> EConstr.mkProj (Projection.make p false, term)) (Array.to_list projs) - in + (try + let l1' = Stack.tail pars sk1 in + let l2' = + let term = Stack.zip evd (term2,sk2) in + List.map (fun p -> EConstr.mkProj (Projection.make p false, term)) (Array.to_list projs) + in exact_ise_stack2 env evd (evar_conv_x { flags with with_cs = false}) l1' - (Stack.append_app_list l2' Stack.empty) + (Stack.append_app_list l2' Stack.empty) with - | Invalid_argument _ -> - (* Stack.tail: partially applied constructor *) - UnifFailure(evd,NotSameHead)) + | Invalid_argument _ -> + (* Stack.tail: partially applied constructor *) + UnifFailure(evd,NotSameHead)) | _ -> UnifFailure (evd,NotSameHead) let evar_conv_x flags = evar_conv_x flags @@ -1569,7 +1569,7 @@ let apply_conversion_problem_heuristic flags env evd with_ho pbty t1 t2 = let (term1,l1 as appr1) = try destApp evd t1 with DestKO -> (t1, [||]) in let (term2,l2 as appr2) = try destApp evd t2 with DestKO -> (t2, [||]) in let () = if !debug_unification then - let open Pp in + let open Pp in Feedback.msg_debug (v 0 (str "Heuristic:" ++ spc () ++ Termops.Internal.print_constr_env env evd t1 ++ cut () ++ Termops.Internal.print_constr_env env evd t2 ++ cut ())) in @@ -1705,7 +1705,7 @@ let solve_unif_constraints_with_heuristics env match pbs with | (pbty,env,t1,t2 as pb) :: pbs -> (match apply_conversion_problem_heuristic flags env evd with_ho pbty t1 t2 with - | Success evd' -> + | Success evd' -> let evd' = solve_unconstrained_evars_with_candidates flags evd' in let (evd', rest) = extract_all_conv_pbs evd' in begin match rest with @@ -1719,11 +1719,11 @@ let solve_unif_constraints_with_heuristics env if is_beyond_capabilities reason then aux evd pbs progress ((pb,reason) :: stuck) else aux evd [] false ((pb,reason) :: stuck)) - | _ -> + | _ -> if progress then aux evd (List.map fst stuck) false [] - else - match stuck with - | [] -> (* We're finished *) evd + else + match stuck with + | [] -> (* We're finished *) evd | ((pbty,env,t1,t2 as pb), reason) :: _ -> (* There remains stuck problems *) Pretype_errors.error_cannot_unify ?loc:(loc_of_conv_pb evd pb) diff --git a/pretyping/evarconv.mli b/pretyping/evarconv.mli index e1dd0a0cdc..a1acf8b382 100644 --- a/pretyping/evarconv.mli +++ b/pretyping/evarconv.mli @@ -76,9 +76,9 @@ val check_problems_are_solved : env -> evar_map -> unit (** Check if a canonical structure is applicable *) -val check_conv_record : env -> evar_map -> +val check_conv_record : env -> evar_map -> state -> state -> - Univ.ContextSet.t * (constr * constr) + Univ.ContextSet.t * (constr * constr) * constr * constr list * (constr Stack.t * constr Stack.t) * (constr Stack.t * constr Stack.t) * (constr Stack.t * constr Stack.t) * constr * diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml index 705ab56703..aebdd14396 100644 --- a/pretyping/evardefine.ml +++ b/pretyping/evardefine.ml @@ -94,13 +94,13 @@ let define_pure_evar_as_product env evd evk = (* Impredicative product, conclusion must fall in [Prop]. *) new_evar newenv evd1 concl ~src ~filter else - let status = univ_flexible_alg in - let evd3, (rng, srng) = + let status = univ_flexible_alg in + let evd3, (rng, srng) = new_type_evar newenv evd1 status ~src ~filter in - let prods = Univ.sup (univ_of_sort u1) (univ_of_sort srng) in + let prods = Univ.sup (univ_of_sort u1) (univ_of_sort srng) in let evd3 = Evd.set_leq_sort evenv evd3 (Sorts.sort_of_univ prods) (ESorts.kind evd1 s) in - evd3, rng + evd3, rng in let prod = mkProd (make_annot (Name id) rdom, dom, subst_var id rng) in let evd3 = Evd.define evk prod evd2 in @@ -169,7 +169,7 @@ let rec evar_absorb_arguments env evd (evk,args as ev) = function let define_evar_as_sort env evd (ev,args) = let evd, s = new_sort_variable univ_rigid evd in - let evi = Evd.find_undefined evd ev in + let evi = Evd.find_undefined evd ev in let concl = Reductionops.whd_all (evar_env evi) evd evi.evar_concl in let sort = destSort evd concl in let evd' = Evd.define ev (mkSort s) evd in @@ -185,15 +185,15 @@ let split_tycon ?loc env evd tycon = let t = Reductionops.whd_all env evd c in match EConstr.kind evd t with | Prod (na,dom,rng) -> evd, (na, dom, rng) - | Evar ev (* ev is undefined because of whd_all *) -> + | Evar ev (* ev is undefined because of whd_all *) -> let (evd',prod) = define_evar_as_product env evd ev in let (na,dom,rng) = destProd evd prod in let anon = {na with binder_name = Anonymous} in evd',(anon, dom, rng) | App (c,args) when isEvar evd c -> let (evd',lam) = define_evar_as_lambda env evd (destEvar evd c) in - real_split evd' (mkApp (lam,args)) - | _ -> error_not_product ?loc env evd c + real_split evd' (mkApp (lam,args)) + | _ -> error_not_product ?loc env evd c in match tycon with | None -> evd,(make_annot Anonymous Relevant,None,None) diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 769079dea7..5a23525fb0 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -84,14 +84,14 @@ let get_polymorphic_positions env sigma f = | _ -> assert false let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) ?(refreshset=false) - pbty env evd t = + pbty env evd t = let evdref = ref evd in (* direction: true for fresh universes lower than the existing ones *) let refresh_sort status ~direction s = let s = ESorts.kind !evdref s in let sigma, s' = new_sort_variable status !evdref in evdref := sigma; - let evd = + let evd = if direction then set_leq_sort env !evdref s' s else set_leq_sort env !evdref s s' in evdref := evd; mkSort s' @@ -103,13 +103,13 @@ let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) ?(refreshset=false) | Type u -> (* TODO: check if max(l,u) is not ok as well *) (match Univ.universe_level u with - | None -> refresh_sort status ~direction s - | Some l -> + | None -> refresh_sort status ~direction s + | Some l -> (match Evd.universe_rigidity !evdref l with - | UnivRigid -> - if not onlyalg then refresh_sort status ~direction s - else t - | UnivFlexible alg -> + | UnivRigid -> + if not onlyalg then refresh_sort status ~direction s + else t + | UnivFlexible alg -> (if alg then evdref := Evd.make_nonalgebraic_variable !evdref l); t)) @@ -130,7 +130,7 @@ let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) ?(refreshset=false) | App (f, args) when Termops.is_template_polymorphic_ind env !evdref f -> let pos = get_polymorphic_positions env !evdref f in refresh_polymorphic_positions args pos; t - | App (f, args) when top && isEvar !evdref f -> + | App (f, args) when top && isEvar !evdref f -> let f' = refresh_term_evars ~onevars:true ~top:false f in let args' = Array.map (refresh_term_evars ~onevars ~top:false) args in if f' == f && args' == args then t @@ -149,23 +149,23 @@ let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) ?(refreshset=false) | _ -> EConstr.map !evdref (refresh_term_evars ~onevars ~top:false) t and refresh_polymorphic_positions args pos = let rec aux i = function - | Some l :: ls -> - if i < Array.length args then + | Some l :: ls -> + if i < Array.length args then ignore(refresh_term_evars ~onevars:true ~top:false args.(i)); aux (succ i) ls - | None :: ls -> - if i < Array.length args then + | None :: ls -> + if i < Array.length args then ignore(refresh_term_evars ~onevars:false ~top:false args.(i)); - aux (succ i) ls + aux (succ i) ls | [] -> () in aux 0 pos in - let t' = + let t' = if isArity !evdref t then match pbty with | None -> - (* No cumulativity needed, but we still need to refresh the algebraics *) - refresh ~onlyalg:true univ_flexible ~direction:false t + (* No cumulativity needed, but we still need to refresh the algebraics *) + refresh ~onlyalg:true univ_flexible ~direction:false t | Some direction -> refresh ~onlyalg status ~direction t else refresh_term_evars ~onevars:false ~top:true t in !evdref, t' @@ -192,22 +192,22 @@ let recheck_applications unify flags env evdref t = let fty = Retyping.get_type_of env !evdref f in let argsty = Array.map (fun x -> aux env x; Retyping.get_type_of env !evdref x) args in let rec aux i ty = - if i < Array.length argsty then - match EConstr.kind !evdref (whd_all env !evdref ty) with + if i < Array.length argsty then + match EConstr.kind !evdref (whd_all env !evdref ty) with | Prod (na, dom, codom) -> (match unify flags TypeUnification env !evdref Reduction.CUMUL argsty.(i) dom with | Success evd -> evdref := evd; - aux (succ i) (subst1 args.(i) codom) - | UnifFailure (evd, reason) -> - Pretype_errors.error_cannot_unify env evd ~reason (argsty.(i), dom)) - | _ -> raise (IllTypedInstance (env, ty, argsty.(i))) + aux (succ i) (subst1 args.(i) codom) + | UnifFailure (evd, reason) -> + Pretype_errors.error_cannot_unify env evd ~reason (argsty.(i), dom)) + | _ -> raise (IllTypedInstance (env, ty, argsty.(i))) else () in aux 0 fty | _ -> iter_with_full_binders !evdref (fun d env -> push_rel d env) aux env t in aux env t - + (*------------------------------------* * Restricting existing evars * *------------------------------------*) @@ -351,25 +351,25 @@ let compute_var_aliases sign sigma = let compute_rel_aliases var_aliases rels sigma = snd (List.fold_right - (fun decl (n,aliases) -> - (n-1, - match decl with + (fun decl (n,aliases) -> + (n-1, + match decl with | LocalDef (_,t,u) -> - (match EConstr.kind sigma t with - | Var id' -> - let aliases_of_n = - try Id.Map.find id' var_aliases with Not_found -> empty_aliasing in - Int.Map.add n (push_alias aliases_of_n (VarAlias id')) aliases - | Rel p -> - let aliases_of_n = - try Int.Map.find (p+n) aliases with Not_found -> empty_aliasing in - Int.Map.add n (push_alias aliases_of_n (RelAlias (p+n))) aliases - | _ -> - Int.Map.add n (make_aliasing (lift n (mkCast(t,DEFAULTcast,u)))) aliases) - | LocalAssum _ -> aliases) - ) - rels - (List.length rels,Int.Map.empty)) + (match EConstr.kind sigma t with + | Var id' -> + let aliases_of_n = + try Id.Map.find id' var_aliases with Not_found -> empty_aliasing in + Int.Map.add n (push_alias aliases_of_n (VarAlias id')) aliases + | Rel p -> + let aliases_of_n = + try Int.Map.find (p+n) aliases with Not_found -> empty_aliasing in + Int.Map.add n (push_alias aliases_of_n (RelAlias (p+n))) aliases + | _ -> + Int.Map.add n (make_aliasing (lift n (mkCast(t,DEFAULTcast,u)))) aliases) + | LocalAssum _ -> aliases) + ) + rels + (List.length rels,Int.Map.empty)) let make_alias_map env sigma = (* We compute the chain of aliases for each var and rel *) @@ -732,7 +732,7 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = let evd,t_in_sign = let s = Retyping.get_sort_of env evd t_in_env in let evd,ty_t_in_sign = refresh_universes - ~status:univ_flexible (Some false) env evd (mkSort s) in + ~status:univ_flexible (Some false) env evd (mkSort s) in define_evar_from_virtual_equation define_fun env evd src t_in_env ty_t_in_sign sign filter inst_in_env in let evd,d' = match d with @@ -1326,9 +1326,9 @@ let solve_evar_evar ?(force=false) f unify flags env evd pbty (evk1,args1 as ev1 let evi = Evd.find evd evk1 in let downcast evk t evd = downcast evk t evd in let evd = - try + try (* ?X : Π Δ. Type i = ?Y : Π Δ'. Type j. - The body of ?X and ?Y just has to be of type Π Δ. Type k for some k <= i, j. *) + The body of ?X and ?Y just has to be of type Π Δ. Type k for some k <= i, j. *) let evienv = Evd.evar_env evi in let concl1 = EConstr.Unsafe.to_constr evi.evar_concl in let ctx1, i = Reduction.dest_arity evienv concl1 in @@ -1339,22 +1339,22 @@ let solve_evar_evar ?(force=false) f unify flags env evd pbty (evk1,args1 as ev1 let ctx2, j = Reduction.dest_arity evi2env concl2 in let ctx2 = List.map (fun c -> map_rel_decl EConstr.of_constr c) ctx2 in let ui, uj = univ_of_sort i, univ_of_sort j in - if i == j || Evd.check_eq evd ui uj - then (* Shortcut, i = j *) - evd - else if Evd.check_leq evd ui uj then + if i == j || Evd.check_eq evd ui uj + then (* Shortcut, i = j *) + evd + else if Evd.check_leq evd ui uj then let t2 = it_mkProd_or_LetIn (mkSort i) ctx2 in downcast evk2 t2 evd - else if Evd.check_leq evd uj ui then + else if Evd.check_leq evd uj ui then let t1 = it_mkProd_or_LetIn (mkSort j) ctx1 in downcast evk1 t1 evd - else - let evd, k = Evd.new_sort_variable univ_flexible_alg evd in + else + let evd, k = Evd.new_sort_variable univ_flexible_alg evd in let t1 = it_mkProd_or_LetIn (mkSort k) ctx1 in let t2 = it_mkProd_or_LetIn (mkSort k) ctx2 in - let evd = Evd.set_leq_sort env (Evd.set_leq_sort env evd k i) k j in + let evd = Evd.set_leq_sort env (Evd.set_leq_sort env evd k i) k j in downcast evk2 t2 (downcast evk1 t1 evd) - with Reduction.NotArity -> + with Reduction.NotArity -> evd in solve_evar_evar_aux force f unify flags env evd pbty ev1 ev2 @@ -1419,7 +1419,7 @@ let solve_candidates unify flags env evd (evk,argsv) rhs = if Evd.is_undefined evd evk then let evd' = Evd.define evk c evd in check_evar_instance unify flags evd' evk c - else evd + else evd | l when List.length l < List.length l' -> let candidates = List.map fst l in restrict_evar evd evk None (UpdateWith candidates) @@ -1614,10 +1614,10 @@ let rec invert_definition unify flags choose imitate_defs | None -> (* Evar/Rigid problem (or assimilated if not normal): we "imitate" *) map_constr_with_full_binders !evdref (fun d (env,k) -> push_rel d env, k+1) - imitate envk t + imitate envk t in let rhs = whd_beta evd rhs (* heuristic *) in - let fast rhs = + let fast rhs = let filter_ctxt = evar_filtered_context evi in let names = ref Id.Set.empty in let rec is_id_subst ctxt s = @@ -1627,19 +1627,19 @@ let rec invert_definition unify flags choose imitate_defs names := Id.Set.add id !names; isVarId evd id c && is_id_subst ctxt' s' | [], [] -> true - | _ -> false + | _ -> false in is_id_subst filter_ctxt (Array.to_list argsv) && closed0 evd rhs && - Id.Set.subset (collect_vars evd rhs) !names + Id.Set.subset (collect_vars evd rhs) !names in let body = if fast rhs then nf_evar evd rhs (* FIXME? *) else let t' = imitate (env,0) rhs in - if !progress then + if !progress then (recheck_applications unify flags (evar_env evi) evdref t'; t') - else t' + else t' in (!evdref,body) (* [define] tries to solve the problem "?ev[args] = rhs" when "?ev" is @@ -1688,7 +1688,7 @@ and evar_define unify flags ?(choose=false) ?(imitate_defs=true) env evd pbty (e solve_refl (fun flags _b env sigma pb c c' -> is_fconv pb env sigma c c') flags env evd pbty evk argsv argsv2 | _ -> - raise (OccurCheckIn (evd,rhs)) + raise (OccurCheckIn (evd,rhs)) (* This code (i.e. solve_pb, etc.) takes a unification * problem, and tries to solve it. If it solves it, then it removes diff --git a/pretyping/evarsolve.mli b/pretyping/evarsolve.mli index 9d5d75d9ba..908adac7e4 100644 --- a/pretyping/evarsolve.mli +++ b/pretyping/evarsolve.mli @@ -41,7 +41,7 @@ type unification_result = val is_success : unification_result -> bool -(** Replace the vars and rels that are aliases to other vars and rels by +(** Replace the vars and rels that are aliases to other vars and rels by their representative that is most ancient in the context *) val expand_vars_in_term : env -> evar_map -> constr -> constr @@ -130,5 +130,5 @@ val check_evar_instance : unifier -> unify_flags -> val remove_instance_local_defs : evar_map -> Evar.t -> 'a array -> 'a list -val get_type_of_refresh : +val get_type_of_refresh : ?polyprop:bool -> ?lax:bool -> env -> evar_map -> constr -> evar_map * types diff --git a/pretyping/find_subterm.ml b/pretyping/find_subterm.ml index 9db37bfa9b..2d64692cc6 100644 --- a/pretyping/find_subterm.ml +++ b/pretyping/find_subterm.ml @@ -161,13 +161,13 @@ let make_eq_univs_test env evd c = match EConstr.eq_constr_universes_proj env evd c c' with | None -> raise (NotUnifiable None) | Some cst -> - try Evd.add_universe_constraints evd cst - with Evd.UniversesDiffer -> raise (NotUnifiable None) + try Evd.add_universe_constraints evd cst + with Evd.UniversesDiffer -> raise (NotUnifiable None) ); merge_fun = (fun evd _ -> evd); testing_state = evd; last_found = None -} +} let subst_closed_term_occ env evd occs c t = let test = make_eq_univs_test env evd c in diff --git a/pretyping/find_subterm.mli b/pretyping/find_subterm.mli index 3ad69e6e50..6f9dac400f 100644 --- a/pretyping/find_subterm.mli +++ b/pretyping/find_subterm.mli @@ -60,7 +60,7 @@ val replace_term_occ_decl_modulo : val subst_closed_term_occ : env -> evar_map -> occurrences or_like_first -> constr -> constr -> constr * evar_map -(** [subst_closed_term_occ_decl evd occl c decl] replaces occurrences of +(** [subst_closed_term_occ_decl evd occl c decl] replaces occurrences of closed [c] at positions [occl] by [Rel 1] in [decl]. *) val subst_closed_term_occ_decl : env -> evar_map -> (occurrences * hyp_location_flag) or_like_first -> diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index 03bb633fa0..1264b0b33c 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -246,7 +246,7 @@ let fold_glob_constr f acc = DAst.with_val (function | GRec (_,_,bl,tyl,bv) -> let acc = Array.fold_left (List.fold_left (fun acc (na,k,bbd,bty) -> - f (Option.fold_left f acc bbd) bty)) acc bl in + f (Option.fold_left f acc bbd) bty)) acc bl in Array.fold_left f (Array.fold_left f acc tyl) bv | GCast (c,k) -> let acc = match k with @@ -283,8 +283,8 @@ let fold_glob_constr_with_binders g f v acc = DAst.(with_val (function let v' = Array.fold_right g idl v in let f' i acc fid = let v,acc = - List.fold_left - (fun (v,acc) (na,k,bbd,bty) -> + List.fold_left + (fun (v,acc) (na,k,bbd,bty) -> (Name.fold_right g na v, f v (Option.fold_left (f v) acc bbd) bty)) (v,acc) bll.(i) in diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index 0a6c3afd0d..1d240db33c 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -69,7 +69,7 @@ let is_private mib = let check_privacy_block mib = if is_private mib then user_err (str"case analysis on a private inductive type") - + (**********************************************************************) (* Building case analysis schemes *) (* Christine Paulin, 1996 *) @@ -82,10 +82,10 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind = let relevance = Sorts.relevance_of_sort_family kind in let () = if Option.is_empty projs then check_privacy_block mib in - let () = + let () = if not (Sorts.family_leq kind (elim_sort specif)) then raise - (RecursionSchemeError + (RecursionSchemeError (env, NotAllowedCaseAnalysis (false, fst (UnivGen.fresh_sort_in_family kind), pind))) in let ndepar = mip.mind_nrealdecls + 1 in @@ -112,26 +112,26 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind = if dep then Context.Rel.to_extended_vect mkRel 0 deparsign else Context.Rel.to_extended_vect mkRel 1 arsign) in let p = - it_mkLambda_or_LetIn_name env' - ((if dep then mkLambda_name env' else mkLambda) + it_mkLambda_or_LetIn_name env' + ((if dep then mkLambda_name env' else mkLambda) (make_annot Anonymous r,depind,pbody)) arsign in - let obj = - match projs with - | None -> mkCase (ci, lift ndepar p, mkRel 1, - Termops.rel_vect ndepar k) - | Some ps -> - let term = - mkApp (mkRel 2, - Array.map - (fun p -> mkProj (Projection.make p true, mkRel 1)) ps) in - if dep then - let ty = mkApp (mkRel 3, [| mkRel 1 |]) in - mkCast (term, DEFAULTcast, ty) - else term + let obj = + match projs with + | None -> mkCase (ci, lift ndepar p, mkRel 1, + Termops.rel_vect ndepar k) + | Some ps -> + let term = + mkApp (mkRel 2, + Array.map + (fun p -> mkProj (Projection.make p true, mkRel 1)) ps) in + if dep then + let ty = mkApp (mkRel 3, [| mkRel 1 |]) in + mkCast (term, DEFAULTcast, ty) + else term in - it_mkLambda_or_LetIn_name env' obj deparsign + it_mkLambda_or_LetIn_name env' obj deparsign else let cs = lift_constructor (k+1) constrs.(k) in let t = build_branch_type env sigma dep (mkRel (k+1)) cs in @@ -141,7 +141,7 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind = let (sigma, s) = Evd.fresh_sort_in_family ~rigid:Evd.univ_flexible_alg sigma kind in let typP = make_arity env' sigma dep indf s in let typP = EConstr.Unsafe.to_constr typP in - let c = + let c = it_mkLambda_or_LetIn_name env (mkLambda_string "P" Sorts.Relevant typP (add_branch (push_rel (LocalAssum (make_annot Anonymous Sorts.Relevant,typP)) env') 0)) lnamespar @@ -180,19 +180,19 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs = | LetIn (n,b,t,c) when List.is_empty largs -> let d = LocalDef (n,b,t) in mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::sign) c) - | Ind (_,_) -> - let realargs = List.skipn nparams largs in - let base = applist (lift i pk,realargs) in + | Ind (_,_) -> + let realargs = List.skipn nparams largs in + let base = applist (lift i pk,realargs) in if depK then - Reduction.beta_appvect + Reduction.beta_appvect base [|applist (mkRel (i+1), Context.Rel.to_extended_list mkRel 0 sign)|] else - base - | _ -> - let t' = whd_all env sigma (EConstr.of_constr p) in - let t' = EConstr.Unsafe.to_constr t' in - if Constr.equal p' t' then assert false - else prec env i sign t' + base + | _ -> + let t' = whd_all env sigma (EConstr.of_constr p) in + let t' = EConstr.Unsafe.to_constr t' in + if Constr.equal p' t' then assert false + else prec env i sign t' in prec env 0 [] in @@ -200,43 +200,43 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs = if nhyps > 0 then match kind c with | Prod (n,t,c_0) -> let (optionpos,rest) = - match recargs with - | [] -> None,[] + match recargs with + | [] -> None,[] | ra::rest -> (match dest_recarg ra with - | Mrec (_,j) when is_rec -> (depPvect.(j),rest) - | Imbr _ -> (None,rest) + | Mrec (_,j) when is_rec -> (depPvect.(j),rest) + | Imbr _ -> (None,rest) | _ -> (None, rest)) - in + in (match optionpos with - | None -> - make_prod env + | None -> + make_prod env (n,t, process_constr (push_rel (LocalAssum (n,t)) env) (i+1) c_0 rest - (nhyps-1) (i::li)) + (nhyps-1) (i::li)) | Some(dep',p) -> - let nP = lift (i+1+decP) p in + let nP = lift (i+1+decP) p in let env' = push_rel (LocalAssum (n,t)) env in let t_0 = process_pos env' dep' nP (lift 1 t) in let r_0 = Retyping.relevance_of_type env' sigma (EConstr.of_constr t_0) in - make_prod_dep (dep || dep') env + make_prod_dep (dep || dep') env (n,t, mkArrow t_0 r_0 - (process_constr + (process_constr (push_rel (LocalAssum (make_annot Anonymous n.binder_relevance,t_0)) env') - (i+2) (lift 1 c_0) rest (nhyps-1) (i::li)))) + (i+2) (lift 1 c_0) rest (nhyps-1) (i::li)))) | LetIn (n,b,t,c_0) -> mkLetIn (n,b,t, - process_constr + process_constr (push_rel (LocalDef (n,b,t)) env) - (i+1) c_0 recargs (nhyps-1) li) + (i+1) c_0 recargs (nhyps-1) li) | _ -> assert false else if dep then - let realargs = List.rev_map (fun k -> mkRel (i-k)) li in + let realargs = List.rev_map (fun k -> mkRel (i-k)) li in let params = List.map (lift i) vargs in let co = applist (mkConstructU cs.cs_cstr,params@realargs) in - Reduction.beta_appvect c [|co|] + Reduction.beta_appvect c [|co|] else c in let nhyps = List.length cs.cs_args in @@ -260,15 +260,15 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs = | LetIn (n,b,t,c) when List.is_empty largs -> let d = LocalDef (n,b,t) in mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::hyps) c) - | Ind _ -> + | Ind _ -> let realargs = List.skipn nparrec largs and arg = appvect (mkRel (i+1), Context.Rel.to_extended_vect mkRel 0 hyps) in applist(lift i fk,realargs@[arg]) - | _ -> - let t' = whd_all env sigma (EConstr.of_constr p) in - let t' = EConstr.Unsafe.to_constr t' in - if Constr.equal t' p' then assert false - else prec env i hyps t' + | _ -> + let t' = whd_all env sigma (EConstr.of_constr p) in + let t' = EConstr.Unsafe.to_constr t' in + if Constr.equal t' p' then assert false + else prec env i hyps t' in prec env 0 [] in @@ -276,30 +276,30 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs = let rec process_constr env i f = function | (LocalAssum (n,t) as d)::cprest, recarg::rest -> let optionpos = - match dest_recarg recarg with + match dest_recarg recarg with | Norec -> None | Imbr _ -> None | Mrec (_,i) -> fvect.(i) - in + in (match optionpos with | None -> - mkLambda_name env + mkLambda_name env (n,t,process_constr (push_rel d env) (i+1) - (EConstr.Unsafe.to_constr (whd_beta Evd.empty (EConstr.of_constr (applist (lift 1 f, [(mkRel 1)]))))) - (cprest,rest)) + (EConstr.Unsafe.to_constr (whd_beta Evd.empty (EConstr.of_constr (applist (lift 1 f, [(mkRel 1)]))))) + (cprest,rest)) | Some(_,f_0) -> - let nF = lift (i+1+decF) f_0 in + let nF = lift (i+1+decF) f_0 in let env' = push_rel d env in - let arg = process_pos env' nF (lift 1 t) in + let arg = process_pos env' nF (lift 1 t) in mkLambda_name env (n,t,process_constr env' (i+1) - (EConstr.Unsafe.to_constr (whd_beta Evd.empty (EConstr.of_constr (applist (lift 1 f, [(mkRel 1); arg]))))) - (cprest,rest))) + (EConstr.Unsafe.to_constr (whd_beta Evd.empty (EConstr.of_constr (applist (lift 1 f, [(mkRel 1); arg]))))) + (cprest,rest))) | (LocalDef (n,c,t) as d)::cprest, rest -> - mkLetIn + mkLetIn (n,c,t, - process_constr (push_rel d env) (i+1) (lift 1 f) - (cprest,rest)) + process_constr (push_rel d env) (i+1) (lift 1 f) + (cprest,rest)) | [],[] -> f | _,[] | [],_ -> anomaly (Pp.str "process_constr.") @@ -318,8 +318,8 @@ let mis_make_indrec env sigma ?(force_mutual=false) listdepkind mib u = Array.make mib.mind_ntypes (None : (bool * constr) option) in let _ = let rec - assign k = function - | [] -> () + assign k = function + | [] -> () | ((indi,u),mibi,mipi,dep,_)::rest -> (Array.set depPvec (snd indi) (Some(dep,mkRel k)); assign (k-1) rest) @@ -356,79 +356,79 @@ let mis_make_indrec env sigma ?(force_mutual=false) listdepkind mib u = (* constructors in context of the Cases expr, i.e. P1..P_nrec f1..f_nbconstruct F_1..F_nrec a_1..a_nar x:I *) - let args' = Context.Rel.to_extended_list mkRel (dect+nrec) lnamesparrec in - let args'' = Context.Rel.to_extended_list mkRel ndepar lnonparrec in + let args' = Context.Rel.to_extended_list mkRel (dect+nrec) lnamesparrec in + let args'' = Context.Rel.to_extended_list mkRel ndepar lnonparrec in let indf' = make_ind_family((indi,u),args'@args'') in - let branches = - let constrs = get_constructors env indf' in - let fi = Termops.rel_vect (dect-i-nctyi) nctyi in - let vecfi = Array.map - (fun f -> appvect (f, Context.Rel.to_extended_vect mkRel ndepar lnonparrec)) - fi - in - Array.map3 - (make_rec_branch_arg env !evdref - (nparrec,depPvec,larsign)) + let branches = + let constrs = get_constructors env indf' in + let fi = Termops.rel_vect (dect-i-nctyi) nctyi in + let vecfi = Array.map + (fun f -> appvect (f, Context.Rel.to_extended_vect mkRel ndepar lnonparrec)) + fi + in + Array.map3 + (make_rec_branch_arg env !evdref + (nparrec,depPvec,larsign)) vecfi constrs (dest_subterms recargsvec.(tyi)) - in + in - let j = (match depPvec.(tyi) with - | Some (_,c) when isRel c -> destRel c - | _ -> assert false) - in + let j = (match depPvec.(tyi) with + | Some (_,c) when isRel c -> destRel c + | _ -> assert false) + in - (* Predicate in the context of the case *) + (* Predicate in the context of the case *) let depind' = build_dependent_inductive env indf' in let arsign',s = get_arity env indf' in let r = Sorts.relevance_of_sort_family s in let deparsign' = LocalAssum (make_annot Anonymous r,depind')::arsign' in - let pargs = - let nrpar = Context.Rel.to_extended_list mkRel (2*ndepar) lnonparrec - and nrar = if dep then Context.Rel.to_extended_list mkRel 0 deparsign' - else Context.Rel.to_extended_list mkRel 1 arsign' - in nrpar@nrar + let pargs = + let nrpar = Context.Rel.to_extended_list mkRel (2*ndepar) lnonparrec + and nrar = if dep then Context.Rel.to_extended_list mkRel 0 deparsign' + else Context.Rel.to_extended_list mkRel 1 arsign' + in nrpar@nrar - in + in - (* body of i-th component of the mutual fixpoint *) + (* body of i-th component of the mutual fixpoint *) let target_relevance = Sorts.relevance_of_sort_family target_sort in - let deftyi = + let deftyi = let rci = target_relevance in let ci = make_case_info env indi rci RegularStyle in - let concl = applist (mkRel (dect+j+ndepar),pargs) in - let pred = - it_mkLambda_or_LetIn_name env - ((if dep then mkLambda_name env else mkLambda) + let concl = applist (mkRel (dect+j+ndepar),pargs) in + let pred = + it_mkLambda_or_LetIn_name env + ((if dep then mkLambda_name env else mkLambda) (make_annot Anonymous r,depind',concl)) - arsign' - in - let obj = - Inductiveops.make_case_or_project env !evdref indf ci (EConstr.of_constr pred) - (EConstr.mkRel 1) (Array.map EConstr.of_constr branches) - in - let obj = EConstr.to_constr !evdref obj in - it_mkLambda_or_LetIn_name env obj - (Termops.lift_rel_context nrec deparsign) - in - - (* type of i-th component of the mutual fixpoint *) - - let typtyi = - let concl = - let pargs = if dep then Context.Rel.to_extended_vect mkRel 0 deparsign - else Context.Rel.to_extended_vect mkRel 1 arsign - in appvect (mkRel (nbconstruct+ndepar+nonrecpar+j),pargs) - in it_mkProd_or_LetIn_name env - concl - deparsign + arsign' + in + let obj = + Inductiveops.make_case_or_project env !evdref indf ci (EConstr.of_constr pred) + (EConstr.mkRel 1) (Array.map EConstr.of_constr branches) + in + let obj = EConstr.to_constr !evdref obj in + it_mkLambda_or_LetIn_name env obj + (Termops.lift_rel_context nrec deparsign) + in + + (* type of i-th component of the mutual fixpoint *) + + let typtyi = + let concl = + let pargs = if dep then Context.Rel.to_extended_vect mkRel 0 deparsign + else Context.Rel.to_extended_vect mkRel 1 arsign + in appvect (mkRel (nbconstruct+ndepar+nonrecpar+j),pargs) + in it_mkProd_or_LetIn_name env + concl + deparsign in mrec (i+nctyi) (Context.Rel.nhyps arsign ::ln) (target_relevance::lrelevance) (typtyi::ltyp) (deftyi::ldef) rest | [] -> - let fixn = Array.of_list (List.rev ln) in + let fixn = Array.of_list (List.rev ln) in let fixtyi = Array.of_list (List.rev ltyp) in let fixdef = Array.of_list (List.rev ldef) in let lrelevance = CArray.rev_of_list lrelevance in @@ -440,55 +440,55 @@ let mis_make_indrec env sigma ?(force_mutual=false) listdepkind mib u = let rec make_branch env i = function | ((indi,u),mibi,mipi,dep,sfam)::rest -> let tyi = snd indi in - let nconstr = Array.length mipi.mind_consnames in - let rec onerec env j = - if Int.equal j nconstr then - make_branch env (i+j) rest - else - let recarg = (dest_subterms recargsvec.(tyi)).(j) in - let recarg = recargpar@recarg in - let vargs = Context.Rel.to_extended_list mkRel (nrec+i+j) lnamesparrec in - let cs = get_constructor ((indi,u),mibi,mipi,vargs) (j+1) in - let p_0 = - type_rec_branch + let nconstr = Array.length mipi.mind_consnames in + let rec onerec env j = + if Int.equal j nconstr then + make_branch env (i+j) rest + else + let recarg = (dest_subterms recargsvec.(tyi)).(j) in + let recarg = recargpar@recarg in + let vargs = Context.Rel.to_extended_list mkRel (nrec+i+j) lnamesparrec in + let cs = get_constructor ((indi,u),mibi,mipi,vargs) (j+1) in + let p_0 = + type_rec_branch true dep env !evdref (vargs,depPvec,i+j) tyi cs recarg in let r_0 = Sorts.relevance_of_sort_family sfam in mkLambda_string "f" r_0 p_0 (onerec (push_rel (LocalAssum (make_annot Anonymous r_0,p_0)) env) (j+1)) - in onerec env 0 + in onerec env 0 | [] -> - makefix i listdepkind + makefix i listdepkind in let rec put_arity env i = function | ((indi,u),_,_,dep,kinds)::rest -> - let indf = make_ind_family ((indi,u), Context.Rel.to_extended_list mkRel i lnamesparrec) in - let s = + let indf = make_ind_family ((indi,u), Context.Rel.to_extended_list mkRel i lnamesparrec) in + let s = let sigma, res = Evd.fresh_sort_in_family ~rigid:Evd.univ_flexible_alg !evdref kinds in evdref := sigma; res - in - let typP = make_arity env !evdref dep indf s in + in + let typP = make_arity env !evdref dep indf s in let typP = EConstr.Unsafe.to_constr typP in mkLambda_string "P" Sorts.Relevant typP (put_arity (push_rel (LocalAssum (anonR,typP)) env) (i+1) rest) | [] -> - make_branch env 0 listdepkind + make_branch env 0 listdepkind in (* Body on make_one_rec *) let ((indi,u),mibi,mipi,dep,kind) = List.nth listdepkind p in if force_mutual || (mis_is_recursive_subset - (List.map (fun ((indi,u),_,_,_,_) -> snd indi) listdepkind) - mipi.mind_recargs) + (List.map (fun ((indi,u),_,_,_,_) -> snd indi) listdepkind) + mipi.mind_recargs) then - let env' = push_rel_context lnamesparrec env in - it_mkLambda_or_LetIn_name env (put_arity env' 0 listdepkind) - lnamesparrec + let env' = push_rel_context lnamesparrec env in + it_mkLambda_or_LetIn_name env (put_arity env' 0 listdepkind) + lnamesparrec else let evd = !evdref in let (evd, c) = mis_make_case_com dep env evd (indi,u) (mibi,mipi) kind in - evdref := evd; c + evdref := evd; c in (* Body of mis_make_indrec *) !evdref, List.init nrec make_one_rec @@ -533,12 +533,12 @@ let weaken_sort_scheme env evd set sort npars term ty = let rec drec np elim = match kind elim with | Prod (n,t,c) -> - if Int.equal np 0 then + if Int.equal np 0 then let osort, t' = change_sort_arity sort t in - evdref := (if set then Evd.set_eq_sort else Evd.set_leq_sort) env !evdref sort osort; + evdref := (if set then Evd.set_eq_sort else Evd.set_leq_sort) env !evdref sort osort; mkProd (n, t', c), mkLambda (n, t', mkApp(term,Termops.rel_vect 0 (npars+1))) - else + else let c',term' = drec (np-1) c in mkProd (n, t, c'), mkLambda (n, t, term') | LetIn (n,b,t,c) -> let c',term' = drec np c in @@ -558,12 +558,12 @@ let check_arities env listdepkind = (fun ln (((_,ni as mind),u),mibi,mipi,dep,kind) -> let kelim = elim_sort (mibi,mipi) in if not (Sorts.family_leq kind kelim) then raise - (RecursionSchemeError + (RecursionSchemeError (env, NotAllowedCaseAnalysis (true, fst (UnivGen.fresh_sort_in_family kind),(mind,u)))) else if Int.List.mem ni ln then raise (RecursionSchemeError (env, NotMutualInScheme (mind,mind))) else ni::ln) - [] listdepkind + [] listdepkind in true let build_mutual_induction_scheme env sigma ?(force_mutual=false) = function @@ -573,16 +573,16 @@ let build_mutual_induction_scheme env sigma ?(force_mutual=false) = function raise (RecursionSchemeError (env, NotAllowedDependentAnalysis (true, mind))); let (sp,tyi) = mind in let listdepkind = - ((mind,u),mib,mip,dep,s):: - (List.map - (function ((mind',u'),dep',s') -> - let (sp',_) = mind' in - if MutInd.equal sp sp' then + ((mind,u),mib,mip,dep,s):: + (List.map + (function ((mind',u'),dep',s') -> + let (sp',_) = mind' in + if MutInd.equal sp sp' then let (mibi',mipi') = lookup_mind_specif env mind' in - ((mind',u'),mibi',mipi',dep',s') - else + ((mind',u'),mibi',mipi',dep',s') + else raise (RecursionSchemeError (env, NotMutualInScheme (mind,mind')))) - lrecspec) + lrecspec) in let _ = check_arities env listdepkind in mis_make_indrec env sigma ~force_mutual listdepkind mib u diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index 55eb74cacf..06466cc67d 100644 --- a/pretyping/inductiveops.mli +++ b/pretyping/inductiveops.mli @@ -151,7 +151,7 @@ val has_dependent_elim : mutual_inductive_body -> bool (** Primitive projections *) val type_of_projection_knowing_arg : env -> evar_map -> Projection.t -> - EConstr.t -> EConstr.types -> types + EConstr.t -> EConstr.types -> types (** Extract information from an inductive family *) diff --git a/pretyping/locusops.ml b/pretyping/locusops.ml index 9c6cf090a2..ffb29bb38c 100644 --- a/pretyping/locusops.ml +++ b/pretyping/locusops.ml @@ -71,12 +71,12 @@ let simple_clause_of enum_hyps cl = let hyps = match cl.onhyps with | None -> - List.map Option.make (enum_hyps ()) + List.map Option.make (enum_hyps ()) | Some l -> - List.map (fun ((occs,id),w) -> + List.map (fun ((occs,id),w) -> if not (is_all_occurrences occs) then error_occurrences (); - if w = InHypValueOnly then error_body_selection (); - Some id) l in + if w = InHypValueOnly then error_body_selection (); + Some id) l in if cl.concl_occs = NoOccurrences then hyps else if not (is_all_occurrences cl.concl_occs) then error_occurrences () @@ -88,10 +88,10 @@ let concrete_clause_of enum_hyps cl = let hyps = match cl.onhyps with | None -> - let f id = OnHyp (id,AllOccurrences,InHyp) in - List.map f (enum_hyps ()) + let f id = OnHyp (id,AllOccurrences,InHyp) in + List.map f (enum_hyps ()) | Some l -> - List.map (fun ((occs,id),w) -> OnHyp (id,occs,w)) l in + List.map (fun ((occs,id),w) -> OnHyp (id,occs,w)) l in if cl.concl_occs = NoOccurrences then hyps else OnConcl cl.concl_occs :: hyps diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index 0178d5c009..2db674d397 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -29,7 +29,7 @@ exception Find_at of int (* profiling *) let profiling_enabled = ref false - + (* for supported platforms, filename for profiler results *) let profile_filename = ref "native_compute_profile.data" @@ -52,8 +52,8 @@ let set_profile_filename fn = (* find unused profile filename *) let get_available_profile_filename () = let profile_filename = get_profile_filename () in - let dir = Filename.dirname profile_filename in - let base = Filename.basename profile_filename in + let dir = Filename.dirname profile_filename in + let base = Filename.basename profile_filename in (* starting with OCaml 4.04, could use Filename.remove_extension and Filename.extension, which gets rid of need for exception-handling here *) @@ -65,7 +65,7 @@ let get_available_profile_filename () = (nm,ex) with Invalid_argument _ -> (base,"") in - try + try (* unlikely race: fn deleted, another process uses fn *) Filename.temp_file ~temp_dir:dir (name ^ "_") ext with Sys_error s -> @@ -75,16 +75,16 @@ let get_available_profile_filename () = let get_profiling_enabled () = !profiling_enabled - + let set_profiling_enabled b = profiling_enabled := b - + let invert_tag cst tag reloc_tbl = try for j = 0 to Array.length reloc_tbl - 1 do let tagj,arity = reloc_tbl.(j) in if Int.equal tag tagj && (cst && Int.equal arity 0 || not(cst || Int.equal arity 0)) then - raise (Find_at j) + raise (Find_at j) else () done;raise Not_found with Find_at j -> (j+1) @@ -101,7 +101,7 @@ let app_type env c = let t = whd_all env c in try destApp t with DestKO -> (t,[||]) - + let find_rectype_a env c = let (t, l) = app_type env c in match kind t with @@ -117,7 +117,7 @@ let type_constructor mind mib u (ctx, typ) params = let nparams = Array.length params in if Int.equal nparams 0 then ctyp else - let _,ctyp = decompose_prod_n nparams ctyp in + let _,ctyp = decompose_prod_n nparams ctyp in substl (List.rev (Array.to_list params)) ctyp let construct_of_constr_notnative const env tag (mind, _ as ind) u allargs = @@ -127,12 +127,12 @@ let construct_of_constr_notnative const env tag (mind, _ as ind) u allargs = let i = invert_tag const tag mip.mind_reloc_tbl in let ctyp = type_constructor mind mib u (mip.mind_nf_lc.(i-1)) params in (mkApp(mkConstructU((ind,i),u), params), ctyp) - + let construct_of_constr const env sigma tag typ = let t, l = app_type env typ in match EConstr.kind_upto sigma t with - | Ind (ind,u) -> + | Ind (ind,u) -> construct_of_constr_notnative const env tag ind u l | _ -> assert (Constr.equal t (Typeops.type_of_int env)); @@ -165,7 +165,7 @@ let build_branches_type env sigma (mind,_ as _ind) mib mip u params p = let params = Array.map (lift ndecl) params in let dep_cstr = mkApp(mkApp(mkConstructU (cstr,snd ind),params),relargs) in mkApp(papp,[|dep_cstr|]) - in + in decl, decl_with_letin, codom in Array.mapi build_one_branch mip.mind_nf_lc @@ -174,11 +174,11 @@ let build_case_type p realargs c = (* normalisation of values *) -let branch_of_switch lvl ans bs = +let branch_of_switch lvl ans bs = let tbl = ans.asw_reloc in - let branch i = + let branch i = let tag,arity = tbl.(i) in - let ci = + let ci = if Int.equal arity 0 then mk_const tag else mk_block tag (mk_rels_accu lvl arity) in bs ci in @@ -195,11 +195,11 @@ let get_proj env (ind, proj_arg) = let rec nf_val env sigma v typ = match kind_of_value v with | Vaccu accu -> nf_accu env sigma accu - | Vfun f -> + | Vfun f -> let lvl = nb_rel env in let name,dom,codom = - try decompose_prod env typ - with DestKO -> + try decompose_prod env typ + with DestKO -> CErrors.anomaly (Pp.strbrk "Returned a functional value in a type not recognized as a product type.") in @@ -221,7 +221,7 @@ and nf_type env sigma v = and nf_type_sort env sigma v = match kind_of_value v with - | Vaccu accu -> + | Vaccu accu -> let t,s = nf_accu_type env sigma accu in let s = try @@ -249,12 +249,12 @@ and nf_accu_type env sigma accu = mkApp(a,Array.of_list args), t and nf_args env sigma args t = - let aux arg (t,l) = + let aux arg (t,l) = let _,dom,codom = try decompose_prod env t with - DestKO -> - CErrors.anomaly - (Pp.strbrk "Returned a functional value in a type not recognized as a product type.") + DestKO -> + CErrors.anomaly + (Pp.strbrk "Returned a functional value in a type not recognized as a product type.") in let c = nf_val env sigma arg dom in (subst1 c codom, c::l) @@ -268,10 +268,10 @@ and nf_bargs env sigma b t = Array.init len (fun i -> let _,dom,codom = - try decompose_prod env !t with - DestKO -> - CErrors.anomaly - (Pp.strbrk "Returned a functional value in a type not recognized as a product type.") + try decompose_prod env !t with + DestKO -> + CErrors.anomaly + (Pp.strbrk "Returned a functional value in a type not recognized as a product type.") in let c = nf_val env sigma (block_field b i) dom in t := subst1 c codom; c) @@ -318,9 +318,9 @@ and nf_atom_type env sigma atom = let nparams = mib.mind_nparams in let params,realargs = Array.chop nparams allargs in let nparamdecls = Context.Rel.length (Inductive.inductive_paramdecls (mib,u)) in - let pT = + let pT = hnf_prod_applist_assum env nparamdecls - (Inductiveops.type_of_inductive env ind) (Array.to_list params) in + (Inductiveops.type_of_inductive env ind) (Array.to_list params) in let p = nf_predicate env sigma ind mip params p pT in (* Calcul du type des branches *) let btypes = build_branches_type env sigma (fst ind) mib mip u params p in @@ -330,11 +330,11 @@ and nf_atom_type env sigma atom = let decl,decl_with_letin,codom = btypes.(i) in let b = nf_val (Termops.push_rels_assum decl env) sigma v codom in Termops.it_mkLambda_or_LetIn_from_no_LetIn b decl_with_letin - in + in let branchs = Array.mapi mkbranch bsw in let tcase = build_case_type p realargs a in let ci = ans.asw_ci in - mkCase(ci, p, a, branchs), tcase + mkCase(ci, p, a, branchs), tcase | Afix(tt,ft,rp,s) -> let tt = Array.map (fun t -> nf_type_sort env sigma t) tt in let tt = Array.map fst tt and rt = Array.map snd tt in @@ -393,7 +393,7 @@ and nf_predicate env sigma ind mip params v pT = let k = nb_rel env in let vb = f (mk_rel_accu k) in let body = - nf_predicate (push_rel (LocalAssum (name,dom)) env) sigma ind mip params vb codom in + nf_predicate (push_rel (LocalAssum (name,dom)) env) sigma ind mip params vb codom in mkLambda(name,dom,body) | _ -> nf_type env sigma v end @@ -444,23 +444,23 @@ let start_profiler_linux profile_fn = let dev_null = Unix.descr_of_out_channel (open_out_bin "/dev/null") in let _ = Feedback.msg_info (Pp.str ("Profiling to file " ^ profile_fn)) in let perf = "perf" in - let profiler_pid = + let profiler_pid = Unix.create_process perf [|perf; "record"; "-g"; "-o"; profile_fn; "-p"; string_of_int coq_pid |] Unix.stdin dev_null dev_null in (* doesn't seem to be a way to test whether process creation succeeded *) - if !Flags.debug then + if !Flags.debug then Feedback.msg_debug (Pp.str (Format.sprintf "Native compute profiler started, pid = %d, output to: %s" profiler_pid profile_fn)); Some profiler_pid (* kill profiler via SIGINT *) -let stop_profiler_linux m_pid = - match m_pid with +let stop_profiler_linux m_pid = + match m_pid with | Some pid -> ( let _ = if !Flags.debug then Feedback.msg_debug (Pp.str "Stopping native code profiler") in - try + try Unix.kill pid Sys.sigint; let _ = Unix.waitpid [] pid in () with Unix.Unix_error (Unix.ESRCH,"kill","") -> @@ -475,7 +475,7 @@ let start_profiler () = | _ -> let _ = Feedback.msg_info (Pp.str (Format.sprintf "Native_compute profiling not supported on the platform: %s" - (profiler_platform ()))) in + (profiler_platform ()))) in None let stop_profiler m_pid = diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index 0c4312dc77..9ca3529b5c 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -136,7 +136,7 @@ let rec head_pattern_bound t = | PRef r -> r | PVar id -> GlobRef.VarRef id | PEvar _ | PRel _ | PMeta _ | PSoApp _ | PSort _ | PFix _ | PProj _ - -> raise BoundPattern + -> raise BoundPattern (* Perhaps they were arguments, but we don't beta-reduce *) | PLambda _ -> raise BoundPattern | PCoFix _ | PInt _ | PFloat _ -> anomaly ~label:"head_pattern_bound" (Pp.str "not a type.") @@ -180,7 +180,7 @@ let pattern_of_constr env sigma t = | Const (sp,u) -> PRef (GlobRef.ConstRef (Constant.make1 (Constant.canonical sp))) | Ind (sp,u) -> PRef (canonical_gr (GlobRef.IndRef sp)) | Construct (sp,u) -> PRef (canonical_gr (GlobRef.ConstructRef sp)) - | Proj (p, c) -> + | Proj (p, c) -> pattern_of_constr env (EConstr.Unsafe.to_constr (Retyping.expand_projection env sigma p (EConstr.of_constr c) [])) | Evar (evk,ctxt as ev) -> (match snd (Evd.evar_source evk sigma) with @@ -192,20 +192,20 @@ let pattern_of_constr env sigma t = if Evd.is_defined sigma evk then pattern_of_constr env (Evd.existential_value0 sigma ev) else PEvar (evk,Array.map (pattern_of_constr env) ctxt) | Evar_kinds.MatchingVar (Evar_kinds.SecondOrderPatVar ido) -> assert false - | _ -> - PMeta None) + | _ -> + PMeta None) | Case (ci,p,a,br) -> let cip = - { cip_style = ci.ci_pp_info.style; - cip_ind = Some ci.ci_ind; - cip_ind_tags = Some ci.ci_pp_info.ind_tags; - cip_extensible = false } - in - let branch_of_constr i c = - (i, ci.ci_pp_info.cstr_tags.(i), pattern_of_constr env c) - in - PCase (cip, pattern_of_constr env p, pattern_of_constr env a, - Array.to_list (Array.mapi branch_of_constr br)) + { cip_style = ci.ci_pp_info.style; + cip_ind = Some ci.ci_ind; + cip_ind_tags = Some ci.ci_pp_info.ind_tags; + cip_extensible = false } + in + let branch_of_constr i c = + (i, ci.ci_pp_info.cstr_tags.(i), pattern_of_constr env c) + in + PCase (cip, pattern_of_constr env p, pattern_of_constr env a, + Array.to_list (Array.mapi branch_of_constr br)) | Fix (lni,(lna,tl,bl)) -> let push env na2 c2 = push_rel (LocalAssum (na2,c2)) env in let env' = Array.fold_left2 push env lna tl in @@ -244,7 +244,7 @@ let map_pattern_with_binders g f l = function let error_instantiate_pattern id l = let is = match l with - | [_] -> "is" + | [_] -> "is" | _ -> "are" in user_err (str "Cannot substitute the term bound to " ++ Id.print id @@ -257,23 +257,23 @@ let instantiate_pattern env sigma lvar c = let rec aux vars = function | PVar id as x -> (try - let ctx,c = Id.Map.find id lvar in - try - let inst = - List.map + let ctx,c = Id.Map.find id lvar in + try + let inst = + List.map (fun id -> mkRel (List.index Name.equal (Name id) vars)) ctx in - let c = substl inst c in + let c = substl inst c in (* FIXME: Stupid workaround to pattern_of_constr being evar sensitive *) - let c = Evarutil.nf_evar sigma c in - pattern_of_constr env sigma (EConstr.Unsafe.to_constr c) - with Not_found (* List.index failed *) -> - let vars = - List.map_filter (function Name id -> Some id | _ -> None) vars in - error_instantiate_pattern id (List.subtract Id.equal ctx vars) + let c = Evarutil.nf_evar sigma c in + pattern_of_constr env sigma (EConstr.Unsafe.to_constr c) + with Not_found (* List.index failed *) -> + let vars = + List.map_filter (function Name id -> Some id | _ -> None) vars in + error_instantiate_pattern id (List.subtract Id.equal ctx vars) with Not_found (* Map.find failed *) -> - x) + x) | c -> map_pattern_with_binders (fun id vars -> id::vars) aux vars c in aux [] c @@ -297,44 +297,44 @@ let rec subst_pattern env sigma subst pat = | PRel _ | PInt _ | PFloat _ -> pat - | PProj (p,c) -> + | PProj (p,c) -> let p' = Projection.map (subst_mind subst) p in let c' = subst_pattern env sigma subst c in - if p' == p && c' == c then pat else - PProj(p',c') + if p' == p && c' == c then pat else + PProj(p',c') | PApp (f,args) -> let f' = subst_pattern env sigma subst f in let args' = Array.Smart.map (subst_pattern env sigma subst) args in - if f' == f && args' == args then pat else - PApp (f',args') + if f' == f && args' == args then pat else + PApp (f',args') | PSoApp (i,args) -> let args' = List.Smart.map (subst_pattern env sigma subst) args in - if args' == args then pat else - PSoApp (i,args') + if args' == args then pat else + PSoApp (i,args') | PLambda (name,c1,c2) -> let c1' = subst_pattern env sigma subst c1 in let c2' = subst_pattern env sigma subst c2 in - if c1' == c1 && c2' == c2 then pat else - PLambda (name,c1',c2') + if c1' == c1 && c2' == c2 then pat else + PLambda (name,c1',c2') | PProd (name,c1,c2) -> let c1' = subst_pattern env sigma subst c1 in let c2' = subst_pattern env sigma subst c2 in - if c1' == c1 && c2' == c2 then pat else - PProd (name,c1',c2') + if c1' == c1 && c2' == c2 then pat else + PProd (name,c1',c2') | PLetIn (name,c1,t,c2) -> let c1' = subst_pattern env sigma subst c1 in let t' = Option.Smart.map (subst_pattern env sigma subst) t in let c2' = subst_pattern env sigma subst c2 in - if c1' == c1 && t' == t && c2' == c2 then pat else - PLetIn (name,c1',t',c2') + if c1' == c1 && t' == t && c2' == c2 then pat else + PLetIn (name,c1',t',c2') | PSort _ | PMeta _ -> pat | PIf (c,c1,c2) -> let c' = subst_pattern env sigma subst c in let c1' = subst_pattern env sigma subst c1 in let c2' = subst_pattern env sigma subst c2 in - if c' == c && c1' == c1 && c2' == c2 then pat else - PIf (c',c1',c2') + if c' == c && c1' == c1 && c2' == c2 then pat else + PIf (c',c1',c2') | PCase (cip,typ,c,branches) -> let ind = cip.cip_ind in let ind' = Option.Smart.map (subst_ind subst) ind in @@ -343,7 +343,7 @@ let rec subst_pattern env sigma subst pat = let c' = subst_pattern env sigma subst c in let subst_branch ((i,n,c) as br) = let c' = subst_pattern env sigma subst c in - if c' == c then br else (i,n,c') + if c' == c then br else (i,n,c') in let branches' = List.Smart.map subst_branch branches in if cip' == cip && typ' == typ && c' == c && branches' == branches @@ -400,21 +400,21 @@ let rec pat_of_raw metas vars = DAst.with_loc_val (fun ?loc -> function metas := n::!metas; PSoApp (n, List.map (pat_of_raw metas vars) cl) | _ -> PApp (pat_of_raw metas vars c, - Array.of_list (List.map (pat_of_raw metas vars) cl)) + Array.of_list (List.map (pat_of_raw metas vars) cl)) end | GLambda (na,bk,c1,c2) -> Name.iter (fun n -> metas := n::!metas) na; PLambda (na, pat_of_raw metas vars c1, - pat_of_raw metas (na::vars) c2) + pat_of_raw metas (na::vars) c2) | GProd (na,bk,c1,c2) -> Name.iter (fun n -> metas := n::!metas) na; PProd (na, pat_of_raw metas vars c1, - pat_of_raw metas (na::vars) c2) + pat_of_raw metas (na::vars) c2) | GLetIn (na,c1,t,c2) -> Name.iter (fun n -> metas := n::!metas) na; PLetIn (na, pat_of_raw metas vars c1, Option.map (pat_of_raw metas vars) t, - pat_of_raw metas (na::vars) c2) + pat_of_raw metas (na::vars) c2) | GSort gs -> (try PSort (Glob_ops.glob_sort_family gs) with Glob_ops.ComplexSort -> user_err ?loc (str "Unexpected universe in pattern.")) @@ -431,26 +431,26 @@ let rec pat_of_raw metas vars = DAst.with_loc_val (fun ?loc -> function GLambda (na,Explicit, DAst.make @@ GHole (Evar_kinds.InternalHole, Namegen.IntroAnonymous, None),c) in let c = List.fold_right mkGLambda nal c in let cip = - { cip_style = LetStyle; - cip_ind = None; - cip_ind_tags = None; - cip_extensible = false } + { cip_style = LetStyle; + cip_ind = None; + cip_ind_tags = None; + cip_extensible = false } in let tags = List.map (fun _ -> false) nal (* Approximation which can be without let-ins... *) in PCase (cip, PMeta None, pat_of_raw metas vars b, [0,tags,pat_of_raw metas vars c]) | GCases (sty,p,[c,(na,indnames)],brs) -> - let get_ind p = match DAst.get p with + let get_ind p = match DAst.get p with | PatCstr((ind,_),_,_) -> Some ind | _ -> None in let get_ind = function | {CAst.v=(_,[p],_)}::_ -> get_ind p - | _ -> None + | _ -> None in let ind_tags,ind = match indnames with | Some {CAst.v=(ind,nal)} -> Some (List.length nal), Some ind - | None -> None, get_ind brs + | None -> None, get_ind brs in let ext,brs = pats_of_glob_branches loc metas vars ind brs in @@ -459,21 +459,21 @@ let rec pat_of_raw metas vars = DAst.with_loc_val (fun ?loc -> function let nvars = na :: List.rev nal @ vars in rev_it_mkPLambdaUntyped nal (mkPLambdaUntyped na (pat_of_raw metas nvars p)) | None, _ -> PMeta None - | Some p, None -> + | Some p, None -> match DAst.get p with | GHole _ -> PMeta None | _ -> user_err ?loc (strbrk "Clause \"in\" expected in patterns over \"match\" expressions with an explicit \"return\" clause.") in let info = - { cip_style = sty; - cip_ind = ind; - cip_ind_tags = None; - cip_extensible = ext } + { cip_style = sty; + cip_ind = ind; + cip_ind_tags = None; + cip_extensible = ext } in (* Nota : when we have a non-trivial predicate, - the inductive type is known. Same when we have at least - one non-trivial branch. These facts are used in [Constrextern]. *) + the inductive type is known. Same when we have at least + one non-trivial branch. These facts are used in [Constrextern]. *) PCase (info, pred, pat_of_raw metas vars c, brs) | GRec (GFix (ln,n), ids, decls, tl, cl) -> diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 2e1cb9ff08..4925f3e5fa 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -95,8 +95,8 @@ let search_guard ?loc env possible_indexes fixdefs = (* we now search recursively among all combinations *) (try List.iter - (fun l -> - let indexes = Array.of_list l in + (fun l -> + let indexes = Array.of_list l in let fix = ((indexes, 0),fixdefs) in (* spiwack: We search for a unspecified structural argument under the assumption that we need to check the @@ -108,10 +108,10 @@ let search_guard ?loc env possible_indexes fixdefs = let flags = { (typing_flags env) with Declarations.check_guarded = true } in let env = Environ.set_typing_flags flags env in check_fix env fix; raise (Found indexes) - with TypeError _ -> ()) - (List.combinations possible_indexes); + with TypeError _ -> ()) + (List.combinations possible_indexes); let errmsg = "Cannot guess decreasing argument of fix." in - user_err ?loc ~hdr:"search_guard" (Pp.str errmsg) + user_err ?loc ~hdr:"search_guard" (Pp.str errmsg) with Found indexes -> indexes) let esearch_guard ?loc env sigma indexes fix = @@ -281,10 +281,10 @@ let check_extra_evars_are_solved env current_sigma frozen = match frozen with (fun evk -> if not (Evd.is_defined current_sigma evk) then let (loc,k) = evar_source evk current_sigma in - match k with - | Evar_kinds.ImplicitArg (gr, (i, id), false) -> () - | _ -> - error_unsolvable_implicit ?loc env current_sigma evk None) pending + match k with + | Evar_kinds.ImplicitArg (gr, (i, id), false) -> () + | _ -> + error_unsolvable_implicit ?loc env current_sigma evk None) pending (* [check_evars] fails if some unresolved evar remains *) @@ -424,8 +424,8 @@ let interp_instance ?loc evd l = str " universe instances must be greater or equal to Set."); evd, Some (Univ.Instance.of_array (Array.of_list (List.rev l'))) -let pretype_global ?loc rigid env evd gr us = - let evd, instance = +let pretype_global ?loc rigid env evd gr us = + let evd, instance = match us with | None -> evd, None | Some l -> interp_instance ?loc evd l @@ -454,7 +454,7 @@ let interp_sort ?loc evd : glob_sort -> _ = function | UNamed l -> interp_sort_info ?loc evd l let judge_of_sort ?loc evd s = - let judge = + let judge = { uj_val = mkType s; uj_type = mkType (Univ.super s) } in evd, judge @@ -571,9 +571,9 @@ let rec pretype ~program_mode ~poly resolve_tc (tycon : type_constraint) (env : let sigma = match tycon with | Some t -> - let fixi = match fixkind with - | GFix (vn,i) -> i - | GCoFix i -> i + let fixi = match fixkind with + | GFix (vn,i) -> i + | GCoFix i -> i in begin match Evarconv.unify_delay !!env sigma ftys.(fixi) t with | exception Evarconv.UnableToUnify _ -> sigma @@ -605,32 +605,32 @@ let rec pretype ~program_mode ~poly resolve_tc (tycon : type_constraint) (env : let ftys = Array.map nf ftys in (* FIXME *) let fdefs = Array.map (fun x -> nf (j_val x)) vdefj in let fixj = match fixkind with - | GFix (vn,i) -> - (* First, let's find the guard indexes. *) - (* If recursive argument was not given by user, we try all args. - An earlier approach was to look only for inductive arguments, - but doing it properly involves delta-reduction, and it finally + | GFix (vn,i) -> + (* First, let's find the guard indexes. *) + (* If recursive argument was not given by user, we try all args. + An earlier approach was to look only for inductive arguments, + but doing it properly involves delta-reduction, and it finally doesn't seem worth the effort (except for huge mutual - fixpoints ?) *) - let possible_indexes = - Array.to_list (Array.mapi + fixpoints ?) *) + let possible_indexes = + Array.to_list (Array.mapi (fun i annot -> match annot with - | Some n -> [n] - | None -> List.map_i (fun i _ -> i) 0 ctxtv.(i)) + | Some n -> [n] + | None -> List.map_i (fun i _ -> i) 0 ctxtv.(i)) vn) - in + in let fixdecls = (names,ftys,fdefs) in let indexes = esearch_guard ?loc !!env sigma possible_indexes fixdecls in make_judge (mkFix ((indexes,i),fixdecls)) ftys.(i) | GCoFix i -> let fixdecls = (names,ftys,fdefs) in - let cofix = (i, fixdecls) in + let cofix = (i, fixdecls) in (try check_cofix !!env (i, nf_fix sigma fixdecls) with reraise -> let (e, info) = CErrors.push reraise in let info = Option.cata (Loc.add_loc info) info loc in iraise (e, info)); - make_judge (mkCoFix cofix) ftys.(i) + make_judge (mkCoFix cofix) ftys.(i) in inh_conv_coerce_to_tycon ?loc env sigma fixj tycon @@ -674,7 +674,7 @@ let rec pretype ~program_mode ~poly resolve_tc (tycon : type_constraint) (env : with Not_found -> [] else [] in - let app_f = + let app_f = match EConstr.kind sigma fj.uj_val with | Const (p, u) when Recordops.is_primitive_projection p -> let p = Option.get @@ Recordops.find_primitive_projection p in @@ -824,37 +824,37 @@ let rec pretype ~program_mode ~poly resolve_tc (tycon : type_constraint) (env : let (IndType (indf,realargs)) = try find_rectype !!env sigma cj.uj_type with Not_found -> - let cloc = loc_of_glob_constr c in + let cloc = loc_of_glob_constr c in error_case_not_inductive ?loc:cloc !!env sigma cj in let ind = fst (fst (dest_ind_family indf)) in let cstrs = get_constructors !!env indf in if not (Int.equal (Array.length cstrs) 1) then user_err ?loc (str "Destructing let is only for inductive types" ++ - str " with one constructor."); + str " with one constructor."); let cs = cstrs.(0) in if not (Int.equal (List.length nal) cs.cs_nargs) then - user_err ?loc:loc (str "Destructing let on this type expects " ++ - int cs.cs_nargs ++ str " variables."); - let fsign, record = + user_err ?loc:loc (str "Destructing let on this type expects " ++ + int cs.cs_nargs ++ str " variables."); + let fsign, record = let set_name na d = set_name na (map_rel_decl EConstr.of_constr d) in match Environ.get_projections !!env ind with | None -> - List.map2 set_name (List.rev nal) cs.cs_args, false + List.map2 set_name (List.rev nal) cs.cs_args, false | Some ps -> - let rec aux n k names l = - match names, l with + let rec aux n k names l = + match names, l with | na :: names, (LocalAssum (na', t) :: l) -> let t = EConstr.of_constr t in - let proj = Projection.make ps.(cs.cs_nargs - k) true in + let proj = Projection.make ps.(cs.cs_nargs - k) true in LocalDef ({na' with binder_name = na}, lift (cs.cs_nargs - n) (mkProj (proj, cj.uj_val)), t) - :: aux (n+1) (k + 1) names l - | na :: names, (decl :: l) -> - set_name na decl :: aux (n+1) k names l - | [], [] -> [] - | _ -> assert false - in aux 1 1 (List.rev nal) cs.cs_args, true in + :: aux (n+1) (k + 1) names l + | na :: names, (decl :: l) -> + set_name na decl :: aux (n+1) k names l + | [], [] -> [] + | _ -> assert false + in aux 1 1 (List.rev nal) cs.cs_args, true in let fsign = Context.Rel.map (whd_betaiota sigma) fsign in let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in let fsign,env_f = push_rel_context ~hypnaming sigma fsign env in @@ -876,38 +876,38 @@ let rec pretype ~program_mode ~poly resolve_tc (tycon : type_constraint) (env : let predenv = Cases.make_return_predicate_ltac_lvar env sigma na c cj.uj_val in let nar = List.length arsgn in let psign',env_p = push_rel_context ~hypnaming ~force_names:true sigma psign predenv in - (match po with - | Some p -> + (match po with + | Some p -> let sigma, pj = pretype_type empty_valcon env_p sigma p in let ccl = nf_evar sigma pj.utj_val in - let p = it_mkLambda_or_LetIn ccl psign' in - let inst = - (Array.map_to_list EConstr.of_constr cs.cs_concl_realargs) - @[EConstr.of_constr (build_dependent_constructor cs)] in - let lp = lift cs.cs_nargs p in + let p = it_mkLambda_or_LetIn ccl psign' in + let inst = + (Array.map_to_list EConstr.of_constr cs.cs_concl_realargs) + @[EConstr.of_constr (build_dependent_constructor cs)] in + let lp = lift cs.cs_nargs p in let fty = hnf_lam_applist !!env sigma lp inst in let sigma, fj = pretype (mk_tycon fty) env_f sigma d in - let v = - let ind,_ = dest_ind_family indf in + let v = + let ind,_ = dest_ind_family indf in let rci = Typing.check_allowed_sort !!env sigma ind cj.uj_val p in obj ind rci p cj.uj_val fj.uj_val in sigma, { uj_val = v; uj_type = (substl (realargs@[cj.uj_val]) ccl) } - | None -> - let tycon = lift_tycon cs.cs_nargs tycon in + | None -> + let tycon = lift_tycon cs.cs_nargs tycon in let sigma, fj = pretype tycon env_f sigma d in let ccl = nf_evar sigma fj.uj_type in - let ccl = + let ccl = if noccur_between sigma 1 cs.cs_nargs ccl then - lift (- cs.cs_nargs) ccl - else + lift (- cs.cs_nargs) ccl + else error_cant_find_case_type ?loc !!env sigma - cj.uj_val in - (* let ccl = refresh_universes ccl in *) - let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign' in - let v = - let ind,_ = dest_ind_family indf in + cj.uj_val in + (* let ccl = refresh_universes ccl in *) + let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign' in + let v = + let ind,_ = dest_ind_family indf in let rci = Typing.check_allowed_sort !!env sigma ind cj.uj_val p in obj ind rci p cj.uj_val fj.uj_val in sigma, { uj_val = v; uj_type = ccl }) @@ -917,12 +917,12 @@ let rec pretype ~program_mode ~poly resolve_tc (tycon : type_constraint) (env : let (IndType (indf,realargs)) = try find_rectype !!env sigma cj.uj_type with Not_found -> - let cloc = loc_of_glob_constr c in + let cloc = loc_of_glob_constr c in error_case_not_inductive ?loc:cloc !!env sigma cj in let cstrs = get_constructors !!env indf in if not (Int.equal (Array.length cstrs) 2) then - user_err ?loc - (str "If is only for inductive types with two constructors."); + user_err ?loc + (str "If is only for inductive types with two constructors."); let arsgn, indr = let arsgn,s = get_arity !!env indf in @@ -937,27 +937,27 @@ let rec pretype ~program_mode ~poly resolve_tc (tycon : type_constraint) (env : let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in let psign,env_p = push_rel_context ~hypnaming sigma psign predenv in let sigma, pred, p = match po with - | Some p -> + | Some p -> let sigma, pj = pretype_type empty_valcon env_p sigma p in let ccl = nf_evar sigma pj.utj_val in let pred = it_mkLambda_or_LetIn ccl psign in let typ = lift (- nar) (beta_applist sigma (pred,[cj.uj_val])) in sigma, pred, typ - | None -> + | None -> let sigma, p = match tycon with | Some ty -> sigma, ty | None -> new_type_evar env sigma loc - in + in sigma, it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in let pred = nf_evar sigma pred in let p = nf_evar sigma p in let f sigma cs b = - let n = Context.Rel.length cs.cs_args in - let pi = lift n pred in (* liftn n 2 pred ? *) + let n = Context.Rel.length cs.cs_args in + let pi = lift n pred in (* liftn n 2 pred ? *) let pi = beta_applist sigma (pi, [EConstr.of_constr (build_dependent_constructor cs)]) in let cs_args = List.map (fun d -> map_rel_decl EConstr.of_constr d) cs.cs_args in let cs_args = Context.Rel.map (whd_betaiota sigma) cs_args in - let csgn = + let csgn = List.map (set_name Anonymous) cs_args in let _,env_c = push_rel_context ~hypnaming sigma csgn env in @@ -966,7 +966,7 @@ let rec pretype ~program_mode ~poly resolve_tc (tycon : type_constraint) (env : let sigma, b1 = f sigma cstrs.(0) b1 in let sigma, b2 = f sigma cstrs.(1) b2 in let v = - let ind,_ = dest_ind_family indf in + let ind,_ = dest_ind_family indf in let pred = nf_evar sigma pred in let rci = Typing.check_allowed_sort !!env sigma ind cj.uj_val pred in let ci = make_case_info !!env (fst ind) rci IfStyle in @@ -991,7 +991,7 @@ let rec pretype ~program_mode ~poly resolve_tc (tycon : type_constraint) (env : ~onlyalg:true ~status:Evd.univ_flexible (Some false) !!env sigma tj.utj_val in let tval = nf_evar sigma tval in let (sigma, cj), tval = match k with - | VMcast -> + | VMcast -> let sigma, cj = pretype empty_tycon env sigma c in let cty = nf_evar sigma cj.uj_type and tval = nf_evar sigma tval in if not (occur_existential sigma cty || occur_existential sigma tval) then @@ -1000,9 +1000,9 @@ let rec pretype ~program_mode ~poly resolve_tc (tycon : type_constraint) (env : | None -> error_actual_type ?loc !!env sigma cj tval (ConversionFailed (!!env,cty,tval)) - else user_err ?loc (str "Cannot check cast with vm: " ++ - str "unresolved arguments remain.") - | NATIVEcast -> + else user_err ?loc (str "Cannot check cast with vm: " ++ + str "unresolved arguments remain.") + | NATIVEcast -> let sigma, cj = pretype empty_tycon env sigma c in let cty = nf_evar sigma cj.uj_type and tval = nf_evar sigma tval in begin @@ -1121,13 +1121,13 @@ and pretype_type ~program_mode ~poly resolve_tc valcon (env : GlobEnv.t) sigma c let sigma, j = pretype ~program_mode ~poly resolve_tc empty_tycon env sigma c in let loc = loc_of_glob_constr c in let sigma, tj = Coercion.inh_coerce_to_sort ?loc !!env sigma j in - match valcon with + match valcon with | None -> sigma, tj - | Some v -> + | Some v -> begin match Evarconv.unify_leq_delay !!env sigma v tj.utj_val with | sigma -> sigma, tj | exception Evarconv.UnableToUnify _ -> - error_unexpected_type + error_unexpected_type ?loc:(loc_of_glob_constr c) !!env sigma tj.utj_val v end diff --git a/pretyping/program.ml b/pretyping/program.ml index a15e66f329..1bc31646dd 100644 --- a/pretyping/program.ml +++ b/pretyping/program.ml @@ -11,7 +11,7 @@ open CErrors open Util -let papp evdref r args = +let papp evdref r args = let open EConstr in let gr = delayed_force r in let evd, hd = Evarutil.new_global !evdref gr in diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index 48838a44c4..5b416a99f9 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -119,7 +119,7 @@ let find_primitive_projection c = c := [x1:B1]...[xk:Bk](Build_R a1...am t1...t_n) If ti has the form (ci ui1...uir) where ci is a global reference (or - a sort, or a product or a reference to a parameter) and if the + a sort, or a product or a reference to a parameter) and if the corresponding projection Li of the structure R is defined, one declares a "conversion" between ci and Li. diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli index 3f64c06a2d..e8b0d771aa 100644 --- a/pretyping/recordops.mli +++ b/pretyping/recordops.mli @@ -61,8 +61,8 @@ val is_primitive_projection : Constant.t -> bool val find_primitive_projection : Constant.t -> Projection.Repr.t option (** {6 Canonical structures } *) -(** A canonical structure declares "canonical" conversion hints between - the effective components of a structure and the projections of the +(** A canonical structure declares "canonical" conversion hints between + the effective components of a structure and the projections of the structure *) (** A cs_pattern characterizes the form of a component of canonical structure *) diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 2952466fbb..4d4fe13983 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -134,14 +134,14 @@ module ReductionBehaviour = struct | _ -> assert false let inRedBehaviour = declare_object { - (default_object "REDUCTIONBEHAVIOUR") with - load_function = load; - cache_function = cache; - classify_function = classify; - subst_function = subst; - discharge_function = discharge; - rebuild_function = rebuild; - } + (default_object "REDUCTIONBEHAVIOUR") with + load_function = load; + cache_function = cache; + classify_function = classify; + subst_function = subst; + discharge_function = discharge; + rebuild_function = rebuild; + } let set ~local r b = Lib.add_anonymous_leaf (inRedBehaviour (local, (r, b))) @@ -156,9 +156,9 @@ module ReductionBehaviour = struct | Some b -> let pp_nomatch = spc () ++ str "but avoid exposing match constructs" in let pp_recargs recargs = spc() ++ str "when the " ++ - pr_enum (fun x -> pr_nth (x+1)) recargs ++ str (String.plural (List.length recargs) " argument") ++ - str (String.plural (if List.length recargs >= 2 then 1 else 2) " evaluate") ++ - str " to a constructor" in + pr_enum (fun x -> pr_nth (x+1)) recargs ++ str (String.plural (List.length recargs) " argument") ++ + str (String.plural (if List.length recargs >= 2 then 1 else 2) " evaluate") ++ + str " to a constructor" in let pp_nargs nargs = spc() ++ str "when applied to " ++ int nargs ++ str (String.plural nargs " argument") in @@ -206,9 +206,9 @@ module Cst_stack = struct let append2cst = function | (c,params,[]) -> (c, h::params, []) | (c,params,((i,t)::q)) when i = pred (Array.length t) -> - (c, params, q) + (c, params, q) | (c,params,(i,t)::q) -> - (c, params, (succ i,t)::q) + (c, params, (succ i,t)::q) in drop_useless (List.map append2cst cst_l) @@ -234,18 +234,18 @@ module Cst_stack = struct (fun t (i,args) -> mkApp (t,Array.sub args i (Array.length args - i))) in List.fold_right (fun (cst,params,args) t -> Termops.replace_term sigma - (reconstruct_head d args) - (applist (cst, List.rev params)) - t) cst_l c + (reconstruct_head d args) + (applist (cst, List.rev params)) + t) cst_l c let pr env sigma l = let open Pp in let p_c c = Termops.Internal.print_constr_env env sigma c in prlist_with_sep pr_semicolon (fun (c,params,args) -> - hov 1 (str"(" ++ p_c c ++ str ")" ++ spc () ++ pr_sequence p_c params ++ spc () ++ str "(args:" ++ - pr_sequence (fun (i,el) -> prvect_with_sep spc p_c (Array.sub el i (Array.length el - i))) args ++ - str ")")) l + hov 1 (str"(" ++ p_c c ++ str ")" ++ spc () ++ pr_sequence p_c params ++ spc () ++ str "(args:" ++ + pr_sequence (fun (i,el) -> prvect_with_sep spc p_c (Array.sub el i (Array.length el - i))) args ++ + str ")")) l end @@ -313,8 +313,8 @@ struct let pr_app_node pr (i,a,j) = let open Pp in surround ( - prvect_with_sep pr_comma pr (Array.sub a i (j - i + 1)) - ) + prvect_with_sep pr_comma pr (Array.sub a i (j - i + 1)) + ) type cst_member = @@ -339,7 +339,7 @@ struct | App app -> str "ZApp" ++ pr_app_node pr_c app | Case (_,_,br,cst) -> str "ZCase(" ++ - prvect_with_sep (pr_bar) pr_c br + prvect_with_sep (pr_bar) pr_c br ++ str ")" | Proj (p,cst) -> str "ZProj(" ++ Constant.debug_print (Projection.constant p) ++ str ")" @@ -352,8 +352,8 @@ struct | Cst (mem,curr,remains,params,cst_l) -> str "ZCst(" ++ pr_cst_member pr_c mem ++ pr_comma () ++ int curr ++ pr_comma () ++ - prlist_with_sep pr_semicolon int remains ++ - pr_comma () ++ pr pr_c params ++ str ")" + prlist_with_sep pr_semicolon int remains ++ + pr_comma () ++ pr pr_c params ++ str ")" and pr pr_c l = let open Pp in prlist_with_sep pr_semicolon (fun x -> hov 1 (pr_member pr_c x)) l @@ -364,7 +364,7 @@ struct | Cst_const (c, u) -> if Univ.Instance.is_empty u then Constant.debug_print c else str"(" ++ Constant.debug_print c ++ str ", " ++ - Univ.Instance.pr Univ.Level.pr u ++ str")" + Univ.Instance.pr Univ.Level.pr u ++ str")" | Cst_proj p -> str".(" ++ Constant.debug_print (Projection.constant p) ++ str")" @@ -421,13 +421,13 @@ struct let compare_shape stk1 stk2 = let rec compare_rec bal stk1 stk2 = match (stk1,stk2) with - ([],[]) -> Int.equal bal 0 + ([],[]) -> Int.equal bal 0 | (App (i,_,j)::s1, _) -> compare_rec (bal + j + 1 - i) s1 stk2 | (_, App (i,_,j)::s2) -> compare_rec (bal - j - 1 + i) stk1 s2 | (Case(c1,_,_,_)::s1, Case(c2,_,_,_)::s2) -> Int.equal bal 0 (* && c1.ci_ind = c2.ci_ind *) && compare_rec 0 s1 s2 | (Proj (p,_)::s1, Proj(p2,_)::s2) -> - Int.equal bal 0 && compare_rec 0 s1 s2 + Int.equal bal 0 && compare_rec 0 s1 s2 | (Fix(_,a1,_)::s1, Fix(_,a2,_)::s2) -> Int.equal bal 0 && compare_rec 0 a1 a2 && compare_rec 0 s1 s2 | (Primitive(_,_,a1,_,_)::s1, Primitive(_,_,a2,_,_)::s2) -> @@ -462,14 +462,14 @@ struct let rec map f x = List.map (function | (Proj (_,_)) as e -> e - | App (i,a,j) -> - let le = j - i + 1 in - App (0,Array.map f (Array.sub a i le), le-1) + | App (i,a,j) -> + let le = j - i + 1 in + App (0,Array.map f (Array.sub a i le), le-1) | Case (info,ty,br,alt) -> Case (info, f ty, Array.map f br, alt) | Fix ((r,(na,ty,bo)),arg,alt) -> Fix ((r,(na,Array.map f ty, Array.map f bo)),map f arg,alt) | Cst (cst,curr,remains,params,alt) -> - Cst (cst,curr,remains,map f params,alt) + Cst (cst,curr,remains,map f params,alt) | Primitive (p,c,args,kargs,cst_l) -> Primitive(p,c, map f args, kargs, cst_l) ) x @@ -490,15 +490,15 @@ struct let strip_n_app n s = let rec aux n out = function | App (i,a,j) as e :: s -> - let nb = j - i + 1 in - if n >= nb then - aux (n - nb) (e::out) s - else - let p = i+n in - Some (CList.rev - (if Int.equal n 0 then out else App (i,a,p-1) :: out), - a.(p), - if j > p then App(succ p,a,j)::s else s) + let nb = j - i + 1 in + if n >= nb then + aux (n - nb) (e::out) s + else + let p = i+n in + Some (CList.rev + (if Int.equal n 0 then out else App (i,a,p-1) :: out), + a.(p), + if j > p then App(succ p,a,j)::s else s) | s -> None in aux n [] s @@ -530,15 +530,15 @@ struct let tail n0 s0 = let rec aux n s = if Int.equal n 0 then s else - match s with + match s with | App (i,a,j) :: s -> - let nb = j - i + 1 in - if n >= nb then + let nb = j - i + 1 in + if n >= nb then aux (n - nb) s - else - let p = i+n in - if j >= p then App(p,a,j)::s else s - | _ -> raise (Invalid_argument "Reductionops.Stack.tail") + else + let p = i+n in + if j >= p then App(p,a,j)::s else s + | _ -> raise (Invalid_argument "Reductionops.Stack.tail") in aux n0 s0 let nth s p = @@ -551,17 +551,17 @@ struct let rec aux sk def = function |(cst, params, []) -> (cst, append_app_list (List.rev params) sk) |(cst, params, (i,t)::q) -> match decomp sk with - | Some (el,sk') when EConstr.eq_constr sigma el t.(i) -> - if i = pred (Array.length t) - then aux sk' def (cst, params, q) - else aux sk' def (cst, params, (succ i,t)::q) - | _ -> def + | Some (el,sk') when EConstr.eq_constr sigma el t.(i) -> + if i = pred (Array.length t) + then aux sk' def (cst, params, q) + else aux sk' def (cst, params, (succ i,t)::q) + | _ -> def in List.fold_left (aux sk) s l let constr_of_cst_member f sk = match f with | Cst_const (c, u) -> mkConstU (c, EInstance.make u), sk - | Cst_proj p -> + | Cst_proj p -> match decomp sk with | Some (hd, sk) -> mkProj (p, hd), sk | None -> assert false @@ -571,8 +571,8 @@ struct | f, [] -> f | f, (App (i,a,j) :: s) -> let a' = if Int.equal i 0 && Int.equal j (Array.length a - 1) - then a - else Array.sub a i (j - i + 1) in + then a + else Array.sub a i (j - i + 1) in zip (mkApp (f, a'), s) | f, (Case (ci,rt,br,cst_l)::s) when refold -> zip (best_state sigma (mkCase (ci,rt,f,br), s) cst_l) @@ -781,11 +781,11 @@ let reduce_mind_case sigma mia = match EConstr.kind sigma mia.mconstr with | Construct ((ind_sp,i),u) -> (* let ncargs = (fst mia.mci).(i-1) in*) - let real_cargs = List.skipn mia.mci.ci_npar mia.mcargs in + let real_cargs = List.skipn mia.mci.ci_npar mia.mcargs in applist (mia.mlf.(i-1),real_cargs) | CoFix cofix -> - let cofix_def = contract_cofix sigma cofix in - mkCase (mia.mci, mia.mP, applist(cofix_def,mia.mcargs), mia.mlf) + let cofix_def = contract_cofix sigma cofix in + mkCase (mia.mci, mia.mP, applist(cofix_def,mia.mcargs), mia.mlf) | _ -> assert false (* contracts fix==FIX[nl;i](A1...Ak;[F1...Fk]{B1....Bk}) to produce @@ -797,10 +797,10 @@ let contract_fix ?env sigma ?reference ((recindices,bodynum),(names,types,bodies let ind = nbodies-j-1 in if Int.equal bodynum ind then mkFix ((recindices,ind),typedbodies) else - let bd = mkFix ((recindices,ind),typedbodies) in - match env with - | None -> bd - | Some e -> + let bd = mkFix ((recindices,ind),typedbodies) in + match env with + | None -> bd + | Some e -> match reference with | None -> bd | Some r -> magicaly_constant_of_fixbody e sigma r bd names.(ind).binder_name in @@ -990,13 +990,13 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = let open ReductionBehaviour in let rec whrec cst_l (x, stack) = let () = if !debug_RAKAM then - let open Pp in + let open Pp in let pr c = Termops.Internal.print_constr_env env sigma c in Feedback.msg_debug (h 0 (str "<<" ++ pr x ++ str "|" ++ cut () ++ Cst_stack.pr env sigma cst_l ++ - str "|" ++ cut () ++ Stack.pr pr stack ++ - str ">>")) + str "|" ++ cut () ++ Stack.pr pr stack ++ + str ">>")) in let c0 = EConstr.kind sigma x in let fold () = @@ -1012,7 +1012,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = | Var id when CClosure.RedFlags.red_set flags (CClosure.RedFlags.fVAR id) -> (match lookup_named id env with | LocalDef (_,body,_) -> - whrec (if refold then Cst_stack.add_cst (mkVar id) cst_l else cst_l) (body, stack) + whrec (if refold then Cst_stack.add_cst (mkVar id) cst_l else cst_l) (body, stack) | _ -> fold ()) | Evar ev -> fold () | Meta ev -> @@ -1125,28 +1125,28 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = | Cast (c,_,_) -> whrec cst_l (c, stack) | App (f,cl) -> whrec - (if refold then Cst_stack.add_args cl cst_l else cst_l) - (f, Stack.append_app cl stack) + (if refold then Cst_stack.add_args cl cst_l else cst_l) + (f, Stack.append_app cl stack) | Lambda (na,t,c) -> (match Stack.decomp stack with | Some _ when CClosure.RedFlags.red_set flags CClosure.RedFlags.fBETA -> - apply_subst (fun _ -> whrec) [] sigma refold cst_l x stack + apply_subst (fun _ -> whrec) [] sigma refold cst_l x stack | None when CClosure.RedFlags.red_set flags CClosure.RedFlags.fETA -> let env' = push_rel (LocalAssum (na, t)) env in - let whrec' = whd_state_gen ~refold ~tactic_mode flags env' sigma in + let whrec' = whd_state_gen ~refold ~tactic_mode flags env' sigma in (match EConstr.kind sigma (Stack.zip ~refold sigma (fst (whrec' (c, Stack.empty)))) with | App (f,cl) -> - let napp = Array.length cl in - if napp > 0 then - let (x', l'),_ = whrec' (Array.last cl, Stack.empty) in + let napp = Array.length cl in + if napp > 0 then + let (x', l'),_ = whrec' (Array.last cl, Stack.empty) in match EConstr.kind sigma x', l' with | Rel 1, [] -> - let lc = Array.sub cl 0 (napp-1) in - let u = if Int.equal napp 1 then f else mkApp (f,lc) in - if noccurn sigma 1 u then (pop u,Stack.empty),Cst_stack.empty else fold () + let lc = Array.sub cl 0 (napp-1) in + let u = if Int.equal napp 1 then f else mkApp (f,lc) in + if noccurn sigma 1 u then (pop u,Stack.empty),Cst_stack.empty else fold () | _ -> fold () - else fold () - | _ -> fold ()) + else fold () + | _ -> fold ()) | _ -> fold ()) | Case (ci,p,d,lf) -> @@ -1156,57 +1156,57 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = (match Stack.strip_n_app ri.(n) stack with |None -> fold () |Some (bef,arg,s') -> - whrec Cst_stack.empty (arg, Stack.Fix(f,bef,cst_l)::s')) + whrec Cst_stack.empty (arg, Stack.Fix(f,bef,cst_l)::s')) | Construct ((ind,c),u) -> let use_match = CClosure.RedFlags.red_set flags CClosure.RedFlags.fMATCH in let use_fix = CClosure.RedFlags.red_set flags CClosure.RedFlags.fFIX in if use_match || use_fix then - match Stack.strip_app stack with - |args, (Stack.Case(ci, _, lf,_)::s') when use_match -> - whrec Cst_stack.empty (lf.(c-1), (Stack.tail ci.ci_npar args) @ s') + match Stack.strip_app stack with + |args, (Stack.Case(ci, _, lf,_)::s') when use_match -> + whrec Cst_stack.empty (lf.(c-1), (Stack.tail ci.ci_npar args) @ s') |args, (Stack.Proj (p,_)::s') when use_match -> whrec Cst_stack.empty (Stack.nth args (Projection.npars p + Projection.arg p), s') - |args, (Stack.Fix (f,s',cst_l)::s'') when use_fix -> - let x' = Stack.zip sigma (x, args) in - let out_sk = s' @ (Stack.append_app [|x'|] s'') in - reduce_and_refold_fix whrec env sigma refold cst_l f out_sk - |args, (Stack.Cst (const,curr,remains,s',cst_l) :: s'') -> - let x' = Stack.zip sigma (x, args) in - begin match remains with - | [] -> - (match const with - | Stack.Cst_const const -> - (match constant_opt_value_in env const with - | None -> fold () - | Some body -> + |args, (Stack.Fix (f,s',cst_l)::s'') when use_fix -> + let x' = Stack.zip sigma (x, args) in + let out_sk = s' @ (Stack.append_app [|x'|] s'') in + reduce_and_refold_fix whrec env sigma refold cst_l f out_sk + |args, (Stack.Cst (const,curr,remains,s',cst_l) :: s'') -> + let x' = Stack.zip sigma (x, args) in + begin match remains with + | [] -> + (match const with + | Stack.Cst_const const -> + (match constant_opt_value_in env const with + | None -> fold () + | Some body -> let const = (fst const, EInstance.make (snd const)) in let body = EConstr.of_constr body in - whrec (if refold then Cst_stack.add_cst (mkConstU const) cst_l else cst_l) - (body, s' @ (Stack.append_app [|x'|] s''))) - | Stack.Cst_proj p -> + whrec (if refold then Cst_stack.add_cst (mkConstU const) cst_l else cst_l) + (body, s' @ (Stack.append_app [|x'|] s''))) + | Stack.Cst_proj p -> let stack = s' @ (Stack.append_app [|x'|] s'') in - match Stack.strip_n_app 0 stack with - | None -> assert false - | Some (_,arg,s'') -> + match Stack.strip_n_app 0 stack with + | None -> assert false + | Some (_,arg,s'') -> whrec Cst_stack.empty (arg, Stack.Proj (p,cst_l) :: s'')) - | next :: remains' -> match Stack.strip_n_app (next-curr-1) s'' with - | None -> fold () - | Some (bef,arg,s''') -> - whrec Cst_stack.empty - (arg, - Stack.Cst (const,next,remains',s' @ (Stack.append_app [|x'|] bef),cst_l) :: s''') - end + | next :: remains' -> match Stack.strip_n_app (next-curr-1) s'' with + | None -> fold () + | Some (bef,arg,s''') -> + whrec Cst_stack.empty + (arg, + Stack.Cst (const,next,remains',s' @ (Stack.append_app [|x'|] bef),cst_l) :: s''') + end |_, (Stack.App _)::_ -> assert false - |_, _ -> fold () + |_, _ -> fold () else fold () | CoFix cofix -> if CClosure.RedFlags.red_set flags CClosure.RedFlags.fCOFIX then - match Stack.strip_app stack with - |args, ((Stack.Case _ |Stack.Proj _)::s') -> - reduce_and_refold_cofix whrec env sigma refold cst_l cofix stack - |_ -> fold () + match Stack.strip_app stack with + |args, ((Stack.Case _ |Stack.Proj _)::s') -> + reduce_and_refold_cofix whrec env sigma refold cst_l cofix stack + |_ -> fold () else fold () | Int _ | Float _ -> @@ -1253,21 +1253,21 @@ let local_whd_state_gen flags sigma = | Lambda (_,_,c) -> (match Stack.decomp stack with | Some (a,m) when CClosure.RedFlags.red_set flags CClosure.RedFlags.fBETA -> - stacklam whrec [a] sigma c m + stacklam whrec [a] sigma c m | None when CClosure.RedFlags.red_set flags CClosure.RedFlags.fETA -> (match EConstr.kind sigma (Stack.zip sigma (whrec (c, Stack.empty))) with | App (f,cl) -> - let napp = Array.length cl in - if napp > 0 then - let x', l' = whrec (Array.last cl, Stack.empty) in + let napp = Array.length cl in + if napp > 0 then + let x', l' = whrec (Array.last cl, Stack.empty) in match EConstr.kind sigma x', l' with | Rel 1, [] -> - let lc = Array.sub cl 0 (napp-1) in - let u = if Int.equal napp 1 then f else mkApp (f,lc) in - if noccurn sigma 1 u then (pop u,Stack.empty) else s + let lc = Array.sub cl 0 (napp-1) in + let u = if Int.equal napp 1 then f else mkApp (f,lc) in + if noccurn sigma 1 u then (pop u,Stack.empty) else s | _ -> s - else s - | _ -> s) + else s + | _ -> s) | _ -> s) | Proj (p,c) when CClosure.RedFlags.red_projection flags p -> @@ -1291,24 +1291,24 @@ let local_whd_state_gen flags sigma = let use_match = CClosure.RedFlags.red_set flags CClosure.RedFlags.fMATCH in let use_fix = CClosure.RedFlags.red_set flags CClosure.RedFlags.fFIX in if use_match || use_fix then - match Stack.strip_app stack with - |args, (Stack.Case(ci, _, lf,_)::s') when use_match -> - whrec (lf.(c-1), (Stack.tail ci.ci_npar args) @ s') + match Stack.strip_app stack with + |args, (Stack.Case(ci, _, lf,_)::s') when use_match -> + whrec (lf.(c-1), (Stack.tail ci.ci_npar args) @ s') |args, (Stack.Proj (p,_) :: s') when use_match -> whrec (Stack.nth args (Projection.npars p + Projection.arg p), s') - |args, (Stack.Fix (f,s',cst)::s'') when use_fix -> - let x' = Stack.zip sigma (x,args) in - whrec (contract_fix sigma f, s' @ (Stack.append_app [|x'|] s'')) + |args, (Stack.Fix (f,s',cst)::s'') when use_fix -> + let x' = Stack.zip sigma (x,args) in + whrec (contract_fix sigma f, s' @ (Stack.append_app [|x'|] s'')) |_, (Stack.App _|Stack.Cst _)::_ -> assert false - |_, _ -> s + |_, _ -> s else s | CoFix cofix -> if CClosure.RedFlags.red_set flags CClosure.RedFlags.fCOFIX then - match Stack.strip_app stack with - |args, ((Stack.Case _ | Stack.Proj _)::s') -> - whrec (contract_cofix sigma cofix, stack) - |_ -> s + match Stack.strip_app stack with + |args, ((Stack.Case _ | Stack.Proj _)::s') -> + whrec (contract_cofix sigma cofix, stack) + |_ -> s else s | Rel _ | Var _ | Sort _ | Prod _ | LetIn _ | Const _ | Ind _ | Proj _ @@ -1510,7 +1510,7 @@ let sigma_compare_instances ~flex i0 i1 sigma = try Evd.set_eq_instances ~flex sigma i0 i1 with Evd.UniversesDiffer | Univ.UniverseInconsistency _ -> - raise Reduction.NotConvertible + raise Reduction.NotConvertible let sigma_check_inductive_instances cv_pb variance u1 u2 sigma = match Evarutil.compare_cumulative_instances cv_pb variance u1 u2 sigma with @@ -1518,7 +1518,7 @@ let sigma_check_inductive_instances cv_pb variance u1 u2 sigma = | Inr _ -> raise Reduction.NotConvertible -let sigma_univ_state = +let sigma_univ_state = let open Reduction in { compare_sorts = sigma_compare_sorts; compare_instances = sigma_compare_instances; @@ -1545,9 +1545,9 @@ let infer_conv_gen conv_fun ?(catch_incon=true) ?(pb=Reduction.CUMUL) | None -> let x = EConstr.Unsafe.to_constr x in let y = EConstr.Unsafe.to_constr y in - let sigma' = - conv_fun pb ~l2r:false sigma ts - env (sigma, sigma_univ_state) x y in + let sigma' = + conv_fun pb ~l2r:false sigma ts + env (sigma, sigma_univ_state) x y in Some sigma' with | Reduction.NotConvertible -> None @@ -1583,23 +1583,23 @@ let plain_instance sigma s c = let l' = Array.Fun1.Smart.map irec n l in (match EConstr.kind sigma f with | Meta p -> - (* Don't flatten application nodes: this is used to extract a + (* Don't flatten application nodes: this is used to extract a proof-term from a proof-tree and we want to keep the structure of the proof-tree *) - (try let g = Metamap.find p s in - match EConstr.kind sigma g with + (try let g = Metamap.find p s in + match EConstr.kind sigma g with | App _ -> let l' = Array.Fun1.Smart.map lift 1 l' in let r = Sorts.Relevant in (* TODO fix relevance *) let na = make_annot (Name default_plain_instance_ident) r in mkLetIn (na,g,t,mkApp(mkRel 1, l')) | _ -> mkApp (g,l') - with Not_found -> mkApp (f,l')) + with Not_found -> mkApp (f,l')) | _ -> mkApp (irec n f,l')) | Cast (m,_,_) when isMeta sigma m -> - (try lift n (Metamap.find (destMeta sigma m) s) with Not_found -> u) + (try lift n (Metamap.find (destMeta sigma m) s) with Not_found -> u) | _ -> - map_with_binders sigma succ irec n u + map_with_binders sigma succ irec n u in if Metamap.is_empty s then c else irec 0 c @@ -1701,10 +1701,10 @@ let splay_prod_assum env sigma = prodec_rec (push_rel (LocalDef (x,b,t)) env) (Context.Rel.add (LocalDef (x,b,t)) l) c | Cast (c,_,_) -> prodec_rec env l c - | _ -> + | _ -> let t' = whd_all env sigma t in - if EConstr.eq_constr sigma t t' then l,t - else prodec_rec env l t' + if EConstr.eq_constr sigma t t' then l,t + else prodec_rec env l t' in prodec_rec env Context.Rel.empty @@ -1751,19 +1751,19 @@ let whd_betaiota_deltazeta_for_iota_state ts env sigma s = let (t, stack as s),csts' = whd_state_gen ~csts ~refold ~tactic_mode CClosure.betaiota env sigma s in match Stack.strip_app stack with |args, (Stack.Case _ :: _ as stack') -> - let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' ~refold ~tactic_mode - (CClosure.RedFlags.red_add_transparent CClosure.all ts) env sigma (t,args) in - if reducible_mind_case sigma t_o then whrec csts_o (t_o, stack_o@stack') else s,csts' + let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' ~refold ~tactic_mode + (CClosure.RedFlags.red_add_transparent CClosure.all ts) env sigma (t,args) in + if reducible_mind_case sigma t_o then whrec csts_o (t_o, stack_o@stack') else s,csts' |args, (Stack.Fix _ :: _ as stack') -> - let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' ~refold ~tactic_mode - (CClosure.RedFlags.red_add_transparent CClosure.all ts) env sigma (t,args) in - if isConstruct sigma t_o then whrec csts_o (t_o, stack_o@stack') else s,csts' + let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' ~refold ~tactic_mode + (CClosure.RedFlags.red_add_transparent CClosure.all ts) env sigma (t,args) in + if isConstruct sigma t_o then whrec csts_o (t_o, stack_o@stack') else s,csts' |args, (Stack.Proj (p,_) :: stack'') -> - let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' ~refold ~tactic_mode - (CClosure.RedFlags.red_add_transparent CClosure.all ts) env sigma (t,args) in - if isConstruct sigma t_o then + let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' ~refold ~tactic_mode + (CClosure.RedFlags.red_add_transparent CClosure.all ts) env sigma (t,args) in + if isConstruct sigma t_o then whrec Cst_stack.empty (Stack.nth stack_o (Projection.npars p + Projection.arg p), stack'') - else s,csts' + else s,csts' |_, ((Stack.App _|Stack.Cst _|Stack.Primitive _) :: _|[]) -> s,csts' in fst (whrec Cst_stack.empty s) @@ -1822,43 +1822,43 @@ let meta_reducible_instance evd b = let u = whd_betaiota Evd.empty u (* FIXME *) in match EConstr.kind evd u with | Case (ci,p,c,bl) when EConstr.isMeta evd (strip_outer_cast evd c) -> - let m = destMeta evd (strip_outer_cast evd c) in - (match - try - let g, s = Metamap.find m metas in + let m = destMeta evd (strip_outer_cast evd c) in + (match + try + let g, s = Metamap.find m metas in let is_coerce = match s with CoerceToType -> true | _ -> false in - if isConstruct evd g || not is_coerce then Some g else None - with Not_found -> None - with - | Some g -> irec (mkCase (ci,p,g,bl)) - | None -> mkCase (ci,irec p,c,Array.map irec bl)) + if isConstruct evd g || not is_coerce then Some g else None + with Not_found -> None + with + | Some g -> irec (mkCase (ci,p,g,bl)) + | None -> mkCase (ci,irec p,c,Array.map irec bl)) | App (f,l) when EConstr.isMeta evd (strip_outer_cast evd f) -> - let m = destMeta evd (strip_outer_cast evd f) in - (match - try - let g, s = Metamap.find m metas in + let m = destMeta evd (strip_outer_cast evd f) in + (match + try + let g, s = Metamap.find m metas in let is_coerce = match s with CoerceToType -> true | _ -> false in - if isLambda evd g || not is_coerce then Some g else None - with Not_found -> None - with - | Some g -> irec (mkApp (g,l)) - | None -> mkApp (f,Array.map irec l)) + if isLambda evd g || not is_coerce then Some g else None + with Not_found -> None + with + | Some g -> irec (mkApp (g,l)) + | None -> mkApp (f,Array.map irec l)) | Meta m -> - (try let g, s = Metamap.find m metas in + (try let g, s = Metamap.find m metas in let is_coerce = match s with CoerceToType -> true | _ -> false in if not is_coerce then irec g else u - with Not_found -> u) + with Not_found -> u) | Proj (p,c) when isMeta evd c || isCast evd c && isMeta evd (pi1 (destCast evd c)) (* What if two nested casts? *) -> let m = try destMeta evd c with _ -> destMeta evd (pi1 (destCast evd c)) (* idem *) in - (match - try - let g, s = Metamap.find m metas in + (match + try + let g, s = Metamap.find m metas in let is_coerce = match s with CoerceToType -> true | _ -> false in - if isConstruct evd g || not is_coerce then Some g else None - with Not_found -> None - with - | Some g -> irec (mkProj (p,g)) - | None -> mkProj (p,c)) + if isConstruct evd g || not is_coerce then Some g else None + with Not_found -> None + with + | Some g -> irec (mkProj (p,g)) + | None -> mkProj (p,c)) | _ -> EConstr.map evd irec u in if Metaset.is_empty fm then (* nf_betaiota? *) b.rebus diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index 966c8f6e12..f089b242a2 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -104,7 +104,7 @@ let retype ?(polyprop=true) sigma = (try strip_outer_cast sigma (Evd.meta_ftype sigma n).Evd.rebus with Not_found -> retype_error (BadMeta n)) | Rel n -> - let ty = RelDecl.get_type (lookup_rel n env) in + let ty = RelDecl.get_type (lookup_rel n env) in lift n ty | Var id -> type_of_var env id | Const (cst, u) -> EConstr.of_constr (rename_type_of_constant env (cst, EInstance.kind sigma u)) @@ -133,7 +133,7 @@ let retype ?(polyprop=true) sigma = | Fix ((_,i),(_,tys,_)) -> tys.(i) | CoFix (i,(_,tys,_)) -> tys.(i) | App(f,args) when Termops.is_template_polymorphic_ind env sigma f -> - let t = type_of_global_reference_knowing_parameters env f args in + let t = type_of_global_reference_knowing_parameters env f args in strip_outer_cast sigma (subst_type env sigma t (Array.to_list args)) | App(f,args) -> strip_outer_cast sigma @@ -141,8 +141,8 @@ let retype ?(polyprop=true) sigma = | Proj (p,c) -> let ty = type_of env c in EConstr.of_constr (try - Inductiveops.type_of_projection_knowing_arg env sigma p c ty - with Invalid_argument _ -> retype_error BadRecursiveType) + Inductiveops.type_of_projection_knowing_arg env sigma p c ty + with Invalid_argument _ -> retype_error BadRecursiveType) | Cast (c,_, t) -> t | Sort _ | Prod _ -> mkSort (sort_of env cstr) | Int _ -> EConstr.of_constr (Typeops.type_of_int env) @@ -174,9 +174,9 @@ let retype ?(polyprop=true) sigma = | Ind (ind, u) -> let u = EInstance.kind sigma u in let mip = lookup_mind_specif env ind in - EConstr.of_constr (try Inductive.type_of_inductive_knowing_parameters - ~polyprop env (mip, u) argtyps - with Reduction.NotArity -> retype_error NotAnArity) + EConstr.of_constr (try Inductive.type_of_inductive_knowing_parameters + ~polyprop env (mip, u) argtyps + with Reduction.NotArity -> retype_error NotAnArity) | Construct (cstr, u) -> let u = EInstance.kind sigma u in EConstr.of_constr (type_of_constructor env (cstr, u)) @@ -192,17 +192,17 @@ let get_sort_family_of ?(truncation_style=false) ?(polyprop=true) env sigma t = | Sort _ -> InType | Prod (name,t,c2) -> let s2 = sort_family_of (push_rel (LocalAssum (name,t)) env) c2 in - if not (is_impredicative_set env) && - s2 == InSet && sort_family_of env t == InType then InType else s2 + if not (is_impredicative_set env) && + s2 == InSet && sort_family_of env t == InType then InType else s2 | App(f,args) when Termops.is_template_polymorphic_ind env sigma f -> if truncation_style then InType else - let t = type_of_global_reference_knowing_parameters env f args in + let t = type_of_global_reference_knowing_parameters env f args in Sorts.family (sort_of_atomic_type env sigma t args) | App(f,args) -> - Sorts.family (sort_of_atomic_type env sigma (type_of env f) args) + Sorts.family (sort_of_atomic_type env sigma (type_of env f) args) | Lambda _ | Fix _ | Construct _ -> retype_error NotAType | Ind _ when truncation_style && Termops.is_template_polymorphic_ind env sigma t -> InType - | _ -> + | _ -> Sorts.family (decomp_sort env sigma (type_of env t)) in sort_family_of env t @@ -253,12 +253,12 @@ let sorts_of_context env evc ctxt = let expand_projection env sigma pr c args = let ty = get_type_of ~lax:true env sigma c in - let (i,u), ind_args = - try Inductiveops.find_mrectype env sigma ty + let (i,u), ind_args = + try Inductiveops.find_mrectype env sigma ty with Not_found -> retype_error BadRecursiveType in - mkApp (mkConstU (Projection.constant pr,u), - Array.of_list (ind_args @ (c :: args))) + mkApp (mkConstU (Projection.constant pr,u), + Array.of_list (ind_args @ (c :: args))) let relevance_of_term env sigma c = if Environ.sprop_allowed env then diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index e8a2189611..10e8cf7e0f 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -61,7 +61,7 @@ let is_evaluable env = function let value_of_evaluable_ref env evref u = match evref with - | EvalConstRef con -> + | EvalConstRef con -> let u = Unsafe.to_instance u in EConstr.of_constr (constant_value_in env (con, u)) | EvalVarRef id -> env |> lookup_named id |> NamedDecl.get_value |> Option.get @@ -112,7 +112,7 @@ let destEvalRefU sigma c = match EConstr.kind sigma c with let unsafe_reference_opt_value env sigma eval = match eval with | EvalConst cst -> - (match (lookup_constant cst env).Declarations.const_body with + (match (lookup_constant cst env).Declarations.const_body with | Declarations.Def c -> Some (EConstr.of_constr (Mod_subst.force_constr c)) | _ -> None) | EvalVar id -> @@ -124,7 +124,7 @@ let unsafe_reference_opt_value env sigma eval = | Evar _ -> None | c -> Some (EConstr.of_kind c) -let reference_opt_value env sigma eval u = +let reference_opt_value env sigma eval u = match eval with | EvalConst cst -> let u = EInstance.kind sigma u in @@ -197,15 +197,15 @@ let check_fix_reversibility sigma labs args ((lv,i),(_,tys,bds)) = (function d -> match EConstr.kind sigma d with | Rel k -> if - Array.for_all (Vars.noccurn sigma k) tys - && Array.for_all (Vars.noccurn sigma (k+nbfix)) bds - && k <= n - then - (k, List.nth labs (k-1)) - else - raise Elimconst + Array.for_all (Vars.noccurn sigma k) tys + && Array.for_all (Vars.noccurn sigma (k+nbfix)) bds + && k <= n + then + (k, List.nth labs (k-1)) + else + raise Elimconst | _ -> - raise Elimconst) args + raise Elimconst) args in let reversible_rels = List.map fst li in if not (List.distinct_f Int.compare reversible_rels) then @@ -238,28 +238,28 @@ let invert_name labs l {binder_name=na0} env sigma ref na = | Name id' when Id.equal id' id -> Some (minfxargs,ref) | _ -> - let refi = match ref with - | EvalRel _ | EvalEvar _ -> None - | EvalVar id' -> Some (EvalVar id) + let refi = match ref with + | EvalRel _ | EvalEvar _ -> None + | EvalVar id' -> Some (EvalVar id) | EvalConst kn -> let kn = Constant.change_label kn (Label.of_id id) in if Environ.mem_constant kn env then Some (EvalConst kn) else None in - match refi with - | None -> None - | Some ref -> - try match unsafe_reference_opt_value env sigma ref with - | None -> None - | Some c -> - let labs',ccl = decompose_lam sigma c in - let _, l' = whd_betalet_stack sigma ccl in + match refi with + | None -> None + | Some ref -> + try match unsafe_reference_opt_value env sigma ref with + | None -> None + | Some c -> + let labs',ccl = decompose_lam sigma c in + let _, l' = whd_betalet_stack sigma ccl in let labs' = List.map snd labs' in (* ppedrot: there used to be generic equality on terms here *) let eq_constr c1 c2 = EConstr.eq_constr sigma c1 c2 in - if List.equal eq_constr labs' labs && + if List.equal eq_constr labs' labs && List.equal eq_constr l l' then Some (minfxargs,ref) else None - with Not_found (* Undefined ref *) -> None + with Not_found (* Undefined ref *) -> None end | Anonymous -> None (* Actually, should not occur *) @@ -275,8 +275,8 @@ let compute_consteval_direct env sigma ref = let open Context.Rel.Declaration in srec (push_rel (LocalAssum (id,t)) env) (n+1) (t::labs) onlyproj g | Fix fix when not onlyproj -> - (try check_fix_reversibility sigma labs l fix - with Elimconst -> NotAnElimination) + (try check_fix_reversibility sigma labs l fix + with Elimconst -> NotAnElimination) | Case (_,_,d,_) when isRel sigma d && not onlyproj -> EliminationCases n | Case (_,_,d,_) -> srec env n labs true d | Proj (p, d) when isRel sigma d -> EliminationProj n @@ -295,23 +295,23 @@ let compute_consteval_mutual_fix env sigma ref = let open Context.Rel.Declaration in srec (push_rel (LocalAssum (na,t)) env) (minarg+1) (t::labs) ref g | Fix ((lv,i),(names,_,_)) -> - (* Last known constant wrapping Fix is ref = [labs](Fix l) *) - (match compute_consteval_direct env sigma ref with - | NotAnElimination -> (*Above const was eliminable but this not!*) - NotAnElimination - | EliminationFix (minarg',minfxargs,infos) -> - let refs = - Array.map - (invert_name labs l names.(i) env sigma ref) names in - let new_minarg = max (minarg'+minarg-nargs) minarg' in - EliminationMutualFix (new_minarg,ref,(refs,infos)) - | _ -> assert false) + (* Last known constant wrapping Fix is ref = [labs](Fix l) *) + (match compute_consteval_direct env sigma ref with + | NotAnElimination -> (*Above const was eliminable but this not!*) + NotAnElimination + | EliminationFix (minarg',minfxargs,infos) -> + let refs = + Array.map + (invert_name labs l names.(i) env sigma ref) names in + let new_minarg = max (minarg'+minarg-nargs) minarg' in + EliminationMutualFix (new_minarg,ref,(refs,infos)) + | _ -> assert false) | _ when isEvalRef env sigma c' -> - (* Forget all \'s and args and do as if we had started with c' *) - let ref,_ = destEvalRefU sigma c' in - (match unsafe_reference_opt_value env sigma ref with - | None -> anomaly (Pp.str "Should have been trapped by compute_direct.") - | Some c -> srec env (minarg-nargs) [] ref c) + (* Forget all \'s and args and do as if we had started with c' *) + let ref,_ = destEvalRefU sigma c' in + (match unsafe_reference_opt_value env sigma ref with + | None -> anomaly (Pp.str "Should have been trapped by compute_direct.") + | Some c -> srec env (minarg-nargs) [] ref c) | _ -> (* Should not occur *) NotAnElimination in match unsafe_reference_opt_value env sigma ref with @@ -321,17 +321,17 @@ let compute_consteval_mutual_fix env sigma ref = let compute_consteval env sigma ref = match compute_consteval_direct env sigma ref with | EliminationFix (_,_,(nbfix,_,_)) when not (Int.equal nbfix 1) -> - compute_consteval_mutual_fix env sigma ref + compute_consteval_mutual_fix env sigma ref | elim -> elim let reference_eval env sigma = function | EvalConst cst as ref -> (try - Cmap.find cst !eval_table + Cmap.find cst !eval_table with Not_found -> begin - let v = compute_consteval env sigma ref in - eval_table := Cmap.add cst v !eval_table; - v + let v = compute_consteval env sigma ref in + eval_table := Cmap.add cst v !eval_table; + v end) | ref -> compute_consteval env sigma ref @@ -435,7 +435,7 @@ let solve_arity_problem env sigma fxminargs c = Array.iter (check strict) rcargs | (Var _|Const _) when isEvalRef env sigma h -> (let ev, u = destEvalRefU sigma h in - match reference_opt_value env sigma ev u with + match reference_opt_value env sigma ev u with | Some h' -> let bak = !evm in (try Array.iter (check false) rcargs @@ -473,9 +473,9 @@ let reduce_fix whdfun sigma fix stack = | Some (recargnum,recarg) -> let (recarg'hd,_ as recarg') = whdfun sigma recarg in let stack' = List.assign stack recargnum (applist recarg') in - (match EConstr.kind sigma recarg'hd with + (match EConstr.kind sigma recarg'hd with | Construct _ -> Reduced (contract_fix sigma fix, stack') - | _ -> NotReducible) + | _ -> NotReducible) let contract_fix_use_function env sigma f ((recindices,bodynum),(_names,_types,bodies as typedbodies)) = @@ -489,16 +489,16 @@ let reduce_fix_use_function env sigma f whfun fix stack = | None -> NotReducible | Some (recargnum,recarg) -> let (recarg'hd,_ as recarg') = - if EConstr.isRel sigma recarg then - (* The recarg cannot be a local def, no worry about the right env *) - (recarg, []) - else - whfun recarg in + if EConstr.isRel sigma recarg then + (* The recarg cannot be a local def, no worry about the right env *) + (recarg, []) + else + whfun recarg in let stack' = List.assign stack recargnum (applist recarg') in - (match EConstr.kind sigma recarg'hd with + (match EConstr.kind sigma recarg'hd with | Construct _ -> - Reduced (contract_fix_use_function env sigma f fix,stack') - | _ -> NotReducible) + Reduced (contract_fix_use_function env sigma f fix,stack') + | _ -> NotReducible) let contract_cofix_use_function env sigma f (bodynum,(_names,_,bodies as typedbodies)) = @@ -511,34 +511,34 @@ let contract_cofix_use_function env sigma f let reduce_mind_case_use_function func env sigma mia = match EConstr.kind sigma mia.mconstr with | Construct ((ind_sp,i),u) -> - let real_cargs = List.skipn mia.mci.ci_npar mia.mcargs in - applist (mia.mlf.(i-1), real_cargs) + let real_cargs = List.skipn mia.mci.ci_npar mia.mcargs in + applist (mia.mlf.(i-1), real_cargs) | CoFix (bodynum,(names,_,_) as cofix) -> - let build_cofix_name = - if isConst sigma func then + let build_cofix_name = + if isConst sigma func then let minargs = List.length mia.mcargs in - fun i -> - if Int.equal i bodynum then Some (minargs,func) + fun i -> + if Int.equal i bodynum then Some (minargs,func) else match names.(i).binder_name with - | Anonymous -> None - | Name id -> - (* In case of a call to another component of a block of - mutual inductive, try to reuse the global name if - the block was indeed initially built as a global - definition *) + | Anonymous -> None + | Name id -> + (* In case of a call to another component of a block of + mutual inductive, try to reuse the global name if + the block was indeed initially built as a global + definition *) let (kn, u) = destConst sigma func in let kn = Constant.change_label kn (Label.of_id id) in let cst = (kn, EInstance.kind sigma u) in - try match constant_opt_value_in env cst with - | None -> None + try match constant_opt_value_in env cst with + | None -> None (* TODO: check kn is correct *) - | Some _ -> Some (minargs,mkConstU (kn, u)) - with Not_found -> None - else - fun _ -> None in - let cofix_def = + | Some _ -> Some (minargs,mkConstU (kn, u)) + with Not_found -> None + else + fun _ -> None in + let cofix_def = contract_cofix_use_function env sigma build_cofix_name cofix in - mkCase (mia.mci, mia.mP, applist(cofix_def,mia.mcargs), mia.mlf) + mkCase (mia.mci, mia.mP, applist(cofix_def,mia.mcargs), mia.mlf) | _ -> assert false @@ -567,7 +567,7 @@ let match_eval_ref_value env sigma constr stack = if is_evaluable env (EvalConstRef (Projection.constant p)) then Some (mkProj (Projection.unfold p, c)) else None - | Var id when is_evaluable env (EvalVarRef id) -> + | Var id when is_evaluable env (EvalVarRef id) -> env |> lookup_named id |> NamedDecl.get_value | Rel n -> env |> lookup_rel n |> RelDecl.get_value |> Option.map (lift n) @@ -582,18 +582,18 @@ let special_red_case env sigma whfun (ci, p, c, lf) = | None -> raise Redelimination | Some gvalue -> if reducible_mind_case sigma gvalue then - reduce_mind_case_use_function constr env sigma - {mP=p; mconstr=gvalue; mcargs=cargs; + reduce_mind_case_use_function constr env sigma + {mP=p; mconstr=gvalue; mcargs=cargs; mci=ci; mlf=lf} - else - redrec (applist(gvalue, cargs))) + else + redrec (applist(gvalue, cargs))) | None -> if reducible_mind_case sigma constr then reduce_mind_case sigma - {mP=p; mconstr=constr; mcargs=cargs; - mci=ci; mlf=lf} + {mP=p; mconstr=constr; mcargs=cargs; + mci=ci; mlf=lf} else - raise Redelimination + raise Redelimination in redrec c @@ -603,7 +603,7 @@ let recargs = function let reduce_projection env sigma p ~npars (recarg'hd,stack') stack = (match EConstr.kind sigma recarg'hd with - | Construct _ -> + | Construct _ -> let proj_narg = npars + Projection.arg p in Reduced (List.nth stack' proj_narg, stack) | _ -> NotReducible) @@ -611,19 +611,19 @@ let reduce_projection env sigma p ~npars (recarg'hd,stack') stack = let reduce_proj env sigma whfun whfun' c = let rec redrec s = match EConstr.kind sigma s with - | Proj (proj, c) -> + | Proj (proj, c) -> let c' = try redrec c with Redelimination -> c in let constr, cargs = whfun c' in - (match EConstr.kind sigma constr with - | Construct _ -> + (match EConstr.kind sigma constr with + | Construct _ -> let proj_narg = Projection.npars proj + Projection.arg proj in List.nth cargs proj_narg - | _ -> raise Redelimination) - | Case (n,p,c,brs) -> + | _ -> raise Redelimination) + | Case (n,p,c,brs) -> let c' = redrec c in let p = (n,p,c',brs) in - (try special_red_case env sigma whfun' p - with Redelimination -> mkCase p) + (try special_red_case env sigma whfun' p + with Redelimination -> mkCase p) | _ -> raise Redelimination in redrec c @@ -632,30 +632,30 @@ let whd_nothing_for_iota env sigma s = match EConstr.kind sigma x with | Rel n -> let open Context.Rel.Declaration in - (match lookup_rel n env with + (match lookup_rel n env with | LocalDef (_,body,_) -> whrec (lift n body, stack) - | _ -> s) + | _ -> s) | Var id -> let open Context.Named.Declaration in - (match lookup_named id env with + (match lookup_named id env with | LocalDef (_,body,_) -> whrec (body, stack) - | _ -> s) + | _ -> s) | Evar ev -> s | Meta ev -> (try whrec (Evd.meta_value sigma ev, stack) - with Not_found -> s) + with Not_found -> s) | Const (const, u) -> let u = EInstance.kind sigma u in - (match constant_opt_value_in env (const, u) with - | Some body -> whrec (EConstr.of_constr body, stack) - | None -> s) + (match constant_opt_value_in env (const, u) with + | Some body -> whrec (EConstr.of_constr body, stack) + | None -> s) | LetIn (_,b,_,c) -> stacklam whrec [b] sigma c stack | Cast (c,_,_) -> whrec (c, stack) | App (f,cl) -> whrec (f, Stack.append_app cl stack) | Lambda (na,t,c) -> (match Stack.decomp stack with | Some (a,m) -> stacklam whrec [a] sigma c m - | _ -> s) + | _ -> s) | x -> s in @@ -701,38 +701,38 @@ let rec red_elim_const env sigma ref u largs = in try match reference_eval env sigma ref with | EliminationCases n when nargs >= n -> - let c = reference_value env sigma ref u in - let c', lrest = whd_nothing_for_iota env sigma (applist(c,largs)) in - let whfun = whd_simpl_stack env sigma in + let c = reference_value env sigma ref u in + let c', lrest = whd_nothing_for_iota env sigma (applist(c,largs)) in + let whfun = whd_simpl_stack env sigma in (special_red_case env sigma whfun (EConstr.destCase sigma c'), lrest), nocase | EliminationProj n when nargs >= n -> - let c = reference_value env sigma ref u in - let c', lrest = whd_nothing_for_iota env sigma (applist(c,largs)) in - let whfun = whd_construct_stack env sigma in - let whfun' = whd_simpl_stack env sigma in - (reduce_proj env sigma whfun whfun' c', lrest), nocase + let c = reference_value env sigma ref u in + let c', lrest = whd_nothing_for_iota env sigma (applist(c,largs)) in + let whfun = whd_construct_stack env sigma in + let whfun' = whd_simpl_stack env sigma in + (reduce_proj env sigma whfun whfun' c', lrest), nocase | EliminationFix (min,minfxargs,infos) when nargs >= min -> - let c = reference_value env sigma ref u in - let d, lrest = whd_nothing_for_iota env sigma (applist(c,largs)) in - let f = make_elim_fun ([|Some (minfxargs,ref)|],infos) u largs in - let whfun = whd_construct_stack env sigma in - (match reduce_fix_use_function env sigma f whfun (destFix sigma d) lrest with - | NotReducible -> raise Redelimination + let c = reference_value env sigma ref u in + let d, lrest = whd_nothing_for_iota env sigma (applist(c,largs)) in + let f = make_elim_fun ([|Some (minfxargs,ref)|],infos) u largs in + let whfun = whd_construct_stack env sigma in + (match reduce_fix_use_function env sigma f whfun (destFix sigma d) lrest with + | NotReducible -> raise Redelimination | Reduced (c,rest) -> (nf_beta env sigma c, rest), nocase) | EliminationMutualFix (min,refgoal,refinfos) when nargs >= min -> - let rec descend (ref,u) args = - let c = reference_value env sigma ref u in - if evaluable_reference_eq sigma ref refgoal then - (c,args) - else - let c', lrest = whd_betalet_stack sigma (applist(c,args)) in - descend (destEvalRefU sigma c') lrest in - let (_, midargs as s) = descend (ref,u) largs in - let d, lrest = whd_nothing_for_iota env sigma (applist s) in - let f = make_elim_fun refinfos u midargs in - let whfun = whd_construct_stack env sigma in - (match reduce_fix_use_function env sigma f whfun (destFix sigma d) lrest with - | NotReducible -> raise Redelimination + let rec descend (ref,u) args = + let c = reference_value env sigma ref u in + if evaluable_reference_eq sigma ref refgoal then + (c,args) + else + let c', lrest = whd_betalet_stack sigma (applist(c,args)) in + descend (destEvalRefU sigma c') lrest in + let (_, midargs as s) = descend (ref,u) largs in + let d, lrest = whd_nothing_for_iota env sigma (applist s) in + let f = make_elim_fun refinfos u midargs in + let whfun = whd_construct_stack env sigma in + (match reduce_fix_use_function env sigma f whfun (destFix sigma d) lrest with + | NotReducible -> raise Redelimination | Reduced (c,rest) -> (nf_beta env sigma c, rest), nocase) | NotAnElimination when unfold_nonelim -> let c = reference_value env sigma ref u in @@ -740,20 +740,20 @@ let rec red_elim_const env sigma ref u largs = | _ -> raise Redelimination with Redelimination when unfold_anyway -> let c = reference_value env sigma ref u in - (whd_betaiotazeta sigma (applist (c, largs)), []), nocase + (whd_betaiotazeta sigma (applist (c, largs)), []), nocase and reduce_params env sigma stack l = let len = List.length stack in List.fold_left (fun stack i -> if len <= i then raise Redelimination else - let arg = List.nth stack i in - let rarg = whd_construct_stack env sigma arg in - match EConstr.kind sigma (fst rarg) with - | Construct _ -> List.assign stack i (applist rarg) - | _ -> raise Redelimination) + let arg = List.nth stack i in + let rarg = whd_construct_stack env sigma arg in + match EConstr.kind sigma (fst rarg) with + | Construct _ -> List.assign stack i (applist rarg) + | _ -> raise Redelimination) stack l - + (* reduce to whd normal form or to an applied constant that does not hide a reducible iota/fix/cofix redex (the "simpl" tactic) *) @@ -774,14 +774,14 @@ and whd_simpl_stack env sigma = | Cast (c,_,_) -> redrec (applist(c, stack)) | Case (ci,p,c,lf) -> (try - redrec (applist(special_red_case env sigma redrec (ci,p,c,lf), stack)) - with - Redelimination -> s') + redrec (applist(special_red_case env sigma redrec (ci,p,c,lf), stack)) + with + Redelimination -> s') | Fix fix -> - (try match reduce_fix (whd_construct_stack env) sigma fix stack with + (try match reduce_fix (whd_construct_stack env) sigma fix stack with | Reduced s' -> redrec (applist s') - | NotReducible -> s' - with Redelimination -> s') + | NotReducible -> s' + with Redelimination -> s') | Proj (p, c) -> (try @@ -808,11 +808,11 @@ and whd_simpl_stack env sigma = else s' with Redelimination -> s') - | _ -> + | _ -> match match_eval_ref env sigma x stack with - | Some (ref, u) -> + | Some (ref, u) -> (try - let sapp, nocase = red_elim_const env sigma ref u stack in + let sapp, nocase = red_elim_const env sigma ref u stack in let hd, _ as s'' = redrec (applist(sapp)) in let rec is_case x = match EConstr.kind sigma x with | Lambda (_,_, x) | LetIn (_,_,_, x) | Cast (x, _,_) -> is_case x @@ -822,7 +822,7 @@ and whd_simpl_stack env sigma = if nocase && is_case hd then raise Redelimination else s'' with Redelimination -> s') - | None -> s' + | None -> s' in redrec @@ -869,24 +869,24 @@ let try_red_product env sigma c = | LetIn (x,a,b,t) -> redrec env (Vars.subst1 a t) | Case (ci,p,d,lf) -> simpfun (mkCase (ci,p,redrec env d,lf)) | Proj (p, c) -> - let c' = - match EConstr.kind sigma c with - | Construct _ -> c - | _ -> redrec env c - in + let c' = + match EConstr.kind sigma c with + | Construct _ -> c + | _ -> redrec env c + in let npars = Projection.npars p in (match reduce_projection env sigma p ~npars (whd_betaiotazeta_stack sigma c') [] with - | Reduced s -> simpfun (applist s) - | NotReducible -> raise Redelimination) - | _ -> + | Reduced s -> simpfun (applist s) + | NotReducible -> raise Redelimination) + | _ -> (match match_eval_ref env sigma x [] with | Some (ref, u) -> (* TO DO: re-fold fixpoints after expansion *) (* to get true one-step reductions *) - (match reference_opt_value env sigma ref u with - | None -> raise Redelimination - | Some c -> c) - | _ -> raise Redelimination) + (match reference_opt_value env sigma ref u with + | None -> raise Redelimination + | Some c -> c) + | _ -> raise Redelimination) in redrec env c let red_product env sigma c = @@ -927,28 +927,28 @@ let whd_simpl_orelse_delta_but_fix_old env sigma c = (try redrec (special_red_case env sigma whd_all (ci,p,d,lf), stack) with Redelimination -> - s) + s) | Fix fix -> - (match reduce_fix whd_all fix stack with + (match reduce_fix whd_all fix stack with | Reduced s' -> redrec s' - | NotReducible -> s) + | NotReducible -> s) | _ when isEvalRef env x -> - let ref = destEvalRef x in + let ref = destEvalRef x in (try - redrec (red_elim_const env sigma ref stack) + redrec (red_elim_const env sigma ref stack) with Redelimination -> match reference_opt_value env sigma ref with - | Some c -> - (match kind_of_term (strip_lam c) with + | Some c -> + (match kind_of_term (strip_lam c) with | CoFix _ | Fix _ -> s - | _ -> redrec (c, stack)) - | None -> s) + | _ -> redrec (c, stack)) + | None -> s) | _ -> s in app_stack (redrec (c, empty_stack)) *) -let whd_simpl_stack = - if Flags.profile then +let whd_simpl_stack = + if Flags.profile then let key = CProfile.declare_profile "whd_simpl_stack" in CProfile.profile3 key whd_simpl_stack else whd_simpl_stack @@ -965,14 +965,14 @@ let whd_simpl_orelse_delta_but_fix env sigma c = (match EConstr.kind sigma (snd (decompose_lam sigma c)) with | CoFix _ | Fix _ -> s' | Proj (p,t) when - (match EConstr.kind sigma constr with - | Const (c', _) -> Constant.equal (Projection.constant p) c' - | _ -> false) -> + (match EConstr.kind sigma constr with + | Const (c', _) -> Constant.equal (Projection.constant p) c' + | _ -> false) -> let npars = Projection.npars p in if List.length stack <= npars then (* Do not show the eta-expanded form *) - s' - else redrec (applist (c, stack)) + s' + else redrec (applist (c, stack)) | _ -> redrec (applist(c, stack))) | None -> s' in @@ -1000,7 +1000,7 @@ let matches_head env sigma c t = parameters. This is a temporary fix while rewrite etc... are not up to equivalence of the projection and its eta expanded form. *) -let change_map_constr_with_binders_left_to_right g f (env, l as acc) sigma c = +let change_map_constr_with_binders_left_to_right g f (env, l as acc) sigma c = match EConstr.kind sigma c with | Proj (p, r) -> (* Treat specially for partial applications *) let t = Retyping.expand_projection env sigma p r [] in @@ -1012,7 +1012,7 @@ let change_map_constr_with_binders_left_to_right g f (env, l as acc) sigma c = (match EConstr.kind sigma app' with | App (hdf', al') when hdf' == hdf -> (* Still the same projection, we ignore the change in parameters *) - mkProj (p, a') + mkProj (p, a') | _ -> mkApp (app', [| a' |])) | _ -> map_constr_with_binders_left_to_right sigma g f acc c @@ -1027,11 +1027,11 @@ let e_contextually byhead (occs,c) f = begin fun env sigma t -> else try let subst = - if byhead then matches_head env sigma c t - else Constr_matching.matches env sigma c t in + if byhead then matches_head env sigma c t + else Constr_matching.matches env sigma c t in let ok = - if nowhere_except_in then Int.List.mem !pos locs - else not (Int.List.mem !pos locs) in + if nowhere_except_in then Int.List.mem !pos locs + else not (Int.List.mem !pos locs) in incr pos; if ok then begin if Option.has_some nested then @@ -1039,11 +1039,11 @@ let e_contextually byhead (occs,c) f = begin fun env sigma t -> (* Skip inner occurrences for stable counting of occurrences *) if locs != [] then ignore (traverse_below (Some (!pos-1)) envc t); - let (evm, t) = (f subst) env !evd t in - (evd := evm; t) + let (evm, t) = (f subst) env !evd t in + (evd := evm; t) end else - traverse_below nested envc t + traverse_below nested envc t with Constr_matching.PatternMatchingFailure -> traverse_below nested envc t and traverse_below nested envc t = @@ -1070,7 +1070,7 @@ let contextually byhead occs f env sigma t = * n is the number of the next occurrence of name. * ol is the occurrence list to find. *) -let match_constr_evaluable_ref sigma c evref = +let match_constr_evaluable_ref sigma c evref = match EConstr.kind sigma c, evref with | Const (c,u), EvalConstRef c' when Constant.equal c c' -> Some u | Var id, EvalVarRef id' when Id.equal id id' -> Some EInstance.empty @@ -1083,17 +1083,17 @@ let substlin env sigma evalref n (nowhere_except_in,locs) c = let value u = value_of_evaluable_ref env evalref u in let rec substrec () c = if nowhere_except_in && !pos > maxocc then c - else + else match match_constr_evaluable_ref sigma c evalref with | Some u -> let ok = - if nowhere_except_in then Int.List.mem !pos locs - else not (Int.List.mem !pos locs) in - incr pos; - if ok then value u else c - | None -> + if nowhere_except_in then Int.List.mem !pos locs + else not (Int.List.mem !pos locs) in + incr pos; + if ok then value u else c + | None -> map_constr_with_binders_left_to_right sigma - (fun _ () -> ()) + (fun _ () -> ()) substrec () c in let t' = substrec () c in @@ -1215,7 +1215,7 @@ let check_not_primitive_record env ind = let spec = Inductive.lookup_mind_specif env (fst ind) in if Inductive.is_primitive_record spec then user_err (str "case analysis on a primitive record type: " ++ - str "use projections or let instead.") + str "use projections or let instead.") else ind (* put t as t'=(x1:A1)..(xn:An)B with B an inductive definition of name name @@ -1227,18 +1227,18 @@ let reduce_to_ind_gen allow_product env sigma t = match EConstr.kind sigma (fst (decompose_app_vect sigma t)) with | Ind ind-> (check_privacy env ind, it_mkProd_or_LetIn t l) | Prod (n,ty,t') -> - let open Context.Rel.Declaration in - if allow_product then + let open Context.Rel.Declaration in + if allow_product then elimrec (push_rel (LocalAssum (n,ty)) env) t' ((LocalAssum (n,ty))::l) - else - user_err (str"Not an inductive definition.") + else + user_err (str"Not an inductive definition.") | _ -> - (* Last chance: we allow to bypass the Opaque flag (as it - was partially the case between V5.10 and V8.1 *) - let t' = whd_all env sigma t in - match EConstr.kind sigma (fst (decompose_app_vect sigma t')) with - | Ind ind-> (check_privacy env ind, it_mkProd_or_LetIn t' l) - | _ -> user_err (str"Not an inductive product.") + (* Last chance: we allow to bypass the Opaque flag (as it + was partially the case between V5.10 and V8.1 *) + let t' = whd_all env sigma t in + match EConstr.kind sigma (fst (decompose_app_vect sigma t')) with + | Ind ind-> (check_privacy env ind, it_mkProd_or_LetIn t' l) + | _ -> user_err (str"Not an inductive product.") in elimrec env t [] @@ -1266,29 +1266,29 @@ let one_step_reduce env sigma c = | Cast (c,_,_) -> redrec (c,stack) | Case (ci,p,c,lf) -> (try - (special_red_case env sigma (whd_simpl_stack env sigma) - (ci,p,c,lf), stack) + (special_red_case env sigma (whd_simpl_stack env sigma) + (ci,p,c,lf), stack) with Redelimination -> raise NotStepReducible) | Fix fix -> - (try match reduce_fix (whd_construct_stack env) sigma fix stack with + (try match reduce_fix (whd_construct_stack env) sigma fix stack with | Reduced s' -> s' - | NotReducible -> raise NotStepReducible + | NotReducible -> raise NotStepReducible with Redelimination -> raise NotStepReducible) | _ when isEvalRef env sigma x -> - let ref,u = destEvalRefU sigma x in + let ref,u = destEvalRefU sigma x in (try fst (red_elim_const env sigma ref u stack) with Redelimination -> - match reference_opt_value env sigma ref u with - | Some d -> (d, stack) - | None -> raise NotStepReducible) + match reference_opt_value env sigma ref u with + | Some d -> (d, stack) + | None -> raise NotStepReducible) | _ -> raise NotStepReducible in applist (redrec (c,[])) let error_cannot_recognize ref = - user_err + user_err (str "Cannot recognize a statement based on " ++ Nametab.pr_global_env Id.Set.empty ref ++ str".") @@ -1306,16 +1306,16 @@ let reduce_to_ref_gen allow_product env sigma ref t = match EConstr.kind sigma c with | Prod (n,ty,t') -> if allow_product then - let open Context.Rel.Declaration in + let open Context.Rel.Declaration in elimrec (push_rel (LocalAssum (n,ty)) env) t' ((LocalAssum (n,ty))::l) else error_cannot_recognize ref | _ -> - try + try if GlobRef.equal (fst (global_of_constr sigma c)) ref - then it_mkProd_or_LetIn t l - else raise Not_found - with Not_found -> + then it_mkProd_or_LetIn t l + else raise Not_found + with Not_found -> try let t' = nf_betaiota env sigma (one_step_reduce env sigma t) in elimrec env t' l diff --git a/pretyping/tacred.mli b/pretyping/tacred.mli index c05a6cde18..be4c681cc7 100644 --- a/pretyping/tacred.mli +++ b/pretyping/tacred.mli @@ -92,7 +92,7 @@ val reduce_to_quantified_ref : val reduce_to_atomic_ref : env -> evar_map -> GlobRef.t -> types -> types -val find_hnf_rectype : +val find_hnf_rectype : env -> evar_map -> types -> (inductive * EInstance.t) * constr list val contextually : bool -> occurrences * constr_pattern -> diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index 544fd3d17d..1541e96635 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -64,8 +64,8 @@ type typeclass = { (* The method implementations as projections. *) cl_projs : (Name.t * (direction * hint_info) option - * Constant.t option) list; - + * Constant.t option) list; + cl_strict : bool; cl_unique : bool; @@ -124,7 +124,7 @@ let class_of_constr env sigma c = try Some (dest_class_arity env sigma c) with e when CErrors.noncritical e -> None -let is_class_constr sigma c = +let is_class_constr sigma c = try let gr, u = Termops.global_of_constr sigma c in GlobRef.Map.mem gr !classes with Not_found -> false @@ -135,7 +135,7 @@ let rec is_class_type evd c = | Prod (_, _, t) -> is_class_type evd t | Cast (t, _, _) -> is_class_type evd t | _ -> is_class_constr evd c - + let is_class_evar evd evi = is_class_type evd evi.Evd.evar_concl @@ -160,7 +160,7 @@ let load_class cl = (** Build the subinstances hints. *) let check_instance env sigma c = - try + try let (evd, c) = resolve_one_typeclass env sigma (Retyping.get_type_of env sigma c) in not (Evd.has_undefined evd) @@ -168,8 +168,8 @@ let check_instance env sigma c = let build_subclasses ~check env sigma glob { hint_priority = pri } = let _id = Nametab.basename_of_global glob in - let _next_id = - let i = ref (-1) in + let _next_id = + let i = ref (-1) in (fun () -> incr i; Nameops.add_suffix _id ("_subinstance_" ^ string_of_int !i)) in @@ -182,37 +182,37 @@ let build_subclasses ~check env sigma glob { hint_priority = pri } = match class_of_constr env sigma ty with | None -> [] | Some (rels, ((tc,u), args)) -> - let instapp = - Reductionops.whd_beta sigma (EConstr.of_constr (appvectc c (Context.Rel.to_extended_vect mkRel 0 rels))) - in - let instapp = EConstr.Unsafe.to_constr instapp in - let projargs = Array.of_list (args @ [instapp]) in - let projs = List.map_filter - (fun (n, b, proj) -> - match b with - | None -> None - | Some (Backward, _) -> None - | Some (Forward, info) -> - let proj = Option.get proj in - let rels = List.map (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) rels in - let u = EConstr.EInstance.kind sigma u in - let body = it_mkLambda_or_LetIn (mkApp (mkConstU (proj,u), projargs)) rels in - if check && check_instance env sigma (EConstr.of_constr body) then None - else - let newpri = - match pri, info.hint_priority with - | Some p, Some p' -> Some (p + p') - | Some p, None -> Some (p + 1) - | _, _ -> None - in + let instapp = + Reductionops.whd_beta sigma (EConstr.of_constr (appvectc c (Context.Rel.to_extended_vect mkRel 0 rels))) + in + let instapp = EConstr.Unsafe.to_constr instapp in + let projargs = Array.of_list (args @ [instapp]) in + let projs = List.map_filter + (fun (n, b, proj) -> + match b with + | None -> None + | Some (Backward, _) -> None + | Some (Forward, info) -> + let proj = Option.get proj in + let rels = List.map (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) rels in + let u = EConstr.EInstance.kind sigma u in + let body = it_mkLambda_or_LetIn (mkApp (mkConstU (proj,u), projargs)) rels in + if check && check_instance env sigma (EConstr.of_constr body) then None + else + let newpri = + match pri, info.hint_priority with + | Some p, Some p' -> Some (p + p') + | Some p, None -> Some (p + 1) + | _, _ -> None + in Some (GlobRef.ConstRef proj, { info with hint_priority = newpri }, body)) tc.cl_projs - in - let declare_proj hints (cref, info, body) = - let path' = cref :: path in - let ty = Retyping.get_type_of env sigma (EConstr.of_constr body) in - let rest = aux pri body ty path' in - hints @ (path', info, body) :: rest - in List.fold_left declare_proj [] projs + in + let declare_proj hints (cref, info, body) = + let path' = cref :: path in + let ty = Retyping.get_type_of env sigma (EConstr.of_constr body) in + let rest = aux pri body ty path' in + hints @ (path', info, body) :: rest + in List.fold_left declare_proj [] projs in let term = Constr.mkRef (glob, inst) in (*FIXME subclasses should now get substituted for each particular instance of @@ -249,10 +249,10 @@ let instance_constructor (cl,u) args = applist (mkIndU ind, pars)) | GlobRef.ConstRef cst -> let cst = cst, u in - let term = match args with - | [] -> None - | _ -> Some (List.last args) - in + let term = match args with + | [] -> None + | _ -> Some (List.last args) + in (term, applist (mkConstU cst, pars)) | _ -> assert false @@ -263,7 +263,7 @@ let cmap_elements c = GlobRef.Map.fold (fun k v acc -> v :: acc) c [] let instances_of c = try cmap_elements (GlobRef.Map.find c.cl_impl !instances) with Not_found -> [] -let all_instances () = +let all_instances () = GlobRef.Map.fold (fun k v acc -> GlobRef.Map.fold (fun k v acc -> v :: acc) v acc) !instances [] @@ -271,7 +271,7 @@ let all_instances () = let instances env sigma r = let cl = class_info env sigma r in instances_of cl -let is_class gr = +let is_class gr = GlobRef.Map.exists (fun _ v -> GlobRef.equal v.cl_impl gr) !classes open Evar_kinds diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli index 787c722938..2715c1eda5 100644 --- a/pretyping/typeclasses.mli +++ b/pretyping/typeclasses.mli @@ -40,16 +40,16 @@ type typeclass = { (** Context of definitions and properties on defs, will not be shared *) cl_projs : (Name.t * (direction * hint_info) option * Constant.t option) list; - (** The methods implementations of the typeclass as projections. - Some may be undefinable due to sorting restrictions or simply undefined if + (** The methods implementations of the typeclass as projections. + Some may be undefinable due to sorting restrictions or simply undefined if no name is provided. The [int option option] indicates subclasses whose hint has the given priority. *) - cl_strict : bool; + cl_strict : bool; (** Whether we use matching or full unification during resolution *) cl_unique : bool; - (** Whether we can assume that instances are unique, which allows + (** Whether we can assume that instances are unique, which allows no backtracking and sharing of resolution. *) } @@ -132,7 +132,7 @@ val solve_all_instances_hook : (env -> evar_map -> evar_filter -> bool -> bool - val solve_one_instance_hook : (env -> evar_map -> EConstr.types -> bool -> evar_map * EConstr.constr) Hook.t (** Build the subinstances hints for a given typeclass object. - check tells if we should check for existence of the + check tells if we should check for existence of the subinstances and add only the missing ones. *) val build_subclasses : check:bool -> env -> evar_map -> GlobRef.t -> diff --git a/pretyping/typing.ml b/pretyping/typing.ml index 1a145fe1b2..a15134f58d 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -382,7 +382,7 @@ let rec execute env sigma cstr = | Type u -> sigma, judge_of_type u end - | Proj (p, c) -> + | Proj (p, c) -> let sigma, cj = execute env sigma c in sigma, judge_of_projection env sigma p cj diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 7147580b3d..48d5fac321 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -114,10 +114,10 @@ let abstract_scheme env evd c l lname_typ = (* [occur_meta ta] test removed for support of eelim/ecase but consequences are unclear... if occur_meta ta then error "cannot find a type for the generalisation" - else *) + else *) if occur_meta evd a then mkLambda_name env (na,ta,t), evd else - let t', evd' = Find_subterm.subst_closed_term_occ env evd locc a t in + let t', evd' = Find_subterm.subst_closed_term_occ env evd locc a t in mkLambda_name env (na,ta,t'), evd') (c,evd) (List.rev l) @@ -215,21 +215,21 @@ let pose_all_metas_as_evars env evd t = let solve_pattern_eqn_array (env,nb) f l c (sigma,metasubst,evarsubst : subst0) = match EConstr.kind sigma f with | Meta k -> - (* We enforce that the Meta does not depend on the [nb] - extra assumptions added by unification to the context *) + (* We enforce that the Meta does not depend on the [nb] + extra assumptions added by unification to the context *) let env' = pop_rel_context nb env in - let sigma,c = pose_all_metas_as_evars env' sigma c in - let c = solve_pattern_eqn env sigma l c in - let pb = (Conv,TypeNotProcessed) in - if noccur_between sigma 1 nb c then + let sigma,c = pose_all_metas_as_evars env' sigma c in + let c = solve_pattern_eqn env sigma l c in + let pb = (Conv,TypeNotProcessed) in + if noccur_between sigma 1 nb c then sigma,(k,lift (-nb) c,pb)::metasubst,evarsubst - else + else let l = List.map of_alias l in error_cannot_unify_local env sigma (applist (f, l),c,c) | Evar ev -> let env' = pop_rel_context nb env in - let sigma,c = pose_all_metas_as_evars env' sigma c in - sigma,metasubst,(env,ev,solve_pattern_eqn env sigma l c)::evarsubst + let sigma,c = pose_all_metas_as_evars env' sigma c in + sigma,metasubst,(env,ev,solve_pattern_eqn env sigma l c)::evarsubst | _ -> assert false let push d (env,n) = (push_rel_assum d env,n+1) @@ -479,7 +479,7 @@ let use_metas_pattern_unification sigma flags nb l = || flags.use_meta_bound_pattern_unification && Array.for_all (fun c -> isRel sigma c && destRel sigma c <= nb) l -type key = +type key = | IsKey of CClosure.table_key | IsProj of Projection.t * EConstr.constr @@ -494,7 +494,7 @@ let unfold_projection env p stk = let expand_key ts env sigma = function | Some (IsKey k) -> Option.map EConstr.of_constr (expand_table_key env k) - | Some (IsProj (p, c)) -> + | Some (IsProj (p, c)) -> let red = Stack.zip sigma (whd_betaiota_deltazeta_for_iota_state ts env sigma (c, unfold_projection env p [])) in if EConstr.eq_constr sigma (EConstr.mkProj (p, c)) red then None else Some red @@ -504,7 +504,7 @@ let isApp_or_Proj sigma c = match kind sigma c with | App _ | Proj _ -> true | _ -> false - + type unirec_flags = { at_top: bool; with_types: bool; @@ -522,7 +522,7 @@ let key_of env sigma b flags f = || Recordops.is_primitive_projection cst) -> let u = EInstance.kind sigma u in Some (IsKey (ConstKey (cst, u))) - | Var id when is_transparent env (VarKey id) && + | Var id when is_transparent env (VarKey id) && TransparentState.is_transparent_variable flags.modulo_delta id -> Some (IsKey (VarKey id)) | Proj (p, c) when Projection.unfolded p @@ -530,7 +530,7 @@ let key_of env sigma b flags f = (TransparentState.is_transparent_constant flags.modulo_delta (Projection.constant p))) -> Some (IsProj (p, c)) | _ -> None - + let translate_key = function | ConstKey (cst,u) -> ConstKey cst @@ -538,9 +538,9 @@ let translate_key = function | RelKey n -> RelKey n let translate_key = function - | IsKey k -> translate_key k + | IsKey k -> translate_key k | IsProj (c, _) -> ConstKey (Projection.constant c) - + let oracle_order env cf1 cf2 = match cf1 with | None -> @@ -551,16 +551,16 @@ let oracle_order env cf1 cf2 = match cf2 with | None -> Some true | Some k2 -> - match k1, k2 with - | IsProj (p, _), IsKey (ConstKey (p',_)) - when Constant.equal (Projection.constant p) p' -> - Some (not (Projection.unfolded p)) - | IsKey (ConstKey (p,_)), IsProj (p', _) - when Constant.equal p (Projection.constant p') -> - Some (Projection.unfolded p') - | _ -> + match k1, k2 with + | IsProj (p, _), IsKey (ConstKey (p',_)) + when Constant.equal (Projection.constant p) p' -> + Some (not (Projection.unfolded p)) + | IsKey (ConstKey (p,_)), IsProj (p', _) + when Constant.equal p (Projection.constant p') -> + Some (Projection.unfolded p') + | _ -> Some (Conv_oracle.oracle_order (fun x -> x) - (Environ.oracle env) false (translate_key k1) (translate_key k2)) + (Environ.oracle env) false (translate_key k1) (translate_key k2)) let is_rigid_head sigma flags t = match EConstr.kind sigma t with @@ -588,20 +588,20 @@ let constr_cmp pb env sigma flags t u = let cstrs = if pb == Reduction.CONV then EConstr.eq_constr_universes env sigma t u else EConstr.leq_constr_universes env sigma t u - in + in match cstrs with | Some cstrs -> begin try Some (Evd.add_universe_constraints sigma cstrs) with Univ.UniverseInconsistency _ -> None - | Evd.UniversesDiffer -> - if is_rigid_head sigma flags t then + | Evd.UniversesDiffer -> + if is_rigid_head sigma flags t then try Some (Evd.add_universe_constraints sigma (force_eqs cstrs)) with Univ.UniverseInconsistency _ -> None else None end | None -> None - + let do_reduce ts (env, nb) sigma c = Stack.zip sigma (whd_betaiota_deltazeta_for_iota_state ts env sigma (c, Stack.empty)) @@ -653,7 +653,7 @@ let rec is_neutral env sigma ts t = not (Environ.evaluable_constant c env) || not (is_transparent env (ConstKey c)) || not (TransparentState.is_transparent_constant ts c) - | Var id -> + | Var id -> not (Environ.evaluable_named id env) || not (is_transparent env (VarKey id)) || not (TransparentState.is_transparent_variable ts id) @@ -676,7 +676,7 @@ let is_eta_constructor_app env sigma ts f l1 term = let (_, projs, _, _) = info.(i) in Array.length projs == Array.length l1 - mib.Declarations.mind_nparams -> (* Check that the other term is neutral *) - is_neutral env sigma ts term + is_neutral env sigma ts term | _ -> false) | _ -> false @@ -687,10 +687,10 @@ let eta_constructor_app env sigma f l1 term = (match get_projections env ind with | Some projs -> let npars = mib.Declarations.mind_nparams in - let pars, l1' = Array.chop npars l1 in - let arg = Array.append pars [|term|] in + let pars, l1' = Array.chop npars l1 in + let arg = Array.append pars [|term|] in let l2 = Array.map (fun p -> mkApp (mkConstU (Projection.Repr.constant p,u), arg)) projs in - l1', l2 + l1', l2 | _ -> assert false) | _ -> assert false @@ -698,167 +698,167 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e let rec unirec_rec (curenv,nb as curenvnb) pb opt ((sigma,metasubst,evarsubst) as substn : subst0) curm curn = let cM = Evarutil.whd_head_evar sigma curm and cN = Evarutil.whd_head_evar sigma curn in - let () = + let () = if !debug_unification then Feedback.msg_debug ( Termops.Internal.print_constr_env curenv sigma cM ++ str" ~= " ++ Termops.Internal.print_constr_env curenv sigma cN) in match (EConstr.kind sigma cM, EConstr.kind sigma cN) with - | Meta k1, Meta k2 -> + | Meta k1, Meta k2 -> if Int.equal k1 k2 then substn else - let stM,stN = extract_instance_status pb in - let sigma = - if opt.with_types && flags.check_applied_meta_types then - let tyM = Typing.meta_type sigma k1 in - let tyN = Typing.meta_type sigma k2 in - let l, r = if k2 < k1 then tyN, tyM else tyM, tyN in - check_compatibility curenv CUMUL flags substn l r - else sigma - in - if k2 < k1 then sigma,(k1,cN,stN)::metasubst,evarsubst - else sigma,(k2,cM,stM)::metasubst,evarsubst - | Meta k, _ + let stM,stN = extract_instance_status pb in + let sigma = + if opt.with_types && flags.check_applied_meta_types then + let tyM = Typing.meta_type sigma k1 in + let tyN = Typing.meta_type sigma k2 in + let l, r = if k2 < k1 then tyN, tyM else tyM, tyN in + check_compatibility curenv CUMUL flags substn l r + else sigma + in + if k2 < k1 then sigma,(k1,cN,stN)::metasubst,evarsubst + else sigma,(k2,cM,stM)::metasubst,evarsubst + | Meta k, _ when not (occur_metavariable sigma k cN) (* helps early trying alternatives *) -> - let sigma = - if opt.with_types && flags.check_applied_meta_types then - (try + let sigma = + if opt.with_types && flags.check_applied_meta_types then + (try let tyM = Typing.meta_type sigma k in let tyN = get_type_of curenv ~lax:true sigma cN in check_compatibility curenv CUMUL flags substn tyN tyM - with RetypeError _ -> + with RetypeError _ -> (* Renounce, maybe metas/evars prevents typing *) sigma) - else sigma - in - (* Here we check that [cN] does not contain any local variables *) - if Int.equal nb 0 then + else sigma + in + (* Here we check that [cN] does not contain any local variables *) + if Int.equal nb 0 then sigma,(k,cN,snd (extract_instance_status pb))::metasubst,evarsubst else if noccur_between sigma 1 nb cN then (sigma, - (k,lift (-nb) cN,snd (extract_instance_status pb))::metasubst, + (k,lift (-nb) cN,snd (extract_instance_status pb))::metasubst, evarsubst) - else error_cannot_unify_local curenv sigma (m,n,cN) - | _, Meta k + else error_cannot_unify_local curenv sigma (m,n,cN) + | _, Meta k when not (occur_metavariable sigma k cM) (* helps early trying alternatives *) -> - let sigma = - if opt.with_types && flags.check_applied_meta_types then + let sigma = + if opt.with_types && flags.check_applied_meta_types then (try let tyM = get_type_of curenv ~lax:true sigma cM in let tyN = Typing.meta_type sigma k in check_compatibility curenv CUMUL flags substn tyM tyN with RetypeError _ -> (* Renounce, maybe metas/evars prevents typing *) sigma) - else sigma - in - (* Here we check that [cM] does not contain any local variables *) - if Int.equal nb 0 then + else sigma + in + (* Here we check that [cM] does not contain any local variables *) + if Int.equal nb 0 then (sigma,(k,cM,fst (extract_instance_status pb))::metasubst,evarsubst) - else if noccur_between sigma 1 nb cM - then + else if noccur_between sigma 1 nb cM + then (sigma,(k,lift (-nb) cM,fst (extract_instance_status pb))::metasubst, evarsubst) - else error_cannot_unify_local curenv sigma (m,n,cM) - | Evar (evk,_ as ev), Evar (evk',_) + else error_cannot_unify_local curenv sigma (m,n,cM) + | Evar (evk,_ as ev), Evar (evk',_) when is_evar_allowed flags evk && Evar.equal evk evk' -> begin match constr_cmp cv_pb env sigma flags cM cN with | Some sigma -> sigma, metasubst, evarsubst | None -> - sigma,metasubst,((curenv,ev,cN)::evarsubst) + sigma,metasubst,((curenv,ev,cN)::evarsubst) end - | Evar (evk,_ as ev), _ + | Evar (evk,_ as ev), _ when is_evar_allowed flags evk - && not (occur_evar sigma evk cN) -> - let cmvars = free_rels sigma cM and cnvars = free_rels sigma cN in - if Int.Set.subset cnvars cmvars then - sigma,metasubst,((curenv,ev,cN)::evarsubst) - else error_cannot_unify_local curenv sigma (m,n,cN) - | _, Evar (evk,_ as ev) + && not (occur_evar sigma evk cN) -> + let cmvars = free_rels sigma cM and cnvars = free_rels sigma cN in + if Int.Set.subset cnvars cmvars then + sigma,metasubst,((curenv,ev,cN)::evarsubst) + else error_cannot_unify_local curenv sigma (m,n,cN) + | _, Evar (evk,_ as ev) when is_evar_allowed flags evk - && not (occur_evar sigma evk cM) -> - let cmvars = free_rels sigma cM and cnvars = free_rels sigma cN in - if Int.Set.subset cmvars cnvars then - sigma,metasubst,((curenv,ev,cM)::evarsubst) - else error_cannot_unify_local curenv sigma (m,n,cN) - | Sort s1, Sort s2 -> - (try + && not (occur_evar sigma evk cM) -> + let cmvars = free_rels sigma cM and cnvars = free_rels sigma cN in + if Int.Set.subset cmvars cnvars then + sigma,metasubst,((curenv,ev,cM)::evarsubst) + else error_cannot_unify_local curenv sigma (m,n,cN) + | Sort s1, Sort s2 -> + (try let s1 = ESorts.kind sigma s1 in let s2 = ESorts.kind sigma s2 in - let sigma' = - if pb == CUMUL - then Evd.set_leq_sort curenv sigma s1 s2 - else Evd.set_eq_sort curenv sigma s1 s2 - in (sigma', metasubst, evarsubst) - with e when CErrors.noncritical e -> + let sigma' = + if pb == CUMUL + then Evd.set_leq_sort curenv sigma s1 s2 + else Evd.set_eq_sort curenv sigma s1 s2 + in (sigma', metasubst, evarsubst) + with e when CErrors.noncritical e -> error_cannot_unify curenv sigma (m,n)) | Lambda (na,t1,c1), Lambda (__,t2,c2) -> unirec_rec (push (na,t1) curenvnb) CONV {opt with at_top = true} - (unirec_rec curenvnb CONV {opt with at_top = true; with_types = false} substn t1 t2) c1 c2 + (unirec_rec curenvnb CONV {opt with at_top = true; with_types = false} substn t1 t2) c1 c2 | Prod (na,t1,c1), Prod (_,t2,c2) -> unirec_rec (push (na,t1) curenvnb) pb {opt with at_top = true} - (unirec_rec curenvnb CONV {opt with at_top = true; with_types = false} substn t1 t2) c1 c2 + (unirec_rec curenvnb CONV {opt with at_top = true; with_types = false} substn t1 t2) c1 c2 | LetIn (_,a,_,c), _ -> unirec_rec curenvnb pb opt substn (subst1 a c) cN | _, LetIn (_,a,_,c) -> unirec_rec curenvnb pb opt substn cM (subst1 a c) (* Fast path for projections. *) - | Proj (p1,c1), Proj (p2,c2) when Constant.equal - (Projection.constant p1) (Projection.constant p2) -> - (try unify_same_proj curenvnb cv_pb {opt with at_top = true} - substn c1 c2 - with ex when precatchable_exception ex -> - unify_not_same_head curenvnb pb opt substn cM cN) + | Proj (p1,c1), Proj (p2,c2) when Constant.equal + (Projection.constant p1) (Projection.constant p2) -> + (try unify_same_proj curenvnb cv_pb {opt with at_top = true} + substn c1 c2 + with ex when precatchable_exception ex -> + unify_not_same_head curenvnb pb opt substn cM cN) (* eta-expansion *) | Lambda (na,t1,c1), _ when flags.modulo_eta -> unirec_rec (push (na,t1) curenvnb) CONV {opt with at_top = true} substn - c1 (mkApp (lift 1 cN,[|mkRel 1|])) + c1 (mkApp (lift 1 cN,[|mkRel 1|])) | _, Lambda (na,t2,c2) when flags.modulo_eta -> unirec_rec (push (na,t2) curenvnb) CONV {opt with at_top = true} substn - (mkApp (lift 1 cM,[|mkRel 1|])) c2 - - (* For records *) - | App (f1, l1), _ when flags.modulo_eta && - (* This ensures cN is an evar, meta or irreducible constant/variable - and not a constructor. *) - is_eta_constructor_app curenv sigma flags.modulo_delta f1 l1 cN -> - (try - let l1', l2' = eta_constructor_app curenv sigma f1 l1 cN in - let opt' = {opt with at_top = true; with_cs = false} in - Array.fold_left2 (unirec_rec curenvnb CONV opt') substn l1' l2' - with ex when precatchable_exception ex -> - match EConstr.kind sigma cN with - | App(f2,l2) when - (isMeta sigma f2 && use_metas_pattern_unification sigma flags nb l2 - || use_evars_pattern_unification flags && isAllowedEvar sigma flags f2) -> - unify_app_pattern false curenvnb pb opt substn cM f1 l1 cN f2 l2 - | _ -> raise ex) - - | _, App (f2, l2) when flags.modulo_eta && - is_eta_constructor_app curenv sigma flags.modulo_delta f2 l2 cM -> - (try - let l2', l1' = eta_constructor_app curenv sigma f2 l2 cM in - let opt' = {opt with at_top = true; with_cs = false} in - Array.fold_left2 (unirec_rec curenvnb CONV opt') substn l1' l2' - with ex when precatchable_exception ex -> - match EConstr.kind sigma cM with - | App(f1,l1) when - (isMeta sigma f1 && use_metas_pattern_unification sigma flags nb l1 - || use_evars_pattern_unification flags && isAllowedEvar sigma flags f1) -> - unify_app_pattern true curenvnb pb opt substn cM f1 l1 cN f2 l2 - | _ -> raise ex) + (mkApp (lift 1 cM,[|mkRel 1|])) c2 + + (* For records *) + | App (f1, l1), _ when flags.modulo_eta && + (* This ensures cN is an evar, meta or irreducible constant/variable + and not a constructor. *) + is_eta_constructor_app curenv sigma flags.modulo_delta f1 l1 cN -> + (try + let l1', l2' = eta_constructor_app curenv sigma f1 l1 cN in + let opt' = {opt with at_top = true; with_cs = false} in + Array.fold_left2 (unirec_rec curenvnb CONV opt') substn l1' l2' + with ex when precatchable_exception ex -> + match EConstr.kind sigma cN with + | App(f2,l2) when + (isMeta sigma f2 && use_metas_pattern_unification sigma flags nb l2 + || use_evars_pattern_unification flags && isAllowedEvar sigma flags f2) -> + unify_app_pattern false curenvnb pb opt substn cM f1 l1 cN f2 l2 + | _ -> raise ex) + + | _, App (f2, l2) when flags.modulo_eta && + is_eta_constructor_app curenv sigma flags.modulo_delta f2 l2 cM -> + (try + let l2', l1' = eta_constructor_app curenv sigma f2 l2 cM in + let opt' = {opt with at_top = true; with_cs = false} in + Array.fold_left2 (unirec_rec curenvnb CONV opt') substn l1' l2' + with ex when precatchable_exception ex -> + match EConstr.kind sigma cM with + | App(f1,l1) when + (isMeta sigma f1 && use_metas_pattern_unification sigma flags nb l1 + || use_evars_pattern_unification flags && isAllowedEvar sigma flags f1) -> + unify_app_pattern true curenvnb pb opt substn cM f1 l1 cN f2 l2 + | _ -> raise ex) | Case (ci1,p1,c1,cl1), Case (ci2,p2,c2,cl2) -> (try if not (eq_ind ci1.ci_ind ci2.ci_ind) then error_cannot_unify curenv sigma (cM,cN); - let opt' = {opt with at_top = true; with_types = false} in - Array.fold_left2 (unirec_rec curenvnb CONV {opt with at_top = true}) - (unirec_rec curenvnb CONV opt' - (unirec_rec curenvnb CONV opt' substn p1 p2) c1 c2) + let opt' = {opt with at_top = true; with_types = false} in + Array.fold_left2 (unirec_rec curenvnb CONV {opt with at_top = true}) + (unirec_rec curenvnb CONV opt' + (unirec_rec curenvnb CONV opt' substn p1 p2) c1 c2) cl1 cl2 - with ex when precatchable_exception ex -> - reduce curenvnb pb opt substn cM cN) + with ex when precatchable_exception ex -> + reduce curenvnb pb opt substn cM cN) | Fix ((ln1,i1),(lna1,tl1,bl1)), Fix ((ln2,i2),(_,tl2,bl2)) when Int.equal i1 i2 && Array.equal Int.equal ln1 ln2 -> @@ -880,68 +880,68 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e with ex when precatchable_exception ex -> reduce curenvnb pb opt substn cM cN) - | App (f1,l1), _ when - (isMeta sigma f1 && use_metas_pattern_unification sigma flags nb l1 + | App (f1,l1), _ when + (isMeta sigma f1 && use_metas_pattern_unification sigma flags nb l1 || use_evars_pattern_unification flags && isAllowedEvar sigma flags f1) -> - unify_app_pattern true curenvnb pb opt substn cM f1 l1 cN cN [||] + unify_app_pattern true curenvnb pb opt substn cM f1 l1 cN cN [||] - | _, App (f2,l2) when - (isMeta sigma f2 && use_metas_pattern_unification sigma flags nb l2 + | _, App (f2,l2) when + (isMeta sigma f2 && use_metas_pattern_unification sigma flags nb l2 || use_evars_pattern_unification flags && isAllowedEvar sigma flags f2) -> - unify_app_pattern false curenvnb pb opt substn cM cM [||] cN f2 l2 + unify_app_pattern false curenvnb pb opt substn cM cM [||] cN f2 l2 + + | App (f1,l1), App (f2,l2) -> + unify_app curenvnb pb opt substn cM f1 l1 cN f2 l2 - | App (f1,l1), App (f2,l2) -> - unify_app curenvnb pb opt substn cM f1 l1 cN f2 l2 - - | App (f1,l1), Proj(p2,c2) -> - unify_app curenvnb pb opt substn cM f1 l1 cN cN [||] + | App (f1,l1), Proj(p2,c2) -> + unify_app curenvnb pb opt substn cM f1 l1 cN cN [||] - | Proj (p1,c1), App(f2,l2) -> - unify_app curenvnb pb opt substn cM cM [||] cN f2 l2 + | Proj (p1,c1), App(f2,l2) -> + unify_app curenvnb pb opt substn cM cM [||] cN f2 l2 - | _ -> + | _ -> unify_not_same_head curenvnb pb opt substn cM cN and unify_app_pattern dir curenvnb pb opt (sigma, _, _ as substn) cM f1 l1 cN f2 l2 = let f, l, t = if dir then f1, l1, cN else f2, l2, cM in match is_unification_pattern curenvnb sigma f (Array.to_list l) t with | None -> - (match EConstr.kind sigma t with - | App (f',l') -> - if dir then unify_app curenvnb pb opt substn cM f1 l1 t f' l' - else unify_app curenvnb pb opt substn t f' l' cN f2 l2 - | Proj _ -> unify_app curenvnb pb opt substn cM f1 l1 cN f2 l2 - | _ -> unify_not_same_head curenvnb pb opt substn cM cN) + (match EConstr.kind sigma t with + | App (f',l') -> + if dir then unify_app curenvnb pb opt substn cM f1 l1 t f' l' + else unify_app curenvnb pb opt substn t f' l' cN f2 l2 + | Proj _ -> unify_app curenvnb pb opt substn cM f1 l1 cN f2 l2 + | _ -> unify_not_same_head curenvnb pb opt substn cM cN) | Some l -> - solve_pattern_eqn_array curenvnb f l t substn + solve_pattern_eqn_array curenvnb f l t substn and unify_app (curenv, nb as curenvnb) pb opt (sigma, metas, evars as substn : subst0) cM f1 l1 cN f2 l2 = try - let needs_expansion p c' = - match EConstr.kind sigma c' with - | Meta _ -> true - | Evar _ -> true - | Const (c, u) -> Constant.equal c (Projection.constant p) - | _ -> false + let needs_expansion p c' = + match EConstr.kind sigma c' with + | Meta _ -> true + | Evar _ -> true + | Const (c, u) -> Constant.equal c (Projection.constant p) + | _ -> false in - let expand_proj c c' l = - match EConstr.kind sigma c with - | Proj (p, t) when not (Projection.unfolded p) && needs_expansion p c' -> - (try destApp sigma (Retyping.expand_projection curenv sigma p t (Array.to_list l)) + let expand_proj c c' l = + match EConstr.kind sigma c with + | Proj (p, t) when not (Projection.unfolded p) && needs_expansion p c' -> + (try destApp sigma (Retyping.expand_projection curenv sigma p t (Array.to_list l)) with RetypeError _ -> (* Unification can be called on ill-typed terms, due - to FO and eta in particular, fail gracefully in that case *) - (c, l)) - | _ -> (c, l) + to FO and eta in particular, fail gracefully in that case *) + (c, l)) + | _ -> (c, l) in let f1, l1 = expand_proj f1 f2 l1 in let f2, l2 = expand_proj f2 f1 l2 in let opta = {opt with at_top = true; with_types = false} in let optf = {opt with at_top = true; with_types = true} in let (f1,l1,f2,l2) = adjust_app_array_size f1 l1 f2 l2 in - if Array.length l1 == 0 then error_cannot_unify (fst curenvnb) sigma (cM,cN) - else - Array.fold_left2 (unirec_rec curenvnb CONV opta) - (unirec_rec curenvnb CONV optf substn f1 f2) l1 l2 + if Array.length l1 == 0 then error_cannot_unify (fst curenvnb) sigma (cM,cN) + else + Array.fold_left2 (unirec_rec curenvnb CONV opta) + (unirec_rec curenvnb CONV optf substn f1 f2) l1 l2 with ex when precatchable_exception ex -> try reduce curenvnb pb {opt with with_types = false} substn cM cN with ex when precatchable_exception ex -> @@ -952,14 +952,14 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e and unify_same_proj (curenv, nb as curenvnb) cv_pb opt substn c1 c2 = let substn = unirec_rec curenvnb CONV opt substn c1 c2 in try (* Force unification of the types to fill in parameters *) - let ty1 = get_type_of curenv ~lax:true sigma c1 in - let ty2 = get_type_of curenv ~lax:true sigma c2 in - unify_0_with_initial_metas substn true curenv cv_pb + let ty1 = get_type_of curenv ~lax:true sigma c1 in + let ty2 = get_type_of curenv ~lax:true sigma c2 in + unify_0_with_initial_metas substn true curenv cv_pb { flags with modulo_conv_on_closed_terms = Some TransparentState.full; modulo_delta = TransparentState.full; - modulo_eta = true; - modulo_betaiota = true } - ty1 ty2 + modulo_eta = true; + modulo_betaiota = true } + ty1 ty2 with RetypeError _ -> substn and unify_not_same_head curenvnb pb opt (sigma, metas, evars as substn : subst0) cM cN = @@ -968,41 +968,41 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e match constr_cmp cv_pb env sigma flags cM cN with | Some sigma -> (sigma, metas, evars) | None -> - try reduce curenvnb pb opt substn cM cN - with ex when precatchable_exception ex -> - let (f1,l1) = - match EConstr.kind sigma cM with App (f,l) -> (f,l) | _ -> (cM,[||]) in - let (f2,l2) = - match EConstr.kind sigma cN with App (f,l) -> (f,l) | _ -> (cN,[||]) in - expand curenvnb pb opt substn cM f1 l1 cN f2 l2 + try reduce curenvnb pb opt substn cM cN + with ex when precatchable_exception ex -> + let (f1,l1) = + match EConstr.kind sigma cM with App (f,l) -> (f,l) | _ -> (cM,[||]) in + let (f2,l2) = + match EConstr.kind sigma cN with App (f,l) -> (f,l) | _ -> (cN,[||]) in + expand curenvnb pb opt substn cM f1 l1 cN f2 l2 and reduce curenvnb pb opt (sigma, metas, evars as substn) cM cN = if flags.modulo_betaiota && not (subterm_restriction opt flags) then let cM' = do_reduce flags.modulo_delta curenvnb sigma cM in - if not (EConstr.eq_constr sigma cM cM') then - unirec_rec curenvnb pb opt substn cM' cN - else - let cN' = do_reduce flags.modulo_delta curenvnb sigma cN in - if not (EConstr.eq_constr sigma cN cN') then - unirec_rec curenvnb pb opt substn cM cN' - else error_cannot_unify (fst curenvnb) sigma (cM,cN) + if not (EConstr.eq_constr sigma cM cM') then + unirec_rec curenvnb pb opt substn cM' cN + else + let cN' = do_reduce flags.modulo_delta curenvnb sigma cN in + if not (EConstr.eq_constr sigma cN cN') then + unirec_rec curenvnb pb opt substn cM cN' + else error_cannot_unify (fst curenvnb) sigma (cM,cN) else error_cannot_unify (fst curenvnb) sigma (cM,cN) - + and expand (curenv,_ as curenvnb) pb opt (sigma,metasubst,evarsubst as substn : subst0) cM f1 l1 cN f2 l2 = let res = (* Try full conversion on meta-free terms. *) (* Back to 1995 (later on called trivial_unify in 2002), the - heuristic was to apply conversion on meta-free (but not - evar-free!) terms in all cases (i.e. for apply but also for - auto and rewrite, even though auto and rewrite did not use - modulo conversion in the rest of the unification - algorithm). By compatibility we need to support this - separately from the main unification algorithm *) + heuristic was to apply conversion on meta-free (but not + evar-free!) terms in all cases (i.e. for apply but also for + auto and rewrite, even though auto and rewrite did not use + modulo conversion in the rest of the unification + algorithm). By compatibility we need to support this + separately from the main unification algorithm *) (* The exploitation of known metas has been added in May 2007 - (it is used by apply and rewrite); it might now be redundant - with the support for delta-expansion (which is used - essentially for apply)... *) - if subterm_restriction opt flags then None else + (it is used by apply and rewrite); it might now be redundant + with the support for delta-expansion (which is used + essentially for apply)... *) + if subterm_restriction opt flags then None else match flags.modulo_conv_on_closed_terms with | None -> None | Some convflags -> @@ -1014,16 +1014,16 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e | None -> (* some undefined Metas in cN *) None | Some n1 -> (* No subterm restriction there, too much incompatibilities *) - let sigma = - if opt.with_types then - try (* Ensure we call conversion on terms of the same type *) - let tyM = get_type_of curenv ~lax:true sigma m1 in - let tyN = get_type_of curenv ~lax:true sigma n1 in - check_compatibility curenv CUMUL flags substn tyM tyN - with RetypeError _ -> - (* Renounce, maybe metas/evars prevents typing *) sigma - else sigma - in + let sigma = + if opt.with_types then + try (* Ensure we call conversion on terms of the same type *) + let tyM = get_type_of curenv ~lax:true sigma m1 in + let tyN = get_type_of curenv ~lax:true sigma n1 in + check_compatibility curenv CUMUL flags substn tyM tyN + with RetypeError _ -> + (* Renounce, maybe metas/evars prevents typing *) sigma + else sigma + in match infer_conv ~pb ~ts:convflags curenv sigma m1 n1 with | Some sigma -> Some (sigma, metasubst, evarsubst) @@ -1036,41 +1036,41 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e | Some substn -> substn | None -> let cf1 = key_of curenv sigma opt flags f1 and cf2 = key_of curenv sigma opt flags f2 in - match oracle_order curenv cf1 cf2 with - | None -> error_cannot_unify curenv sigma (cM,cN) - | Some true -> - (match expand_key flags.modulo_delta curenv sigma cf1 with - | Some c -> - unirec_rec curenvnb pb opt substn + match oracle_order curenv cf1 cf2 with + | None -> error_cannot_unify curenv sigma (cM,cN) + | Some true -> + (match expand_key flags.modulo_delta curenv sigma cf1 with + | Some c -> + unirec_rec curenvnb pb opt substn (whd_betaiotazeta sigma (mkApp(c,l1))) cN - | None -> - (match expand_key flags.modulo_delta curenv sigma cf2 with - | Some c -> - unirec_rec curenvnb pb opt substn cM + | None -> + (match expand_key flags.modulo_delta curenv sigma cf2 with + | Some c -> + unirec_rec curenvnb pb opt substn cM (whd_betaiotazeta sigma (mkApp(c,l2))) - | None -> - error_cannot_unify curenv sigma (cM,cN))) - | Some false -> - (match expand_key flags.modulo_delta curenv sigma cf2 with - | Some c -> - unirec_rec curenvnb pb opt substn cM + | None -> + error_cannot_unify curenv sigma (cM,cN))) + | Some false -> + (match expand_key flags.modulo_delta curenv sigma cf2 with + | Some c -> + unirec_rec curenvnb pb opt substn cM (whd_betaiotazeta sigma (mkApp(c,l2))) - | None -> - (match expand_key flags.modulo_delta curenv sigma cf1 with - | Some c -> - unirec_rec curenvnb pb opt substn + | None -> + (match expand_key flags.modulo_delta curenv sigma cf1 with + | Some c -> + unirec_rec curenvnb pb opt substn (whd_betaiotazeta sigma (mkApp(c,l1))) cN - | None -> - error_cannot_unify curenv sigma (cM,cN))) + | None -> + error_cannot_unify curenv sigma (cM,cN))) and canonical_projections (curenv, _ as curenvnb) pb opt cM cN (sigma,_,_ as substn) = let f1 () = if isApp_or_Proj sigma cM then - let f1l1 = whd_nored_state sigma (cM,Stack.empty) in - if is_open_canonical_projection curenv sigma f1l1 then - let f2l2 = whd_nored_state sigma (cN,Stack.empty) in - solve_canonical_projection curenvnb pb opt cM f1l1 cN f2l2 substn - else error_cannot_unify (fst curenvnb) sigma (cM,cN) + let f1l1 = whd_nored_state sigma (cM,Stack.empty) in + if is_open_canonical_projection curenv sigma f1l1 then + let f2l2 = whd_nored_state sigma (cN,Stack.empty) in + solve_canonical_projection curenvnb pb opt cM f1l1 cN f2l2 substn + else error_cannot_unify (fst curenvnb) sigma (cM,cN) else error_cannot_unify (fst curenvnb) sigma (cM,cN) in if not opt.with_cs || @@ -1078,16 +1078,16 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e | None -> true | Some _ -> subterm_restriction opt flags end then - error_cannot_unify (fst curenvnb) sigma (cM,cN) + error_cannot_unify (fst curenvnb) sigma (cM,cN) else - try f1 () with e when precatchable_exception e -> - if isApp_or_Proj sigma cN then - let f2l2 = whd_nored_state sigma (cN, Stack.empty) in - if is_open_canonical_projection curenv sigma f2l2 then - let f1l1 = whd_nored_state sigma (cM, Stack.empty) in - solve_canonical_projection curenvnb pb opt cN f2l2 cM f1l1 substn - else error_cannot_unify (fst curenvnb) sigma (cM,cN) - else error_cannot_unify (fst curenvnb) sigma (cM,cN) + try f1 () with e when precatchable_exception e -> + if isApp_or_Proj sigma cN then + let f2l2 = whd_nored_state sigma (cN, Stack.empty) in + if is_open_canonical_projection curenv sigma f2l2 then + let f1l1 = whd_nored_state sigma (cM, Stack.empty) in + solve_canonical_projection curenvnb pb opt cN f2l2 cM f1l1 substn + else error_cannot_unify (fst curenvnb) sigma (cM,cN) + else error_cannot_unify (fst curenvnb) sigma (cM,cN) and solve_canonical_projection curenvnb pb opt cM f1l1 cN f2l2 (sigma,ms,es) = let (ctx,t,c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) = @@ -1097,44 +1097,44 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e if Reductionops.Stack.compare_shape ts ts1 then let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in let (evd,ks,_) = - List.fold_left - (fun (evd,ks,m) b -> - if match n with Some n -> Int.equal m n | None -> false then + List.fold_left + (fun (evd,ks,m) b -> + if match n with Some n -> Int.equal m n | None -> false then (evd,t2::ks, m-1) else let mv = new_meta () in let evd' = meta_declare mv (substl ks b) evd in - (evd', mkMeta mv :: ks, m - 1)) - (sigma,[],List.length bs) bs + (evd', mkMeta mv :: ks, m - 1)) + (sigma,[],List.length bs) bs in try let opt' = {opt with with_types = false} in let substn = Reductionops.Stack.fold2 - (fun s u1 u -> unirec_rec curenvnb pb opt' s u1 (substl ks u)) - (evd,ms,es) us2 us in + (fun s u1 u -> unirec_rec curenvnb pb opt' s u1 (substl ks u)) + (evd,ms,es) us2 us in let substn = Reductionops.Stack.fold2 - (fun s u1 u -> unirec_rec curenvnb pb opt' s u1 (substl ks u)) - substn params1 params in + (fun s u1 u -> unirec_rec curenvnb pb opt' s u1 (substl ks u)) + substn params1 params in let substn = Reductionops.Stack.fold2 (fun s u1 u2 -> unirec_rec curenvnb pb opt' s u1 u2) substn ts ts1 in let app = mkApp (c, Array.rev_of_list ks) in (* let substn = unirec_rec curenvnb pb b false substn t cN in *) - unirec_rec curenvnb pb opt' substn c1 app + unirec_rec curenvnb pb opt' substn c1 app with Reductionops.Stack.IncompatibleFold2 -> - error_cannot_unify (fst curenvnb) sigma (cM,cN) + error_cannot_unify (fst curenvnb) sigma (cM,cN) else error_cannot_unify (fst curenvnb) sigma (cM,cN) in - + if !debug_unification then Feedback.msg_debug (str "Starting unification"); let opt = { at_top = conv_at_top; with_types = false; with_cs = true } in try - let res = + let res = if subterm_restriction opt flags || occur_meta_or_undefined_evar sigma m || occur_meta_or_undefined_evar sigma n then None - else + else let ans = match flags.modulo_conv_on_closed_terms with - | Some convflags -> infer_conv ~pb:cv_pb ~ts:convflags env sigma m n + | Some convflags -> infer_conv ~pb:cv_pb ~ts:convflags env sigma m n | _ -> constr_cmp cv_pb env sigma flags m n in match ans with | Some sigma -> ans @@ -1144,9 +1144,9 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e let open TransparentState in Id.Pred.subset dl.tr_var cv.tr_var && Cpred.subset dl.tr_cst cv.tr_cst | None, dl -> TransparentState.is_empty dl) - then error_cannot_unify env sigma (m, n) else None - in - let a = match res with + then error_cannot_unify env sigma (m, n) else None + in + let a = match res with | Some sigma -> sigma, ms, es | None -> unirec_rec (env,0) cv_pb opt subst m n in if !debug_unification then Feedback.msg_debug (str "Leaving unification with success"); @@ -1183,14 +1183,14 @@ let rec unify_with_eta keptside flags env sigma c1 c2 = (mkApp (lift 1 c1,[|mkRel 1|])) c2' | _ -> (keptside,unify_0 env sigma CONV flags c1 c2) - + (* We solved problems [?n =_pb u] (i.e. [u =_(opp pb) ?n]) and [?n =_pb' u'], we now compute the problem on [u =? u'] and decide which of u or u' is kept Rem: the upper constraint is lost in case u <= ?n <= u' (and symmetrically in the case u' <= ?n <= u) *) - + let merge_instances env sigma flags st1 st2 c1 c2 = match (opp_status st1, st2) with | (Conv, Conv) -> @@ -1217,7 +1217,7 @@ let merge_instances env sigma flags st1 st2 c1 c2 = (try (left, IsSuperType, unify_0 env sigma CUMUL flags c1 c2) with e when CErrors.noncritical e -> (right, IsSuperType, unify_0 env sigma CUMUL flags c2 c1)) - + (* Unification * * Procedure: @@ -1304,7 +1304,7 @@ let w_coerce_to_type env evd c cty mvty = fst (nat,nat)) and stops while it could have seen that it is rigid *) let cty = Tacred.hnf_constr env evd cty in try_to_coerce env evd c cty tycon - + let w_coerce env evd mv c = let cty = get_type_of env evd c in let mvty = Typing.meta_type evd mv in @@ -1319,7 +1319,7 @@ let unify_to_type env sigma flags c status u = let unify_type env sigma flags mv status c = let mvty = Typing.meta_type sigma mv in let mvty = nf_meta sigma mvty in - unify_to_type env sigma + unify_to_type env sigma (set_flags_for_type flags) c status mvty @@ -1353,89 +1353,89 @@ let w_merge env with_types flags (evd,metas,evars : subst0) = (* Process evars *) match evars with | (curenv,(evk,_ as ev),rhs)::evars' -> - if Evd.is_defined evd evk then - let v = mkEvar ev in - let (evd,metas',evars'') = - unify_0 curenv evd CONV flags rhs v in - w_merge_rec evd (metas'@metas) (evars''@evars') eqns - else begin - (* This can make rhs' ill-typed if metas are *) + if Evd.is_defined evd evk then + let v = mkEvar ev in + let (evd,metas',evars'') = + unify_0 curenv evd CONV flags rhs v in + w_merge_rec evd (metas'@metas) (evars''@evars') eqns + else begin + (* This can make rhs' ill-typed if metas are *) let rhs' = subst_meta_instances evd metas rhs in match EConstr.kind evd rhs with - | App (f,cl) when occur_meta evd rhs' -> - if occur_evar evd evk rhs' then + | App (f,cl) when occur_meta evd rhs' -> + if occur_evar evd evk rhs' then error_occur_check curenv evd evk rhs'; - if is_mimick_head evd flags.modulo_delta f then - let evd' = - mimick_undefined_evar evd flags f (Array.length cl) evk in - w_merge_rec evd' metas evars eqns - else - let evd' = - let evd', rhs'' = pose_all_metas_as_evars curenv evd rhs' in + if is_mimick_head evd flags.modulo_delta f then + let evd' = + mimick_undefined_evar evd flags f (Array.length cl) evk in + w_merge_rec evd' metas evars eqns + else + let evd' = + let evd', rhs'' = pose_all_metas_as_evars curenv evd rhs' in try solve_simple_evar_eqn eflags curenv evd' ev rhs'' - with Retyping.RetypeError _ -> - error_cannot_unify curenv evd' (mkEvar ev,rhs'') - in w_merge_rec evd' metas evars' eqns + with Retyping.RetypeError _ -> + error_cannot_unify curenv evd' (mkEvar ev,rhs'') + in w_merge_rec evd' metas evars' eqns | _ -> - let evd', rhs'' = pose_all_metas_as_evars curenv evd rhs' in - let evd' = + let evd', rhs'' = pose_all_metas_as_evars curenv evd rhs' in + let evd' = try solve_simple_evar_eqn eflags curenv evd' ev rhs'' - with Retyping.RetypeError _ -> error_cannot_unify curenv evd' (mkEvar ev, rhs'') - in - w_merge_rec evd' metas evars' eqns - end + with Retyping.RetypeError _ -> error_cannot_unify curenv evd' (mkEvar ev, rhs'') + in + w_merge_rec evd' metas evars' eqns + end | [] -> (* Process metas *) match metas with | (mv,c,(status,to_type))::metas -> let ((evd,c),(metas'',evars'')),eqns = - if with_types && to_type != TypeProcessed then - begin match to_type with - | CoerceToType -> + if with_types && to_type != TypeProcessed then + begin match to_type with + | CoerceToType -> (* Some coercion may have to be inserted *) - (w_coerce env evd mv c,([],[])),eqns - | _ -> + (w_coerce env evd mv c,([],[])),eqns + | _ -> (* No coercion needed: delay the unification of types *) - ((evd,c),([],[])),(mv,status,c)::eqns - end - else - ((evd,c),([],[])),eqns - in - if meta_defined evd mv then - let {rebus=c'},(status',_) = meta_fvalue evd mv in + ((evd,c),([],[])),(mv,status,c)::eqns + end + else + ((evd,c),([],[])),eqns + in + if meta_defined evd mv then + let {rebus=c'},(status',_) = meta_fvalue evd mv in let (take_left,st,(evd,metas',evars')) = merge_instances env evd flags status' status c' c - in - let evd' = + in + let evd' = if take_left then evd else meta_reassign mv (c,(st,TypeProcessed)) evd - in + in w_merge_rec evd' (metas'@metas@metas'') (evars'@evars'') eqns - else + else let evd' = if occur_meta_evd evd mv c then if isMetaOf evd mv (whd_all env evd c) then evd else error_cannot_unify env evd (mkMeta mv,c) else meta_assign mv (c,(status,TypeProcessed)) evd in - w_merge_rec evd' (metas''@metas) evars'' eqns + w_merge_rec evd' (metas''@metas) evars'' eqns | [] -> - (* Process type eqns *) - let rec process_eqns failures = function - | (mv,status,c)::eqns -> + (* Process type eqns *) + let rec process_eqns failures = function + | (mv,status,c)::eqns -> (match (try Inl (unify_type env evd flags mv status c) - with e when CErrors.noncritical e -> Inr e) - with - | Inr e -> process_eqns (((mv,status,c),e)::failures) eqns - | Inl (evd,metas,evars) -> - w_merge_rec evd metas evars (List.map fst failures @ eqns)) - | [] -> - (match failures with - | [] -> evd - | ((mv,status,c),e)::_ -> raise e) - in process_eqns [] eqns - + with e when CErrors.noncritical e -> Inr e) + with + | Inr e -> process_eqns (((mv,status,c),e)::failures) eqns + | Inl (evd,metas,evars) -> + w_merge_rec evd metas evars (List.map fst failures @ eqns)) + | [] -> + (match failures with + | [] -> evd + | ((mv,status,c),e)::_ -> raise e) + in process_eqns [] eqns + and mimick_undefined_evar evd flags hdc nargs sp = let ev = Evd.find_undefined evd sp in let sp_env = reset_with_named_context (evar_filtered_hyps ev) env in @@ -1448,7 +1448,7 @@ let w_merge env with_types flags (evd,metas,evars : subst0) = then Evd.define sp c evd''' else Evd.define sp (Evarutil.nf_evar evd''' c) evd''' in - let check_types evd = + let check_types evd = let metas = Evd.meta_list evd in let eqns = List.fold_left (fun acc (mv, b) -> match b with @@ -1740,17 +1740,17 @@ let make_abstraction env evd ccl abs = (make_eq_test env evd c) env evd c ty occs check_occs ccl -let keyed_unify env evd kop = +let keyed_unify env evd kop = if not !keyed_unification then fun cl -> true - else - match kop with + else + match kop with | None -> fun _ -> true | Some kop -> fun cl -> - let kc = Keys.constr_key (fun c -> EConstr.kind evd c) cl in - match kc with - | None -> false - | Some kc -> Keys.equiv_keys kop kc + let kc = Keys.constr_key (fun c -> EConstr.kind evd c) cl in + match kc with + | None -> false + | Some kc -> Keys.equiv_keys kop kc (* Tries to find an instance of term [cl] in term [op]. Unifies [cl] to every subterm of [op] until it finds a match. @@ -1765,59 +1765,59 @@ let w_unify_to_subterm env evd ?(flags=default_unify_flags ()) (op,cl) = (try if !keyed_unification then let f1, l1 = decompose_app_vect evd op in - let f2, l2 = decompose_app_vect evd cl in - w_typed_unify_array env evd flags f1 l1 f2 l2,cl - else w_typed_unify env evd CONV flags op cl,cl + let f2, l2 = decompose_app_vect evd cl in + w_typed_unify_array env evd flags f1 l1 f2 l2,cl + else w_typed_unify env evd CONV flags op cl,cl with ex when Pretype_errors.unsatisfiable_exception ex -> - bestexn := Some ex; user_err Pp.(str "Unsat")) + bestexn := Some ex; user_err Pp.(str "Unsat")) else user_err Pp.(str "Bound 1") with ex when precatchable_exception ex -> (match EConstr.kind evd cl with - | App (f,args) -> - let n = Array.length args in - assert (n>0); - let c1 = mkApp (f,Array.sub args 0 (n-1)) in - let c2 = args.(n-1) in - (try - matchrec c1 - with ex when precatchable_exception ex -> - matchrec c2) + | App (f,args) -> + let n = Array.length args in + assert (n>0); + let c1 = mkApp (f,Array.sub args 0 (n-1)) in + let c2 = args.(n-1) in + (try + matchrec c1 + with ex when precatchable_exception ex -> + matchrec c2) | Case(_,_,c,lf) -> (* does not search in the predicate *) - (try - matchrec c - with ex when precatchable_exception ex -> - iter_fail matchrec lf) + (try + matchrec c + with ex when precatchable_exception ex -> + iter_fail matchrec lf) | LetIn(_,c1,_,c2) -> - (try - matchrec c1 - with ex when precatchable_exception ex -> - matchrec c2) + (try + matchrec c1 + with ex when precatchable_exception ex -> + matchrec c2) - | Proj (p,c) -> matchrec c + | Proj (p,c) -> matchrec c | Fix(_,(_,types,terms)) -> - (try - iter_fail matchrec types - with ex when precatchable_exception ex -> - iter_fail matchrec terms) + (try + iter_fail matchrec types + with ex when precatchable_exception ex -> + iter_fail matchrec terms) | CoFix(_,(_,types,terms)) -> - (try - iter_fail matchrec types - with ex when precatchable_exception ex -> - iter_fail matchrec terms) + (try + iter_fail matchrec types + with ex when precatchable_exception ex -> + iter_fail matchrec terms) | Prod (_,t,c) -> - (try - matchrec t - with ex when precatchable_exception ex -> - matchrec c) + (try + matchrec t + with ex when precatchable_exception ex -> + matchrec c) | Lambda (_,t,c) -> - (try - matchrec t - with ex when precatchable_exception ex -> - matchrec c) + (try + matchrec t + with ex when precatchable_exception ex -> + matchrec c) | Cast (_, _, _) (* Is this expected? *) | Rel _ | Var _ | Meta _ | Evar _ | Sort _ | Const _ | Ind _ @@ -1856,36 +1856,36 @@ let w_unify_to_subterm_all env evd ?(flags=default_unify_flags ()) (op,cl) = let rec matchrec cl = let cl = strip_outer_cast evd cl in (bind - (if closed0 evd cl - then return (fun () -> w_typed_unify env evd CONV flags op cl,cl) + (if closed0 evd cl + then return (fun () -> w_typed_unify env evd CONV flags op cl,cl) else fail "Bound 1") (match EConstr.kind evd cl with - | App (f,args) -> - let n = Array.length args in - assert (n>0); - let c1 = mkApp (f,Array.sub args 0 (n-1)) in - let c2 = args.(n-1) in - bind (matchrec c1) (matchrec c2) + | App (f,args) -> + let n = Array.length args in + assert (n>0); + let c1 = mkApp (f,Array.sub args 0 (n-1)) in + let c2 = args.(n-1) in + bind (matchrec c1) (matchrec c2) | Case(_,_,c,lf) -> (* does not search in the predicate *) - bind (matchrec c) (bind_iter matchrec lf) + bind (matchrec c) (bind_iter matchrec lf) - | Proj (p,c) -> matchrec c + | Proj (p,c) -> matchrec c | LetIn(_,c1,_,c2) -> - bind (matchrec c1) (matchrec c2) + bind (matchrec c1) (matchrec c2) | Fix(_,(_,types,terms)) -> - bind (bind_iter matchrec types) (bind_iter matchrec terms) + bind (bind_iter matchrec types) (bind_iter matchrec terms) | CoFix(_,(_,types,terms)) -> - bind (bind_iter matchrec types) (bind_iter matchrec terms) + bind (bind_iter matchrec types) (bind_iter matchrec terms) | Prod (_,t,c) -> - bind (matchrec t) (matchrec c) + bind (matchrec t) (matchrec c) | Lambda (_,t,c) -> - bind (matchrec t) (matchrec c) + bind (matchrec t) (matchrec c) | Cast (_, _, _) -> fail "Match_subterm" (* Is this expected? *) @@ -1904,13 +1904,13 @@ let w_unify_to_subterm_list env evd flags hdmeta oplist t = (fun op (evd,l) -> let op = whd_meta evd op in if isMeta evd op then - if flags.allow_K_in_toplevel_higher_order_unification then (evd,op::l) - else error_abstraction_over_meta env evd hdmeta (destMeta evd op) + if flags.allow_K_in_toplevel_higher_order_unification then (evd,op::l) + else error_abstraction_over_meta env evd hdmeta (destMeta evd op) else let allow_K = flags.allow_K_in_toplevel_higher_order_unification in let flags = if unsafe_occur_meta_or_existential op || !keyed_unification then - (* This is up to delta for subterms w/o metas ... *) + (* This is up to delta for subterms w/o metas ... *) flags else (* up to Nov 2014, unification was bypassed on evar/meta-free terms; @@ -1918,29 +1918,29 @@ let w_unify_to_subterm_list env evd flags hdmeta oplist t = unify pre-existing non frozen evars of the goal or of the pattern *) set_no_delta_flags flags in - let t' = (strip_outer_cast evd op,t) in + let t' = (strip_outer_cast evd op,t) in let (evd',cl) = try - if is_keyed_unification () then - try (* First try finding a subterm w/o conversion on open terms *) - let flags = set_no_delta_open_flags flags in - w_unify_to_subterm env evd ~flags t' - with e -> - (* If this fails, try with full conversion *) - w_unify_to_subterm env evd ~flags t' - else w_unify_to_subterm env evd ~flags t' - with PretypeError (env,_,NoOccurrenceFound _) when + if is_keyed_unification () then + try (* First try finding a subterm w/o conversion on open terms *) + let flags = set_no_delta_open_flags flags in + w_unify_to_subterm env evd ~flags t' + with e -> + (* If this fails, try with full conversion *) + w_unify_to_subterm env evd ~flags t' + else w_unify_to_subterm env evd ~flags t' + with PretypeError (env,_,NoOccurrenceFound _) when allow_K || (* w_unify_to_subterm does not go through evars, so the next step, which was already in <= 8.4, is needed at least for compatibility of rewrite *) dependent evd op t -> (evd,op) in - if not allow_K && + if not allow_K && (* ensure we found a different instance *) - List.exists (fun op -> EConstr.eq_constr evd' op cl) l - then error_non_linear_unification env evd hdmeta cl - else (evd',cl::l)) + List.exists (fun op -> EConstr.eq_constr evd' op cl) l + then error_non_linear_unification env evd hdmeta cl + else (evd',cl::l)) oplist (evd,[]) @@ -2008,29 +2008,29 @@ let w_unify env evd cv_pb ?(flags=default_unify_flags ()) ty1 ty2 = match EConstr.kind evd hd1, not is_empty1, EConstr.kind evd hd2, not is_empty2 with (* Pattern case *) | (Meta _, true, Lambda _, _ | Lambda _, _, Meta _, true) - when Int.equal (Array.length l1) (Array.length l2) -> - (try - w_typed_unify_array env evd flags hd1 l1 hd2 l2 - with ex when precatchable_exception ex -> - try - w_unify2 env evd flags false cv_pb ty1 ty2 - with PretypeError (env,_,NoOccurrenceFound _) as e -> raise e) + when Int.equal (Array.length l1) (Array.length l2) -> + (try + w_typed_unify_array env evd flags hd1 l1 hd2 l2 + with ex when precatchable_exception ex -> + try + w_unify2 env evd flags false cv_pb ty1 ty2 + with PretypeError (env,_,NoOccurrenceFound _) as e -> raise e) (* Second order case *) | (Meta _, true, _, _ | _, _, Meta _, true) -> - (try - w_unify2 env evd flags false cv_pb ty1 ty2 - with PretypeError (env,_,NoOccurrenceFound _) as e -> raise e - | ex when precatchable_exception ex -> - try - w_typed_unify_array env evd flags hd1 l1 hd2 l2 - with ex' when precatchable_exception ex' -> + (try + w_unify2 env evd flags false cv_pb ty1 ty2 + with PretypeError (env,_,NoOccurrenceFound _) as e -> raise e + | ex when precatchable_exception ex -> + try + w_typed_unify_array env evd flags hd1 l1 hd2 l2 + with ex' when precatchable_exception ex' -> (* Last chance, use pattern-matching with typed dependencies (done late for compatibility) *) - try - w_unify2 env evd flags true cv_pb ty1 ty2 - with ex' when precatchable_exception ex' -> - raise ex) + try + w_unify2 env evd flags true cv_pb ty1 ty2 + with ex' when precatchable_exception ex' -> + raise ex) (* General case: try first order *) | _ -> w_typed_unify env evd cv_pb flags ty1 ty2 @@ -2040,7 +2040,7 @@ let w_unify env evd cv_pb ?(flags=default_unify_flags ()) ty1 ty2 = let w_unify env evd cv_pb flags ty1 ty2 = w_unify env evd cv_pb ~flags:flags ty1 ty2 -let w_unify = +let w_unify = if Flags.profile then let wunifkey = CProfile.declare_profile "w_unify" in CProfile.profile6 wunifkey w_unify diff --git a/pretyping/unification.mli b/pretyping/unification.mli index d7ddbcb721..e66234b4ae 100644 --- a/pretyping/unification.mli +++ b/pretyping/unification.mli @@ -121,7 +121,7 @@ val unify_0 : Environ.env -> types -> subst0 -val unify_0_with_initial_metas : +val unify_0_with_initial_metas : subst0 -> bool -> Environ.env -> diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index d15eb578c3..885fc8980d 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -50,7 +50,7 @@ let invert_tag cst tag reloc_tbl = let tagj,arity = reloc_tbl.(j) in let no_arity = Int.equal arity 0 in if Int.equal tag tagj && (cst && no_arity || not (cst || no_arity)) then - raise (Find_at j) + raise (Find_at j) else () done;raise Not_found with Find_at j -> (j+1) @@ -161,9 +161,9 @@ and nf_whd env sigma whd typ = let tag = btag b in let (tag,ofs) = if tag = Obj.last_non_constant_constructor_tag then - match whd_val (bfield b 0) with + match whd_val (bfield b 0) with | Vconstr_const tag -> (tag+Obj.last_non_constant_constructor_tag, 1) - | _ -> assert false + | _ -> assert false else (tag, 0) in let capp,ctyp = construct_of_constr_block env tag typ in let args = nf_bargs env sigma b ofs ctyp in @@ -248,11 +248,11 @@ and nf_stk ?from:(from=0) env sigma c t stk = | [] -> c | Zapp vargs :: stk -> if nargs vargs >= from then - let t, args = nf_args ~from:from env sigma vargs t in - nf_stk env sigma (mkApp(c,args)) t stk + let t, args = nf_args ~from:from env sigma vargs t in + nf_stk env sigma (mkApp(c,args)) t stk else - let rest = from - nargs vargs in - nf_stk ~from:rest env sigma c t stk + let rest = from - nargs vargs in + nf_stk ~from:rest env sigma c t stk | Zfix (f,vargs) :: stk -> assert (from = 0) ; let fa, typ = nf_fix_app env sigma f vargs in @@ -273,8 +273,8 @@ and nf_stk ?from:(from=0) env sigma c t stk = (* calcul des branches *) let bsw = branch_of_switch (nb_rel env) sw in let mkbranch i (n,v) = - let decl,decl_with_letin,codom = btypes.(i) in - let b = nf_val (Termops.push_rels_assum decl env) sigma v codom in + let decl,decl_with_letin,codom = btypes.(i) in + let b = nf_val (Termops.push_rels_assum decl env) sigma v codom in Termops.it_mkLambda_or_LetIn_from_no_LetIn b decl_with_letin in let branchs = Array.mapi mkbranch bsw in @@ -299,7 +299,7 @@ and nf_predicate env sigma ind mip params v pT = let k = nb_rel env in let vb = reduce_fun k f in let body = - nf_predicate (push_rel (LocalAssum (name,dom)) env) sigma ind mip params vb codom in + nf_predicate (push_rel (LocalAssum (name,dom)) env) sigma ind mip params vb codom in mkLambda(name,dom,body) | _ -> assert false end @@ -326,8 +326,8 @@ and nf_args env sigma vargs ?from:(f=0) t = Array.init len (fun i -> let _,dom,codom = decompose_prod env !t in - let c = nf_val env sigma (arg vargs (f+i)) dom in - t := subst1 c codom; c) in + let c = nf_val env sigma (arg vargs (f+i)) dom in + t := subst1 c codom; c) in !t,args and nf_bargs env sigma b ofs t = @@ -337,8 +337,8 @@ and nf_bargs env sigma b ofs t = Array.init len (fun i -> let _,dom,codom = decompose_prod env !t in - let c = nf_val env sigma (bfield b (i+ofs)) dom in - t := subst1 c codom; c) in + let c = nf_val env sigma (bfield b (i+ofs)) dom in + t := subst1 c codom; c) in args and nf_fun env sigma f typ = diff --git a/printing/printer.ml b/printing/printer.ml index 10a31ac256..a85e268306 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -304,10 +304,10 @@ let pr_rel_decl env sigma decl = let pbody = match decl with | RelDecl.LocalAssum _ -> mt () | RelDecl.LocalDef (_,c,_) -> - (* Force evaluation *) - let pb = pr_lconstr_env env sigma c in - let pb = if isCast c then surround pb else pb in - (str":=" ++ spc () ++ pb ++ spc ()) in + (* Force evaluation *) + let pb = pr_lconstr_env env sigma c in + let pb = if isCast c then surround pb else pb in + (str":=" ++ spc () ++ pb ++ spc ()) in let ptyp = pr_ltype_env env sigma typ in match na with | Anonymous -> hov 0 (str"<>" ++ spc () ++ pbody ++ str":" ++ spc () ++ ptyp) @@ -329,7 +329,7 @@ let pr_var_list_decl env sigma decl = let pr_named_context env sigma ne_context = hv 0 (Context.Named.fold_outside - (fun d pps -> pps ++ ws 2 ++ pr_named_decl env sigma d) + (fun d pps -> pps ++ ws 2 ++ pr_named_decl env sigma d) ne_context ~init:(mt ())) let pr_rel_context env sigma rel_context = @@ -436,7 +436,7 @@ let pr_predicate pr_elt (b, elts) = let pr_elts = prlist_with_sep spc pr_elt elts in if b then str"all" ++ - (if List.is_empty elts then mt () else str" except: " ++ pr_elts) + (if List.is_empty elts then mt () else str" except: " ++ pr_elts) else if List.is_empty elts then str"none" else pr_elts @@ -565,10 +565,10 @@ let pr_subgoal n sigma = let rec prrec p = function | [] -> user_err Pp.(str "No such goal.") | g::rest -> - if Int.equal p 1 then + if Int.equal p 1 then pr_selected_subgoal (int n) sigma g - else - prrec (p-1) rest + else + prrec (p-1) rest in prrec n @@ -736,7 +736,7 @@ let pr_subgoals ?(pr_first=true) ?(diffs=false) ?os_map pr_goal ~diffs ?og_s { it = g ; sigma = sigma } ++ (if l=[] then mt () else cut ()) ++ pr_rec 2 l - else + else pr_rec 1 (g::l) in let pr_evar_info gl sigma seeds = @@ -792,15 +792,15 @@ let pr_open_subgoals_diff ?(quiet=false) ?(diffs=false) ?oproof proof = begin match bgoals,shelf,given_up with | [] , [] , [] -> pr_subgoals None sigma ~seeds ~shelf ~stack ~unfocused:[] ~goals | [] , [] , _ -> - Feedback.msg_info (str "No more subgoals, but there are some goals you gave up:"); - fnl () + Feedback.msg_info (str "No more subgoals, but there are some goals you gave up:"); + fnl () ++ pr_subgoals ~pr_first:false None bsigma ~seeds ~shelf:[] ~stack:[] ~unfocused:[] ~goals:given_up ++ fnl () ++ str "You need to go back and solve them." | [] , _ , _ -> - Feedback.msg_info (str "All the remaining goals are on the shelf."); - fnl () + Feedback.msg_info (str "All the remaining goals are on the shelf."); + fnl () ++ pr_subgoals ~pr_first:false None bsigma ~seeds ~shelf:[] ~stack:[] ~unfocused:[] ~goals:shelf - | _ , _, _ -> + | _ , _, _ -> let cmd = if quiet then None else Some (str "This subproof is complete, but there are some unfocused goals." ++ @@ -809,8 +809,8 @@ let pr_open_subgoals_diff ?(quiet=false) ?(diffs=false) ?oproof proof = fnl ()) in pr_subgoals ~pr_first:false cmd bsigma ~seeds ~shelf ~stack:[] ~unfocused:[] ~goals:bgoals - end - | _ -> + end + | _ -> let { Evd.it = bgoals ; sigma = bsigma } = Proof.V82.background_subgoals p in let bgoals_focused, bgoals_unfocused = List.partition (fun x -> List.mem x goals) bgoals in let unfocused_if_needed = if should_unfoc() then bgoals_unfocused else [] in @@ -981,17 +981,17 @@ let pr_assumptionset env sigma s = let tran = safe_pr_constant env kn ++ safe_pr_ltype env sigma typ in (v, a, o, tran :: tr) in - let (vars, axioms, opaque, trans) = + let (vars, axioms, opaque, trans) = ContextObjectMap.fold fold s ([], [], [], []) in let theory = if is_impredicative_set env then - [str "Set is impredicative"] + [str "Set is impredicative"] else [] in let theory = if type_in_type env then - str "Type hierarchy is collapsed (logic is inconsistent)" :: theory + str "Type hierarchy is collapsed (logic is inconsistent)" :: theory else theory in let opt_list title = function diff --git a/printing/printmod.ml b/printing/printmod.ml index 4cc6bc2052..85bb287c22 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -63,9 +63,9 @@ let get_new_id locals id = let rec get_id l id = let dir = DirPath.make [id] in if not (Nametab.exists_dir dir) then - id + id else - get_id (Id.Set.add id l) (Namegen.next_ident_away id l) + get_id (Id.Set.add id l) (Namegen.next_ident_away id l) in let avoid = List.fold_left (fun accu (_, id) -> Id.Set.add id accu) Id.Set.empty locals in get_id avoid id @@ -205,10 +205,10 @@ let print_kn locals kn = pr_qualid qid with Not_found -> - try - print_local_modpath locals kn - with - Not_found -> print_modpath locals kn + try + print_local_modpath locals kn + with + Not_found -> print_modpath locals kn let nametab_register_dir obj_mp = let id = mk_fake_top () in @@ -234,11 +234,11 @@ let nametab_register_body mp dir (l,body) = | SFBmind mib -> let mind = MutInd.make2 mp l in Array.iteri - (fun i mip -> + (fun i mip -> push mip.mind_typename (GlobRef.IndRef (mind,i)); Array.iteri (fun j id -> push id (GlobRef.ConstructRef ((mind,i),j+1))) - mip.mind_consnames) - mib.mind_packets + mip.mind_consnames) + mib.mind_packets type mod_ops = { import_module : export:bool -> ModPath.t -> unit @@ -285,22 +285,22 @@ let print_body is_impl extent env mp (l,body) = | SFBconst cb -> let ctx = Declareops.constant_polymorphic_context cb in (match cb.const_body with - | Def _ -> def "Definition" ++ spc () - | OpaqueDef _ when is_impl -> def "Theorem" ++ spc () - | _ -> def "Parameter" ++ spc ()) ++ name ++ + | Def _ -> def "Definition" ++ spc () + | OpaqueDef _ when is_impl -> def "Theorem" ++ spc () + | _ -> def "Parameter" ++ spc ()) ++ name ++ (match extent with | OnlyNames -> mt () | WithContents -> let bl = UnivNames.universe_binders_with_opt_names ctx None in let sigma = Evd.from_ctx (UState.of_binders bl) in - str " :" ++ spc () ++ + str " :" ++ spc () ++ hov 0 (Printer.pr_ltype_env env sigma cb.const_type) ++ - (match cb.const_body with - | Def l when is_impl -> - spc () ++ - hov 2 (str ":= " ++ + (match cb.const_body with + | Def l when is_impl -> + spc () ++ + hov 2 (str ":= " ++ Printer.pr_lconstr_env env sigma (Mod_subst.force_constr l)) - | _ -> mt ()) ++ str "." ++ + | _ -> mt ()) ++ str "." ++ Printer.pr_abstract_universe_ctx sigma ctx) | SFBmind mib -> match extent with @@ -314,7 +314,7 @@ let print_body is_impl extent env mp (l,body) = | BiFinite -> def "Variant" | CoFinite -> def "CoInductive" in - keyword ++ spc () ++ name) + keyword ++ spc () ++ name) let print_struct is_impl extent env mp struc = prlist_with_sep spc (print_body is_impl extent env mp) struc @@ -324,7 +324,7 @@ let print_structure ~mod_ops is_type extent env mp locals struc = nametab_register_module_body ~mod_ops mp struc; let kwd = if is_type then "Sig" else "Struct" in hv 2 (keyword kwd ++ spc () ++ print_struct false extent env' mp struc ++ - brk (1,-2) ++ keyword "End") + brk (1,-2) ++ keyword "End") let rec flatten_app mexpr l = match mexpr with | MEapply (mexpr, arg) -> flatten_app mexpr (arg::l) @@ -339,7 +339,7 @@ let rec print_typ_expr extent env mp locals mty = let fapp = List.hd lapp in let mapp = List.tl lapp in hov 3 (str"(" ++ (print_kn locals fapp) ++ spc () ++ - prlist_with_sep spc (print_modpath locals) mapp ++ str")") + prlist_with_sep spc (print_modpath locals) mapp ++ str")") | MEwith(me,WithDef(idl,(c, _)))-> let s = String.concat "." (List.map Id.to_string idl) in let body = match extent with @@ -378,7 +378,7 @@ let rec print_functor ~mod_ops fty fatom is_type extent env mp locals = function let kwd = if is_type then "Funsig" else "Functor" in hov 2 (keyword kwd ++ spc () ++ - str "(" ++ Id.print id ++ str ":" ++ pr_mtb1 ++ str ")" ++ + str "(" ++ Id.print id ++ str ":" ++ pr_mtb1 ++ str ")" ++ spc() ++ print_functor ~mod_ops fty fatom is_type extent env' mp locals' me2) let rec print_expression ~mod_ops x = @@ -399,11 +399,11 @@ let rec printable_body dir = try let open Nametab.GlobDirRef in match Nametab.locate_dir (qualid_of_dirpath dir) with - DirOpenModtype _ -> false - | DirModule _ | DirOpenModule _ -> printable_body dir - | _ -> true + DirOpenModtype _ -> false + | DirModule _ | DirOpenModule _ -> printable_body dir + | _ -> true with - Not_found -> true + Not_found -> true (** Since we might play with nametab above, we should reset to prior state after the printing *) diff --git a/proofs/clenv.ml b/proofs/clenv.ml index 0dcc55a1cb..58c0f7db53 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -51,11 +51,11 @@ let refresh_undefined_univs clenv = match EConstr.kind clenv.evd clenv.templval.rebus with | Var _ -> clenv, Univ.empty_level_subst | App (f, args) when isVar clenv.evd f -> clenv, Univ.empty_level_subst - | _ -> + | _ -> let evd', subst = Evd.refresh_undefined_universes clenv.evd in let map_freelisted f = { f with rebus = subst_univs_level_constr subst f.rebus } in { clenv with evd = evd'; templval = map_freelisted clenv.templval; - templtyp = map_freelisted clenv.templtyp }, subst + templtyp = map_freelisted clenv.templtyp }, subst let clenv_hnf_constr ce t = hnf_constr (cl_env ce) (cl_sigma ce) t @@ -68,16 +68,16 @@ let clenv_push_prod cl = let rec clrec typ = match EConstr.kind cl.evd typ with | Cast (t,_,_) -> clrec t | Prod (na,t,u) -> - let mv = new_meta () in - let dep = not (noccurn (cl_sigma cl) 1 u) in + let mv = new_meta () in + let dep = not (noccurn (cl_sigma cl) 1 u) in let na' = if dep then na.binder_name else Anonymous in let e' = meta_declare mv t ~name:na' cl.evd in - let concl = if dep then subst1 (mkMeta mv) u else u in - let def = applist (cl.templval.rebus,[mkMeta mv]) in - { templval = mk_freelisted def; - templtyp = mk_freelisted concl; - evd = e'; - env = cl.env } + let concl = if dep then subst1 (mkMeta mv) u else u in + let def = applist (cl.templval.rebus,[mkMeta mv]) in + { templval = mk_freelisted def; + templtyp = mk_freelisted concl; + evd = e'; + env = cl.env } | _ -> raise NotExtensibleClause in clrec typ @@ -102,12 +102,12 @@ let clenv_environments evd bound t = | (Some 0, _) -> (e, List.rev metas, t) | (n, Cast (t,_,_)) -> clrec (e,metas) n t | (n, Prod (na,t1,t2)) -> - let mv = new_meta () in - let dep = not (noccurn evd 1 t2) in + let mv = new_meta () in + let dep = not (noccurn evd 1 t2) in let na' = if dep then na.binder_name else Anonymous in let e' = meta_declare mv t1 ~name:na' e in - clrec (e', (mkMeta mv)::metas) (Option.map ((+) (-1)) n) - (if dep then (subst1 (mkMeta mv) t2) else t2) + clrec (e', (mkMeta mv)::metas) (Option.map ((+) (-1)) n) + (if dep then (subst1 (mkMeta mv) t2) else t2) | (n, LetIn (na,b,_,t)) -> clrec (e,metas) n (subst1 b t) | (n, _) -> (e, List.rev metas, t) in @@ -167,7 +167,7 @@ let clenv_assign mv rhs clenv = if not (EConstr.eq_constr clenv.evd (fst (meta_fvalue clenv.evd mv)).rebus rhs) then error_incompatible_inst clenv mv else - clenv + clenv else let st = (Conv,TypeNotProcessed) in {clenv with evd = meta_assign mv (rhs_fls.rebus,st) clenv.evd} @@ -226,8 +226,8 @@ let dependent_closure clenv mvs = let rec aux mvs acc = Metaset.fold (fun mv deps -> - let metas_of_meta_type = clenv_metas_in_type_of_meta clenv.evd mv in - aux metas_of_meta_type (Metaset.union deps metas_of_meta_type)) + let metas_of_meta_type = clenv_metas_in_type_of_meta clenv.evd mv in + aux metas_of_meta_type (Metaset.union deps metas_of_meta_type)) mvs acc in aux mvs mvs @@ -241,9 +241,9 @@ let clenv_dependent_gen hyps_only ?(iter=true) clenv = List.filter (fun mv -> if hyps_only then - Metaset.mem mv deps_in_hyps && not (Metaset.mem mv deps_in_concl) + Metaset.mem mv deps_in_hyps && not (Metaset.mem mv deps_in_concl) else - Metaset.mem mv deps_in_hyps || Metaset.mem mv deps_in_concl) + Metaset.mem mv deps_in_hyps || Metaset.mem mv deps_in_concl) all_undefined let clenv_missing ce = clenv_dependent_gen true ce @@ -336,8 +336,8 @@ let clenv_pose_metas_as_evars clenv dep_mvs = let src = evar_source_of_meta mv clenv.evd in let src = adjust_meta_source clenv.evd mv src in let evd = clenv.evd in - let (evd, evar) = new_evar (cl_env clenv) evd ~src ty in - let clenv = clenv_assign mv evar {clenv with evd=evd} in + let (evd, evar) = new_evar (cl_env clenv) evd ~src ty in + let clenv = clenv_assign mv evar {clenv with evd=evd} in fold clenv (fst (destEvar evd evar) :: evs) mvs in fold clenv [] dep_mvs @@ -415,13 +415,13 @@ let qhyp_eq h1 h2 = match h1, h2 with let check_bindings bl = match List.duplicates qhyp_eq (List.map (fun {CAst.v=x} -> fst x) bl) with | NamedHyp s :: _ -> - user_err - (str "The variable " ++ Id.print s ++ - str " occurs more than once in binding list."); + user_err + (str "The variable " ++ Id.print s ++ + str " occurs more than once in binding list."); | AnonHyp n :: _ -> - user_err - (str "The position " ++ int n ++ - str " occurs more than once in binding list.") + user_err + (str "The position " ++ int n ++ + str " occurs more than once in binding list.") | [] -> () let explain_no_such_bound_variable evd id = @@ -472,7 +472,7 @@ let meta_of_binder clause loc mvs = function let error_already_defined b = match b with | NamedHyp id -> - user_err + user_err (str "Binder name \"" ++ Id.print id ++ str"\" already defined with incompatible value.") | AnonHyp n -> @@ -488,12 +488,12 @@ let clenv_unify_binding_type clenv c t u = try let evd,c = w_coerce_to_type (cl_env clenv) clenv.evd c t u in TypeProcessed, { clenv with evd = evd }, c - with + with | PretypeError (_,_,ActualTypeNotCoercible (_,_, (NotClean _ | ConversionFailed _))) as e -> - raise e + raise e | e when precatchable_exception e -> - TypeNotProcessed, clenv, c + TypeNotProcessed, clenv, c let clenv_assign_binding clenv k c = let k_typ = clenv_hnf_constr clenv (clenv_meta_type clenv k) in @@ -509,12 +509,12 @@ let clenv_match_args bl clenv = check_bindings bl; List.fold_left (fun clenv {CAst.loc;v=(b,c)} -> - let k = meta_of_binder clenv loc mvs b in + let k = meta_of_binder clenv loc mvs b in if meta_defined clenv.evd k then if EConstr.eq_constr clenv.evd (fst (meta_fvalue clenv.evd k)).rebus c then clenv else error_already_defined b else - clenv_assign_binding clenv k c) + clenv_assign_binding clenv k c) clenv bl exception NoSuchBinding @@ -525,7 +525,7 @@ let clenv_constrain_last_binding c clenv = clenv_assign_binding clenv k c let error_not_right_number_missing_arguments n = - user_err + user_err (strbrk "Not the right number of missing arguments (expected " ++ int n ++ str ").") @@ -538,14 +538,14 @@ let clenv_constrain_dep_args hyps_only bl clenv = List.fold_left2 clenv_assign_binding clenv occlist bl else if hyps_only then - (* Tolerance for compatibility <= 8.3 *) - let occlist' = clenv_dependent_gen hyps_only ~iter:false clenv in - if Int.equal (List.length occlist') (List.length bl) then - List.fold_left2 clenv_assign_binding clenv occlist' bl - else - error_not_right_number_missing_arguments (List.length occlist) + (* Tolerance for compatibility <= 8.3 *) + let occlist' = clenv_dependent_gen hyps_only ~iter:false clenv in + if Int.equal (List.length occlist') (List.length bl) then + List.fold_left2 clenv_assign_binding clenv occlist' bl + else + error_not_right_number_missing_arguments (List.length occlist) else - error_not_right_number_missing_arguments (List.length occlist) + error_not_right_number_missing_arguments (List.length occlist) (****************************************************************) (* Clausal environment for an application *) @@ -557,7 +557,7 @@ let make_clenv_binding_gen hyps_only n env sigma (c,t) = function | ExplicitBindings lbind -> let t = rename_bound_vars_as_displayed sigma Id.Set.empty [] t in let clause = mk_clenv_from_env env sigma n - (c, t) + (c, t) in clenv_match_args lbind clause | NoBindings -> mk_clenv_from_env env sigma n (c,t) @@ -567,7 +567,7 @@ let make_clenv_binding_env_apply env sigma n = let make_clenv_binding_env env sigma = make_clenv_binding_gen false None env sigma - + let make_clenv_binding_apply env sigma n = make_clenv_binding_gen true n env sigma let make_clenv_binding env sigma = make_clenv_binding_gen false None env sigma @@ -659,7 +659,7 @@ let evar_with_name holes id = | [] -> explain_no_such_bound_variable holes id | [h] -> h.hole_evar | _ -> - user_err + user_err (str "Binder name \"" ++ Id.print id ++ str "\" occurs more than once in clause.") diff --git a/proofs/clenv.mli b/proofs/clenv.mli index eecd318287..3fca967395 100644 --- a/proofs/clenv.mli +++ b/proofs/clenv.mli @@ -24,10 +24,10 @@ open Tactypes type clausenv = { env : env; (** the typing context *) - evd : evar_map; (** the mapping from metavar and evar numbers to their - types and values *) - templval : constr freelisted; (** the template which we are trying to fill - out *) + evd : evar_map; (** the mapping from metavar and evar numbers to their + types and values *) + templval : constr freelisted; (** the template which we are trying to fill + out *) templtyp : constr freelisted (** its type *)} @@ -92,8 +92,8 @@ val clenv_unify_meta_types : ?flags:unify_flags -> clausenv -> clausenv (** start with a clenv to refine with a given term with bindings *) -(** the arity of the lemma is fixed - the optional int tells how many prods of the lemma have to be used +(** the arity of the lemma is fixed + the optional int tells how many prods of the lemma have to be used use all of them if None *) val make_clenv_binding_env_apply : env -> evar_map -> int option -> EConstr.constr * EConstr.constr -> constr bindings -> diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml index 8e7d1df29a..611671255d 100644 --- a/proofs/clenvtac.ml +++ b/proofs/clenvtac.ml @@ -35,15 +35,15 @@ let clenv_cast_meta clenv = and crec_hd u = match EConstr.kind clenv.evd (strip_outer_cast clenv.evd u) with | Meta mv -> - (try + (try let b = Typing.meta_type clenv.evd mv in - assert (not (occur_meta clenv.evd b)); - if occur_meta clenv.evd b then u + assert (not (occur_meta clenv.evd b)); + if occur_meta clenv.evd b then u else mkCast (mkMeta mv, DEFAULTcast, b) - with Not_found -> u) + with Not_found -> u) | App(f,args) -> mkApp (crec_hd f, Array.map crec args) | Case(ci,p,c,br) -> - mkCase (ci, crec_hd p, crec_hd c, Array.map crec br) + mkCase (ci, crec_hd p, crec_hd c, Array.map crec br) | Proj (p, c) -> mkProj (p, crec_hd c) | _ -> u in @@ -130,6 +130,6 @@ let unify ?(flags=fail_quick_unif_flags) m = let evd = clear_metas (Tacmach.New.project gl) in try let evd' = w_unify env evd CONV ~flags m n in - Proofview.Unsafe.tclEVARSADVANCE evd' + Proofview.Unsafe.tclEVARSADVANCE evd' with e when CErrors.noncritical e -> Proofview.tclZERO e end diff --git a/proofs/evar_refiner.ml b/proofs/evar_refiner.ml index 6c9c95e342..59918ab2f9 100644 --- a/proofs/evar_refiner.ml +++ b/proofs/evar_refiner.ml @@ -61,7 +61,7 @@ let w_refine (evk,evi) (ltac_var,rawc) sigma = env sigma ltac_var (Pretyping.OfType evi.evar_concl) rawc with e when CErrors.noncritical e -> let loc = Glob_ops.loc_of_glob_constr rawc in - user_err ?loc + user_err ?loc (str "Instance is not well-typed in the environment of " ++ Termops.pr_existential_key sigma evk ++ str ".") in diff --git a/proofs/goal.ml b/proofs/goal.ml index f95a904a5f..426fba7f63 100644 --- a/proofs/goal.ml +++ b/proofs/goal.ml @@ -121,12 +121,12 @@ module V82 = struct try ignore (Environ.lookup_named (NamedDecl.get_id decl) genv); false with Not_found -> true in Environ.fold_named_context_reverse (fun t decl -> - if is_proof_var decl then + if is_proof_var decl then let decl = Termops.map_named_decl EConstr.of_constr decl in - mkNamedProd_or_LetIn decl t - else - t - ) ~init:(concl sigma gl) env + mkNamedProd_or_LetIn decl t + else + t + ) ~init:(concl sigma gl) env end diff --git a/proofs/goal.mli b/proofs/goal.mli index 46b54f9c2c..7b16d869e9 100644 --- a/proofs/goal.mli +++ b/proofs/goal.mli @@ -21,7 +21,7 @@ val uid : goal -> string (* Debugging help *) val pr_goal : goal -> Pp.t -(* Layer to implement v8.2 tactic engine ontop of the new architecture. +(* Layer to implement v8.2 tactic engine ontop of the new architecture. Types are different from what they used to be due to a change of the internal types. *) module V82 : sig @@ -42,7 +42,7 @@ module V82 : sig (* Old style mk_goal primitive, returns a new goal with corresponding hypotheses and conclusion, together with a term which is precisely the evar corresponding to the goal, and an updated evar_map. *) - val mk_goal : Evd.evar_map -> + val mk_goal : Evd.evar_map -> Environ.named_context_val -> EConstr.constr -> goal * EConstr.constr * Evd.evar_map @@ -61,7 +61,7 @@ module V82 : sig val nf_evar : Evd.evar_map -> goal -> goal * Evd.evar_map (* Goal represented as a type, doesn't take into account section variables *) - val abstract_type : Evd.evar_map -> goal -> EConstr.types + val abstract_type : Evd.evar_map -> goal -> EConstr.types end diff --git a/proofs/logic.ml b/proofs/logic.ml index a9843e080e..a361c4208e 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -68,7 +68,7 @@ let catchable_exception = function (* reduction errors *) | Tacred.ReductionTacticError _ -> true (* unification and typing errors *) - | PretypeError(_,_, e) -> is_unification_error e || is_typing_error e + | PretypeError(_,_, e) -> is_unification_error e || is_typing_error e | _ -> false let error_no_such_hypothesis env sigma id = raise (RefinerError (env, sigma, NoSuchHyp id)) @@ -207,15 +207,15 @@ let split_sign env sigma hfrom hto l = | [] -> error_no_such_hypothesis env sigma hfrom | d :: right -> let hyp = NamedDecl.get_id d in - if Id.equal hyp hfrom then - (left,right,d, toleft || move_location_eq hto MoveLast) - else + if Id.equal hyp hfrom then + (left,right,d, toleft || move_location_eq hto MoveLast) + else let is_toleft = match hto with | MoveAfter h' | MoveBefore h' -> Id.equal hyp h' | _ -> false in - splitrec (d::left) (toleft || is_toleft) - right + splitrec (d::left) (toleft || is_toleft) + right in splitrec [] false l @@ -232,29 +232,29 @@ let move_hyp env sigma toleft (left,declfrom,right) hto = in let rec moverec first middle = function | [] -> - if match hto with MoveFirst | MoveLast -> false | _ -> true then + if match hto with MoveFirst | MoveLast -> false | _ -> true then error_no_such_hypothesis env sigma (hyp_of_move_location hto); - List.rev first @ List.rev middle + List.rev first @ List.rev middle | d :: _ as right when move_location_eq hto (MoveBefore (NamedDecl.get_id d)) -> - List.rev first @ List.rev middle @ right + List.rev first @ List.rev middle @ right | d :: right -> let hyp = NamedDecl.get_id d in - let (first',middle') = - if List.exists (test_dep d) middle then - if not (move_location_eq hto (MoveAfter hyp)) then - (first, d::middle) + let (first',middle') = + if List.exists (test_dep d) middle then + if not (move_location_eq hto (MoveAfter hyp)) then + (first, d::middle) else - user_err ~hdr:"move_hyp" (str "Cannot move " ++ Id.print (NamedDecl.get_id declfrom) ++ + user_err ~hdr:"move_hyp" (str "Cannot move " ++ Id.print (NamedDecl.get_id declfrom) ++ pr_move_location Id.print hto ++ - str (if toleft then ": it occurs in the type of " else ": it depends on ") - ++ Id.print hyp ++ str ".") + str (if toleft then ": it occurs in the type of " else ": it depends on ") + ++ Id.print hyp ++ str ".") else - (d::first, middle) - in - if move_location_eq hto (MoveAfter hyp) then - List.rev first' @ List.rev middle' @ right - else - moverec first' middle' right + (d::first, middle) + in + if move_location_eq hto (MoveAfter hyp) then + List.rev first' @ List.rev middle' @ right + else + moverec first' middle' right in let open EConstr in if toleft then @@ -265,7 +265,7 @@ let move_hyp env sigma toleft (left,declfrom,right) hto = else let right = List.fold_right push_named_context_val - (moverec [] [declfrom] right) empty_named_context_val in + (moverec [] [declfrom] right) empty_named_context_val in List.fold_left (fun sign d -> push_named_context_val d sign) right left @@ -328,7 +328,7 @@ exception Stop of EConstr.t list let meta_free_prefix sigma a = try let a = Array.map EConstr.of_constr a in - let _ = Array.fold_left (fun acc a -> + let _ = Array.fold_left (fun acc a -> if occur_meta sigma a then raise (Stop acc) else a :: acc) [] a in a @@ -355,69 +355,69 @@ let rec mk_refgoals sigma goal goalacc conclty trm = match kind trm with | Meta _ -> let conclty = nf_betaiota env sigma (EConstr.of_constr conclty) in - if !check && occur_meta sigma conclty then + if !check && occur_meta sigma conclty then raise (RefinerError (env, sigma, MetaInType conclty)); - let (gl,ev,sigma) = mk_goal hyps conclty in - let ev = EConstr.Unsafe.to_constr ev in - let conclty = EConstr.Unsafe.to_constr conclty in - gl::goalacc, conclty, sigma, ev + let (gl,ev,sigma) = mk_goal hyps conclty in + let ev = EConstr.Unsafe.to_constr ev in + let conclty = EConstr.Unsafe.to_constr conclty in + gl::goalacc, conclty, sigma, ev | Cast (t,k, ty) -> - check_typability env sigma ty; + check_typability env sigma ty; let sigma = check_conv_leq_goal env sigma trm ty conclty in - let res = mk_refgoals sigma goal goalacc ty t in + let res = mk_refgoals sigma goal goalacc ty t in (* we keep the casts (in particular VMcast and NATIVEcast) except when they are annotating metas *) - if isMeta t then begin - assert (k != VMcast && k != NATIVEcast); - res - end else - let (gls,cty,sigma,ans) = res in + if isMeta t then begin + assert (k != VMcast && k != NATIVEcast); + res + end else + let (gls,cty,sigma,ans) = res in let ans = if ans == t then trm else mkCast(ans,k,ty) in - (gls,cty,sigma,ans) + (gls,cty,sigma,ans) | App (f,l) -> - let (acc',hdty,sigma,applicand) = + let (acc',hdty,sigma,applicand) = if Termops.is_template_polymorphic_ind env sigma (EConstr.of_constr f) then - let ty = - (* Template polymorphism of definitions and inductive types *) - let firstmeta = Array.findi (fun i x -> occur_meta sigma (EConstr.of_constr x)) l in - let args, _ = Option.cata (fun i -> CArray.chop i l) (l, [||]) firstmeta in - type_of_global_reference_knowing_parameters env sigma (EConstr.of_constr f) (Array.map EConstr.of_constr args) - in - let ty = EConstr.Unsafe.to_constr ty in - goalacc, ty, sigma, f - else - mk_hdgoals sigma goal goalacc f - in - let ((acc'',conclty',sigma), args) = mk_arggoals sigma goal acc' hdty l in + let ty = + (* Template polymorphism of definitions and inductive types *) + let firstmeta = Array.findi (fun i x -> occur_meta sigma (EConstr.of_constr x)) l in + let args, _ = Option.cata (fun i -> CArray.chop i l) (l, [||]) firstmeta in + type_of_global_reference_knowing_parameters env sigma (EConstr.of_constr f) (Array.map EConstr.of_constr args) + in + let ty = EConstr.Unsafe.to_constr ty in + goalacc, ty, sigma, f + else + mk_hdgoals sigma goal goalacc f + in + let ((acc'',conclty',sigma), args) = mk_arggoals sigma goal acc' hdty l in let sigma = check_conv_leq_goal env sigma trm conclty' conclty in let ans = if applicand == f && args == l then trm else mkApp (applicand, args) in (acc'',conclty',sigma, ans) | Proj (p,c) -> - let (acc',cty,sigma,c') = mk_hdgoals sigma goal goalacc c in - let c = mkProj (p, c') in - let ty = get_type_of env sigma (EConstr.of_constr c) in - let ty = EConstr.Unsafe.to_constr ty in - (acc',ty,sigma,c) + let (acc',cty,sigma,c') = mk_hdgoals sigma goal goalacc c in + let c = mkProj (p, c') in + let ty = get_type_of env sigma (EConstr.of_constr c) in + let ty = EConstr.Unsafe.to_constr ty in + (acc',ty,sigma,c) | Case (ci,p,c,lf) -> - let (acc',lbrty,conclty',sigma,p',c') = mk_casegoals sigma goal goalacc p c in - let sigma = check_conv_leq_goal env sigma trm conclty' conclty in + let (acc',lbrty,conclty',sigma,p',c') = mk_casegoals sigma goal goalacc p c in + let sigma = check_conv_leq_goal env sigma trm conclty' conclty in let (acc'',sigma,rbranches) = treat_case sigma goal ci lbrty lf acc' in let lf' = Array.rev_of_list rbranches in let ans = if p' == p && c' == c && Array.equal (==) lf' lf then trm else mkCase (ci,p',c',lf') in - (acc'',conclty',sigma, ans) + (acc'',conclty',sigma, ans) | _ -> - if occur_meta sigma (EConstr.of_constr trm) then - anomaly (Pp.str "refiner called with a meta in non app/case subterm."); - let (sigma, t'ty) = goal_type_of env sigma trm in - let sigma = check_conv_leq_goal env sigma trm t'ty conclty in + if occur_meta sigma (EConstr.of_constr trm) then + anomaly (Pp.str "refiner called with a meta in non app/case subterm."); + let (sigma, t'ty) = goal_type_of env sigma trm in + let sigma = check_conv_leq_goal env sigma trm t'ty conclty in (goalacc,t'ty,sigma, trm) (* Same as mkREFGOALS but without knowing the type of the term. Therefore, @@ -426,53 +426,53 @@ let rec mk_refgoals sigma goal goalacc conclty trm = and mk_hdgoals sigma goal goalacc trm = let env = Goal.V82.env sigma goal in let hyps = Goal.V82.hyps sigma goal in - let mk_goal hyps concl = + let mk_goal hyps concl = Goal.V82.mk_goal sigma hyps concl in match kind trm with | Cast (c,_, ty) when isMeta c -> - check_typability env sigma ty; + check_typability env sigma ty; let (gl,ev,sigma) = mk_goal hyps (nf_betaiota env sigma (EConstr.of_constr ty)) in - let ev = EConstr.Unsafe.to_constr ev in - gl::goalacc,ty,sigma,ev + let ev = EConstr.Unsafe.to_constr ev in + gl::goalacc,ty,sigma,ev | Cast (t,_, ty) -> - check_typability env sigma ty; - mk_refgoals sigma goal goalacc ty t + check_typability env sigma ty; + mk_refgoals sigma goal goalacc ty t | App (f,l) -> - let (acc',hdty,sigma,applicand) = + let (acc',hdty,sigma,applicand) = if Termops.is_template_polymorphic_ind env sigma (EConstr.of_constr f) - then - let l' = meta_free_prefix sigma l in - (goalacc,EConstr.Unsafe.to_constr (type_of_global_reference_knowing_parameters env sigma (EConstr.of_constr f) l'),sigma,f) - else mk_hdgoals sigma goal goalacc f - in - let ((acc'',conclty',sigma), args) = mk_arggoals sigma goal acc' hdty l in + then + let l' = meta_free_prefix sigma l in + (goalacc,EConstr.Unsafe.to_constr (type_of_global_reference_knowing_parameters env sigma (EConstr.of_constr f) l'),sigma,f) + else mk_hdgoals sigma goal goalacc f + in + let ((acc'',conclty',sigma), args) = mk_arggoals sigma goal acc' hdty l in let ans = if applicand == f && args == l then trm else mkApp (applicand, args) in - (acc'',conclty',sigma, ans) + (acc'',conclty',sigma, ans) | Case (ci,p,c,lf) -> - let (acc',lbrty,conclty',sigma,p',c') = mk_casegoals sigma goal goalacc p c in + let (acc',lbrty,conclty',sigma,p',c') = mk_casegoals sigma goal goalacc p c in let (acc'',sigma,rbranches) = treat_case sigma goal ci lbrty lf acc' in - let lf' = Array.rev_of_list rbranches in - let ans = + let lf' = Array.rev_of_list rbranches in + let ans = if p' == p && c' == c && Array.equal (==) lf' lf then trm else mkCase (ci,p',c',lf') - in - (acc'',conclty',sigma, ans) + in + (acc'',conclty',sigma, ans) | Proj (p,c) -> let (acc',cty,sigma,c') = mk_hdgoals sigma goal goalacc c in - let c = mkProj (p, c') in + let c = mkProj (p, c') in let ty = get_type_of env sigma (EConstr.of_constr c) in let ty = EConstr.Unsafe.to_constr ty in - (acc',ty,sigma,c) + (acc',ty,sigma,c) | _ -> - if !check && occur_meta sigma (EConstr.of_constr trm) then - anomaly (Pp.str "refine called with a dependent meta."); + if !check && occur_meta sigma (EConstr.of_constr trm) then + anomaly (Pp.str "refine called with a dependent meta."); let (sigma, ty) = goal_type_of env sigma trm in - goalacc, ty, sigma, trm + goalacc, ty, sigma, trm and mk_arggoals sigma goal goalacc funty allargs = let foldmap (goalacc, funty, sigma) harg = diff --git a/proofs/proof.ml b/proofs/proof.ml index 5f07cc1acc..2ee006631a 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -19,7 +19,7 @@ - Focus: a proof has a focus stack: the top of the stack contains the context in which to unfocus the current view to a view focused with the rest of the stack. - In addition, this contains, for each of the focus context, a + In addition, this contains, for each of the focus context, a "focus kind" and a "focus condition" (in practice, and for modularity, the focus kind is actually stored inside the condition). To unfocus, one needs to know the focus kind, and the condition (for instance "no condition" or @@ -179,7 +179,7 @@ let cond_of_focus pr = | (cond,_,_)::_ -> cond | _ -> raise FullyUnfocused -(* An auxiliary function to pop and read the last {!Proofview.focus_context} +(* An auxiliary function to pop and read the last {!Proofview.focus_context} on the focus stack. *) let pop_focus pr = match pr.focus_stack with @@ -202,7 +202,7 @@ let _unfocus pr = { pr with proofview = Proofview.unfocus fc pr.proofview } (* Focus command (focuses on the [i]th subgoal) *) -(* spiwack: there could also, easily be a focus-on-a-range tactic, is there +(* spiwack: there could also, easily be a focus-on-a-range tactic, is there a need for it? *) let focus cond inf i pr = try _focus cond (Obj.repr inf) i i pr @@ -250,7 +250,7 @@ let rec unfocus kind pr () = | Loose -> begin try let pr = _unfocus pr in - unfocus kind pr () + unfocus kind pr () with FullyUnfocused -> raise CannotUnfocusThisWay end @@ -412,7 +412,7 @@ module V82 = struct let top_goal p = let { Evd.it=gls ; sigma=sigma; } = - Proofview.V82.top_goals p.entry p.proofview + Proofview.V82.top_goals p.entry p.proofview in { Evd.it=List.hd gls ; sigma=sigma; } diff --git a/proofs/proof.mli b/proofs/proof.mli index 9973df492d..134b0146b6 100644 --- a/proofs/proof.mli +++ b/proofs/proof.mli @@ -19,7 +19,7 @@ - Focus: a proof has a focus stack: the top of the stack contains the context in which to unfocus the current view to a view focused with the rest of the stack. - In addition, this contains, for each of the focus context, a + In addition, this contains, for each of the focus context, a "focus kind" and a "focus condition" (in practice, and for modularity, the focus kind is actually stored inside the condition). To unfocus, one needs to know the focus kind, and the condition (for instance "no condition" or @@ -107,7 +107,7 @@ val new_focus_kind : unit -> 'a focus_kind the action which focused. Conditions always carry a focus kind, and inherit their type parameter from it.*) -type 'a focus_condition +type 'a focus_condition (* [no_cond] only checks that the unfocusing command uses the right [focus_kind]. If [loose_end] (default [false]) is [true], then if the [focus_kind] @@ -126,7 +126,7 @@ val no_cond : ?loose_end:bool -> 'a focus_kind -> 'a focus_condition val done_cond : ?loose_end:bool -> 'a focus_kind -> 'a focus_condition (* focus command (focuses on the [i]th subgoal) *) -(* spiwack: there could also, easily be a focus-on-a-range tactic, is there +(* spiwack: there could also, easily be a focus-on-a-range tactic, is there a need for it? *) val focus : 'a focus_condition -> 'a -> int -> t -> t diff --git a/proofs/proof_bullet.ml b/proofs/proof_bullet.ml index 5702156b65..66e2ae5c29 100644 --- a/proofs/proof_bullet.ml +++ b/proofs/proof_bullet.ml @@ -50,7 +50,7 @@ module Strict = struct | Suggest of t (* this bullet is mandatory here *) | Unfinished of t (* no mandatory bullet here, but this bullet is unfinished *) | NoBulletInUse (* No mandatory bullet (or brace) here, no bullet pending, - some focused goals exists. *) + some focused goals exists. *) | NeedClosingBrace (* Some unfocussed goal exists "{" needed to focus them *) | ProofFinished (* No more goal anywhere *) diff --git a/proofs/refiner.ml b/proofs/refiner.ml index e1896d51e3..832a749ef2 100644 --- a/proofs/refiner.ml +++ b/proofs/refiner.ml @@ -89,7 +89,7 @@ let thens3parts_tac tacfi tac tacli (sigr,gs) = let gll = (List.map_i (fun i -> apply_sig_tac sigr (if i<nf then tacfi.(i) else if i>=ng-nl then tacli.(nl-ng+i) else tac)) - 0 gs) in + 0 gs) in (sigr,List.flatten gll) (* Apply [taci.(i)] on the first n subgoals and [tac] on the others *) @@ -188,13 +188,13 @@ let tclSHOWHYPS (tac : tactic) (goal: Goal.goal Evd.sigma) (fun hypl -> List.subtract cmp hypl oldhyps) hyps in - let s = + let s = let frst = ref true in List.fold_left (fun acc lh -> acc ^ (if !frst then (frst:=false;"") else " | ") ^ (List.fold_left - (fun acc d -> (Names.Id.to_string (NamedDecl.get_id d)) ^ " " ^ acc) - "" lh)) + (fun acc d -> (Names.Id.to_string (NamedDecl.get_id d)) ^ " " ^ acc) + "" lh)) "" newhyps in Feedback.msg_notice (str "<infoH>" @@ -273,5 +273,5 @@ let tclAT_LEAST_ONCE t = (tclTHEN t (tclREPEAT t)) (* Change evars *) let tclEVARS sigma gls = tclIDTAC {gls with sigma=sigma} -let tclPUSHEVARUNIVCONTEXT ctx gl = +let tclPUSHEVARUNIVCONTEXT ctx gl = tclEVARS (Evd.merge_universe_context (project gl) ctx) gl diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index def67abad7..aed1c89bfe 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -43,7 +43,7 @@ val pf_get_hyp_typ : Goal.goal sigma -> Id.t -> types val pf_get_new_id : Id.t -> Goal.goal sigma -> Id.t val pf_apply : (env -> evar_map -> 'a) -> Goal.goal sigma -> 'a -val pf_eapply : (env -> evar_map -> 'a -> evar_map * 'b) -> +val pf_eapply : (env -> evar_map -> 'a -> evar_map * 'b) -> Goal.goal sigma -> 'a -> Goal.goal sigma * 'b val pf_reduce : (env -> evar_map -> constr -> constr) -> diff --git a/stm/coqworkmgrApi.ml b/stm/coqworkmgrApi.ml index 92dc77172f..2b39a7a2aa 100644 --- a/stm/coqworkmgrApi.ml +++ b/stm/coqworkmgrApi.ml @@ -69,7 +69,7 @@ let parse_response s = let p = try int_of_string p with _ -> raise ParseError in Pong (n,m,p) | _ -> raise ParseError - + let print_request = function | Hello Low -> "HELLO LOW\n" | Hello High -> "HELLO HIGH\n" @@ -101,7 +101,7 @@ let option_map f = function None -> None | Some x -> Some (f x) let init p = try let sock = Sys.getenv "COQWORKMGR_SOCK" in - manager := option_map (fun s -> + manager := option_map (fun s -> let cout = Unix.out_channel_of_descr s in set_binary_mode_out cout true; let cin = Unix.in_channel_of_descr s in diff --git a/stm/dag.mli b/stm/dag.mli index 3a291c8d52..1cd593fdad 100644 --- a/stm/dag.mli +++ b/stm/dag.mli @@ -9,12 +9,12 @@ (************************************************************************) module type S = sig - + type node module NodeSet : Set.S with type elt = node type ('edge,'info,'cdata) t - + val empty : ('e,'i,'d) t val add_edge : ('e,'i,'d) t -> node -> 'e -> node -> ('e,'i,'d) t @@ -45,7 +45,7 @@ module type S = sig val property_of : ('e,'i,'d) t -> node -> 'd Property.t list val del_property : ('e,'i,'d) t -> 'd Property.t -> ('e,'i,'d) t - val iter : ('e,'i,'d) t -> + val iter : ('e,'i,'d) t -> (node -> 'd Property.t list -> 'i option -> (node * 'e) list -> unit) -> unit diff --git a/stm/proofBlockDelimiter.ml b/stm/proofBlockDelimiter.ml index a487799b74..0e8c463b19 100644 --- a/stm/proofBlockDelimiter.ml +++ b/stm/proofBlockDelimiter.ml @@ -108,7 +108,7 @@ let () = register_proof_block_delimiter "bullet" static_bullet dynamic_bullet (* ******************** { block } ***************************************** *) - + let static_curly_brace ({ entry_point; prev_node } as view) = let open Vernacexpr in assert(entry_point.ast.CAst.v.expr = VernacEndSubproof); @@ -169,7 +169,7 @@ let static_indent ({ entry_point; prev_node } as view) = else crawl view ~init:(Some last_tac) (fun prev node -> if node.indentation >= last_tac.indentation then `Cont node - else + else `Found { block_stop = entry_point.id; block_start = node.id; dynamic_switch = node.id; carry_on_data = of_vernac_control_val entry_point.ast } @@ -180,7 +180,7 @@ let dynamic_indent doc { dynamic_switch = id; carry_on_data = e } = match is_focused_goal_simple ~doc id with | `Simple [] -> `Leaks | `Simple focused -> - let but_last = List.tl (List.rev focused) in + let but_last = List.tl (List.rev focused) in `ValidBlock { base_state = id; goals_to_admit = but_last; diff --git a/stm/vcs.ml b/stm/vcs.ml index 78edeb53d3..26be9ae76f 100644 --- a/stm/vcs.ml +++ b/stm/vcs.ml @@ -24,20 +24,20 @@ module type S = sig end type id - + type ('kind) branch_info = { kind : [> `Master] as 'kind; root : id; pos : id; } - + type ('kind,'diff,'info,'property_data) t constraint 'kind = [> `Master ] - + val empty : id -> ('kind,'diff,'info,'property_data) t - + val current_branch : ('k,'e,'i,'c) t -> Branch.t val branches : ('k,'e,'i,'c) t -> Branch.t list - + val get_branch : ('k,'e,'i,'c) t -> Branch.t -> 'k branch_info val reset_branch : ('k,'e,'i,'c) t -> Branch.t -> id -> ('k,'e,'i,'c) t val branch : @@ -52,7 +52,7 @@ module type S = sig ('k,'diff,'i,'c) t -> id -> ours:'diff -> theirs:'diff -> at:id -> Branch.t -> ('k,'diff,'i,'c) t val checkout : ('k,'e,'i,'c) t -> Branch.t -> ('k,'e,'i,'c) t - + val set_info : ('k,'e,'info,'c) t -> id -> 'info -> ('k,'e,'info,'c) t val get_info : ('k,'e,'info,'c) t -> id -> 'info option @@ -62,7 +62,7 @@ module type S = sig val create_property : ('k,'e,'i,'c) t -> id list -> 'c -> ('k,'e,'i,'c) t val property_of : ('k,'e,'i,'c) t -> id -> 'c Dag.Property.t list - val delete_property : ('k,'e,'i,'c) t -> 'c Dag.Property.t -> ('k,'e,'i,'c) t + val delete_property : ('k,'e,'i,'c) t -> 'c Dag.Property.t -> ('k,'e,'i,'c) t (* Removes all unreachable nodes and returns them *) val gc : ('k,'e,'info,'c) t -> ('k,'e,'info,'c) t * Dag.NodeSet.t diff --git a/stm/vcs.mli b/stm/vcs.mli index f6ca81257b..584560f833 100644 --- a/stm/vcs.mli +++ b/stm/vcs.mli @@ -41,20 +41,20 @@ module type S = sig end type id - + type ('kind) branch_info = { kind : [> `Master] as 'kind; root : id; pos : id; } - + type ('kind,'diff,'info,'property_data) t constraint 'kind = [> `Master ] - + val empty : id -> ('kind,'diff,'info,'property_data) t - + val current_branch : ('k,'e,'i,'c) t -> Branch.t val branches : ('k,'e,'i,'c) t -> Branch.t list - + val get_branch : ('k,'e,'i,'c) t -> Branch.t -> 'k branch_info val reset_branch : ('k,'e,'i,'c) t -> Branch.t -> id -> ('k,'e,'i,'c) t val branch : @@ -69,25 +69,25 @@ module type S = sig ('k,'diff,'i,'c) t -> id -> ours:'diff -> theirs:'diff -> at:id -> Branch.t -> ('k,'diff,'i,'c) t val checkout : ('k,'e,'i,'c) t -> Branch.t -> ('k,'e,'i,'c) t - + val set_info : ('k,'e,'info,'c) t -> id -> 'info -> ('k,'e,'info,'c) t val get_info : ('k,'e,'info,'c) t -> id -> 'info option (* Read only dag *) module Dag : Dag.S with type node = id val dag : ('kind,'diff,'info,'cdata) t -> ('diff,'info,'cdata) Dag.t - + (* Properties are not a concept typical of a VCS, but a useful metadata * of a DAG (or graph). *) val create_property : ('k,'e,'i,'c) t -> id list -> 'c -> ('k,'e,'i,'c) t val property_of : ('k,'e,'i,'c) t -> id -> 'c Dag.Property.t list - val delete_property : ('k,'e,'i,'c) t -> 'c Dag.Property.t -> ('k,'e,'i,'c) t + val delete_property : ('k,'e,'i,'c) t -> 'c Dag.Property.t -> ('k,'e,'i,'c) t (* Removes all unreachable nodes and returns them *) val gc : ('k,'e,'info,'c) t -> ('k,'e,'info,'c) t * Dag.NodeSet.t val reachable : ('k,'e,'info,'c) t -> id -> Dag.NodeSet.t - + end module Make(OT : Map.OrderedType) : S diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index ff0bf0ac2a..c5b3e0931b 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -74,7 +74,7 @@ let classify_vernac e = | VernacShow _ | VernacPrint _ | VernacSearch _ | VernacLocate _ | VernacCheckMayEval _ -> VtQuery (* ProofStep *) - | VernacProof _ + | VernacProof _ | VernacFocus _ | VernacUnfocus | VernacSubproof _ | VernacCheckGuard @@ -83,7 +83,7 @@ let classify_vernac e = VtProofStep { parallel = `No; proof_block_detection = None } | VernacBullet _ -> VtProofStep { parallel = `No; proof_block_detection = Some "bullet" } - | VernacEndSubproof -> + | VernacEndSubproof -> VtProofStep { parallel = `No; proof_block_detection = Some "curly" } (* StartProof *) @@ -146,7 +146,7 @@ let classify_vernac e = | VernacUniverse _ | VernacConstraint _ | VernacCanonical _ | VernacCoercion _ | VernacIdentityCoercion _ | VernacAddLoadPath _ | VernacRemoveLoadPath _ | VernacAddMLPath _ - | VernacChdir _ + | VernacChdir _ | VernacCreateHintDb _ | VernacRemoveHints _ | VernacHints _ | VernacArguments _ | VernacReserve _ diff --git a/stm/vio_checking.ml b/stm/vio_checking.ml index baa7b3570c..837ba3d880 100644 --- a/stm/vio_checking.ml +++ b/stm/vio_checking.ml @@ -52,7 +52,7 @@ let schedule_vio_checking j fs = | ((f',id),_,_) :: tl when last = f' -> aux last (id::acc) tl | ((f',id),_,_) :: _ as l -> (last,acc) :: aux f' [] l in aux f [] l in - let prog = Sys.argv.(0) in + let prog = Sys.argv.(0) in let stdargs = filter_argv false (List.tl (Array.to_list Sys.argv)) in let make_job () = let cur = ref 0.0 in @@ -79,7 +79,7 @@ let schedule_vio_checking j fs = let cmp_job (f1,_,_) (f2,_,_) = compare f1 f2 in List.flatten (List.map (fun (f, tl) -> - "-check-vio-tasks" :: + "-check-vio-tasks" :: String.concat "," (List.map string_of_int tl) :: [f]) (pack (List.sort cmp_job !what))) in let rc = ref 0 in @@ -115,7 +115,7 @@ let schedule_vio_compilation j fs = | s :: rest when String.length s > 0 && s.[0] = '-' && b -> filter_argv false (s :: rest) | _ :: rest when b -> filter_argv b rest | s :: rest -> s :: filter_argv b rest in - let prog = Sys.argv.(0) in + let prog = Sys.argv.(0) in let stdargs = filter_argv false (List.tl (Array.to_list Sys.argv)) in let all_jobs = !jobs in let make_job () = diff --git a/stm/workerPool.ml b/stm/workerPool.ml index f77ced2f3a..d82741576e 100644 --- a/stm/workerPool.ml +++ b/stm/workerPool.ml @@ -88,7 +88,7 @@ let rec create_worker extra pool priority id = let cpanel = { exit; cancelled; extra } in let manager = CThread.create (Model.manager cpanel) worker in { name; cancel; manager; process } - + and cleanup x priority = locking x begin fun { workers; count; extra_arg } -> workers := List.map (function | { cancel } as w when !cancel = false -> w diff --git a/stm/workerPool.mli b/stm/workerPool.mli index 5468a24959..88175a788c 100644 --- a/stm/workerPool.mli +++ b/stm/workerPool.mli @@ -31,7 +31,7 @@ end module Make(Model : PoolModel) : sig type pool - + val create : Model.extra -> size:int -> CoqworkmgrApi.priority -> pool val is_empty : pool -> bool diff --git a/tactics/auto.ml b/tactics/auto.ml index 0b465418f2..9c1a975330 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -135,9 +135,9 @@ let conclPattern concl pat tac = match pat with | None -> Proofview.tclUNIT Id.Map.empty | Some pat -> - try - Proofview.tclUNIT (Constr_matching.matches env sigma pat concl) - with Constr_matching.PatternMatchingFailure -> + try + Proofview.tclUNIT (Constr_matching.matches env sigma pat concl) + with Constr_matching.PatternMatchingFailure -> Tacticals.New.tclZEROMSG (str "pattern-matching failed") in Proofview.Goal.enter begin fun gl -> @@ -323,9 +323,9 @@ let rec trivial_fail_db dbg mod_delta db_list local_db = let nf c = Evarutil.nf_evar sigma c in let decl = Tacmach.New.pf_last_hyp gl in let hyp = Context.Named.Declaration.map_constr nf decl in - let hintl = make_resolve_hyp env sigma hyp - in trivial_fail_db dbg mod_delta db_list - (Hint_db.add_list env sigma hintl local_db) + let hintl = make_resolve_hyp env sigma hyp + in trivial_fail_db dbg mod_delta db_list + (Hint_db.add_list env sigma hintl local_db) end) in Proofview.Goal.enter begin fun gl -> @@ -350,31 +350,31 @@ and my_find_search_delta sigma db_list local_db secvars hdc concl = let f = hintmap_of sigma secvars hdc concl in if occur_existential sigma concl then List.map_append - (fun db -> - if Hint_db.use_dn db then - let flags = flags_of_state (Hint_db.transparent_state db) in - List.map (fun x -> (Some flags,x)) (f db) - else - let flags = auto_flags_of_state (Hint_db.transparent_state db) in - List.map (fun x -> (Some flags,x)) (f db)) - (local_db::db_list) + (fun db -> + if Hint_db.use_dn db then + let flags = flags_of_state (Hint_db.transparent_state db) in + List.map (fun x -> (Some flags,x)) (f db) + else + let flags = auto_flags_of_state (Hint_db.transparent_state db) in + List.map (fun x -> (Some flags,x)) (f db)) + (local_db::db_list) else List.map_append (fun db -> - if Hint_db.use_dn db then - let flags = flags_of_state (Hint_db.transparent_state db) in - List.map (fun x -> (Some flags, x)) (f db) - else + if Hint_db.use_dn db then + let flags = flags_of_state (Hint_db.transparent_state db) in + List.map (fun x -> (Some flags, x)) (f db) + else let st = Hint_db.transparent_state db in - let flags, l = - let l = - match hdc with None -> Hint_db.map_none ~secvars db - | Some hdc -> + let flags, l = + let l = + match hdc with None -> Hint_db.map_none ~secvars db + | Some hdc -> if TransparentState.is_empty st - then Hint_db.map_auto sigma ~secvars hdc concl db - else Hint_db.map_existential sigma ~secvars hdc concl db - in auto_flags_of_state st, l - in List.map (fun x -> (Some flags,x)) l) - (local_db::db_list) + then Hint_db.map_auto sigma ~secvars hdc concl db + else Hint_db.map_existential sigma ~secvars hdc concl db + in auto_flags_of_state st, l + in List.map (fun x -> (Some flags,x)) l) + (local_db::db_list) and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly;db=dbname})) = let tactic = function @@ -384,13 +384,13 @@ and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly;db= | Res_pf_THEN_trivial_fail (c,cl) -> Tacticals.New.tclTHEN (unify_resolve_gen ~poly flags (c,cl)) - (* With "(debug) trivial", we shouldn't end here, and - with "debug auto" we don't display the details of inner trivial *) + (* With "(debug) trivial", we shouldn't end here, and + with "debug auto" we don't display the details of inner trivial *) (trivial_fail_db (no_dbg dbg) (not (Option.is_empty flags)) db_list local_db) | Unfold_nth c -> Proofview.Goal.enter begin fun gl -> if exists_evaluable_reference (Tacmach.New.pf_env gl) c then - Tacticals.New.tclPROGRESS (reduce (Unfold [AllOccurrences,c]) Locusops.onConcl) + Tacticals.New.tclPROGRESS (reduce (Unfold [AllOccurrences,c]) Locusops.onConcl) else Tacticals.New.tclFAIL 0 (str"Unbound reference") end | Extern tacast -> @@ -409,12 +409,12 @@ and trivial_resolve sigma dbg mod_delta db_list local_db secvars cl = try let head = try let hdconstr = decompose_app_bound sigma cl in - Some hdconstr + Some hdconstr with Bound -> None in List.map (tac_of_hint dbg db_list local_db cl) - (priority - (my_find_search mod_delta sigma db_list local_db secvars head cl)) + (priority + (my_find_search mod_delta sigma db_list local_db secvars head cl)) with Not_found -> [] (** The use of the "core" database can be de-activated by passing @@ -458,11 +458,11 @@ let possible_resolve sigma dbg mod_delta db_list local_db secvars cl = try let head = try let hdconstr = decompose_app_bound sigma cl in - Some hdconstr + Some hdconstr with Bound -> None in List.map (tac_of_hint dbg db_list local_db cl) - (my_find_search mod_delta sigma db_list local_db secvars head cl) + (my_find_search mod_delta sigma db_list local_db secvars head cl) with Not_found -> [] let extend_local_db decl db gl = @@ -490,16 +490,16 @@ let search d n mod_delta db_list local_db = Proofview.tclEXTEND [] begin if Int.equal n 0 then Tacticals.New.tclZEROMSG (str"BOUND 2") else Tacticals.New.tclORELSE0 (dbg_assumption d) - (Tacticals.New.tclORELSE0 (intro_register d (search d n) local_db) - ( Proofview.Goal.enter begin fun gl -> + (Tacticals.New.tclORELSE0 (intro_register d (search d n) local_db) + ( Proofview.Goal.enter begin fun gl -> let concl = Tacmach.New.pf_concl gl in let sigma = Tacmach.New.project gl in let secvars = compute_secvars gl in - let d' = incr_dbg d in - Tacticals.New.tclFIRST - (List.map - (fun ntac -> Tacticals.New.tclTHEN ntac (search d' (n-1) local_db)) - (possible_resolve sigma d mod_delta db_list local_db secvars concl)) + let d' = incr_dbg d in + Tacticals.New.tclFIRST + (List.map + (fun ntac -> Tacticals.New.tclTHEN ntac (search d' (n-1) local_db)) + (possible_resolve sigma d mod_delta db_list local_db secvars concl)) end)) end [] in @@ -519,7 +519,7 @@ let delta_auto debug mod_delta n lems dbnames = (search d n mod_delta db_list hints) end -let delta_auto = +let delta_auto = if Flags.profile then let key = CProfile.declare_profile "delta_auto" in CProfile.profile5 key delta_auto diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index 0bc410010c..cd6f445503 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -20,11 +20,11 @@ open Locus (* Rewriting rules *) type rew_rule = { rew_lemma: constr; - rew_type: types; - rew_pat: constr; - rew_ctx: Univ.ContextSet.t; - rew_l2r: bool; - rew_tac: Genarg.glob_generic_argument option } + rew_type: types; + rew_pat: constr; + rew_ctx: Univ.ContextSet.t; + rew_l2r: bool; + rew_tac: Genarg.glob_generic_argument option } let subst_hint subst hint = let cst' = subst_mps subst hint.rew_lemma in @@ -33,8 +33,8 @@ let subst_hint subst hint = let t' = Option.Smart.map (Genintern.generic_substitute subst) hint.rew_tac in if hint.rew_lemma == cst' && hint.rew_type == typ' && hint.rew_tac == t' then hint else { hint with - rew_lemma = cst'; rew_type = typ'; - rew_pat = pat'; rew_tac = t' } + rew_lemma = cst'; rew_type = typ'; + rew_pat = pat'; rew_tac = t' } module HintIdent = struct @@ -79,13 +79,13 @@ let print_rewrite_hintdb bas = let env = Global.env () in let sigma = Evd.from_env env in (str "Database " ++ str bas ++ fnl () ++ - prlist_with_sep fnl - (fun h -> - str (if h.rew_l2r then "rewrite -> " else "rewrite <- ") ++ + prlist_with_sep fnl + (fun h -> + str (if h.rew_l2r then "rewrite -> " else "rewrite <- ") ++ Printer.pr_lconstr_env env sigma h.rew_lemma ++ str " of type " ++ Printer.pr_lconstr_env env sigma h.rew_type ++ - Option.cata (fun tac -> str " then use tactic " ++ + Option.cata (fun tac -> str " then use tactic " ++ Pputils.pr_glb_generic env sigma tac) (mt ()) h.rew_tac) - (find_rewrites bas)) + (find_rewrites bas)) type raw_rew_rule = (constr Univ.in_universe_context_set * bool * Genarg.raw_generic_argument option) CAst.t @@ -116,7 +116,7 @@ let one_base general_rewrite_maybe_in tac_main bas = Tacticals.New.tclREPEAT_MAIN (Proofview.tclPROGRESS (List.fold_left (fun tac (ctx,csr,dir,tc) -> Tacticals.New.tclTHEN tac (Tacticals.New.tclREPEAT_MAIN - (Tacticals.New.tclTHENFIRST (try_rewrite dir ctx csr tc) tac_main))) + (Tacticals.New.tclTHENFIRST (try_rewrite dir ctx csr tc) tac_main))) (Proofview.tclUNIT()) lrul)) (* The AutoRewrite tactic *) @@ -125,9 +125,9 @@ let autorewrite ?(conds=Naive) tac_main lbas = (List.fold_left (fun tac bas -> Tacticals.New.tclTHEN tac (one_base (fun dir c tac -> - let tac = (tac, conds) in - general_rewrite dir AllOccurrences true false ~tac (EConstr.of_constr c)) - tac_main bas)) + let tac = (tac, conds) in + general_rewrite dir AllOccurrences true false ~tac (EConstr.of_constr c)) + tac_main bas)) (Proofview.tclUNIT()) lbas)) let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas = @@ -158,19 +158,19 @@ let gen_auto_multi_rewrite conds tac_main lbas cl = else let compose_tac t1 t2 = match cl.onhyps with - | Some [] -> t1 - | _ -> Tacticals.New.tclTHENFIRST t1 t2 + | Some [] -> t1 + | _ -> Tacticals.New.tclTHENFIRST t1 t2 in compose_tac - (if cl.concl_occs != NoOccurrences then autorewrite ~conds tac_main lbas else Proofview.tclUNIT ()) - (match cl.onhyps with - | Some l -> try_do_hyps (fun ((_,id),_) -> id) l - | None -> - (* try to rewrite in all hypothesis - (except maybe the rewritten one) *) + (if cl.concl_occs != NoOccurrences then autorewrite ~conds tac_main lbas else Proofview.tclUNIT ()) + (match cl.onhyps with + | Some l -> try_do_hyps (fun ((_,id),_) -> id) l + | None -> + (* try to rewrite in all hypothesis + (except maybe the rewritten one) *) Proofview.Goal.enter begin fun gl -> let ids = Tacmach.New.pf_ids_of_hyps gl in - try_do_hyps (fun id -> id) ids + try_do_hyps (fun id -> id) ids end) let auto_multi_rewrite ?(conds=Naive) lems cl = @@ -180,10 +180,10 @@ let auto_multi_rewrite_with ?(conds=Naive) tac_main lbas cl = let onconcl = match cl.Locus.concl_occs with NoOccurrences -> false | _ -> true in match onconcl,cl.Locus.onhyps with | false,Some [_] | true,Some [] | false,Some [] -> - (* autorewrite with .... in clause using tac n'est sur que - si clause represente soit le but soit UNE hypothese - *) - Proofview.V82.wrap_exceptions (fun () -> gen_auto_multi_rewrite conds tac_main lbas cl) + (* autorewrite with .... in clause using tac n'est sur que + si clause represente soit le but soit UNE hypothese + *) + 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.") @@ -233,7 +233,7 @@ let decompose_applied_relation metas env sigma c ctype left2right = let rec split_last_two = function | [c1;c2] -> [],(c1, c2) | x::y::z -> - let l,res = split_last_two (y::z) in x::l, res + let l,res = split_last_two (y::z) in x::l, res | _ -> raise Not_found in try @@ -255,19 +255,19 @@ let decompose_applied_relation metas env sigma c ctype left2right = match find_rel ctype with | Some c -> Some c | None -> - let ctx,t' = Reductionops.splay_prod_assum env sigma ctype in (* Search for underlying eq *) - match find_rel (it_mkProd_or_LetIn t' ctx) with - | Some c -> Some c - | None -> None + let ctx,t' = Reductionops.splay_prod_assum env sigma ctype in (* Search for underlying eq *) + match find_rel (it_mkProd_or_LetIn t' ctx) with + | Some c -> Some c + | None -> None let find_applied_relation ?loc metas env sigma c left2right = let ctype = Typing.unsafe_type_of env sigma (EConstr.of_constr c) in match decompose_applied_relation metas env sigma c ctype left2right with | Some c -> c | None -> - user_err ?loc ~hdr:"decompose_applied_relation" - (str"The type" ++ spc () ++ Printer.pr_econstr_env env sigma ctype ++ - spc () ++ str"of this term does not end with an applied relation.") + user_err ?loc ~hdr:"decompose_applied_relation" + (str"The type" ++ spc () ++ Printer.pr_econstr_env env sigma ctype ++ + spc () ++ str"of this term does not end with an applied relation.") (* To add rewriting rules to a base *) let add_rew_rules base lrul = @@ -279,13 +279,13 @@ let add_rew_rules base lrul = let lrul = List.fold_left (fun dn {CAst.loc;v=((c,ctx),b,t)} -> - let sigma = Evd.merge_context_set Evd.univ_rigid sigma ctx in - let info = find_applied_relation ?loc false env sigma c b in - let pat = if b then info.hyp_left else info.hyp_right in - let rul = { rew_lemma = c; rew_type = info.hyp_ty; - rew_pat = pat; rew_ctx = ctx; rew_l2r = b; - rew_tac = Option.map intern t} - in incr counter; - HintDN.add pat (!counter, rul) dn) HintDN.empty lrul + let sigma = Evd.merge_context_set Evd.univ_rigid sigma ctx in + let info = find_applied_relation ?loc false env sigma c b in + let pat = if b then info.hyp_left else info.hyp_right in + let rul = { rew_lemma = c; rew_type = info.hyp_ty; + rew_pat = pat; rew_ctx = ctx; rew_l2r = b; + rew_tac = Option.map intern t} + in incr counter; + HintDN.add pat (!counter, rul) dn) HintDN.empty lrul in Lib.add_anonymous_leaf (inHintRewrite (base,lrul)) diff --git a/tactics/autorewrite.mli b/tactics/autorewrite.mli index e5125ffe50..6df2ea9b12 100644 --- a/tactics/autorewrite.mli +++ b/tactics/autorewrite.mli @@ -28,11 +28,11 @@ val autorewrite_in : ?conds:conditions -> Names.Id.t -> unit Proofview.tactic -> (** Rewriting rules *) type rew_rule = { rew_lemma: constr; - rew_type: types; - rew_pat: constr; - rew_ctx: Univ.ContextSet.t; - rew_l2r: bool; - rew_tac: Genarg.glob_generic_argument option } + rew_type: types; + rew_pat: constr; + rew_ctx: Univ.ContextSet.t; + rew_l2r: bool; + rew_tac: Genarg.glob_generic_argument option } val find_rewrites : string -> rew_rule list diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml index d0816b266f..ae3aea5788 100644 --- a/tactics/btermdn.ml +++ b/tactics/btermdn.ml @@ -80,8 +80,8 @@ let constr_val_discr_st sigma ts t = | Var id when not (TransparentState.is_transparent_variable ts id) -> Label(GRLabel (VarRef id),l) | Prod (n, d, c) -> Label(ProdLabel, [d; c]) | Lambda (n, d, c) -> - if List.is_empty l then - Label(LambdaLabel, [d; c] @ l) + if List.is_empty l then + Label(LambdaLabel, [d; c] @ l) else Everything | Sort _ -> Label(SortLabel, []) | Evar _ -> Everything @@ -154,27 +154,27 @@ struct let add = function | None -> - (fun dn (c,v) -> - Dn.add dn bounded_constr_pat_discr ((c,!dnet_depth),v)) + (fun dn (c,v) -> + Dn.add dn bounded_constr_pat_discr ((c,!dnet_depth),v)) | Some st -> - (fun dn (c,v) -> - Dn.add dn (bounded_constr_pat_discr_st st) ((c,!dnet_depth),v)) + (fun dn (c,v) -> + Dn.add dn (bounded_constr_pat_discr_st st) ((c,!dnet_depth),v)) let rmv = function | None -> - (fun dn (c,v) -> - Dn.rmv dn bounded_constr_pat_discr ((c,!dnet_depth),v)) + (fun dn (c,v) -> + Dn.rmv dn bounded_constr_pat_discr ((c,!dnet_depth),v)) | Some st -> - (fun dn (c,v) -> - Dn.rmv dn (bounded_constr_pat_discr_st st) ((c,!dnet_depth),v)) + (fun dn (c,v) -> + Dn.rmv dn (bounded_constr_pat_discr_st st) ((c,!dnet_depth),v)) let lookup sigma = function | None -> - (fun dn t -> - Dn.lookup dn (bounded_constr_val_discr sigma) (t,!dnet_depth)) + (fun dn t -> + Dn.lookup dn (bounded_constr_val_discr sigma) (t,!dnet_depth)) | Some st -> - (fun dn t -> - Dn.lookup dn (bounded_constr_val_discr_st sigma st) (t,!dnet_depth)) + (fun dn t -> + Dn.lookup dn (bounded_constr_val_discr_st sigma st) (t,!dnet_depth)) let app f dn = Dn.app f dn diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index cf5c64c3ae..f8cb8870ea 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -457,7 +457,7 @@ let catchable = function | Refiner.FailError _ -> true | e -> Logic.catchable_exception e -let pr_depth l = +let pr_depth l = let rec fmt elts = match elts with | [] -> [] @@ -758,8 +758,8 @@ module Search = struct Feedback.msg_debug (str"Adding shelved subgoals to the search: " ++ prlist_with_sep spc (pr_ev sigma) goals ++ - str" while shelving " ++ - prlist_with_sep spc (pr_ev sigma) shelved); + str" while shelving " ++ + prlist_with_sep spc (pr_ev sigma) shelved); shelve_goals shelved <*> (if List.is_empty goals then tclUNIT () else @@ -776,7 +776,7 @@ module Search = struct (with_shelf tac >>= fun s -> let i = !idx in incr idx; result s i None) (fun e' -> - if CErrors.noncritical (fst e') then + if CErrors.noncritical (fst e') then (pr_error e'; aux (merge_exceptions e e') tl) else iraise e') and aux e = function diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index 56e8e7a11f..1f5a6380fd 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -66,10 +66,10 @@ let contradiction_context = | d :: rest -> let id = NamedDecl.get_id d in let typ = nf_evar sigma (NamedDecl.get_type d) in - let typ = whd_all env sigma typ in + let typ = whd_all env sigma typ in if is_empty_type env sigma typ then - simplest_elim (mkVar id) - else match EConstr.kind sigma typ with + simplest_elim (mkVar id) + else match EConstr.kind sigma typ with | Prod (na,t,u) when is_empty_type env sigma u -> let is_unit_or_eq = match_with_unit_or_eq_type env sigma t in Tacticals.New.tclORELSE @@ -84,17 +84,17 @@ let contradiction_context = simplest_elim (mkApp (mkVar id,[|p|])) | None -> Tacticals.New.tclZEROMSG (Pp.str"Not a negated unit type.")) - (Proofview.tclORELSE + (Proofview.tclORELSE (Proofview.Goal.enter begin fun gl -> let is_conv_leq = Tacmach.New.pf_apply is_conv_leq gl in - filter_hyp (fun typ -> is_conv_leq typ t) - (fun id' -> simplest_elim (mkApp (mkVar id,[|mkVar id'|]))) + filter_hyp (fun typ -> is_conv_leq typ t) + (fun id' -> simplest_elim (mkApp (mkVar id,[|mkVar id'|]))) end) begin function (e, info) -> match e with - | Not_found -> seek_neg rest + | Not_found -> seek_neg rest | e -> Proofview.tclZERO ~info e end) - | _ -> seek_neg rest + | _ -> seek_neg rest in let hyps = Proofview.Goal.hyps gl in seek_neg hyps diff --git a/tactics/dn.ml b/tactics/dn.ml index aed2c28323..e1c9b7c0b5 100644 --- a/tactics/dn.ml +++ b/tactics/dn.ml @@ -11,14 +11,14 @@ struct type t = (Y.t * int) option let compare x y = match x,y with - None,None -> 0 - | Some (l,n),Some (l',n') -> - let m = Y.compare l l' in - if Int.equal m 0 then - n-n' - else m - | Some(l,n),None -> 1 - | None, Some(l,n) -> -1 + None,None -> 0 + | Some (l,n),Some (l',n') -> + let m = Y.compare l l' in + if Int.equal m 0 then + n-n' + else m + | Some(l,n),None -> 1 + | None, Some(l,n) -> -1 end module ZSet = Set.Make(Z) module X_tries = @@ -50,12 +50,12 @@ prefix ordering, [dna] is the function returning the main node of a pattern *) and pathrec deferred t = match dna t with - | None -> - None :: (path_of_deferred deferred) - | Some (lbl,[]) -> - (Some (lbl,0))::(path_of_deferred deferred) - | Some (lbl,(h::def_subl as v)) -> - (Some (lbl,List.length v))::(pathrec (def_subl@deferred) h) + | None -> + None :: (path_of_deferred deferred) + | Some (lbl,[]) -> + (Some (lbl,0))::(path_of_deferred deferred) + | Some (lbl,(h::def_subl as v)) -> + (Some (lbl,List.length v))::(pathrec (def_subl@deferred) h) in pathrec [] @@ -76,16 +76,16 @@ prefix ordering, [dna] is the function returning the main node of a pattern *) let lookup tm dna t = let rec lookrec t tm = match dna t with - | Nothing -> tm_of tm None - | Label(lbl,v) -> - tm_of tm None@ - (List.fold_left - (fun l c -> - List.flatten(List.map (fun (tm, b) -> - if b then lookrec c tm - else [tm,b]) l)) - (tm_of tm (Some(lbl,List.length v))) v) - | Everything -> skip_arg 1 tm + | Nothing -> tm_of tm None + | Label(lbl,v) -> + tm_of tm None@ + (List.fold_left + (fun l c -> + List.flatten(List.map (fun (tm, b) -> + if b then lookrec c tm + else [tm,b]) l)) + (tm_of tm (Some(lbl,List.length v))) v) + | Everything -> skip_arg 1 tm in List.flatten (List.map (fun (tm,b) -> ZSet.elements (Trie.get tm)) (lookrec t tm)) diff --git a/tactics/dnet.ml b/tactics/dnet.ml index 3171bee7ca..389329c19f 100644 --- a/tactics/dnet.ml +++ b/tactics/dnet.ml @@ -62,7 +62,7 @@ struct module Idset = Set.Make(Ident) module Mmap = Map.Make(Meta) module Tmap = Map.Make(struct type t = unit structure - let compare = T.compare end) + let compare = T.compare end) type idset = Idset.t @@ -93,23 +93,23 @@ struct let rec add (Nodes (t,m):t) (w:term_pattern) (id:ident) : t = match w with Term w -> ( try - let (n,tl) = split t w in - let new_node = match n with - | Terminal (e,is) -> Terminal (e,Idset.add id is) - | Node e -> Node (T.map2 (fun t p -> add t p id) e w) in - Nodes ((Tmap.add (head w) new_node tl), m) - with Not_found -> - let new_content = T.map (fun p -> add empty p id) w in - let new_node = - if T.terminal w then - Terminal (new_content, Idset.singleton id) - else Node new_content in - Nodes ((Tmap.add (head w) new_node t), m) ) + let (n,tl) = split t w in + let new_node = match n with + | Terminal (e,is) -> Terminal (e,Idset.add id is) + | Node e -> Node (T.map2 (fun t p -> add t p id) e w) in + Nodes ((Tmap.add (head w) new_node tl), m) + with Not_found -> + let new_content = T.map (fun p -> add empty p id) w in + let new_node = + if T.terminal w then + Terminal (new_content, Idset.singleton id) + else Node new_content in + Nodes ((Tmap.add (head w) new_node t), m) ) | Meta i -> - let m = - try Mmap.add i (Idset.add id (Mmap.find i m)) m - with Not_found -> Mmap.add i (Idset.singleton id) m in - Nodes (t, m) + let m = + try Mmap.add i (Idset.add id (Mmap.find i m)) m + with Not_found -> Mmap.add i (Idset.singleton id) m in + Nodes (t, m) let add t w id = add t w id @@ -117,12 +117,12 @@ struct Idset.union (Mmap.fold (fun _ -> Idset.union) m Idset.empty) (Tmap.fold - ( fun _ n acc -> - let s2 = match n with - | Terminal (_,is) -> is - | Node e -> T.choose find_all e in - Idset.union acc s2 - ) t Idset.empty) + ( fun _ n acc -> + let s2 = match n with + | Terminal (_,is) -> is + | Node e -> T.choose find_all e in + Idset.union acc s2 + ) t Idset.empty) (* (\* optimization hack: Not_found is caught in fold_pattern *\) *) (* let fast_inter s1 s2 = *) @@ -176,13 +176,13 @@ struct let inter s1 s2 : t = match s1,s2 with | (None, a | a, None) -> a | Some a, Some b -> Some (S.inter a b) - let is_empty : t -> bool = function + let is_empty : t -> bool = function | None -> false | Some s -> S.is_empty s (* optimization hack: Not_found is caught in fold_pattern *) let fast_inter s1 s2 = if is_empty s1 || is_empty s2 then raise Not_found - else let r = inter s1 s2 in + else let r = inter s1 s2 in if is_empty r then raise Not_found else r let full = None let empty = Some S.empty @@ -197,29 +197,29 @@ struct let rec fp_rec metas p (Nodes(t,m) as dn:t) = (* TODO gérer les dnets non-linéaires *) let metas = Mmap.fold (fun _ -> Idset.union) m metas in - match p with - | Meta m -> defer (metas,m,dn); OIdset.full - | Term w -> - let curm = Mmap.fold (fun _ -> Idset.union) m Idset.empty in - try match select t w with - | Terminal (_,is) -> Some (Idset.union curm is) - | Node e -> - let ids = if complete then T.fold2 - (fun acc w e -> - OIdset.fast_inter acc (fp_rec metas w e) - ) OIdset.full w e - else - let (all_metas, res) = T.fold2 - (fun (b,acc) w e -> match w with - | Term _ -> false, OIdset.fast_inter acc (fp_rec metas w e) - | Meta _ -> b, acc - ) (true,OIdset.full) w e in - if all_metas then T.choose (T.choose (fp_rec metas) w) e - else res in - OIdset.union ids (Some curm) - with Not_found -> - if Idset.is_empty metas then raise Not_found else Some curm in - let cand = + match p with + | Meta m -> defer (metas,m,dn); OIdset.full + | Term w -> + let curm = Mmap.fold (fun _ -> Idset.union) m Idset.empty in + try match select t w with + | Terminal (_,is) -> Some (Idset.union curm is) + | Node e -> + let ids = if complete then T.fold2 + (fun acc w e -> + OIdset.fast_inter acc (fp_rec metas w e) + ) OIdset.full w e + else + let (all_metas, res) = T.fold2 + (fun (b,acc) w e -> match w with + | Term _ -> false, OIdset.fast_inter acc (fp_rec metas w e) + | Meta _ -> b, acc + ) (true,OIdset.full) w e in + if all_metas then T.choose (T.choose (fp_rec metas) w) e + else res in + OIdset.union ids (Some curm) + with Not_found -> + if Idset.is_empty metas then raise Not_found else Some curm in + let cand = try fp_rec Idset.empty pat dn with Not_found -> OIdset.empty in let res = List.fold_left f acc !deferred in @@ -229,54 +229,54 @@ struct let rec inter (t1:t) (t2:t) : t = let inter_map f (Nodes (t1,m1):t) (Nodes (t2,m2):t) : t = Nodes - (Tmap.fold - ( fun k e acc -> - try Tmap.add k (f e (Tmap.find k t2)) acc - with Not_found -> acc - ) t1 Tmap.empty, - Mmap.fold - ( fun m s acc -> - try Mmap.add m (Idset.inter s (Mmap.find m m2)) acc - with Not_found -> acc - ) m1 Mmap.empty - ) in + (Tmap.fold + ( fun k e acc -> + try Tmap.add k (f e (Tmap.find k t2)) acc + with Not_found -> acc + ) t1 Tmap.empty, + Mmap.fold + ( fun m s acc -> + try Mmap.add m (Idset.inter s (Mmap.find m m2)) acc + with Not_found -> acc + ) m1 Mmap.empty + ) in inter_map (fun n1 n2 -> match n1,n2 with - | Terminal (e1,s1), Terminal (_,s2) -> Terminal (e1,Idset.inter s1 s2) - | Node e1, Node e2 -> Node (T.map2 inter e1 e2) - | _ -> assert false + | Terminal (e1,s1), Terminal (_,s2) -> Terminal (e1,Idset.inter s1 s2) + | Node e1, Node e2 -> Node (T.map2 inter e1 e2) + | _ -> assert false ) t1 t2 let rec union (t1:t) (t2:t) : t = let union_map f (Nodes (t1,m1):t) (Nodes (t2,m2):t) : t = Nodes - (Tmap.fold - ( fun k e acc -> - try Tmap.add k (f e (Tmap.find k acc)) acc - with Not_found -> Tmap.add k e acc - ) t1 t2, - Mmap.fold - ( fun m s acc -> - try Mmap.add m (Idset.inter s (Mmap.find m acc)) acc - with Not_found -> Mmap.add m s acc - ) m1 m2 - ) in + (Tmap.fold + ( fun k e acc -> + try Tmap.add k (f e (Tmap.find k acc)) acc + with Not_found -> Tmap.add k e acc + ) t1 t2, + Mmap.fold + ( fun m s acc -> + try Mmap.add m (Idset.inter s (Mmap.find m acc)) acc + with Not_found -> Mmap.add m s acc + ) m1 m2 + ) in union_map (fun n1 n2 -> match n1,n2 with - | Terminal (e1,s1), Terminal (_,s2) -> Terminal (e1,Idset.union s1 s2) - | Node e1, Node e2 -> Node (T.map2 union e1 e2) - | _ -> assert false + | Terminal (e1,s1), Terminal (_,s2) -> Terminal (e1,Idset.union s1 s2) + | Node e1, Node e2 -> Node (T.map2 union e1 e2) + | _ -> assert false ) t1 t2 let find_match (p:term_pattern) (t:t) : idset = let metas = ref Mmap.empty in let (mset,lset) = fold_pattern ~complete:false (fun acc (mset,m,t) -> - let all = OIdset.fast_inter acc - (Some(let t = try inter t (Mmap.find m !metas) with Not_found -> t in - metas := Mmap.add m t !metas; - find_all t)) in - OIdset.union (Some mset) all + let all = OIdset.fast_inter acc + (Some(let t = try inter t (Mmap.find m !metas) with Not_found -> t in + metas := Mmap.add m t !metas; + find_all t)) in + OIdset.union (Some mset) all ) None p t in Option.get (OIdset.inter mset lset) diff --git a/tactics/eauto.ml b/tactics/eauto.ml index ef2402489e..361215bf38 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -154,8 +154,8 @@ and e_my_find_search env sigma db_list local_db secvars hdc concl = let hint_of_db = hintmap_of sigma secvars hdc concl in let hintl = List.map_append (fun db -> - let flags = auto_flags_of_state (Hint_db.transparent_state db) in - List.map (fun x -> flags, x) (hint_of_db db)) (local_db::db_list) + let flags = auto_flags_of_state (Hint_db.transparent_state db) in + List.map (fun x -> flags, x) (hint_of_db db)) (local_db::db_list) in let tac_of_hint = fun (st, {pri = b; pat = p; code = t; poly = poly}) -> @@ -227,12 +227,12 @@ module SearchProblem = struct let rec aux = function | [] -> [] | (tac, cost, pptac) :: tacl -> - try - let lgls = apply_tac_list (Proofview.V82.of_tactic tac) glls in + try + let lgls = apply_tac_list (Proofview.V82.of_tactic tac) glls in (* let gl = Proof_trees.db_pr_goal (List.hd (sig_it glls)) in *) (* msg (hov 1 (pptac ++ str" gives: \n" ++ pr_goals lgls ++ str"\n")); *) - (lgls, cost, pptac) :: aux tacl - with e when CErrors.noncritical e -> + (lgls, cost, pptac) :: aux tacl + with e when CErrors.noncritical e -> let e = CErrors.push e in Refiner.catch_failerror e; aux tacl in aux l @@ -262,60 +262,60 @@ module SearchProblem = struct let assumption_tacs = let tacs = List.map map_assum hyps in let l = filter_tactics s.tacres tacs in - List.map (fun (res, cost, pp) -> { depth = s.depth; priority = cost; tacres = res; - last_tactic = pp; dblist = s.dblist; - localdb = List.tl s.localdb; - prev = ps; local_lemmas = s.local_lemmas}) l + List.map (fun (res, cost, pp) -> { depth = s.depth; priority = cost; tacres = res; + last_tactic = pp; dblist = s.dblist; + localdb = List.tl s.localdb; + prev = ps; local_lemmas = s.local_lemmas}) l in let intro_tac = let l = filter_tactics s.tacres [Tactics.intro, (-1), lazy (str "intro")] in - List.map - (fun (lgls, cost, pp) -> - let g' = first_goal lgls in - let hintl = - make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g') - in + List.map + (fun (lgls, cost, pp) -> + let g' = first_goal lgls in + let hintl = + make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g') + in let ldb = Hint_db.add_list (pf_env g') (project g') - hintl (List.hd s.localdb) in - { depth = s.depth; priority = cost; tacres = lgls; - last_tactic = pp; dblist = s.dblist; - localdb = ldb :: List.tl s.localdb; prev = ps; + hintl (List.hd s.localdb) in + { depth = s.depth; priority = cost; tacres = lgls; + last_tactic = pp; dblist = s.dblist; + localdb = ldb :: List.tl s.localdb; prev = ps; local_lemmas = s.local_lemmas}) - l + l in let rec_tacs = - let l = + let l = let concl = Reductionops.nf_evar (project g) (pf_concl g) in - filter_tactics s.tacres + filter_tactics s.tacres (e_possible_resolve (pf_env g) (project g) s.dblist (List.hd s.localdb) secvars concl) - in - List.map - (fun (lgls, cost, pp) -> - let nbgl' = List.length (sig_it lgls) in - if nbgl' < nbgl then - { depth = s.depth; priority = cost; tacres = lgls; last_tactic = pp; + in + List.map + (fun (lgls, cost, pp) -> + let nbgl' = List.length (sig_it lgls) in + if nbgl' < nbgl then + { depth = s.depth; priority = cost; tacres = lgls; last_tactic = pp; prev = ps; dblist = s.dblist; localdb = List.tl s.localdb; local_lemmas = s.local_lemmas } - else - let newlocal = - let hyps = pf_hyps g in - List.map (fun gl -> - let gls = {Evd.it = gl; sigma = lgls.Evd.sigma } in - let hyps' = pf_hyps gls in - if hyps' == hyps then List.hd s.localdb + else + let newlocal = + let hyps = pf_hyps g in + List.map (fun gl -> + let gls = {Evd.it = gl; sigma = lgls.Evd.sigma } in + let hyps' = pf_hyps gls in + if hyps' == hyps then List.hd s.localdb else make_local_hint_db (pf_env gls) (project gls) ~ts:TransparentState.full true s.local_lemmas) - (List.firstn ((nbgl'-nbgl) + 1) (sig_it lgls)) - in - { depth = pred s.depth; priority = cost; tacres = lgls; - dblist = s.dblist; last_tactic = pp; prev = ps; - localdb = newlocal @ List.tl s.localdb; + (List.firstn ((nbgl'-nbgl) + 1) (sig_it lgls)) + in + { depth = pred s.depth; priority = cost; tacres = lgls; + dblist = s.dblist; last_tactic = pp; prev = ps; + localdb = newlocal @ List.tl s.localdb; local_lemmas = s.local_lemmas }) - l + l in List.sort compare (assumption_tacs @ intro_tac @ rec_tacs) let pp s = hov 0 (str " depth=" ++ int s.depth ++ spc () ++ - (Lazy.force s.last_tactic)) + (Lazy.force s.last_tactic)) end @@ -361,12 +361,12 @@ let pr_info dbg s = else let rec loop s = match s.prev with - | Unknown | Init -> s.depth - | State sp -> - let mindepth = loop sp in - let indent = String.make (mindepth - sp.depth) ' ' in + | Unknown | Init -> s.depth + | State sp -> + let mindepth = loop sp in + let indent = String.make (mindepth - sp.depth) ' ' in Feedback.msg_notice (str indent ++ Lazy.force s.last_tactic ++ str "."); - mindepth + mindepth in ignore (loop s) @@ -430,15 +430,15 @@ let make_dimension n = function let cons a l = a :: l let autounfolds db occs cls gl = - let unfolds = List.concat (List.map (fun dbname -> - let db = try searchtable_map dbname + let unfolds = List.concat (List.map (fun dbname -> + let db = try searchtable_map dbname with Not_found -> user_err ~hdr:"autounfold" (str "Unknown database " ++ str dbname) in let (ids, csts) = Hint_db.unfolds db in let hyps = pf_ids_of_hyps gl in let ids = Id.Set.filter (fun id -> List.mem id hyps) ids in Cset.fold (fun cst -> cons (AllOccurrences, EvalConstRef cst)) csts - (Id.Set.fold (fun id -> cons (AllOccurrences, EvalVarRef id)) ids [])) db) + (Id.Set.fold (fun id -> cons (AllOccurrences, EvalVarRef id)) ids [])) db) in Proofview.V82.of_tactic (unfold_option unfolds cls) gl let autounfold db cls = @@ -461,36 +461,36 @@ let autounfold_tac db cls = autounfold dbs cls let unfold_head env sigma (ids, csts) c = - let rec aux c = + let rec aux c = match EConstr.kind sigma c with | Var id when Id.Set.mem id ids -> - (match Environ.named_body id env with - | Some b -> true, EConstr.of_constr b - | None -> false, c) + (match Environ.named_body id env with + | Some b -> true, EConstr.of_constr b + | None -> false, c) | Const (cst, u) when Cset.mem cst csts -> let u = EInstance.kind sigma u in - true, EConstr.of_constr (Environ.constant_value_in env (cst, u)) + true, EConstr.of_constr (Environ.constant_value_in env (cst, u)) | App (f, args) -> - (match aux f with - | true, f' -> true, Reductionops.whd_betaiota sigma (mkApp (f', args)) - | false, _ -> - let done_, args' = - Array.fold_left_i (fun i (done_, acc) arg -> - if done_ then done_, arg :: acc - else match aux arg with - | true, arg' -> true, arg' :: acc - | false, arg' -> false, arg :: acc) - (false, []) args - in - if done_ then true, mkApp (f, Array.of_list (List.rev args')) - else false, c) - | _ -> - let done_ = ref false in - let c' = EConstr.map sigma (fun c -> - if !done_ then c else - let x, c' = aux c in - done_ := x; c') c - in !done_, c' + (match aux f with + | true, f' -> true, Reductionops.whd_betaiota sigma (mkApp (f', args)) + | false, _ -> + let done_, args' = + Array.fold_left_i (fun i (done_, acc) arg -> + if done_ then done_, arg :: acc + else match aux arg with + | true, arg' -> true, arg' :: acc + | false, arg' -> false, arg :: acc) + (false, []) args + in + if done_ then true, mkApp (f, Array.of_list (List.rev args')) + else false, c) + | _ -> + let done_ = ref false in + let c' = EConstr.map sigma (fun c -> + if !done_ then c else + let x, c' = aux c in + done_ := x; c') c + in !done_, c' in aux c let autounfold_one db cl = @@ -499,15 +499,15 @@ let autounfold_one db cl = let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in let st = - List.fold_left (fun (i,c) dbname -> - let db = try searchtable_map dbname - with Not_found -> user_err ~hdr:"autounfold" (str "Unknown database " ++ str dbname) + List.fold_left (fun (i,c) dbname -> + let db = try searchtable_map dbname + with Not_found -> user_err ~hdr:"autounfold" (str "Unknown database " ++ str dbname) in let (ids, csts) = Hint_db.unfolds db in - (Id.Set.union ids i, Cset.union csts c)) (Id.Set.empty, Cset.empty) db + (Id.Set.union ids i, Cset.union csts c)) (Id.Set.empty, Cset.empty) db in - let did, c' = unfold_head env sigma st - (match cl with Some (id, _) -> Tacmach.New.pf_get_hyp_typ id gl | None -> concl) + let did, c' = unfold_head env sigma st + (match cl with Some (id, _) -> Tacmach.New.pf_get_hyp_typ id gl | None -> concl) in if did then match cl with diff --git a/tactics/elim.ml b/tactics/elim.ml index fcc2a94ef5..ea61b8e4df 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -66,8 +66,8 @@ and general_decompose_aux recognizer id = elimHypThen (introElimAssumsThen (fun bas -> - tclTHEN (clear [id]) - (tclMAP (general_decompose_on_hyp recognizer) + tclTHEN (clear [id]) + (tclMAP (general_decompose_on_hyp recognizer) (ids_of_named_context bas.Tacticals.assums)))) id @@ -88,7 +88,7 @@ let general_decompose recognizer c = [ tclTHEN (intro_using tmphyp_name) (onLastHypId (ifOnHyp (recognizer env sigma) (general_decompose_aux (recognizer env sigma)) - (fun id -> clear [id]))); + (fun id -> clear [id]))); exact_no_check c ] end @@ -136,22 +136,22 @@ let induction_trailer abs_i abs_j bargs = (onLastHypId (fun id -> Proofview.Goal.enter begin fun gl -> - let idty = pf_unsafe_type_of gl (mkVar id) in - let fvty = global_vars (pf_env gl) (project gl) idty in - let possible_bring_hyps = - (List.tl (nLastDecls gl (abs_j - abs_i))) @ bargs.Tacticals.assums + let idty = pf_unsafe_type_of gl (mkVar id) in + let fvty = global_vars (pf_env gl) (project gl) idty in + let possible_bring_hyps = + (List.tl (nLastDecls gl (abs_j - abs_i))) @ bargs.Tacticals.assums in - let (hyps,_) = + let (hyps,_) = List.fold_left - (fun (bring_ids,leave_ids) d -> + (fun (bring_ids,leave_ids) d -> let cid = NamedDecl.get_id d in if not (List.mem cid leave_ids) then (d::bring_ids,leave_ids) else (bring_ids,cid::leave_ids)) - ([],fvty) possible_bring_hyps - in + ([],fvty) possible_bring_hyps + in let ids = List.rev (ids_of_named_context hyps) in - (tclTHENLIST + (tclTHENLIST [revert ids; simple_elimination (mkVar id)]) end )) @@ -167,7 +167,7 @@ let double_ind h1 h2 = abs >>= fun (abs_i,abs_j) -> (tclTHEN (tclDO abs_i intro) (onLastHypId - (fun id -> + (fun id -> elimination_then (introElimAssumsThen (induction_trailer abs_i abs_j)) (mkVar id)))) end diff --git a/tactics/elimschemes.ml b/tactics/elimschemes.ml index 9cd2e7b52c..51f01888aa 100644 --- a/tactics/elimschemes.ml +++ b/tactics/elimschemes.ml @@ -38,12 +38,12 @@ let optimize_non_type_induction_scheme kind dep sort _ ind = let (mib,mip) = Global.lookup_inductive ind in let npars = (* if a constructor of [ind] contains a recursive call, the scheme - is generalized only wrt recursively uniform parameters *) + is generalized only wrt recursively uniform parameters *) if (Inductiveops.mis_is_recursive_subset [snd ind] mip.mind_recargs) then - mib.mind_nparams_rec + mib.mind_nparams_rec else - mib.mind_nparams in + mib.mind_nparams in let sigma, sort = Evd.fresh_sort_in_family sigma sort in let sigma, t', c' = weaken_sort_scheme env sigma false sort npars c t in let sigma = Evd.minimize_universes sigma in diff --git a/tactics/elimschemes.mli b/tactics/elimschemes.mli index 11dbbc7155..093a4c456b 100644 --- a/tactics/elimschemes.mli +++ b/tactics/elimschemes.mli @@ -12,7 +12,7 @@ open Ind_tables (** Induction/recursion schemes *) -val optimize_non_type_induction_scheme : +val optimize_non_type_induction_scheme : 'a Ind_tables.scheme_kind -> Indrec.dep_flag -> Sorts.family -> diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index e8782aa674..1df56be0be 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -42,7 +42,7 @@ One may wonder whether these extensions are worth to be done regarding the price we have to pay and regarding the rare - situations where they are needed. However, I believe it meets a + situations where they are needed. However, I believe it meets a natural expectation of the user. *) @@ -69,7 +69,7 @@ let hid = Id.of_string "H" let xid = Id.of_string "X" let default_id_of_sort = function InSProp | InProp | InSet -> hid | InType -> xid let fresh env id = next_global_ident_away id Id.Set.empty -let with_context_set ctx (b, ctx') = +let with_context_set ctx (b, ctx') = (b, Univ.ContextSet.union ctx ctx') let build_dependent_inductive ind (mib,mip) = @@ -88,7 +88,7 @@ let name_context env hyps = snd (List.fold_left (fun (env,hyps) d -> - let d' = name_assumption env d in (push_rel d' env, d' :: hyps)) + let d' = name_assumption env d in (push_rel d' env, d' :: hyps)) (env,[]) (List.rev hyps)) let my_it_mkLambda_or_LetIn s c = it_mkLambda_or_LetIn c s @@ -102,7 +102,7 @@ let get_coq_eq ctx = try let eq = Globnames.destIndRef (Coqlib.lib_ref "core.eq.type") in (* Do not force the lazy if they are not defined *) - let eq, ctx = with_context_set ctx + let eq, ctx = with_context_set ctx (UnivGen.fresh_inductive_instance (Global.env ()) eq) in mkIndU eq, mkConstructUi (eq,1), ctx with Not_found -> @@ -211,16 +211,16 @@ let build_sym_scheme env ind = name_context env ((LocalAssum (make_annot (Name varH) indr,applied_ind))::realsign) in let rci = Sorts.Relevant in (* TODO relevance *) let ci = make_case_info (Global.env()) ind rci RegularStyle in - let c = + let c = (my_it_mkLambda_or_LetIn paramsctxt (my_it_mkLambda_or_LetIn_name realsign_ind (mkCase (ci, my_it_mkLambda_or_LetIn_name (lift_rel_context (nrealargs+1) realsign_ind) (mkApp (mkIndU indu,Array.concat - [Context.Rel.to_extended_vect mkRel (3*nrealargs+2) paramsctxt1; - rel_vect 1 nrealargs; - rel_vect (2*nrealargs+2) nrealargs])), + [Context.Rel.to_extended_vect mkRel (3*nrealargs+2) paramsctxt1; + rel_vect 1 nrealargs; + rel_vect (2*nrealargs+2) nrealargs])), mkRel 1 (* varH *), [|cstr (nrealargs+1)|])))) in c, UState.of_context_set ctx @@ -247,9 +247,9 @@ let sym_scheme_kind = (* *) (**********************************************************************) -let const_of_scheme kind env ind ctx = +let const_of_scheme kind env ind ctx = let sym_scheme, eff = (find_scheme kind ind) in - let sym, ctx = with_context_set ctx + let sym, ctx = with_context_set ctx (UnivGen.fresh_constant_instance (Global.env()) sym_scheme) in mkConstU sym, ctx, eff @@ -273,30 +273,30 @@ let build_sym_involutive_scheme env ind = name_context env ((LocalAssum (make_annot (Name varH) indr,applied_ind))::realsign) in let rci = Sorts.Relevant in (* TODO relevance *) let ci = make_case_info (Global.env()) ind rci RegularStyle in - let c = + let c = (my_it_mkLambda_or_LetIn paramsctxt (my_it_mkLambda_or_LetIn_name realsign_ind (mkCase (ci, - my_it_mkLambda_or_LetIn_name - (lift_rel_context (nrealargs+1) realsign_ind) - (mkApp (eq,[| - mkApp - (mkIndU indu, Array.concat - [Context.Rel.to_extended_vect mkRel (3*nrealargs+2) paramsctxt1; - rel_vect (2*nrealargs+2) nrealargs; - rel_vect 1 nrealargs]); + my_it_mkLambda_or_LetIn_name + (lift_rel_context (nrealargs+1) realsign_ind) + (mkApp (eq,[| + mkApp + (mkIndU indu, Array.concat + [Context.Rel.to_extended_vect mkRel (3*nrealargs+2) paramsctxt1; + rel_vect (2*nrealargs+2) nrealargs; + rel_vect 1 nrealargs]); mkApp (sym,Array.concat - [Context.Rel.to_extended_vect mkRel (3*nrealargs+2) paramsctxt1; - rel_vect 1 nrealargs; - rel_vect (2*nrealargs+2) nrealargs; - [|mkApp (sym,Array.concat - [Context.Rel.to_extended_vect mkRel (3*nrealargs+2) paramsctxt1; - rel_vect (2*nrealargs+2) nrealargs; - rel_vect 1 nrealargs; - [|mkRel 1|]])|]]); - mkRel 1|])), - mkRel 1 (* varH *), - [|mkApp(eqrefl,[|applied_ind_C;cstr (nrealargs+1)|])|])))) + [Context.Rel.to_extended_vect mkRel (3*nrealargs+2) paramsctxt1; + rel_vect 1 nrealargs; + rel_vect (2*nrealargs+2) nrealargs; + [|mkApp (sym,Array.concat + [Context.Rel.to_extended_vect mkRel (3*nrealargs+2) paramsctxt1; + rel_vect (2*nrealargs+2) nrealargs; + rel_vect 1 nrealargs; + [|mkRel 1|]])|]]); + mkRel 1|])), + mkRel 1 (* varH *), + [|mkApp(eqrefl,[|applied_ind_C;cstr (nrealargs+1)|])|])))) in (c, UState.of_context_set ctx), eff let sym_involutive_scheme_kind = @@ -405,7 +405,7 @@ let build_l2r_rew_scheme dep env ind kind = Array.concat [Context.Rel.to_extended_vect mkRel (nrealargs*3+4) paramsctxt1; rel_vect (nrealargs+4) nrealargs; rel_vect 1 nrealargs; - [|mkRel 1|]]) in + [|mkRel 1|]]) in let s, ctx' = UnivGen.fresh_sort_in_family kind in let ctx = Univ.ContextSet.union ctx ctx' in let s = mkSort s in @@ -423,20 +423,20 @@ let build_l2r_rew_scheme dep env ind kind = (if dep then [|mkRel 2|] else [||])) in let applied_sym_sym = mkApp (sym,Array.concat - [Context.Rel.to_extended_vect mkRel (2*nrealargs+4) paramsctxt1; + [Context.Rel.to_extended_vect mkRel (2*nrealargs+4) paramsctxt1; rel_vect 4 nrealargs; rel_vect (nrealargs+4) nrealargs; [|mkApp (sym,Array.concat - [Context.Rel.to_extended_vect mkRel (2*nrealargs+4) paramsctxt1; - rel_vect (nrealargs+4) nrealargs; - rel_vect 4 nrealargs; - [|mkRel 2|]])|]]) in + [Context.Rel.to_extended_vect mkRel (2*nrealargs+4) paramsctxt1; + rel_vect (nrealargs+4) nrealargs; + rel_vect 4 nrealargs; + [|mkRel 2|]])|]]) in let main_body = mkCase (ci, my_it_mkLambda_or_LetIn_name realsign_ind_G applied_PG, applied_sym_C 3, [|mkVar varHC|]) in - let c = + let c = (my_it_mkLambda_or_LetIn paramsctxt (my_it_mkLambda_or_LetIn_name realsign (mkNamedLambda (make_annot varP indr) @@ -525,11 +525,11 @@ let build_l2r_forward_rew_scheme dep env ind kind = mkApp (mkVar varP,Array.append (rel_vect (nrealargs+2) nrealargs) (if dep then [|cstr (2*nrealargs+2) (nrealargs+2)|] - else [||])) in + else [||])) in let applied_PG = mkApp (mkVar varP,Array.append (rel_vect 3 nrealargs) (if dep then [|cstr (3*nrealargs+4) 3|] else [||])) in - let c = + let c = (my_it_mkLambda_or_LetIn paramsctxt (my_it_mkLambda_or_LetIn_name realsign (mkNamedLambda (make_annot varH indr) applied_ind @@ -538,14 +538,14 @@ let build_l2r_forward_rew_scheme dep env ind kind = (lift_rel_context (nrealargs+1) realsign_ind) (mkNamedProd (make_annot varP indr) (my_it_mkProd_or_LetIn - (if dep then realsign_ind_P 2 applied_ind_P else realsign_P 2) s) + (if dep then realsign_ind_P 2 applied_ind_P else realsign_P 2) s) (mkNamedProd (make_annot varHC indr) applied_PC applied_PG)), (mkVar varH), [|mkNamedLambda (make_annot varP indr) (my_it_mkProd_or_LetIn - (if dep then realsign_ind_P 1 applied_ind_P' else realsign_P 2) s) + (if dep then realsign_ind_P 1 applied_ind_P' else realsign_P 2) s) (mkNamedLambda (make_annot varHC indr) applied_PC' - (mkVar varHC))|]))))) + (mkVar varHC))|]))))) in c, UState.of_context_set ctx (**********************************************************************) @@ -578,7 +578,7 @@ let build_l2r_forward_rew_scheme dep env ind kind = (* statement but no need for symmetry of the equality. *) (**********************************************************************) -let build_r2l_forward_rew_scheme dep env ind kind = +let build_r2l_forward_rew_scheme dep env ind kind = let (ind,u as indu), ctx = UnivGen.fresh_inductive_instance env ind in let ((mib,mip as specif),constrargs,realsign,paramsctxt,nrealargs) = get_non_sym_eq_data env indu in @@ -603,8 +603,8 @@ let build_r2l_forward_rew_scheme dep env ind kind = let applied_PG = mkApp (mkVar varP, if dep then Context.Rel.to_extended_vect mkRel 0 realsign_ind - else Context.Rel.to_extended_vect mkRel 1 realsign) in - let c = + else Context.Rel.to_extended_vect mkRel 1 realsign) in + let c = (my_it_mkLambda_or_LetIn paramsctxt (my_it_mkLambda_or_LetIn_name realsign_ind (mkNamedLambda (make_annot varP indr) @@ -619,8 +619,8 @@ let build_r2l_forward_rew_scheme dep env ind kind = mkRel 3 (* varH *), [|mkLambda (make_annot (Name varHC) indr, - lift (nrealargs+3) applied_PC, - mkRel 1)|]), + lift (nrealargs+3) applied_PC, + mkRel 1)|]), [|mkVar varHC|])))))) in c, UState.of_context_set ctx @@ -648,14 +648,14 @@ let fix_r2l_forward_rew_scheme (c, ctx') = let ctx,_ = decompose_prod_assum t in match ctx with | hp :: p :: ind :: indargs -> - let c' = + let c' = my_it_mkLambda_or_LetIn indargs (mkLambda_or_LetIn (RelDecl.map_constr (liftn (-1) 1) p) - (mkLambda_or_LetIn (RelDecl.map_constr (liftn (-1) 2) hp) - (mkLambda_or_LetIn (RelDecl.map_constr (lift 2) ind) + (mkLambda_or_LetIn (RelDecl.map_constr (liftn (-1) 2) hp) + (mkLambda_or_LetIn (RelDecl.map_constr (lift 2) ind) (EConstr.Unsafe.to_constr (Reductionops.whd_beta sigma - (EConstr.of_constr (applist (c, - Context.Rel.to_extended_list mkRel 3 indargs @ [mkRel 1;mkRel 3;mkRel 2])))))))) + (EConstr.of_constr (applist (c, + Context.Rel.to_extended_list mkRel 3 indargs @ [mkRel 1;mkRel 3;mkRel 2])))))))) in c', ctx' | _ -> anomaly (Pp.str "Ill-formed non-dependent left-to-right rewriting scheme.") @@ -679,7 +679,7 @@ let fix_r2l_forward_rew_scheme (c, ctx') = (* (H:I q1..qm a1..an), *) (* P b1..bn C -> P a1..an H *) (**********************************************************************) - + let build_r2l_rew_scheme dep env ind k = let sigma = Evd.from_env env in let (sigma, indu) = Evd.fresh_inductive_instance env sigma ind in @@ -772,7 +772,7 @@ let rew_r2l_scheme_kind = (* TODO: extend it to types with more than one index *) let build_congr env (eq,refl,ctx) ind = - let (ind,u as indu), ctx = with_context_set ctx + let (ind,u as indu), ctx = with_context_set ctx (UnivGen.fresh_inductive_instance env ind) in let (mib,mip) = lookup_mind_specif env ind in if not (Int.equal (Array.length mib.mind_packets) 1) || not (Int.equal (Array.length mip.mind_nf_lc) 1) then @@ -802,7 +802,7 @@ let build_congr env (eq,refl,ctx) ind = let ci = make_case_info (Global.env()) ind rci RegularStyle in let uni, ctx = Univ.extend_in_context_set (UnivGen.new_global_univ ()) ctx in let ctx = (fst ctx, Univ.enforce_leq uni (univ_of_eq env eq) (snd ctx)) in - let c = + let c = my_it_mkLambda_or_LetIn paramsctxt (mkNamedLambda (make_annot varB Sorts.Relevant) (mkType uni) (mkNamedLambda (make_annot varf Sorts.Relevant) (mkArrow (lift 1 ty) tyr (mkVar varB)) @@ -810,26 +810,26 @@ let build_congr env (eq,refl,ctx) ind = (mkNamedLambda (make_annot varH Sorts.Relevant) (applist (mkIndU indu, - Context.Rel.to_extended_list mkRel (mip.mind_nrealargs+2) paramsctxt @ - Context.Rel.to_extended_list mkRel 0 realsign)) + Context.Rel.to_extended_list mkRel (mip.mind_nrealargs+2) paramsctxt @ + Context.Rel.to_extended_list mkRel 0 realsign)) (mkCase (ci, my_it_mkLambda_or_LetIn_name - (lift_rel_context (mip.mind_nrealargs+3) realsign) + (lift_rel_context (mip.mind_nrealargs+3) realsign) (mkLambda (make_annot Anonymous Sorts.Relevant, applist (mkIndU indu, - Context.Rel.to_extended_list mkRel (2*mip.mind_nrealdecls+3) - paramsctxt - @ Context.Rel.to_extended_list mkRel 0 realsign), + Context.Rel.to_extended_list mkRel (2*mip.mind_nrealdecls+3) + paramsctxt + @ Context.Rel.to_extended_list mkRel 0 realsign), mkApp (eq, - [|mkVar varB; + [|mkVar varB; mkApp (mkVar varf, [|lift (2*mip.mind_nrealdecls+4) b|]); - mkApp (mkVar varf, [|mkRel (mip.mind_nrealargs - i + 2)|])|]))), + mkApp (mkVar varf, [|mkRel (mip.mind_nrealargs - i + 2)|])|]))), mkVar varH, [|mkApp (refl, [|mkVar varB; - mkApp (mkVar varf, [|lift (mip.mind_nrealargs+3) b|])|])|])))))) + mkApp (mkVar varf, [|lift (mip.mind_nrealargs+3) b|])|])|])))))) in c, UState.of_context_set ctx let congr_scheme_kind = declare_individual_scheme_object "_congr" diff --git a/tactics/eqschemes.mli b/tactics/eqschemes.mli index b3e10013ac..fd4221f7c0 100644 --- a/tactics/eqschemes.mli +++ b/tactics/eqschemes.mli @@ -24,9 +24,9 @@ val rew_l2r_forward_dep_scheme_kind : individual scheme_kind val rew_r2l_dep_scheme_kind : individual scheme_kind val rew_r2l_scheme_kind : individual scheme_kind -val build_r2l_rew_scheme : bool -> env -> inductive -> Sorts.family -> +val build_r2l_rew_scheme : bool -> env -> inductive -> Sorts.family -> constr Evd.in_evar_universe_context -val build_l2r_rew_scheme : bool -> env -> inductive -> Sorts.family -> +val build_l2r_rew_scheme : bool -> env -> inductive -> Sorts.family -> constr Evd.in_evar_universe_context * Evd.side_effects val build_r2l_forward_rew_scheme : bool -> env -> inductive -> Sorts.family -> constr Evd.in_evar_universe_context @@ -38,12 +38,12 @@ val build_l2r_forward_rew_scheme : val build_sym_scheme : env -> inductive -> constr Evd.in_evar_universe_context val sym_scheme_kind : individual scheme_kind -val build_sym_involutive_scheme : env -> inductive -> +val build_sym_involutive_scheme : env -> inductive -> constr Evd.in_evar_universe_context * Evd.side_effects val sym_involutive_scheme_kind : individual scheme_kind (** Builds a congruence scheme for an equality type *) val congr_scheme_kind : individual scheme_kind -val build_congr : env -> constr * constr * Univ.ContextSet.t -> inductive -> +val build_congr : env -> constr * constr * Univ.ContextSet.t -> inductive -> constr Evd.in_evar_universe_context diff --git a/tactics/equality.ml b/tactics/equality.ml index 1f125a3c59..fc37d5a254 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -241,7 +241,7 @@ let rewrite_keyed_unif_flags = { let rewrite_elim with_evars frzevars cls c e = Proofview.Goal.enter begin fun gl -> let flags = if Unification.is_keyed_unification () - then rewrite_keyed_unif_flags else rewrite_conv_closed_unif_flags in + then rewrite_keyed_unif_flags else rewrite_conv_closed_unif_flags in let flags = make_flags frzevars (Tacmach.New.project gl) flags c in general_elim_clause with_evars flags cls c e end @@ -366,7 +366,7 @@ let find_elim hdcncl lft2rgt dep cls ot = then let sort = elimination_sort_of_clause cls gl in let c = - match EConstr.kind sigma hdcncl with + match EConstr.kind sigma hdcncl with | Ind (ind_sp,u) -> begin match lft2rgt, cls with | Some true, None @@ -381,19 +381,19 @@ let find_elim hdcncl lft2rgt dep cls ot = try let _ = Global.lookup_constant c1' in c1' with Not_found -> - user_err ~hdr:"Equality.find_elim" + user_err ~hdr:"Equality.find_elim" (str "Cannot find rewrite principle " ++ Label.print l' ++ str ".") - end + end | _ -> begin match if is_eq then eq_elimination_ref false sort else None with | Some r -> destConstRef r | None -> destConstRef (lookup_eliminator env ind_sp sort) end end - | _ -> - (* cannot occur since we checked that we are in presence of - Logic.eq or Jmeq just before *) - assert false + | _ -> + (* cannot occur since we checked that we are in presence of + Logic.eq or Jmeq just before *) + assert false in pf_constr_of_global (GlobRef.ConstRef c) else @@ -410,9 +410,9 @@ let find_elim hdcncl lft2rgt dep cls ot = | true, _, false -> rew_r2l_forward_dep_scheme_kind in match EConstr.kind sigma hdcncl with - | Ind (ind,u) -> - - let c, eff = find_scheme scheme_name ind in + | Ind (ind,u) -> + + let c, eff = find_scheme scheme_name ind in Proofview.tclEFFECTS eff <*> pf_constr_of_global (GlobRef.ConstRef c) | _ -> assert false @@ -463,27 +463,27 @@ let general_rewrite_ebindings_clause cls lft2rgt occs frzevars dep_proof_ok ?tac let rels, t = decompose_prod_assum sigma (whd_betaiotazeta sigma ctype) in match match_with_equality_type env sigma t with | Some (hdcncl,args) -> (* Fast path: direct leibniz-like rewrite *) - let lft2rgt = adjust_rewriting_direction args lft2rgt in + let lft2rgt = adjust_rewriting_direction args lft2rgt in leibniz_rewrite_ebindings_clause cls lft2rgt tac c (it_mkProd_or_LetIn t rels) - l with_evars frzevars dep_proof_ok hdcncl + l with_evars frzevars dep_proof_ok hdcncl | None -> - Proofview.tclORELSE + Proofview.tclORELSE begin - rewrite_side_tac (Hook.get forward_general_setoid_rewrite_clause cls - lft2rgt occs (c,l) ~new_goals:[]) tac + rewrite_side_tac (Hook.get forward_general_setoid_rewrite_clause cls + lft2rgt occs (c,l) ~new_goals:[]) tac end begin function | (e, info) -> Proofview.tclEVARMAP >>= fun sigma -> - let env' = push_rel_context rels env in - let rels',t' = splay_prod_assum env' sigma t in (* Search for underlying eq *) + let env' = push_rel_context rels env in + let rels',t' = splay_prod_assum env' sigma t in (* Search for underlying eq *) match match_with_equality_type env sigma t' with - | Some (hdcncl,args) -> - let lft2rgt = adjust_rewriting_direction args lft2rgt in - leibniz_rewrite_ebindings_clause cls lft2rgt tac c - (it_mkProd_or_LetIn t' (rels' @ rels)) l with_evars frzevars dep_proof_ok hdcncl - | None -> Proofview.tclZERO ~info e - (* error "The provided term does not end with an equality or a declared rewrite relation." *) + | Some (hdcncl,args) -> + let lft2rgt = adjust_rewriting_direction args lft2rgt in + leibniz_rewrite_ebindings_clause cls lft2rgt tac c + (it_mkProd_or_LetIn t' (rels' @ rels)) l with_evars frzevars dep_proof_ok hdcncl + | None -> Proofview.tclZERO ~info e + (* error "The provided term does not end with an equality or a declared rewrite relation." *) end end @@ -517,44 +517,44 @@ let general_rewrite_clause l2r with_evars ?tac c cl = in match cl.onhyps with | Some l -> - (* If a precise list of locations is given, success is mandatory for - each of these locations. *) - let rec do_hyps = function - | [] -> Proofview.tclUNIT () - | ((occs,id),_) :: l -> - tclTHENFIRST - (general_rewrite_ebindings_in l2r (occs_of occs) false true ?tac id c with_evars) - (do_hyps l) - in - if cl.concl_occs == NoOccurrences then do_hyps l else - tclTHENFIRST - (general_rewrite_ebindings l2r (occs_of cl.concl_occs) false true ?tac c with_evars) + (* If a precise list of locations is given, success is mandatory for + each of these locations. *) + let rec do_hyps = function + | [] -> Proofview.tclUNIT () + | ((occs,id),_) :: l -> + tclTHENFIRST + (general_rewrite_ebindings_in l2r (occs_of occs) false true ?tac id c with_evars) + (do_hyps l) + in + if cl.concl_occs == NoOccurrences then do_hyps l else + tclTHENFIRST + (general_rewrite_ebindings l2r (occs_of cl.concl_occs) false true ?tac c with_evars) (do_hyps l) | None -> - (* Otherwise, if we are told to rewrite in all hypothesis via the + (* Otherwise, if we are told to rewrite in all hypothesis via the syntax "* |-", we fail iff all the different rewrites fail *) - let rec do_hyps_atleastonce = function - | [] -> tclZEROMSG (Pp.str"Nothing to rewrite.") - | id :: l -> + let rec do_hyps_atleastonce = function + | [] -> tclZEROMSG (Pp.str"Nothing to rewrite.") + | id :: l -> tclIFTHENFIRSTTRYELSEMUST - (general_rewrite_ebindings_in l2r AllOccurrences false true ?tac id c with_evars) - (do_hyps_atleastonce l) - in - let do_hyps = - (* If the term to rewrite uses an hypothesis H, don't rewrite in H *) - let ids gl = - let ids_in_c = Termops.global_vars_set (Proofview.Goal.env gl) (project gl) (fst c) in + (general_rewrite_ebindings_in l2r AllOccurrences false true ?tac id c with_evars) + (do_hyps_atleastonce l) + in + let do_hyps = + (* If the term to rewrite uses an hypothesis H, don't rewrite in H *) + let ids gl = + let ids_in_c = Termops.global_vars_set (Proofview.Goal.env gl) (project gl) (fst c) in let ids_of_hyps = pf_ids_of_hyps gl in - Id.Set.fold (fun id l -> List.remove Id.equal id l) ids_in_c ids_of_hyps - in + Id.Set.fold (fun id l -> List.remove Id.equal id l) ids_in_c ids_of_hyps + in Proofview.Goal.enter begin fun gl -> do_hyps_atleastonce (ids gl) end - in - if cl.concl_occs == NoOccurrences then do_hyps else + in + if cl.concl_occs == NoOccurrences then do_hyps else tclIFTHENFIRSTTRYELSEMUST - (general_rewrite_ebindings l2r (occs_of cl.concl_occs) false true ?tac c with_evars) - do_hyps + (general_rewrite_ebindings l2r (occs_of cl.concl_occs) false true ?tac c with_evars) + do_hyps let apply_special_clear_request clear_flag f = Proofview.Goal.enter begin fun gl -> @@ -615,9 +615,9 @@ let check_setoid cl = let concloccs = Locusops.occurrences_map (fun x -> x) cl.concl_occs in Option.fold_left (List.fold_left - (fun b ((occ,_),_) -> + (fun b ((occ,_),_) -> b||(not (Locusops.is_all_occurrences (Locusops.occurrences_map (fun x -> x) occ))) - ) + ) ) (not (Locusops.is_all_occurrences concloccs) && (concloccs <> NoOccurrences)) @@ -631,7 +631,7 @@ let replace_core clause l2r eq = (onLastHypId (fun id -> tclTHEN (tclTRY (general_rewrite_clause l2r false (mkVar id,NoBindings) clause)) - (clear [id]))) + (clear [id]))) (* eq,sym_eq : equality on Type and its symmetry theorem c1 c2 : c1 is to be replaced by c2 @@ -649,7 +649,7 @@ let replace_using_leibniz clause c1 c2 l2r unsafe try_prove_eq_opt = let get_type_of = pf_apply get_type_of gl in let t1 = get_type_of c1 and t2 = get_type_of c2 in - let evd = + let evd = if unsafe then Some (Tacmach.New.project gl) else try Some (Evarconv.unify_delay (Proofview.Goal.env gl) (Tacmach.New.project gl) t1 t2) @@ -760,37 +760,37 @@ let find_positions env sigma ~keep_proofs ~no_discr t1 t2 = | Construct ((ind1,i1 as sp1),u1), Construct (sp2,_) when Int.equal (List.length args1) (constructor_nallargs env sp1) -> - let sorts' = + let sorts' = CList.intersect Sorts.family_equal sorts (sorts_below (top_allowed_sort env (fst sp1))) in (* both sides are fully applied constructors, so either we descend, or we can discriminate here. *) - if eq_constructor sp1 sp2 then + if eq_constructor sp1 sp2 then let nparams = inductive_nparams env ind1 in - let params1,rargs1 = List.chop nparams args1 in - let _,rargs2 = List.chop nparams args2 in + let params1,rargs1 = List.chop nparams args1 in + let _,rargs2 = List.chop nparams args2 in let (mib,mip) = lookup_mind_specif env ind1 in let params1 = List.map EConstr.Unsafe.to_constr params1 in let u1 = EInstance.kind sigma u1 in let ctxt = (get_constructor ((ind1,u1),mib,mip,params1) i1).cs_args in let adjust i = CVars.adjust_rel_to_rel_context ctxt (i+1) - 1 in List.flatten - (List.map2_i (fun i -> findrec sorts' ((sp1,adjust i)::posn)) - 0 rargs1 rargs2) + (List.map2_i (fun i -> findrec sorts' ((sp1,adjust i)::posn)) + 0 rargs1 rargs2) else if List.mem_f Sorts.family_equal InType sorts' && not no_discr then (* see build_discriminator *) - raise (DiscrFound (List.rev posn,sp1,sp2)) - else + raise (DiscrFound (List.rev posn,sp1,sp2)) + else (* if we cannot eliminate to Type, we cannot discriminate but we - may still try to project *) - project env sorts posn (applist (hd1,args1)) (applist (hd2,args2)) + may still try to project *) + project env sorts posn (applist (hd1,args1)) (applist (hd2,args2)) | _ -> - let t1_0 = applist (hd1,args1) + let t1_0 = applist (hd1,args1) and t2_0 = applist (hd2,args2) in if is_conv env sigma t1_0 t2_0 then - [] + [] else - project env sorts posn t1_0 t2_0 + project env sorts posn t1_0 t2_0 in try let sorts = if keep_proofs then [InSet;InType;InProp] else [InSet;InType] in @@ -881,7 +881,7 @@ let descend_then env sigma head dirn = let IndType (indf,_) = try find_rectype env sigma (get_type_of env sigma head) with Not_found -> - user_err Pp.(str "Cannot project on an inductive type derived from a dependency.") + user_err Pp.(str "Cannot project on an inductive type derived from a dependency.") in let indp,_ = (dest_ind_family indf) in let ind, _ = check_privacy env indp in @@ -894,12 +894,12 @@ let descend_then env sigma head dirn = (fun sigma dirnval (dfltval,resty) -> let deparsign = make_arity_signature env sigma true indf in let p = - it_mkLambda_or_LetIn (lift (mip.mind_nrealargs+1) resty) deparsign in + it_mkLambda_or_LetIn (lift (mip.mind_nrealargs+1) resty) deparsign in let build_branch i = - let result = if Int.equal i dirn then dirnval else dfltval in - let cs_args = List.map (fun d -> map_rel_decl EConstr.of_constr d) cstr.(i-1).cs_args in - let args = name_context env sigma cs_args in - it_mkLambda_or_LetIn result args in + let result = if Int.equal i dirn then dirnval else dfltval in + let cs_args = List.map (fun d -> map_rel_decl EConstr.of_constr d) cstr.(i-1).cs_args in + let args = name_context env sigma cs_args in + it_mkLambda_or_LetIn result args in let brl = List.map build_branch (List.interval 1 (Array.length mip.mind_consnames)) in @@ -934,8 +934,8 @@ let build_selector env sigma dirn c ind special default = CP : changed assert false in a more informative error *) user_err ~hdr:"Equality.construct_discriminator" - (str "Cannot discriminate on inductive constructors with \ - dependent types.") in + (str "Cannot discriminate on inductive constructors with \ + dependent types.") in let (indp,_) = dest_ind_family indf in let ind, _ = check_privacy env indp in let typ = Retyping.get_type_of env sigma default in @@ -1055,9 +1055,9 @@ let discrEq (lbeq,_,(t,t1,t2) as u) eq_clause = let env = Proofview.Goal.env gl in match find_positions env sigma ~keep_proofs:false ~no_discr:false t1 t2 with | Inr _ -> - tclZEROMSG (str"Not a discriminable equality.") + tclZEROMSG (str"Not a discriminable equality.") | Inl (cpath, (_,dirn), _) -> - discr_positions env sigma u eq_clause cpath dirn + discr_positions env sigma u eq_clause cpath dirn end let onEquality with_evars tac (c,lbindc) = @@ -1216,17 +1216,17 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt = let sigma = Evarconv.solve_unif_constraints_with_heuristics env sigma in sigma, dflt with Evarconv.UnableToUnify _ -> - user_err Pp.(str "Cannot solve a unification problem.") + user_err Pp.(str "Cannot solve a unification problem.") else let (a,p_i_minus_1) = match whd_beta_stack sigma p_i with - | (_sigS,[a;p]) -> (a, p) - | _ -> anomaly ~label:"sig_clausal_form" (Pp.str "should be a sigma type.") in + | (_sigS,[a;p]) -> (a, p) + | _ -> anomaly ~label:"sig_clausal_form" (Pp.str "should be a sigma type.") in let sigma, ev = Evarutil.new_evar env sigma a in let rty = beta_applist sigma (p_i_minus_1,[ev]) in let sigma, tuple_tail = sigrec_clausal_form sigma (siglen-1) rty in let evopt = match EConstr.kind sigma ev with Evar _ -> None | _ -> Some ev in match evopt with - | Some w -> + | Some w -> let w_type = unsafe_type_of env sigma w in begin match Evarconv.unify_leq_delay env sigma w_type a with | sigma -> @@ -1235,14 +1235,14 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt = | exception Evarconv.UnableToUnify _ -> user_err Pp.(str "Cannot solve a unification problem.") end - | None -> + | None -> (* This at least happens if what has been detected as a dependency is not one; use an evasive error message; even if the problem is upwards: unification should be tried in the first place in make_iterated_tuple instead of approximatively computing the free rels; then unsolved evars would mean not binding rel *) - user_err Pp.(str "Cannot solve a unification problem.") + user_err Pp.(str "Cannot solve a unification problem.") in let sigma = Evd.clear_metas sigma in let sigma, scf = sigrec_clausal_form sigma siglen ty in @@ -1328,7 +1328,7 @@ let rec build_injrec env sigma dflt c = function let res = kont sigma subval (dfltval,tuplety) in sigma, (res, tuplety,dfltval) with - UserError _ -> failwith "caught" + UserError _ -> failwith "caught" let build_injector env sigma dflt c cpath = let sigma, (injcode,resty,_) = build_injrec env sigma dflt c cpath in @@ -1405,8 +1405,8 @@ let inject_at_positions env sigma l2r (eq,_,(t,t1,t2)) eq_clause posns tac = let inj_clause = apply_on_clause (pf,pf_typ) eq_clause in let pf = Clenvtac.clenv_value_cast_meta inj_clause in let ty = simplify_args env sigma (clenv_type inj_clause) in - evdref := sigma; - Some (pf, ty) + evdref := sigma; + Some (pf, ty) with Failure _ -> None in let injectors = List.map_filter filter posns in @@ -1438,7 +1438,7 @@ let injEqThen keep_proofs tac l2r (eq,_,(t,t1,t2) as u) eq_clause = tclZEROMSG (str"Nothing to inject.") | Inr posns -> inject_at_positions env sigma l2r u eq_clause posns - (tac (clenv_value eq_clause)) + (tac (clenv_value eq_clause)) let get_previous_hyp_position id gl = let env, sigma = Proofview.Goal.(env gl, sigma gl) in @@ -1497,11 +1497,11 @@ let decompEqThen keep_proofs ntac (lbeq,_,(t,t1,t2) as u) clause = let env = Proofview.Goal.env gl in match find_positions env sigma ~keep_proofs ~no_discr:false t1 t2 with | Inl (cpath, (_,dirn), _) -> - discr_positions env sigma u clause cpath dirn + discr_positions env sigma u clause cpath dirn | Inr [] -> (* Change: do not fail, simplify clear this trivial hyp *) ntac (clenv_value clause) 0 | Inr posns -> - inject_at_positions env sigma true u clause posns + inject_at_positions env sigma true u clause posns (ntac (clenv_value clause)) end @@ -1636,9 +1636,9 @@ let cutSubstInHyp l2r eqn id = let try_rewrite tac = Proofview.tclORELSE tac begin function (e, info) -> match e with | Constr_matching.PatternMatchingFailure -> - tclZEROMSG (str "Not a primitive equality here.") + tclZEROMSG (str "Not a primitive equality here.") | e when catchable_exception e -> - tclZEROMSG + tclZEROMSG (strbrk "Cannot find a well-typed generalization of the goal that makes the proof progress.") | e -> Proofview.tclZERO ~info e end @@ -1766,7 +1766,7 @@ let subst_one_var dep_proof_ok x = Context.Named.fold_outside test ~init:() hyps; user_err ~hdr:"Subst" (str "Cannot find any non-recursive equality over " ++ Id.print x ++ - str".") + str".") with FoundHyp res -> res in subst_one dep_proof_ok x res end @@ -1903,12 +1903,12 @@ let rewrite_assumption_cond cond_eq_term cl = | [] -> user_err Pp.(str "No such assumption.") | hyp ::rest -> let id = NamedDecl.get_id hyp in - begin - try + begin + try let dir = cond_eq_term (NamedDecl.get_type hyp) gl in - general_rewrite_clause dir false (mkVar id,NoBindings) cl - with | Failure _ | UserError _ -> arec rest gl - end + general_rewrite_clause dir false (mkVar id,NoBindings) cl + with | Failure _ | UserError _ -> arec rest gl + end in Proofview.Goal.enter begin fun gl -> let hyps = Proofview.Goal.hyps gl in diff --git a/tactics/equality.mli b/tactics/equality.mli index 8225195ca7..a9ccadf53a 100644 --- a/tactics/equality.mli +++ b/tactics/equality.mli @@ -57,7 +57,7 @@ val general_rewrite_bindings_in : ?tac:(unit Proofview.tactic * conditions) -> Id.t -> constr with_bindings -> evars_flag -> unit Proofview.tactic val general_rewrite_in : - orientation -> occurrences -> freeze_evars_flag -> dep_proof_flag -> + orientation -> occurrences -> freeze_evars_flag -> dep_proof_flag -> ?tac:(unit Proofview.tactic * conditions) -> Id.t -> constr -> evars_flag -> unit Proofview.tactic val general_rewrite_clause : diff --git a/tactics/hints.ml b/tactics/hints.ml index ac18d5ce97..eb50a2a67c 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -253,9 +253,9 @@ type stored_data = int * full_hint (* First component is the index of insertion in the table, to keep most recent first semantics. *) module Bounded_net = Btermdn.Make(struct - type t = stored_data - let compare = pri_order_int - end) + type t = stored_data + let compare = pri_order_int + end) type search_entry = { sentry_nopat : stored_data list; @@ -275,18 +275,18 @@ let eq_pri_auto_tactic (_, x) (_, y) = KerName.equal x.code.uid y.code.uid let add_tac pat t st se = match pat with - | None -> + | None -> if List.exists (eq_pri_auto_tactic t) se.sentry_nopat then se else { se with sentry_nopat = List.insert pri_order t se.sentry_nopat } - | Some pat -> + | Some pat -> if List.exists (eq_pri_auto_tactic t) se.sentry_pat then se else { se with sentry_pat = List.insert pri_order t se.sentry_pat; sentry_bnet = Bounded_net.add st se.sentry_bnet (pat, t); } let rebuild_dn st se = - let dn' = - List.fold_left + let dn' = + List.fold_left (fun dn (id, t) -> Bounded_net.add (Some st) dn (Option.get t.pat, (id, t))) Bounded_net.empty se.sentry_pat in @@ -302,9 +302,9 @@ let is_transparent_gr ts = let open GlobRef in function | ConstRef cst -> TransparentState.is_transparent_constant ts cst | IndRef _ | ConstructRef _ -> false -let strip_params env sigma c = +let strip_params env sigma c = match EConstr.kind sigma c with - | App (f, args) -> + | App (f, args) -> (match EConstr.kind sigma f with | Const (cst,_) -> (match Recordops.find_primitive_projection cst with @@ -322,10 +322,10 @@ let strip_params env sigma c = let instantiate_hint env sigma p = let mk_clenv (c, cty, ctx) = let sigma = Evd.merge_context_set univ_flexible sigma ctx in - let cl = mk_clenv_from_env env sigma None (c,cty) in - {cl with templval = - { cl.templval with rebus = strip_params env sigma cl.templval.rebus }; - env = empty_env} + let cl = mk_clenv_from_env env sigma None (c,cty) in + {cl with templval = + { cl.templval with rebus = strip_params env sigma cl.templval.rebus }; + env = empty_env} in let code = match p.code.obj with | Res_pf c -> Res_pf (c, mk_clenv c) @@ -359,11 +359,11 @@ let path_matches hp hints = match hp, hints with | PathAtom _, [] -> false | PathAtom PathAny, (_ :: hints') -> k hints' - | PathAtom p, (h :: hints') -> + | PathAtom p, (h :: hints') -> if hints_path_atom_eq p h then k hints' else false - | PathStar hp', hints -> + | PathStar hp', hints -> k hints || aux hp' hints (fun hints' -> aux hp hints' k) - | PathSeq (hp, hp'), hints -> + | PathSeq (hp, hp'), hints -> aux hp hints (fun hints' -> aux hp' hints' k) | PathOr (hp, hp'), hints -> aux hp hints k || aux hp' hints k @@ -392,7 +392,7 @@ let path_seq p p' = | PathEpsilon, p' -> p' | p, PathEpsilon -> p | p, p' -> PathSeq (p, p') - + let rec path_derivate hp hint = let rec derivate_atoms hints hints' = match hints, hints' with @@ -404,7 +404,7 @@ let rec path_derivate hp hint = in match hp with | PathAtom PathAny -> PathEpsilon - | PathAtom (PathHints grs) -> + | PathAtom (PathHints grs) -> (match grs, hint with | h :: _, PathAny -> PathEmpty | hints, PathHints hints' -> derivate_atoms hints hints' @@ -412,9 +412,9 @@ let rec path_derivate hp hint = | PathStar p -> if path_matches p [hint] then hp else PathEpsilon | PathSeq (hp, hp') -> let hpder = path_derivate hp hint in - if matches_epsilon hp then + if matches_epsilon hp then PathOr (path_seq hpder hp', path_derivate hp' hint) - else if is_empty hpder then PathEmpty + else if is_empty hpder then PathEmpty else path_seq hpder hp' | PathOr (hp, hp') -> PathOr (path_derivate hp hint, path_derivate hp' hint) @@ -427,11 +427,11 @@ let rec normalize_path h = | PathSeq (PathEmpty, _) | PathSeq (_, PathEmpty) -> PathEmpty | PathSeq (PathEpsilon, p) | PathSeq (p, PathEpsilon) -> normalize_path p | PathOr (PathEmpty, p) | PathOr (p, PathEmpty) -> normalize_path p - | PathOr (p, q) -> + | PathOr (p, q) -> let p', q' = normalize_path p, normalize_path q in if hints_path_eq p p' && hints_path_eq q q' then h else normalize_path (PathOr (p', q')) - | PathSeq (p, q) -> + | PathSeq (p, q) -> let p', q' = normalize_path p, normalize_path q in if hints_path_eq p p' && hints_path_eq q q' then h else normalize_path (PathSeq (p', q')) @@ -450,13 +450,13 @@ let pp_hints_path_gen prg = | PathStar (PathAtom PathAny) -> str"_*" | PathStar p -> str "(" ++ aux p ++ str")*" | PathSeq (p, p') -> aux p ++ spc () ++ aux p' - | PathOr (p, p') -> + | PathOr (p, p') -> str "(" ++ aux p ++ spc () ++ str"|" ++ cut () ++ spc () ++ aux p' ++ str ")" | PathEmpty -> str"emp" | PathEpsilon -> str"eps" in aux - + let pp_hints_path = pp_hints_path_gen pr_global let glob_hints_path_atom p = @@ -552,18 +552,18 @@ struct { db with hintdb_max_id = succ db.hintdb_max_id }, h let empty ?name st use_dn = { hintdb_state = st; - hintdb_cut = PathEmpty; - hintdb_unfolds = (Id.Set.empty, Cset.empty); - hintdb_max_id = 0; - use_dn = use_dn; + hintdb_cut = PathEmpty; + hintdb_unfolds = (Id.Set.empty, Cset.empty); + hintdb_max_id = 0; + use_dn = use_dn; hintdb_map = GlobRef.Map.empty; - hintdb_nopat = []; - hintdb_name = name; } + hintdb_nopat = []; + hintdb_name = name; } let find key db = try GlobRef.Map.find key db.hintdb_map with Not_found -> empty_se - + let realize_tac secvars (id,tac) = if Id.Pred.subset tac.secvars secvars then Some tac else @@ -588,11 +588,11 @@ struct (try ignore(head_evar sigma arg); false with Evarutil.NoHeadEvar -> true) | ModeOutput -> true - + let matches_mode sigma args mode = Array.length mode == Array.length args && Array.for_all2 (match_mode sigma) mode args - + let matches_modes sigma args modes = if List.is_empty modes then true else List.exists (matches_mode sigma args) modes @@ -609,7 +609,7 @@ struct let map_all ~secvars k db = let se = find k db in merge_entry secvars db se.sentry_nopat se.sentry_pat - + (* Precondition: concl has no existentials *) let map_auto sigma ~secvars (k,args) concl db = let se = find k db in @@ -644,7 +644,7 @@ struct let idv = id, { v with db = db.hintdb_name } in let k = match gr with | Some gr -> if db.use_dn && is_transparent_gr db.hintdb_state gr && - is_unfold v.code.obj then None else Some gr + is_unfold v.code.obj then None else Some gr | None -> None in let dnst = if db.use_dn then Some db.hintdb_state else None in @@ -652,18 +652,18 @@ struct match k with | None -> let is_present (_, (_, v')) = KerName.equal v.code.uid v'.code.uid in - if not (List.exists is_present db.hintdb_nopat) then + if not (List.exists is_present db.hintdb_nopat) then (* FIXME *) - { db with hintdb_nopat = (gr,idv) :: db.hintdb_nopat } - else db + { db with hintdb_nopat = (gr,idv) :: db.hintdb_nopat } + else db | Some gr -> - let oval = find gr db in + let oval = find gr db in { db with hintdb_map = GlobRef.Map.add gr (add_tac pat idv dnst oval) db.hintdb_map } let rebuild_db st' db = let db' = { db with hintdb_map = GlobRef.Map.map (rebuild_dn st') db.hintdb_map; - hintdb_state = st'; hintdb_nopat = [] } + hintdb_state = st'; hintdb_nopat = [] } in List.fold_left (fun db (gr,(id,v)) -> addkv gr id v db) db' db.hintdb_nopat @@ -674,14 +674,14 @@ struct | Unfold_nth egr -> let addunf ts (ids, csts) = let open TransparentState in - match egr with + match egr with | EvalVarRef id -> { ts with tr_var = Id.Pred.add id ts.tr_var }, (Id.Set.add id ids, csts) | EvalConstRef cst -> { ts with tr_cst = Cpred.add cst ts.tr_cst }, (ids, Cset.add cst csts) - in - let state, unfs = addunf db.hintdb_state db.hintdb_unfolds in - state, { db with hintdb_unfolds = unfs }, true + in + let state, unfs = addunf db.hintdb_state db.hintdb_unfolds in + state, { db with hintdb_unfolds = unfs }, true | _ -> db.hintdb_state, db, false in let db = if db.use_dn && rebuild then rebuild_db st' db else db in @@ -807,19 +807,19 @@ let make_exact_entry env sigma info ~poly ?(name=PathAny) (c, cty, ctx) = | Prod _ -> failwith "make_exact_entry" | _ -> let pat = Patternops.pattern_of_constr env sigma (EConstr.to_constr ~abort_on_undefined_evars:false sigma cty) in - let hd = - try head_pattern_bound pat - with BoundPattern -> failwith "make_exact_entry" - in - let pri = match info.hint_priority with None -> 0 | Some p -> p in - let pat = match info.hint_pattern with - | Some pat -> snd pat - | None -> pat - in + let hd = + try head_pattern_bound pat + with BoundPattern -> failwith "make_exact_entry" + in + let pri = match info.hint_priority with None -> 0 | Some p -> p in + let pat = match info.hint_pattern with + | Some pat -> snd pat + | None -> pat + in (Some hd, - { pri; poly; pat = Some pat; name; - db = None; secvars; - code = with_uid (Give_exact (c, cty, ctx)); }) + { pri; poly; pat = Some pat; name; + db = None; secvars; + code = with_uid (Give_exact (c, cty, ctx)); }) let make_apply_entry env sigma (eapply,hnf,verbose) info ~poly ?(name=PathAny) (c, cty, ctx) = let cty = if hnf then hnf_constr env sigma cty else cty in @@ -912,7 +912,7 @@ let make_resolves env sigma flags info ~poly ?name cr = user_err ~hdr:"Hint" (pr_leconstr_env env sigma c ++ spc() ++ (if pi1 flags then str"cannot be used as a hint." - else str "can be used as a hint only for eauto.")); + else str "can be used as a hint only for eauto.")); ents (* used to add an hypothesis to the local hint database *) @@ -949,9 +949,9 @@ let make_extern pri pat tacast = name = PathAny; db = None; secvars = Id.Pred.empty; (* Approximation *) - code = with_uid (Extern tacast) }) + code = with_uid (Extern tacast) }) -let make_mode ref m = +let make_mode ref m = let open Term in let ty, _ = Typeops.type_of_global_in_context (Global.env ()) ref in let ctx, t = decompose_prod ty in @@ -959,10 +959,10 @@ let make_mode ref m = let m' = Array.of_list m in if not (n == Array.length m') then user_err ~hdr:"Hint" - (pr_global ref ++ str" has " ++ int n ++ - str" arguments while the mode declares " ++ int (Array.length m')) + (pr_global ref ++ str" has " ++ int n ++ + str" arguments while the mode declares " ++ int (Array.length m')) else m' - + let make_trivial env sigma poly ?(name=PathAny) r = let c,ctx = fresh_global_or_constr env sigma poly r in let sigma = Evd.merge_context_set univ_flexible sigma ctx in @@ -970,9 +970,9 @@ let make_trivial env sigma poly ?(name=PathAny) r = let hd = head_constr sigma t in let ce = mk_clenv_from_env env sigma None (c,t) in (Some hd, { pri=1; - poly = poly; + poly = poly; pat = Some (Patternops.pattern_of_constr env ce.evd (EConstr.to_constr sigma (clenv_type ce))); - name = name; + name = name; db = None; secvars = secvars_of_constr env sigma c; code= with_uid (Res_pf_THEN_trivial_fail(c,t,ctx)) }) @@ -1096,7 +1096,7 @@ let subst_autohint (subst, obj) = if c==c' && t'==t then data.code.obj else ERes_pf (c',t',ctx) | Give_exact (c,t,ctx) -> let c' = subst_mps subst c in - let t' = subst_mps subst t in + let t' = subst_mps subst t in if c==c' && t'== t then data.code.obj else Give_exact (c',t',ctx) | Res_pf_THEN_trivial_fail (c,t,ctx) -> let c' = subst_mps subst c in @@ -1106,8 +1106,8 @@ let subst_autohint (subst, obj) = let ref' = subst_evaluable_reference subst ref in if ref==ref' then data.code.obj else Unfold_nth ref' | Extern tac -> - let tac' = Genintern.generic_substitute subst tac in - if tac==tac' then data.code.obj else Extern tac' + let tac' = Genintern.generic_substitute subst tac in + if tac==tac' then data.code.obj else Extern tac' in let name' = subst_path_atom subst data.name in let uid' = subst_kn subst data.code.uid in @@ -1154,10 +1154,10 @@ let classify_autohint obj = let inAutoHint : hint_obj -> obj = declare_object {(default_object "AUTOHINT") with cache_function = cache_autohint; - load_function = load_autohint; - open_function = open_autohint; - subst_function = subst_autohint; - classify_function = classify_autohint; } + load_function = load_autohint; + open_function = open_autohint; + subst_function = subst_autohint; + classify_function = classify_autohint; } let make_hint ?(local = false) name action = { hint_local = local; @@ -1227,7 +1227,7 @@ let add_extern info tacast local dbname = | Some (_, pat) -> Some pat in let hint = make_hint ~local dbname - (AddHints [make_extern (Option.get info.hint_priority) pat tacast]) in + (AddHints [make_extern (Option.get info.hint_priority) pat tacast]) in Lib.add_anonymous_leaf (inAutoHint hint) let add_externs info tacast local dbnames = @@ -1274,10 +1274,10 @@ let prepare_hint check env init (sigma,c) = let t = Evarutil.nf_evar sigma (existential_type sigma ev) in let t = List.fold_right (fun (e,id) c -> replace_term sigma e id c) !subst t in if not (closed0 sigma c) then - user_err Pp.(str "Hints with holes dependent on a bound variable not supported."); + user_err Pp.(str "Hints with holes dependent on a bound variable not supported."); if occur_existential sigma t then - (* Not clever enough to construct dependency graph of evars *) - user_err Pp.(str "Not clever enough to deal with evars dependent in other evars."); + (* Not clever enough to construct dependency graph of evars *) + user_err Pp.(str "Not clever enough to deal with evars dependent in other evars."); raise (Found (c,t)) | _ -> EConstr.iter sigma find_next_evar c in let rec iter c = @@ -1350,7 +1350,7 @@ let interp_hints ~poly = match c with | HintsReference c -> let gr = global_with_alias c in - (PathHints [gr], poly, IsGlobRef gr) + (PathHints [gr], poly, IsGlobRef gr) | HintsConstr c -> (PathAny, poly, f poly c) in let fp = Constrintern.intern_constr_pattern env sigma in @@ -1376,14 +1376,14 @@ let interp_hints ~poly = | HintsConstructors lqid -> let constr_hints_of_ind qid = let ind = global_inductive_with_alias qid in - let mib,_ = Global.lookup_inductive ind in + let mib,_ = Global.lookup_inductive ind in Dumpglob.dump_reference ?loc:qid.CAst.loc "<>" (string_of_qualid qid) "ind"; List.init (nconstructors env ind) - (fun i -> let c = (ind,i+1) in + (fun i -> let c = (ind,i+1) in let gr = GlobRef.ConstructRef c in - empty_hint_info, + empty_hint_info, (Declareops.inductive_is_polymorphic mib), true, - PathHints [gr], IsGlobRef gr) + PathHints [gr], IsGlobRef gr) in HintsResolveEntry (List.flatten (List.map constr_hints_of_ind lqid)) | HintsExtern (pri, patcom, tacexp) -> let pat = Option.map (fp sigma) patcom in @@ -1415,11 +1415,11 @@ let expand_constructor_hints env sigma lems = match EConstr.kind sigma lem with | Ind (ind,u) -> List.init (nconstructors env ind) - (fun i -> - let ctx = Univ.ContextSet.diff (Evd.universe_context_set evd) - (Evd.universe_context_set sigma) in - not (Univ.ContextSet.is_empty ctx), - IsConstr (mkConstructU ((ind,i+1),u),ctx)) + (fun i -> + let ctx = Univ.ContextSet.diff (Evd.universe_context_set evd) + (Evd.universe_context_set sigma) in + not (Univ.ContextSet.is_empty ctx), + IsConstr (mkConstructU ((ind,i+1),u),ctx)) | _ -> let (c, ctx) = prepare_hint false env sigma (evd,lem) in [not (Univ.ContextSet.is_empty ctx), IsConstr (c, ctx)]) lems @@ -1436,7 +1436,7 @@ let make_local_hint_db env sigma ts eapply lems = let lems = List.map map lems in let sign = EConstr.named_context env in let ts = match ts with - | None -> Hint_db.transparent_state (searchtable_map "core") + | None -> Hint_db.transparent_state (searchtable_map "core") | Some ts -> ts in let hintlist = List.map_append (make_resolve_hyp env sigma) sign in @@ -1510,19 +1510,19 @@ let pr_hint_term env sigma cl = let dbs = current_db () in let valid_dbs = let fn = try - let hdc = decompose_app_bound sigma cl in - if occur_existential sigma cl then - Hint_db.map_existential sigma ~secvars:Id.Pred.full hdc cl - else Hint_db.map_auto sigma ~secvars:Id.Pred.full hdc cl - with Bound -> Hint_db.map_none ~secvars:Id.Pred.full + let hdc = decompose_app_bound sigma cl in + if occur_existential sigma cl then + Hint_db.map_existential sigma ~secvars:Id.Pred.full hdc cl + else Hint_db.map_auto sigma ~secvars:Id.Pred.full hdc cl + with Bound -> Hint_db.map_none ~secvars:Id.Pred.full in let fn db = List.map (fun x -> 0, x) (fn db) in List.map (fun (name, db) -> (name, db, fn db)) dbs in if List.is_empty valid_dbs then - (str "No hint applicable for current goal") + (str "No hint applicable for current goal") else - (str "Applicable Hints :" ++ fnl () ++ + (str "Applicable Hints :" ++ fnl () ++ hov 0 (prlist (pr_hints_db env sigma) valid_dbs)) with Match_failure _ | Failure _ -> (str "No hint applicable for current goal") diff --git a/tactics/hints.mli b/tactics/hints.mli index 5b89f8b381..2a9b71387e 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -112,7 +112,7 @@ type 'a hints_path_gen = type pre_hints_path = Libnames.qualid hints_path_gen type hints_path = GlobRef.t hints_path_gen - + val normalize_path : hints_path -> hints_path val path_matches : hints_path -> hints_path_atom list -> bool val path_derivate : hints_path -> hints_path_atom -> hints_path @@ -139,17 +139,17 @@ module Hint_db : (** All hints associated to the reference *) val map_all : secvars:Id.Pred.t -> GlobRef.t -> t -> full_hint list - (** All hints associated to the reference, respecting modes if evars appear in the - arguments, _not_ using the discrimination net. *) + (** All hints associated to the reference, respecting modes if evars appear in the + arguments, _not_ using the discrimination net. *) val map_existential : evar_map -> secvars:Id.Pred.t -> (GlobRef.t * constr array) -> constr -> t -> full_hint list - (** All hints associated to the reference, respecting modes if evars appear in the - arguments and using the discrimination net. *) + (** All hints associated to the reference, respecting modes if evars appear in the + arguments and using the discrimination net. *) val map_eauto : evar_map -> secvars:Id.Pred.t -> (GlobRef.t * constr array) -> constr -> t -> full_hint list - (** All hints associated to the reference, respecting modes if evars appear in the - arguments. *) + (** All hints associated to the reference, respecting modes if evars appear in the + arguments. *) val map_auto : evar_map -> secvars:Id.Pred.t -> (GlobRef.t * constr array) -> constr -> t -> full_hint list @@ -217,7 +217,7 @@ val prepare_hint : bool (* Check no remaining evars *) -> (** [make_exact_entry info (c, ctyp, ctx)]. [c] is the term given as an exact proof to solve the goal; [ctyp] is the type of [c]. - [ctx] is its (refreshable) universe context. + [ctx] is its (refreshable) universe context. In info: [hint_priority] is the hint's desired priority, it is 0 if unspecified [hint_pattern] is the hint's desired pattern, it is inferred if not specified @@ -232,7 +232,7 @@ val make_exact_entry : env -> evar_map -> hint_info -> poly:bool -> ?name:hints_ products; [c] is the term given as an exact proof to solve the goal; [cty] is the type of [c]. - [ctx] is its (refreshable) universe context. + [ctx] is its (refreshable) universe context. In info: [hint_priority] is the hint's desired priority, it is computed as the number of products in [cty] if unspecified diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml index 61e0e41eb9..90a9a7acd9 100644 --- a/tactics/hipattern.ml +++ b/tactics/hipattern.ml @@ -49,9 +49,9 @@ let match_with_non_recursive_type env sigma t = (match EConstr.kind sigma hdapp with | Ind (ind,u) -> if (Environ.lookup_mind (fst ind) env).mind_finite == CoFinite then - Some (hdapp,args) - else - None + Some (hdapp,args) + else + None | _ -> None) | _ -> None @@ -65,7 +65,7 @@ let is_non_recursive_type env sigma t = Option.has_some (match_with_non_recursiv let rec has_nodep_prod_after n env sigma c = match EConstr.kind sigma c with | Prod (_,_,b) | LetIn (_,_,_,b) -> - ( n>0 || Vars.noccurn sigma 1 b) + ( n>0 || Vars.noccurn sigma 1 b) && (has_nodep_prod_after (n-1) env sigma b) | _ -> true @@ -100,36 +100,36 @@ let match_with_one_constructor env sigma style onlybinary allow_rec t = | Ind ind -> let (mib,mip) = Inductive.lookup_mind_specif env (fst ind) in if Int.equal (Array.length mip.mind_consnames) 1 - && (allow_rec || not (mis_is_recursive (fst ind,mib,mip))) + && (allow_rec || not (mis_is_recursive (fst ind,mib,mip))) && (Int.equal mip.mind_nrealargs 0) then - if is_strict_conjunction style (* strict conjunction *) then + if is_strict_conjunction style (* strict conjunction *) then let (ctx, _) = mip.mind_nf_lc.(0) in let ctx = List.skipn (Context.Rel.length mib.mind_params_ctxt) (List.rev ctx) in - if + if (* Constructor has a type of the form c : forall (a_0 ... a_n : Type) (x_0 : A_0) ... (x_n : A_n). T **) - List.for_all - (fun decl -> let c = RelDecl.get_type decl in - is_local_assum decl && + List.for_all + (fun decl -> let c = RelDecl.get_type decl in + is_local_assum decl && Constr.isRel c && Int.equal (Constr.destRel c) mib.mind_nparams) ctx - then - Some (hdapp,args) - else None - else + then + Some (hdapp,args) + else None + else let ctx, cty = mip.mind_nf_lc.(0) in let cty = EConstr.of_constr (Term.it_mkProd_or_LetIn cty ctx) in let ctyp = whd_beta_prod sigma (Termops.prod_applist_assum sigma (Context.Rel.length mib.mind_params_ctxt) cty args) in - let cargs = List.map RelDecl.get_type (prod_assum sigma ctyp) in + let cargs = List.map RelDecl.get_type (prod_assum sigma ctyp) in if not (is_lax_conjunction style) || has_nodep_prod env sigma ctyp then - (* Record or non strict conjunction *) - Some (hdapp,List.rev cargs) - else - None + (* Record or non strict conjunction *) + Some (hdapp,List.rev cargs) + else + None else - None + None | _ -> None in match res with | Some (hdapp, args) when not onlybinary -> res @@ -185,10 +185,10 @@ let match_with_disjunction ?(strict=false) ?(onlybinary=false) env sigma t = then if strict then if test_strict_disjunction (mib, mip) then - Some (hdapp,args) - else - None - else + Some (hdapp,args) + else + None + else let map (ctx, cty) = let ar = EConstr.of_constr (Term.it_mkProd_or_LetIn cty ctx) in pi2 (destProd sigma (prod_applist sigma ar args)) @@ -196,7 +196,7 @@ let match_with_disjunction ?(strict=false) ?(onlybinary=false) env sigma t = let cargs = Array.map map mip.mind_nf_lc in Some (hdapp,Array.to_list cargs) else - None + None | _ -> None in match res with | Some (hdapp,args) when not onlybinary -> res @@ -215,7 +215,7 @@ let match_with_empty_type env sigma t = | Ind (ind, _) -> let (mib,mip) = Inductive.lookup_mind_specif env ind in let nconstr = Array.length mip.mind_consnames in - if Int.equal nconstr 0 then Some hdapp else None + if Int.equal nconstr 0 then Some hdapp else None | _ -> None let is_empty_type env sigma t = Option.has_some (match_with_empty_type env sigma t) @@ -230,9 +230,9 @@ let match_with_unit_or_eq_type env sigma t = let (mib,mip) = Inductive.lookup_mind_specif env ind in let nconstr = Array.length mip.mind_consnames in if Int.equal nconstr 1 && Int.equal mip.mind_consnrealargs.(0) 0 then - Some hdapp - else - None + Some hdapp + else + None | _ -> None let is_unit_or_eq_type env sigma t = Option.has_some (match_with_unit_or_eq_type env sigma t) @@ -307,16 +307,16 @@ let match_with_equation env sigma t = let (mib,mip) = Global.lookup_inductive ind in let constr_types = mip.mind_nf_lc in let nconstr = Array.length mip.mind_consnames in - if Int.equal nconstr 1 then + if Int.equal nconstr 1 then let (ctx, cty) = constr_types.(0) in let cty = EConstr.of_constr (Term.it_mkProd_or_LetIn cty ctx) in if is_matching env sigma coq_refl_leibniz1_pattern cty then - None, hdapp, MonomorphicLeibnizEq(args.(0),args.(1)) + None, hdapp, MonomorphicLeibnizEq(args.(0),args.(1)) else if is_matching env sigma coq_refl_leibniz2_pattern cty then - None, hdapp, PolymorphicLeibnizEq(args.(0),args.(1),args.(2)) + None, hdapp, PolymorphicLeibnizEq(args.(0),args.(1),args.(2)) else if is_matching env sigma coq_refl_jm_pattern cty then - None, hdapp, HeterogenousEq(args.(0),args.(1),args.(2),args.(3)) - else raise NoEquationFound + None, hdapp, HeterogenousEq(args.(0),args.(1),args.(2),args.(3)) + else raise NoEquationFound else raise NoEquationFound | _ -> raise NoEquationFound @@ -485,7 +485,7 @@ let match_sigma env sigma ex = | App (f, [| a; p; car; cdr |]) when Termops.is_global sigma (lib_ref "core.sigT.intro") f -> build_sigma_type (), (snd (destConstruct sigma f), a, p, car, cdr) | _ -> raise PatternMatchingFailure - + let find_sigma_data_decompose env ex = (* fails with PatternMatchingFailure *) match_sigma env ex diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli index 5ff257fbfe..803305a1ca 100644 --- a/tactics/hipattern.mli +++ b/tactics/hipattern.mli @@ -120,7 +120,7 @@ val match_with_equation: (***** Destructing patterns bound to some theory *) -(** Match terms [eq A t u], [identity A t u] or [JMeq A t A u] +(** Match terms [eq A t u], [identity A t u] or [JMeq A t A u] Returns associated lemmas and [A,t,u] or fails PatternMatchingFailure *) val find_eq_data_decompose : Proofview.Goal.t -> constr -> coq_eq_data * EInstance.t * (types * constr * constr) @@ -132,7 +132,7 @@ val find_this_eq_data_decompose : Proofview.Goal.t -> constr -> (** A variant that returns more informative structure on the equality found *) val find_eq_data : evar_map -> constr -> coq_eq_data * EInstance.t * equation_kind -(** Match a term of the form [(existT A P t p)] +(** Match a term of the form [(existT A P t p)] Returns associated lemmas and [A,P,t,p] *) val find_sigma_data_decompose : Environ.env -> evar_map -> constr -> coq_sigma_data * (EInstance.t * constr * constr * constr * constr) diff --git a/tactics/ind_tables.mli b/tactics/ind_tables.mli index e9a792c264..7e544b09dc 100644 --- a/tactics/ind_tables.mli +++ b/tactics/ind_tables.mli @@ -43,7 +43,7 @@ val declare_individual_scheme_object : string -> ?aux:string -> (** Force generation of a (mutually) scheme with possibly user-level names *) -val define_individual_scheme : individual scheme_kind -> +val define_individual_scheme : individual scheme_kind -> internal_flag (** internal *) -> Id.t option -> inductive -> Constant.t * Evd.side_effects diff --git a/tactics/inv.ml b/tactics/inv.ml index 49d0428a6f..be0421d42d 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -84,30 +84,30 @@ let make_inv_predicate env evd indf realargs id status concl = let (hyps,concl) = match status with | NoDep -> - (* We push the arity and leave concl unchanged *) - let hyps_arity,_ = get_arity env indf in - let hyps_arity = List.map (fun d -> map_rel_decl EConstr.of_constr d) hyps_arity in - (hyps_arity,concl) + (* We push the arity and leave concl unchanged *) + let hyps_arity,_ = get_arity env indf in + let hyps_arity = List.map (fun d -> map_rel_decl EConstr.of_constr d) hyps_arity in + (hyps_arity,concl) | Dep dflt_concl -> - if not (occur_var env !evd id concl) then - user_err ~hdr:"make_inv_predicate" + if not (occur_var env !evd id concl) then + user_err ~hdr:"make_inv_predicate" (str "Current goal does not depend on " ++ Id.print id ++ str"."); (* We abstract the conclusion of goal with respect to realargs and c to * be concl in order to rewrite and have c also rewritten when the case * will be done *) - let pred = + let pred = match dflt_concl with | Some concl -> concl (*assumed it's some [x1..xn,H:I(x1..xn)]C*) | None -> - let sort = get_sort_family_of env !evd concl in + let sort = get_sort_family_of env !evd concl in let sort = evd_comb1 Evd.fresh_sort_in_family evd sort in - let p = make_arity env !evd true indf sort in - let evd',(p,ptyp) = Unification.abstract_list_all env + let p = make_arity env !evd true indf sort in + let evd',(p,ptyp) = Unification.abstract_list_all env !evd p concl (realargs@[mkVar id]) - in evd := evd'; p in - let hyps,bodypred = decompose_lam_n_assum !evd (nrealargs+1) pred in - (* We lift to make room for the equations *) - (hyps,lift nrealargs bodypred) + in evd := evd'; p in + let hyps,bodypred = decompose_lam_n_assum !evd (nrealargs+1) pred in + (* We lift to make room for the equations *) + (hyps,lift nrealargs bodypred) in let nhyps = Context.Rel.length hyps in let env' = push_rel_context hyps env in @@ -124,11 +124,11 @@ let make_inv_predicate env evd indf realargs id status concl = let (xi, ti) = compute_eqn env' !evd nhyps n ai in let (lhs,eqnty,rhs) = if closed0 !evd ti then - (xi,ti,ai) + (xi,ti,ai) else - let sigma, res = make_iterated_tuple env' !evd ai (xi,ti) in - evd := sigma; res - in + let sigma, res = make_iterated_tuple env' !evd ai (xi,ti) in + evd := sigma; res + in let eq_term = eqdata.Coqlib.eq in let eq = evd_comb1 (Evd.fresh_global env) evd eq_term in let eqn = applist (eq,[eqnty;lhs;rhs]) in @@ -195,9 +195,9 @@ let dependent_hyps env id idlist gl = let rec dep_rec =function | [] -> [] | d::l -> - (* Update the type of id1: it may have been subject to rewriting *) - let d = pf_get_hyp (NamedDecl.get_id d) gl in - if occur_var_in_decl env (project gl) id d + (* Update the type of id1: it may have been subject to rewriting *) + let d = pf_get_hyp (NamedDecl.get_id d) gl in + if occur_var_in_decl env (project gl) id d then d :: dep_rec l else dep_rec l in @@ -380,14 +380,14 @@ let projectAndApply as_mode thin avoid id eqname names depids = tclTHENLIST [if as_mode then clear [id] else tclIDTAC; (tclMAP_i (false,false) neqns (function (idopt,_) -> - tclTRY (tclTHEN + tclTRY (tclTHEN (intro_move_avoid idopt avoid Logic.MoveLast) - (* try again to substitute and if still not a variable after *) - (* decomposition, arbitrarily try to rewrite RL !? *) - (tclTRY (onLastHypId (substHypIfVariable (fun id -> subst_hyp false id)))))) - names); + (* try again to substitute and if still not a variable after *) + (* decomposition, arbitrarily try to rewrite RL !? *) + (tclTRY (onLastHypId (substHypIfVariable (fun id -> subst_hyp false id)))))) + names); (if as_mode then tclIDTAC else clear [id])] - (* Doing the above late breaks the computation of dids in + (* Doing the above late breaks the computation of dids in generalizeRewriteIntros, and hence breaks proper intros_replacing but it is needed for compatibility *) in @@ -396,7 +396,7 @@ let projectAndApply as_mode thin avoid id eqname names depids = (* and apply a trailer which again try to substitute *) (fun id -> dEqThen ~keep_proofs:None false (deq_trailer id) - (Some (None,ElimOnConstr (EConstr.mkVar id,NoBindings)))) + (Some (None,ElimOnConstr (EConstr.mkVar id,NoBindings)))) id let nLastDecls i tac = @@ -420,17 +420,17 @@ let rewrite_equations as_mode othin neqns names ba = clear (ids_of_named_context nodepids); (nLastDecls neqns (fun ctx -> bring_hyps (List.rev ctx))); (nLastDecls neqns (fun ctx -> clear (ids_of_named_context ctx))); - tclMAP_i (true,false) neqns (fun (idopt,names) -> + tclMAP_i (true,false) neqns (fun (idopt,names) -> (tclTHEN (intro_move_avoid idopt avoid Logic.MoveLast) - (onLastHypId (fun id -> - tclTRY (projectAndApply as_mode thin avoid id first_eq names depids))))) - names; - tclMAP (fun d -> tclIDTAC >>= fun () -> (* delay for [first_eq]. *) + (onLastHypId (fun id -> + tclTRY (projectAndApply as_mode thin avoid id first_eq names depids))))) + names; + tclMAP (fun d -> tclIDTAC >>= fun () -> (* delay for [first_eq]. *) let idopt = if as_mode then Some (NamedDecl.get_id d) else None in intro_move idopt (if thin then Logic.MoveLast else !first_eq)) - nodepids; - (tclMAP (fun d -> tclTRY (clear [NamedDecl.get_id d])) depids)] + nodepids; + (tclMAP (fun d -> tclTRY (clear [NamedDecl.get_id d])) depids)] | None -> (* simple inversion *) if as_mode then @@ -505,10 +505,10 @@ let wrap_inv_error id = function (e, info) -> match e with Proofview.tclENV >>= fun env -> Proofview.tclEVARMAP >>= fun sigma -> tclZEROMSG ( - (strbrk "Inversion would require case analysis on sort " ++ + (strbrk "Inversion would require case analysis on sort " ++ pr_sort sigma k ++ - strbrk " which is not allowed for inductive definition " ++ - pr_inductive env (fst i) ++ str ".")) + strbrk " which is not allowed for inductive definition " ++ + pr_inductive env (fst i) ++ str ".")) | e -> Proofview.tclZERO ~info e (* The most general inversion tactic *) diff --git a/tactics/leminv.ml b/tactics/leminv.ml index 2af3947dd1..cf58c9306c 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -105,11 +105,11 @@ let max_prefix_sign lid sign = let rec max_rec (resid,prefix) = function | [] -> (resid,prefix) | (id::l) -> - let pre = sign_prefix id sign in - if sign_length pre > sign_length prefix then + let pre = sign_prefix id sign in + if sign_length pre > sign_length prefix then max_rec (id,pre) l else - max_rec (resid,prefix) l + max_rec (resid,prefix) l in match lid with | [] -> nil_sign @@ -119,11 +119,11 @@ let rec add_prods_sign env sigma t = match EConstr.kind sigma (whd_all env sigma t) with | Prod (na,c1,b) -> let id = id_of_name_using_hdchar env sigma t na.binder_name in - let b'= subst1 (mkVar id) b in + let b'= subst1 (mkVar id) b in add_prods_sign (push_named (LocalAssum ({na with binder_name=id},c1)) env) sigma b' | LetIn (na,c1,t1,b) -> let id = id_of_name_using_hdchar env sigma t na.binder_name in - let b'= subst1 (mkVar id) b in + let b'= subst1 (mkVar id) b in add_prods_sign (push_named (LocalDef ({na with binder_name=id},c1,t1)) env) sigma b' | _ -> (env,t) @@ -149,7 +149,7 @@ let compute_first_inversion_scheme env sigma ind sort dep_option = let pty = make_arity env sigma true indf sort in let r = relevance_of_inductive_type env ind in let goal = - mkProd + mkProd (make_annot Anonymous r, mkAppliedInd ind, applist(mkVar p,realargs@[mkRel 1])) in pty,goal @@ -157,14 +157,14 @@ let compute_first_inversion_scheme env sigma ind sort dep_option = let i = mkAppliedInd ind in let ivars = global_vars env sigma i in let revargs,ownsign = - fold_named_context - (fun env d (revargs,hyps) -> + fold_named_context + (fun env d (revargs,hyps) -> let d = map_named_decl EConstr.of_constr d in let id = NamedDecl.get_id d in if Id.List.mem id ivars then - ((mkVar id)::revargs, Context.Named.add d hyps) - else - (revargs,hyps)) + ((mkVar id)::revargs, Context.Named.add d hyps) + else + (revargs,hyps)) env ~init:([],[]) in let pty = it_mkNamedProd_or_LetIn (mkSort sort) ownsign in @@ -209,7 +209,7 @@ let inversion_scheme ~name ~poly env sigma t sort dep_option inv_op = (fun env d sign -> let d = map_named_decl EConstr.of_constr d in if mem_named_context_val (NamedDecl.get_id d) global_named_context then sign - else Context.Named.add d sign) + else Context.Named.add d sign) invEnv ~init:Context.Named.empty end in let avoid = ref Id.Set.empty in @@ -218,11 +218,11 @@ let inversion_scheme ~name ~poly env sigma t sort dep_option inv_op = let rec fill_holes c = match EConstr.kind sigma c with | Evar (e,args) -> - let h = next_ident_away (Id.of_string "H") !avoid in - let ty,inst = Evarutil.generalize_evar_over_rels sigma (e,args) in - avoid := Id.Set.add h !avoid; + let h = next_ident_away (Id.of_string "H") !avoid in + let ty,inst = Evarutil.generalize_evar_over_rels sigma (e,args) in + avoid := Id.Set.add h !avoid; ownSign := Context.Named.add (LocalAssum (make_annot h Sorts.Relevant,ty)) !ownSign; - applist (mkVar h, inst) + applist (mkVar h, inst) | _ -> EConstr.map sigma fill_holes c in let c = fill_holes pfterm in @@ -250,7 +250,7 @@ let add_inversion_lemma_exn ~poly na com comsort bool tac = add_inversion_lemma ~poly na env sigma c sort bool tac with | UserError (Some "Case analysis",s) -> (* Reference to Indrec *) - user_err ~hdr:"Inv needs Nodep Prop Set" s + user_err ~hdr:"Inv needs Nodep Prop Set" s (* ================================= *) (* Applying a given inversion lemma *) @@ -264,12 +264,12 @@ let lemInv id c = Clenvtac.res_pf clause ~flags:(Unification.elim_flags ()) ~with_evars:false with | NoSuchBinding -> - user_err - (hov 0 (pr_econstr_env (pf_env gls) (project gls) c ++ spc () ++ str "does not refer to an inversion lemma.")) + user_err + (hov 0 (pr_econstr_env (pf_env gls) (project gls) c ++ spc () ++ str "does not refer to an inversion lemma.")) | UserError (a,b) -> - user_err ~hdr:"LemInv" - (str "Cannot refine current goal with the lemma " ++ - pr_leconstr_env (pf_env gls) (project gls) c) + user_err ~hdr:"LemInv" + (str "Cannot refine current goal with the lemma " ++ + pr_leconstr_env (pf_env gls) (project gls) c) end let lemInv_gen id c = try_intros_until (fun id -> lemInv id c) id diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index b93c4a176f..ed7ab9164a 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -166,7 +166,7 @@ let check_or_and_pattern_size ?loc check_and names branchsigns = user_err ?loc (str "Expects " ++ msg p1 p2 ++ str ".") in let errn n = user_err ?loc (str "Expects a disjunctive pattern with " ++ int n - ++ str " branches.") in + ++ str " branches.") in let err1' p1 p2 = user_err ?loc (strbrk "Expects a disjunctive pattern with 1 branch or " ++ msg p1 p2 ++ str ".") in let errforthcoming ?loc = @@ -246,7 +246,7 @@ let elimination_sort_of_clause = function | Some id -> elimination_sort_of_hyp id -let pf_with_evars glsev k gls = +let pf_with_evars glsev k gls = let evd, a = glsev gls in tclTHEN (Refiner.tclEVARS evd) (k a) gls @@ -411,7 +411,7 @@ module New = struct let tclTRY t = tclORELSE0 t (tclUNIT ()) - + let tclTRYb t = tclORELSE0L (t <*> tclUNIT true) (tclUNIT false) @@ -498,7 +498,7 @@ module New = struct | Evd.Evar_empty -> Some (evk,evi) | Evd.Evar_defined c -> match Constr.kind (EConstr.Unsafe.to_constr c) with | Evar (evk,l) -> is_undefined_up_to_restriction sigma evk - | _ -> + | _ -> (* We make the assumption that there is no way to refine an evar remaining after typing from the initial term given to apply/elim and co tactics, is it correct? *) @@ -567,11 +567,11 @@ module New = struct let nthHypId m gl = (* We only use [id] *) nthDecl m gl |> NamedDecl.get_id - let nthHyp m gl = + let nthHyp m gl = mkVar (nthHypId m gl) let onNthHypId m tac = - Proofview.Goal.enter begin fun gl -> tac (nthHypId m gl) end + Proofview.Goal.enter begin fun gl -> tac (nthHypId m gl) end let onNthHyp m tac = Proofview.Goal.enter begin fun gl -> tac (nthHyp m gl) end @@ -644,12 +644,12 @@ module New = struct match EConstr.kind elimclause.evd p with | Meta p -> p | _ -> - let name_elim = - match EConstr.kind sigma elim with + let name_elim = + match EConstr.kind sigma elim with | Const _ | Var _ -> str " " ++ Printer.pr_econstr_env (pf_env gl) sigma elim | _ -> mt () - in - user_err ~hdr:"Tacticals.general_elim_then_using" + in + user_err ~hdr:"Tacticals.general_elim_then_using" (str "The elimination combinator " ++ name_elim ++ str " is unknown.") in let elimclause' = clenv_fchain ~with_univs:false indmv elimclause indclause in @@ -733,7 +733,7 @@ module New = struct tac branches end - let case_on_ba tac ba = + let case_on_ba tac ba = Proofview.Goal.enter begin fun gl -> let branches = make_elim_branch_assumptions ba (Proofview.Goal.hyps gl) in tac branches diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index c6aef6a554..31d26834d6 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -68,7 +68,7 @@ val afterHyp : Id.t -> Goal.goal sigma -> named_context val ifOnHyp : (Id.t * types -> bool) -> (Id.t -> tactic) -> (Id.t -> tactic) -> - Id.t -> tactic + Id.t -> tactic val onHyps : (Goal.goal sigma -> named_context) -> (named_context -> tactic) -> tactic @@ -109,7 +109,7 @@ val get_and_check_or_and_pattern : bool list array -> intro_patterns array (** Tolerate "[]" to mean a disjunctive pattern of any length *) -val fix_empty_or_and_pattern : int -> +val fix_empty_or_and_pattern : int -> delayed_open_constr or_and_intro_pattern_expr -> delayed_open_constr or_and_intro_pattern_expr diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 6fd18b83d1..33c9c11350 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -446,7 +446,7 @@ let internal_cut_gen ?(check=true) dir replace id t = sign',t,concl,sigma else (if check && mem_named_context_val id sign then - user_err (str "Variable " ++ Id.print id ++ str " is already declared."); + user_err (str "Variable " ++ Id.print id ++ str " is already declared."); push_named_context_val (LocalAssum (make_annot id r,t)) sign,t,concl,sigma) in let nf_t = nf_betaiota env sigma t in Proofview.tclTHEN @@ -660,24 +660,24 @@ let bind_red_expr_occurrences occs nbcl redexp = else match redexp with | Unfold (_::_::_) -> - error_illegal_clause () + error_illegal_clause () | Unfold [(occl,c)] -> - if occl != AllOccurrences then - error_illegal_clause () - else - Unfold [(occs,c)] + if occl != AllOccurrences then + error_illegal_clause () + else + Unfold [(occs,c)] | Pattern (_::_::_) -> - error_illegal_clause () + error_illegal_clause () | Pattern [(occl,c)] -> - if occl != AllOccurrences then - error_illegal_clause () - else - Pattern [(occs,c)] + if occl != AllOccurrences then + error_illegal_clause () + else + Pattern [(occs,c)] | Simpl (f,Some (occl,c)) -> - if occl != AllOccurrences then - error_illegal_clause () - else - Simpl (f,Some (occs,c)) + if occl != AllOccurrences then + error_illegal_clause () + else + Simpl (f,Some (occs,c)) | CbvVm (Some (occl,c)) -> if occl != AllOccurrences then error_illegal_clause () @@ -690,9 +690,9 @@ let bind_red_expr_occurrences occs nbcl redexp = CbvNative (Some (occs,c)) | Red _ | Hnf | Cbv _ | Lazy _ | Cbn _ | ExtraRedExpr _ | Fold _ | Simpl (_,None) | CbvVm None | CbvNative None -> - error_occurrences_not_unsupported () + error_occurrences_not_unsupported () | Unfold [] | Pattern [] -> - assert false + assert false (* The following two tactics apply an arbitrary reduction function either to the conclusion or to a @@ -809,7 +809,7 @@ let check_types env sigma mayneedglobalcheck deep newc origc = if deep then begin let t2 = Retyping.get_type_of env sigma origc in let sigma, t2 = Evarsolve.refresh_universes - ~onlyalg:true (Some false) env sigma t2 in + ~onlyalg:true (Some false) env sigma t2 in match infer_conv ~pb:Reduction.CUMUL env sigma t1 t2 with | None -> if @@ -891,7 +891,7 @@ let change ~check chg c cls = e_change_in_hyps ~check:false ~reorder f hyps end -let change_concl t = +let change_concl t = change_in_concl ~check:true None (make_change_arg t) (* Pour usage interne (le niveau User est pris en compte par reduce) *) @@ -999,7 +999,7 @@ let find_intro_names ctxt gl = let build_intro_tac id dest tac = match dest with | MoveLast -> Tacticals.New.tclTHEN (introduction id) (tac id) - | dest -> Tacticals.New.tclTHENLIST + | dest -> Tacticals.New.tclTHENLIST [introduction id; move_hyp id dest; tac id] let rec intro_then_gen name_flag move_flag force_flag dep_flag tac = @@ -1011,10 +1011,10 @@ let rec intro_then_gen name_flag move_flag force_flag dep_flag tac = match EConstr.kind sigma concl with | Prod (name,t,u) when not dep_flag || not (noccurn sigma 1 u) -> let name = find_name false (LocalAssum (name,t)) name_flag gl in - build_intro_tac name move_flag tac + build_intro_tac name move_flag tac | LetIn (name,b,t,u) when not dep_flag || not (noccurn sigma 1 u) -> let name = find_name false (LocalDef (name,b,t)) name_flag gl in - build_intro_tac name move_flag tac + build_intro_tac name move_flag tac | Evar ev when force_flag -> let sigma, t = Evardefine.define_evar_as_product env sigma ev in Tacticals.New.tclTHEN @@ -1028,9 +1028,9 @@ let rec intro_then_gen name_flag move_flag force_flag dep_flag tac = (* probably also a pity that intro does zeta *) else Proofview.tclUNIT () end <*> - Proofview.tclORELSE - (Tacticals.New.tclTHEN hnf_in_concl - (intro_then_gen name_flag move_flag false dep_flag tac)) + Proofview.tclORELSE + (Tacticals.New.tclTHEN hnf_in_concl + (intro_then_gen name_flag move_flag false dep_flag tac)) begin function (e, info) -> match e with | RefinerError (env, sigma, IntroNeedsProduct) -> Tacticals.New.tclZEROMSG (str "No product even after head-reduction.") @@ -1107,9 +1107,9 @@ let intros_possibly_replacing ids = let hyps = Proofview.Goal.hyps gl in let posl = List.map (fun id -> (id, get_next_hyp_position env sigma id hyps)) ids in Tacticals.New.tclTHEN - (Tacticals.New.tclMAP (fun id -> - Tacticals.New.tclTRY (clear_for_replacing [id])) - (if suboptimal then ids else List.rev ids)) + (Tacticals.New.tclMAP (fun id -> + Tacticals.New.tclTRY (clear_for_replacing [id])) + (if suboptimal then ids else List.rev ids)) (Tacticals.New.tclMAP (fun (id,pos) -> Tacticals.New.tclORELSE (intro_move (Some id) pos) (intro_using id)) posl) @@ -1182,9 +1182,9 @@ let depth_of_quantified_hypothesis red h gl = | None -> user_err ~hdr:"lookup_quantified_hypothesis" (str "No " ++ msg_quantified_hypothesis h ++ - strbrk " in current goal" ++ - (if red then strbrk " even after head-reduction" else mt ()) ++ - str".") + strbrk " in current goal" ++ + (if red then strbrk " even after head-reduction" else mt ()) ++ + str".") let intros_until_gen red h = Proofview.Goal.enter begin fun gl -> @@ -1215,7 +1215,7 @@ let rec intros_move = function | [] -> Proofview.tclUNIT () | (hyp,destopt) :: rest -> Tacticals.New.tclTHEN (intro_gen (NamingMustBe (CAst.make hyp)) destopt false false) - (intros_move rest) + (intros_move rest) (* Apply a tactic on a quantified hypothesis, an hypothesis in context or a term with bindings *) @@ -1365,8 +1365,8 @@ let do_replace id = function let clenv_refine_in with_evars targetid id sigma0 clenv tac = let clenv = Clenvtac.clenv_pose_dependent_evars ~with_evars clenv in let clenv = - { clenv with evd = Typeclasses.resolve_typeclasses - ~fail:(not with_evars) clenv.env clenv.evd } + { clenv with evd = Typeclasses.resolve_typeclasses + ~fail:(not with_evars) clenv.env clenv.evd } in let new_hyp_typ = clenv_type clenv in if not with_evars then check_unresolved_evars_of_metas sigma0 clenv; @@ -1518,8 +1518,8 @@ let general_case_analysis with_evars clear_flag (c,lbindc as cx) = Proofview.tclEVARMAP >>= fun sigma -> match EConstr.kind sigma c with | Var id when lbindc == NoBindings -> - Tacticals.New.tclTHEN (try_intros_until_id_check id) - (general_case_analysis_in_context with_evars clear_flag cx) + Tacticals.New.tclTHEN (try_intros_until_id_check id) + (general_case_analysis_in_context with_evars clear_flag cx) | _ -> general_case_analysis_in_context with_evars clear_flag cx @@ -1569,10 +1569,10 @@ let elim with_evars clear_flag (c,lbindc as cx) elim = Proofview.tclEVARMAP >>= fun sigma -> match EConstr.kind sigma c with | Var id when lbindc == NoBindings -> - Tacticals.New.tclTHEN (try_intros_until_id_check id) - (elim_in_context with_evars clear_flag cx elim) + Tacticals.New.tclTHEN (try_intros_until_id_check id) + (elim_in_context with_evars clear_flag cx elim) | _ -> - elim_in_context with_evars clear_flag cx elim + elim_in_context with_evars clear_flag cx elim (* The simplest elimination tactic, with no substitutions at all. *) @@ -1605,36 +1605,36 @@ let make_projection env sigma params cstr sign elim i n c u = let b = match decl with LocalAssum _ -> mkRel (i+1) | LocalDef (_,b,_) -> b in let branch = it_mkLambda_or_LetIn b cs_args in if - (* excludes dependent projection types *) - noccur_between sigma 1 (n-i-1) t - (* to avoid surprising unifications, excludes flexible - projection types or lambda which will be instantiated by Meta/Evar *) - && not (isEvar sigma (fst (whd_betaiota_stack sigma t))) - && (accept_universal_lemma_under_conjunctions () || not (isRel sigma t)) + (* excludes dependent projection types *) + noccur_between sigma 1 (n-i-1) t + (* to avoid surprising unifications, excludes flexible + projection types or lambda which will be instantiated by Meta/Evar *) + && not (isEvar sigma (fst (whd_betaiota_stack sigma t))) + && (accept_universal_lemma_under_conjunctions () || not (isRel sigma t)) then let t = lift (i+1-n) t in - let abselim = beta_applist sigma (elim, params@[t;branch]) in - let args = Context.Rel.to_extended_vect mkRel 0 sign in - let c = beta_applist sigma (abselim, [mkApp (c, args)]) in - Some (it_mkLambda_or_LetIn c sign, it_mkProd_or_LetIn t sign) + let abselim = beta_applist sigma (elim, params@[t;branch]) in + let args = Context.Rel.to_extended_vect mkRel 0 sign in + let c = beta_applist sigma (abselim, [mkApp (c, args)]) in + Some (it_mkLambda_or_LetIn c sign, it_mkProd_or_LetIn t sign) else - None + None | DefinedRecord l -> (* goes from left to right when i increases! *) match List.nth l i with | Some proj -> - let args = Context.Rel.to_extended_vect mkRel 0 sign in - let proj = + let args = Context.Rel.to_extended_vect mkRel 0 sign in + let proj = match Recordops.find_primitive_projection proj with | Some proj -> - mkProj (Projection.make proj false, mkApp (c, args)) + mkProj (Projection.make proj false, mkApp (c, args)) | None -> - mkApp (mkConstU (proj,u), Array.append (Array.of_list params) - [|mkApp (c, args)|]) - in - let app = it_mkLambda_or_LetIn proj sign in - let t = Retyping.get_type_of env sigma app in - Some (app, t) + mkApp (mkConstU (proj,u), Array.append (Array.of_list params) + [|mkApp (c, args)|]) + in + let app = it_mkLambda_or_LetIn proj sign in + let t = Retyping.get_type_of env sigma app in + Some (app, t) | None -> None in elim @@ -1649,32 +1649,32 @@ let descend_in_conjunctions avoid tac (err, info) c = match match_with_tuple env sigma ccl with | Some (_,_,isrec) -> let n = (constructors_nrealargs env ind).(0) in - let sort = Tacticals.New.elimination_sort_of_goal gl in - let IndType (indf,_) = find_rectype env sigma ccl in - let (_,inst), params = dest_ind_family indf in - let params = List.map EConstr.of_constr params in - let cstr = (get_constructors env indf).(0) in - let elim = - try DefinedRecord (Recordops.lookup_projections ind) - with Not_found -> + let sort = Tacticals.New.elimination_sort_of_goal gl in + let IndType (indf,_) = find_rectype env sigma ccl in + let (_,inst), params = dest_ind_family indf in + let params = List.map EConstr.of_constr params in + let cstr = (get_constructors env indf).(0) in + let elim = + try DefinedRecord (Recordops.lookup_projections ind) + with Not_found -> let u = EInstance.kind sigma u in - let (_, elim) = build_case_analysis_scheme env sigma (ind,u) false sort in - let elim = EConstr.of_constr elim in - NotADefinedRecordUseScheme elim in - Tacticals.New.tclORELSE0 - (Tacticals.New.tclFIRST - (List.init n (fun i -> + let (_, elim) = build_case_analysis_scheme env sigma (ind,u) false sort in + let elim = EConstr.of_constr elim in + NotADefinedRecordUseScheme elim in + Tacticals.New.tclORELSE0 + (Tacticals.New.tclFIRST + (List.init n (fun i -> Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in - match make_projection env sigma params cstr sign elim i n c u with - | None -> Tacticals.New.tclFAIL 0 (mt()) - | Some (p,pt) -> - Tacticals.New.tclTHENS - (assert_before_gen false (NamingAvoid avoid) pt) + match make_projection env sigma params cstr sign elim i n c u with + | None -> Tacticals.New.tclFAIL 0 (mt()) + | Some (p,pt) -> + Tacticals.New.tclTHENS + (assert_before_gen false (NamingAvoid avoid) pt) [Proofview.V82.tactic (refiner ~check:true EConstr.Unsafe.(to_constr p)); - (* Might be ill-typed due to forbidden elimination. *) - Tacticals.New.onLastHypId (tac (not isrec))] + (* Might be ill-typed due to forbidden elimination. *) + Tacticals.New.onLastHypId (tac (not isrec))] end))) (Proofview.tclZERO ~info err) | None -> Proofview.tclZERO ~info err @@ -1783,7 +1783,7 @@ let apply_with_delayed_bindings_gen b e l = let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let (sigma, cb) = f env sigma in - Tacticals.New.tclWITHHOLES e + Tacticals.New.tclWITHHOLES e (general_apply ~respect_opaque:(not b) b b e k CAst.(make ?loc cb)) sigma end in @@ -1903,7 +1903,7 @@ let apply_in_delayed_once ?(respect_opaque = false) with_delta let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let (sigma, c) = f env sigma in - Tacticals.New.tclWITHHOLES with_evars + Tacticals.New.tclWITHHOLES with_evars (apply_in_once ~respect_opaque with_delta with_destruct with_evars naming id (clear_flag,CAst.(make ?loc c)) tac) sigma @@ -2007,7 +2007,7 @@ let assumption = match ans with | Some sigma -> (Proofview.Unsafe.tclEVARS sigma) <*> - exact_no_check (mkVar (NamedDecl.get_id decl)) + exact_no_check (mkVar (NamedDecl.get_id decl)) | None -> arec gl only_eq rest in let assumption_tac gl = @@ -2127,7 +2127,7 @@ let keep hyps = let hyp = NamedDecl.get_id decl in if Id.List.mem hyp hyps || List.exists (occur_var_in_decl env sigma hyp) keep - || occur_var env sigma hyp ccl + || occur_var env sigma hyp ccl then (clear,decl::keep) else (hyp::clear,keep)) ~init:([],[]) (Proofview.Goal.env gl) @@ -2173,7 +2173,7 @@ let bring_hyps hyps = end end -let revert hyps = +let revert hyps = Proofview.Goal.enter begin fun gl -> let ctx = List.map (fun id -> Tacmach.New.pf_get_hyp id gl) hyps in (bring_hyps ctx) <*> (clear hyps) @@ -2187,7 +2187,7 @@ let check_number_of_constructors expctdnumopt i nconstr = if Int.equal i 0 then error "The constructors are numbered starting from 1."; begin match expctdnumopt with | Some n when not (Int.equal n nconstr) -> - user_err ~hdr:"Tactics.check_number_of_constructors" + user_err ~hdr:"Tactics.check_number_of_constructors" (str "Not an inductive goal with " ++ int n ++ str (String.plural n " constructor") ++ str ".") | _ -> () end; @@ -2351,8 +2351,8 @@ let rewrite_hyp_then assert_style with_evars thin l2r id tac = let l2r = not l2r in (* equality of the form eq_true *) if isVar sigma c then let id' = destVar sigma c in - Tacticals.New.tclTHEN (rew_on l2r allHypsAndConcl) - (clear_var_and_eq id'), + Tacticals.New.tclTHEN (rew_on l2r allHypsAndConcl) + (clear_var_and_eq id'), early_clear id' thin else Tacticals.New.tclTHEN (rew_on l2r onConcl) (clear [id]), @@ -2362,7 +2362,7 @@ let rewrite_hyp_then assert_style with_evars thin l2r id tac = thin in (* Skip the side conditions of the rewriting step *) Tacticals.New.tclTHENFIRST eqtac (tac thin) - end + end let prepare_naming ?loc = function | IntroIdentifier id -> NamingMustBe (CAst.make ?loc id) @@ -2473,12 +2473,12 @@ let rec intro_patterns_core with_evars b avoid ids thin destopt bound n tac = match pat with | IntroForthcoming onlydeps -> intro_forthcoming_then_gen (NamingAvoid (Id.Set.union avoid (explicit_intro_names l))) - destopt onlydeps n bound + destopt onlydeps n bound (fun ids -> intro_patterns_core with_evars b avoid ids thin destopt bound (n+List.length ids) tac l) | IntroAction pat -> intro_then_gen (make_tmp_naming avoid l pat) - destopt true false + destopt true false (intro_pattern_action ?loc with_evars (b || not (List.is_empty l)) false pat thin destopt (fun thin bound' -> intro_patterns_core with_evars b avoid ids thin destopt bound' 0 @@ -2496,12 +2496,12 @@ and intro_pattern_naming loc with_evars b avoid ids pat thin destopt bound n tac (fun id -> intro_patterns_core with_evars b avoid (id::ids) thin destopt bound n tac l)) | IntroAnonymous -> intro_then_gen (NamingAvoid (Id.Set.union avoid (explicit_intro_names l))) - destopt true false + destopt true false (fun id -> intro_patterns_core with_evars b avoid (id::ids) thin destopt bound n tac l) | IntroFresh id -> (* todo: avoid thinned names to interfere with generation of fresh name *) intro_then_gen (NamingBasedOn (id, Id.Set.union avoid (explicit_intro_names l))) - destopt true false + destopt true false (fun id -> intro_patterns_core with_evars b avoid (id::ids) thin destopt bound n tac l) and intro_pattern_action ?loc with_evars b style pat thin destopt tac id = @@ -2538,7 +2538,7 @@ and prepare_intros ?loc with_evars dft destopt = function (fun _ l -> clear_wildcards l) in fun id -> intro_pattern_action ?loc with_evars true true ipat [] destopt tac id) - | IntroForthcoming _ -> user_err ?loc + | IntroForthcoming _ -> user_err ?loc (str "Introduction pattern for one hypothesis expected.") let intro_patterns_head_core with_evars b destopt bound pat = @@ -2670,12 +2670,12 @@ let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = let refl = applist (refl, [t;mkVar id]) in let term = mkNamedLetIn (make_annot id Sorts.Relevant) c t (mkLetIn (make_annot (Name heq) Sorts.Relevant, refl, eq, ccl)) in - let sigma, _ = Typing.type_of env sigma term in + let sigma, _ = Typing.type_of env sigma term in let ans = term, Tacticals.New.tclTHENLIST - [ + [ intro_gen (NamingMustBe CAst.(make ?loc heq)) (decode_hyp lastlhyp) true false; - clear_body [heq;id]] + clear_body [heq;id]] in (sigma, ans) | None -> @@ -2830,19 +2830,19 @@ let enough_by na t tac = forward false (Some (Some tac)) (ipat_of_name na) t let generalized_name env sigma c t ids cl = function | Name id as na -> if Id.List.mem id ids then - user_err (Id.print id ++ str " is already used."); + user_err (Id.print id ++ str " is already used."); na | Anonymous -> match EConstr.kind sigma c with | Var id -> - (* Keep the name even if not occurring: may be used by intros later *) - Name id + (* Keep the name even if not occurring: may be used by intros later *) + Name id | _ -> - if noccurn sigma 1 cl then Anonymous else - (* On ne s'etait pas casse la tete : on avait pris pour nom de + if noccurn sigma 1 cl then Anonymous else + (* On ne s'etait pas casse la tete : on avait pris pour nom de variable la premiere lettre du type, meme si "c" avait ete une constante dont on aurait pu prendre directement le nom *) - named_hd env sigma t Anonymous + named_hd env sigma t Anonymous (* Abstract over [c] in [forall x1:A1(c)..xi:Ai(c).T(c)] producing [forall x, x1:A1(x1), .., xi:Ai(x). T(x)] with all [c] abtracted in [Ai] @@ -2890,7 +2890,7 @@ let generalize_dep ?(with_let=false) c = let tothin' = match EConstr.kind sigma c with | Var id when mem_named_context_val id (val_of_named_context sign) && not (Id.List.mem id init_ids) - -> id::tothin + -> id::tothin | _ -> tothin in let cl' = it_mkNamedProd_or_LetIn (pf_concl gl) to_quantify in @@ -2936,19 +2936,19 @@ let new_generalize_gen_let lconstr = let env = Proofview.Goal.env gl in let ids = Tacmach.New.pf_ids_of_hyps gl in let newcl, sigma, args = - List.fold_right_i - (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 + List.fold_right_i + (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 let cl, sigma = generalize_goal_gen env sigma ids i o t cl in (cl, sigma, args)) - 0 lconstr (concl, sigma, []) + 0 lconstr (concl, sigma, []) in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) - (Refine.refine ~typecheck:false begin fun sigma -> + (Refine.refine ~typecheck:false begin fun sigma -> let (sigma, ev) = Evarutil.new_evar env sigma ~principal:true newcl in (sigma, applist (ev, args)) - end) + end) end let generalize_gen lconstr = @@ -3052,7 +3052,7 @@ let specialize (c,lbind) ipat = let repl = do_replace (Some id) naming in Tacticals.New.tclTHENFIRST (assert_before_then_gen repl naming typ tac) - (exact_no_check term) + (exact_no_check term) | _ -> match ipat with | None -> @@ -3067,7 +3067,7 @@ let specialize (c,lbind) ipat = let naming,tac = prepare_intros ?loc false IntroAnonymous MoveLast ipat in Tacticals.New.tclTHENFIRST (assert_before_then_gen false naming typ tac) - (exact_no_check term) + (exact_no_check term) in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) tac end @@ -3253,16 +3253,16 @@ let induct_discharge with_evars dests avoid' tac (avoid,ra) names = let (hyprec,names) = consume_pattern avoid (Name hyprecname) depind gl names in - dest_intro_patterns with_evars avoid thin MoveLast [hyprec] (fun ids' thin -> - peel_tac ra' (update_dest dests ids') names thin) + dest_intro_patterns with_evars avoid thin MoveLast [hyprec] (fun ids' thin -> + peel_tac ra' (update_dest dests ids') names thin) end) end | (IndArg,_,dep,hyprecname) :: ra' -> Proofview.Goal.enter begin fun gl -> - (* Rem: does not happen in Coq schemes, only in user-defined schemes *) + (* Rem: does not happen in Coq schemes, only in user-defined schemes *) let pat,names = consume_pattern avoid (Name hyprecname) dep gl names in - dest_intro_patterns with_evars avoid thin MoveLast [pat] (fun ids thin -> + dest_intro_patterns with_evars avoid thin MoveLast [pat] (fun ids thin -> peel_tac ra' (update_dest dests ids) names thin) end | (RecArg,_,dep,recvarname) :: ra' -> @@ -3270,14 +3270,14 @@ let induct_discharge with_evars dests avoid' tac (avoid,ra) names = let (pat,names) = consume_pattern avoid (Name recvarname) dep gl names in let dest = get_recarg_dest dests in - dest_intro_patterns with_evars avoid thin dest [pat] (fun ids thin -> + dest_intro_patterns with_evars avoid thin dest [pat] (fun ids thin -> peel_tac ra' dests names thin) end | (OtherArg,_,dep,_) :: ra' -> Proofview.Goal.enter begin fun gl -> let (pat,names) = consume_pattern avoid Anonymous dep gl names in let dest = get_recarg_dest dests in - safe_dest_intro_patterns with_evars avoid thin dest [pat] (fun ids thin -> + safe_dest_intro_patterns with_evars avoid thin dest [pat] (fun ids thin -> peel_tac ra' dests names thin) end | [] -> @@ -3301,8 +3301,8 @@ let expand_projections env sigma c = | _ -> map_constr_with_full_binders sigma 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 = @@ -3327,14 +3327,14 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = else let c = List.nth argl (i-1) in match EConstr.kind sigma c with - | Var id when not (List.exists (fun c -> occur_var env sigma id c) args') && + | Var id when not (List.exists (fun c -> occur_var env sigma id c) args') && not (List.exists (fun c -> occur_var env sigma id c) 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) (c::args') (Id.Set.add id avoid) - | _ -> - let c' = expand_projections env' sigma c in + atomize_one (i-1) (c::args) (c::args') (Id.Set.add id avoid) + | _ -> + let c' = expand_projections env' sigma c in let dependent t = dependent sigma c t in if List.exists dependent params' || List.exists dependent args' @@ -3344,7 +3344,7 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = 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) (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 @@ -3355,9 +3355,9 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = let type_of = Tacmach.New.pf_unsafe_type_of gl in id_of_name_using_hdchar env sigma (type_of c) Anonymous in 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) (mkVar x::args') (Id.Set.add x avoid)) + Tacticals.New.tclTHEN + (letin_tac None (Name x) c None allHypsAndConcl) + (atomize_one (i-1) (mkVar x::args) (mkVar x::args') (Id.Set.add x avoid)) in atomize_one (List.length argl) [] [] Id.Set.empty end @@ -3454,30 +3454,30 @@ let cook_sign hyp0_opt inhyps indvars env sigma = toclear := hyp::!toclear; rhyp end else - let dephyp0 = List.is_empty inhyps && - (Option.cata (fun id -> occur_var_in_decl env sigma id decl) false hyp0_opt) + let dephyp0 = List.is_empty inhyps && + (Option.cata (fun id -> occur_var_in_decl env sigma id decl) false hyp0_opt) in let depother = List.is_empty inhyps && - (Id.Set.exists (fun id -> occur_var_in_decl env sigma id decl) indvars || + (Id.Set.exists (fun id -> occur_var_in_decl env sigma id decl) indvars || List.exists (fun decl' -> occur_var_in_decl env sigma (NamedDecl.get_id decl') decl) !decldeps) in if not (List.is_empty inhyps) && Id.List.mem hyp inhyps || dephyp0 || depother then begin - decldeps := decl::!decldeps; - avoid := Id.Set.add hyp !avoid; + decldeps := decl::!decldeps; + avoid := Id.Set.add hyp !avoid; maindep := dephyp0 || !maindep; - if !before then begin + if !before then begin toclear := hyp::!toclear; - rstatus := (hyp,rhyp)::!rstatus + rstatus := (hyp,rhyp)::!rstatus end - else begin - toclear := hyp::!toclear; - ldeps := hyp::!ldeps (* status computed in 2nd phase *) + else begin + toclear := hyp::!toclear; + ldeps := hyp::!ldeps (* status computed in 2nd phase *) end; - MoveBefore hyp end + MoveBefore hyp end else - MoveBefore hyp + MoveBefore hyp in let _ = fold_named_context seek_deps env ~init:MoveFirst in (* 2nd phase from R to L: get left hyp of [hyp0] and [lhyps] *) @@ -3543,7 +3543,7 @@ type elim_scheme = { indarg: rel_declaration option; (* Some (H,I prm1..prmp x1...xni) if HI is in premisses, None otherwise *) concl: types; (* Qi x1...xni HI (f...), HI and (f...) - are optional and mutually exclusive *) + are optional and mutually exclusive *) indarg_in_concl: bool; (* true if HI appears at the end of conclusion *) farg_in_concl: bool; (* true if (f...) appears at the end of conclusion *) } @@ -3584,8 +3584,8 @@ let make_up_names n ind_opt cname = let base_ind = if is_hyp then match ind_opt with - | None -> Id.of_string ind_prefix - | Some ind_id -> add_prefix ind_prefix (Nametab.basename_of_global ind_id) + | None -> Id.of_string ind_prefix + | Some ind_id -> add_prefix ind_prefix (Nametab.basename_of_global ind_id) else add_prefix ind_prefix cname in let hyprecname = make_base n base_ind in let avoid = @@ -3633,7 +3633,7 @@ let lift_togethern n l = let l', _ = List.fold_right (fun x (acc, n) -> - (lift n x :: acc, succ n)) + (lift n x :: acc, succ n)) l ([], n) in l' @@ -3644,14 +3644,14 @@ let ids_of_constr sigma ?(all=false) vars c = match EConstr.kind sigma c with | Var id -> Id.Set.add id vars | App (f, args) -> - (match EConstr.kind sigma f with - | Construct ((ind,_),_) - | Ind (ind,_) -> + (match EConstr.kind sigma f with + | Construct ((ind,_),_) + | Ind (ind,_) -> let (mib,mip) = Global.lookup_inductive ind in - Array.fold_left_from - (if all then 0 else mib.Declarations.mind_nparams) - aux vars args - | _ -> EConstr.fold sigma aux vars c) + Array.fold_left_from + (if all then 0 else mib.Declarations.mind_nparams) + aux vars args + | _ -> EConstr.fold sigma aux vars c) | _ -> EConstr.fold sigma aux vars c in aux vars c @@ -3662,7 +3662,7 @@ let decompose_indapp sigma f args = let (mib,mip) = Global.lookup_inductive ind in let first = mib.Declarations.mind_nparams_rec in let pars, args = Array.chop first args in - mkApp (f, pars), args + mkApp (f, pars), args | _ -> f, args let mk_term_eq homogeneous env sigma ty t ty' t' = @@ -3722,13 +3722,13 @@ let hyps_of_vars env sigma sign nogen hyps = Context.Named.fold_inside (fun (hs,hl) d -> let x = NamedDecl.get_id d in - if Id.Set.mem x nogen then (hs,hl) - else if Id.Set.mem x hs then (hs,x::hl) - else - let xvars = global_vars_set_of_decl env sigma d in - if not (Id.Set.is_empty (Id.Set.diff xvars hs)) then - (Id.Set.add x hs, x :: hl) - else (hs, hl)) + if Id.Set.mem x nogen then (hs,hl) + else if Id.Set.mem x hs then (hs,x::hl) + else + let xvars = global_vars_set_of_decl env sigma d in + if not (Id.Set.is_empty (Id.Set.diff xvars hs)) then + (Id.Set.add x hs, x :: hl) + else (hs, hl)) ~init:(hyps,[]) sign in lh @@ -3739,14 +3739,14 @@ let linear sigma vars args = let seen = ref vars in try Array.iter (fun i -> - let rels = ids_of_constr sigma ~all:true Id.Set.empty i in - let seen' = - Id.Set.fold (fun id acc -> - if Id.Set.mem id acc then raise Seen - else Id.Set.add id acc) - rels !seen - in seen := seen') - args; + let rels = ids_of_constr sigma ~all:true Id.Set.empty i in + let seen' = + Id.Set.fold (fun id acc -> + if Id.Set.mem id acc then raise Seen + else Id.Set.add id acc) + rels !seen + in seen := seen') + args; true with Seen -> false @@ -3785,62 +3785,62 @@ let abstract_args gl generalize_vars dep id defined f args = let leq = constr_cmp !sigma Reduction.CUMUL liftargty ty in match EConstr.kind !sigma arg with | Var id when not (is_defined_variable env id) && leq && not (Id.Set.mem id nongenvars) -> - (subst1 arg arity, ctx, ctxenv, mkApp (c, [|arg|]), args, eqs, refls, - Id.Set.add id nongenvars, Id.Set.remove id vars, env) + (subst1 arg arity, ctx, ctxenv, mkApp (c, [|arg|]), args, eqs, refls, + Id.Set.add id nongenvars, Id.Set.remove id vars, env) | _ -> - let name = get_id name in + let name = get_id name in let decl = LocalAssum (make_annot (Name name) ty_relevance, ty) in - let ctx = decl :: ctx in - let c' = mkApp (lift 1 c, [|mkRel 1|]) in - let args = arg :: args in - let liftarg = lift (List.length ctx) arg in - let eq, refl = - if leq then - let sigma', eq = mkEq !sigma (lift 1 ty) (mkRel 1) liftarg in + let ctx = decl :: ctx in + let c' = mkApp (lift 1 c, [|mkRel 1|]) in + let args = arg :: args in + let liftarg = lift (List.length ctx) arg in + let eq, refl = + if leq then + let sigma', eq = mkEq !sigma (lift 1 ty) (mkRel 1) liftarg in let sigma', refl = mkRefl sigma' (lift (-lenctx) ty) arg in sigma := sigma'; eq, refl - else - let sigma', eq = mkHEq !sigma (lift 1 ty) (mkRel 1) liftargty liftarg in + else + let sigma', eq = mkHEq !sigma (lift 1 ty) (mkRel 1) liftargty liftarg in let sigma', refl = mkHRefl sigma' argty arg in sigma := sigma'; eq, refl - in - let eqs = eq :: lift_list eqs in - let refls = refl :: refls in - let argvars = ids_of_constr !sigma vars arg in - (arity, ctx, push_rel decl ctxenv, c', args, eqs, refls, - nongenvars, Id.Set.union argvars vars, env) + in + let eqs = eq :: lift_list eqs in + let refls = refl :: refls in + let argvars = ids_of_constr !sigma vars arg in + (arity, ctx, push_rel decl ctxenv, c', args, eqs, refls, + nongenvars, Id.Set.union argvars vars, env) in let f', args' = decompose_indapp !sigma f args in let dogen, f', args' = let parvars = ids_of_constr !sigma ~all:true Id.Set.empty f' in if not (linear !sigma parvars args') then true, f, args else - match Array.findi (fun i x -> not (isVar !sigma x) || is_defined_variable env (destVar !sigma x)) args' with - | None -> false, f', args' - | Some nonvar -> - let before, after = Array.chop nonvar args' in - true, mkApp (f', before), after + match Array.findi (fun i x -> not (isVar !sigma x) || is_defined_variable env (destVar !sigma x)) args' with + | None -> false, f', args' + | Some nonvar -> + let before, after = Array.chop nonvar args' in + true, mkApp (f', before), after in if dogen then let tyf' = Tacmach.New.pf_unsafe_type_of gl f' in let arity, ctx, ctxenv, c', args, eqs, refls, nogen, vars, env = - Array.fold_left aux (tyf',[],env,f',[],[],[],Id.Set.empty,Id.Set.empty,env) args' + Array.fold_left aux (tyf',[],env,f',[],[],[],Id.Set.empty,Id.Set.empty,env) args' in let args, refls = List.rev args, List.rev refls in let vars = - if generalize_vars then - let nogen = Id.Set.add id nogen in - hyps_of_vars (pf_env gl) (project gl) (Proofview.Goal.hyps gl) nogen vars - else [] + if generalize_vars then + let nogen = Id.Set.add id nogen in + hyps_of_vars (pf_env gl) (project gl) (Proofview.Goal.hyps gl) nogen vars + else [] in let body, c' = - if defined then Some c', Retyping.get_type_of ctxenv !sigma c' - else None, c' + if defined then Some c', Retyping.get_type_of ctxenv !sigma c' + else None, c' in let typ = Tacmach.New.pf_get_hyp_typ id gl in let tac = make_abstract_generalize (pf_env gl) id typ concl dep ctx body c' eqs args refls in let tac = Proofview.Unsafe.tclEVARS !sigma <*> tac in - Some (tac, dep, succ (List.length ctx), vars) + Some (tac, dep, succ (List.length ctx), vars) else None let abstract_generalize ?(generalize_vars=true) ?(force_dep=false) id = @@ -3852,10 +3852,10 @@ let abstract_generalize ?(generalize_vars=true) ?(force_dep=false) id = let oldid = Tacmach.New.pf_get_new_id id gl in match Tacmach.New.pf_get_hyp id gl with | LocalAssum (_,t) -> let f, args = decompose_app sigma t in - (f, args, false, id, oldid) + (f, args, false, id, oldid) | LocalDef (_,t,_) -> - let f, args = decompose_app sigma t in - (f, args, true, id, oldid) + let f, args = decompose_app sigma t in + (f, args, true, id, oldid) in if List.is_empty args then Proofview.tclUNIT () else @@ -3864,23 +3864,23 @@ let abstract_generalize ?(generalize_vars=true) ?(force_dep=false) id = match newc with | None -> Proofview.tclUNIT () | Some (tac, dep, n, vars) -> - let tac = - if dep then + let tac = + if dep then Tacticals.New.tclTHENLIST [ tac; - rename_hyp [(id, oldid)]; Tacticals.New.tclDO n intro; - generalize_dep ~with_let:true (mkVar oldid)] + rename_hyp [(id, oldid)]; Tacticals.New.tclDO n intro; + generalize_dep ~with_let:true (mkVar oldid)] else Tacticals.New.tclTHENLIST [ tac; - clear [id]; - Tacticals.New.tclDO n intro] - in - if List.is_empty vars then tac - else Tacticals.New.tclTHEN tac + clear [id]; + Tacticals.New.tclDO n intro] + in + if List.is_empty vars then tac + else Tacticals.New.tclTHEN tac (Tacticals.New.tclFIRST [revert vars ; - Tacticals.New.tclMAP (fun id -> - Tacticals.New.tclTRY (generalize_dep ~with_let:true (mkVar id))) vars]) + Tacticals.New.tclMAP (fun id -> + Tacticals.New.tclTRY (generalize_dep ~with_let:true (mkVar id))) vars]) end let compare_upto_variables sigma x y = @@ -3905,26 +3905,26 @@ let specialize_eqs id = let rec aux in_eqs ctx acc ty = match EConstr.kind !evars ty with | Prod (na, t, b) -> - (match EConstr.kind !evars t with + (match EConstr.kind !evars t with | App (eq, [| eqty; x; y |]) when EConstr.is_global !evars Coqlib.(lib_ref "core.eq.type") eq -> - let c = if noccur_between !evars 1 (List.length ctx) x then y else x in - let pt = mkApp (eq, [| eqty; c; c |]) in + let c = if noccur_between !evars 1 (List.length ctx) x then y else x in + let pt = mkApp (eq, [| eqty; c; c |]) in let ind = destInd !evars eq in - let p = mkApp (mkConstructUi (ind,0), [| eqty; c |]) in - if unif (push_rel_context ctx env) evars pt t then - aux true ctx (mkApp (acc, [| p |])) (subst1 p b) - else acc, in_eqs, ctx, ty - | App (heq, [| eqty; x; eqty'; y |]) when EConstr.is_global !evars (Lazy.force coq_heq_ref) heq -> - let eqt, c = if noccur_between !evars 1 (List.length ctx) x then eqty', y else eqty, x in - let pt = mkApp (heq, [| eqt; c; eqt; c |]) in + let p = mkApp (mkConstructUi (ind,0), [| eqty; c |]) in + if unif (push_rel_context ctx env) evars pt t then + aux true ctx (mkApp (acc, [| p |])) (subst1 p b) + else acc, in_eqs, ctx, ty + | App (heq, [| eqty; x; eqty'; y |]) when EConstr.is_global !evars (Lazy.force coq_heq_ref) heq -> + let eqt, c = if noccur_between !evars 1 (List.length ctx) x then eqty', y else eqty, x in + let pt = mkApp (heq, [| eqt; c; eqt; c |]) in let ind = destInd !evars heq in - let p = mkApp (mkConstructUi (ind,0), [| eqt; c |]) in - if unif (push_rel_context ctx env) evars pt t then - aux true ctx (mkApp (acc, [| p |])) (subst1 p b) - else acc, in_eqs, ctx, ty - | _ -> - if in_eqs then acc, in_eqs, ctx, ty - else + let p = mkApp (mkConstructUi (ind,0), [| eqt; c |]) in + if unif (push_rel_context ctx env) evars pt t then + aux true ctx (mkApp (acc, [| p |])) (subst1 p b) + else acc, in_eqs, ctx, ty + | _ -> + if in_eqs then acc, in_eqs, ctx, ty + else let sigma, e = Evarutil.new_evar (push_rel_context ctx env) !evars t in evars := sigma; aux false (LocalDef (na,e,t) :: ctx) (mkApp (lift 1 acc, [| mkRel 1 |])) b) @@ -3944,7 +3944,7 @@ let specialize_eqs id = if worked then Tacticals.New.tclTHENFIRST (internal_cut true id ty') - (exact_no_check ((* refresh_universes_strict *) acc')) + (exact_no_check ((* refresh_universes_strict *) acc')) else Tacticals.New.tclFAIL 0 (str "Nothing to do in hypothesis " ++ Id.print id) end @@ -3973,10 +3973,10 @@ let decompose_paramspred_branch_args sigma elimt = let rec cut_noccur elimt acc2 = match EConstr.kind sigma elimt with | Prod(nme,tpe,elimt') -> - let hd_tpe,_ = decompose_app sigma (snd (decompose_prod_assum sigma tpe)) in - if not (occur_rel sigma 1 elimt') && isRel sigma hd_tpe + let hd_tpe,_ = decompose_app sigma (snd (decompose_prod_assum sigma tpe)) in + if not (occur_rel sigma 1 elimt') && isRel sigma hd_tpe then cut_noccur elimt' (LocalAssum (nme,tpe)::acc2) - else let acc3,ccl = decompose_prod_assum sigma elimt in acc2 , acc3 , ccl + else let acc3,ccl = decompose_prod_assum sigma elimt in acc2 , acc3 , ccl | App(_, _) | Rel _ -> acc2 , [] , elimt | _ -> error_ind_scheme "" in let rec cut_occur elimt acc1 = @@ -4048,8 +4048,8 @@ let compute_elim_sig sigma ?elimc elimt = if !res.farg_in_concl then begin res := { !res with - indarg = None; - indarg_in_concl = false; farg_in_concl = true }; + indarg = None; + indarg_in_concl = false; farg_in_concl = true }; raise Exit end; (* 2- If no args_indargs (=!res.nargs at this point) then no indarg *) @@ -4059,34 +4059,34 @@ let compute_elim_sig sigma ?elimc elimt = match List.hd args_indargs with | LocalDef (hiname,_,hi) -> error_ind_scheme "" | LocalAssum (hiname,hi) -> - let hi_ind, hi_args = decompose_app sigma hi in - let hi_is_ind = (* hi est d'un type globalisable *) - match EConstr.kind sigma hi_ind with - | Ind (mind,_) -> true - | Var _ -> true - | Const _ -> true - | Construct _ -> true - | _ -> false in - let hi_args_enough = (* hi a le bon nbre d'arguments *) - Int.equal (List.length hi_args) (List.length params + !res.nargs -1) in - (* FIXME: Ces deux tests ne sont pas suffisants. *) - if not (hi_is_ind && hi_args_enough) then raise Exit (* No indarg *) - else (* Last arg is the indarg *) - res := {!res with - indarg = Some (List.hd !res.args); - indarg_in_concl = occur_rel sigma 1 ccl; - args = List.tl !res.args; nargs = !res.nargs - 1; - }; - raise Exit); + let hi_ind, hi_args = decompose_app sigma hi in + let hi_is_ind = (* hi est d'un type globalisable *) + match EConstr.kind sigma hi_ind with + | Ind (mind,_) -> true + | Var _ -> true + | Const _ -> true + | Construct _ -> true + | _ -> false in + let hi_args_enough = (* hi a le bon nbre d'arguments *) + Int.equal (List.length hi_args) (List.length params + !res.nargs -1) in + (* FIXME: Ces deux tests ne sont pas suffisants. *) + if not (hi_is_ind && hi_args_enough) then raise Exit (* No indarg *) + else (* Last arg is the indarg *) + res := {!res with + indarg = Some (List.hd !res.args); + indarg_in_concl = occur_rel sigma 1 ccl; + args = List.tl !res.args; nargs = !res.nargs - 1; + }; + raise Exit); raise Exit(* exit anyway *) with Exit -> (* Ending by computing indref: *) match !res.indarg with | None -> !res (* No indref *) | Some (LocalDef _) -> error_ind_scheme "" | Some (LocalAssum (_,ind)) -> - let indhd,indargs = decompose_app sigma ind in - try {!res with indref = Some (fst (Termops.global_of_constr sigma indhd)) } - with e when CErrors.noncritical e -> + let indhd,indargs = decompose_app sigma ind in + try {!res with indref = Some (fst (Termops.global_of_constr sigma indhd)) } + with e when CErrors.noncritical e -> error "Cannot find the inductive type of the inductive scheme." let compute_scheme_signature evd scheme names_info ind_type_guess = @@ -4096,23 +4096,23 @@ let compute_scheme_signature evd scheme names_info ind_type_guess = let cond, check_concl = match scheme.indarg with | Some (LocalDef _) -> - error "Strange letin, cannot recognize an induction scheme." + error "Strange letin, cannot recognize an induction scheme." | None -> (* Non standard scheme *) - let cond hd = EConstr.eq_constr evd hd ind_type_guess && not scheme.farg_in_concl - in (cond, fun _ _ -> ()) + let cond hd = EConstr.eq_constr evd hd ind_type_guess && not scheme.farg_in_concl + in (cond, fun _ _ -> ()) | Some (LocalAssum (_,ind)) -> (* Standard scheme from an inductive type *) - let indhd,indargs = decompose_app evd ind in - let cond hd = EConstr.eq_constr evd hd indhd in - let check_concl is_pred p = - (* Check again conclusion *) - let ccl_arg_ok = is_pred (p + scheme.nargs + 1) f == IndArg in - let ind_is_ok = - List.equal (fun c1 c2 -> EConstr.eq_constr evd c1 c2) - (List.lastn scheme.nargs indargs) - (Context.Rel.to_extended_list mkRel 0 scheme.args) in - if not (ccl_arg_ok && ind_is_ok) then - error_ind_scheme "the conclusion of" - in (cond, check_concl) + let indhd,indargs = decompose_app evd ind in + let cond hd = EConstr.eq_constr evd hd indhd in + let check_concl is_pred p = + (* Check again conclusion *) + let ccl_arg_ok = is_pred (p + scheme.nargs + 1) f == IndArg in + let ind_is_ok = + List.equal (fun c1 c2 -> EConstr.eq_constr evd c1 c2) + (List.lastn scheme.nargs indargs) + (Context.Rel.to_extended_list mkRel 0 scheme.args) in + if not (ccl_arg_ok && ind_is_ok) then + error_ind_scheme "the conclusion of" + in (cond, check_concl) in let is_pred n c = let hd = fst (decompose_app evd c) in @@ -4124,27 +4124,27 @@ let compute_scheme_signature evd scheme names_info ind_type_guess = let rec check_branch p c = match EConstr.kind evd c with | Prod (_,t,c) -> - (is_pred p t, true, not (Vars.noccurn evd 1 c)) :: check_branch (p+1) c + (is_pred p t, true, not (Vars.noccurn evd 1 c)) :: check_branch (p+1) c | LetIn (_,_,_,c) -> - (OtherArg, false, not (Vars.noccurn evd 1 c)) :: check_branch (p+1) c + (OtherArg, false, not (Vars.noccurn evd 1 c)) :: check_branch (p+1) c | _ when is_pred p c == IndArg -> [] | _ -> raise Exit in let rec find_branches p lbrch = match lbrch with | LocalAssum (_,t) :: brs -> - (try - let lchck_brch = check_branch p t in - let n = List.fold_left - (fun n (b,_,_) -> if b == RecArg then n+1 else n) 0 lchck_brch in - let recvarname, hyprecname, avoid = - make_up_names n scheme.indref names_info in - let namesign = - List.map (fun (b,is_assum,dep) -> - (b,is_assum,dep,if b == IndArg then hyprecname else recvarname)) - lchck_brch in - (avoid,namesign) :: find_branches (p+1) brs - with Exit-> error_ind_scheme "the branches of") + (try + let lchck_brch = check_branch p t in + let n = List.fold_left + (fun n (b,_,_) -> if b == RecArg then n+1 else n) 0 lchck_brch in + let recvarname, hyprecname, avoid = + make_up_names n scheme.indref names_info in + let namesign = + List.map (fun (b,is_assum,dep) -> + (b,is_assum,dep,if b == IndArg then hyprecname else recvarname)) + lchck_brch in + (avoid,namesign) :: find_branches (p+1) brs + with Exit-> error_ind_scheme "the branches of") | LocalDef _ :: _ -> error_ind_scheme "the branches of" | [] -> check_concl is_pred p; [] in @@ -4210,12 +4210,12 @@ let find_induction_type isrec elim hyp0 gl = (* We drop the scheme waiting to know if it is dependent *) scheme, ElimOver (isrec,hyp0) | Some e -> - let evd, (elimc,elimt),ind_guess = given_elim hyp0 e gl in - let scheme = compute_elim_sig sigma ~elimc elimt in - if Option.is_empty scheme.indarg then error "Cannot find induction type"; - let indsign = compute_scheme_signature evd scheme hyp0 ind_guess in + let evd, (elimc,elimt),ind_guess = given_elim hyp0 e gl in + let scheme = compute_elim_sig sigma ~elimc elimt in + if Option.is_empty scheme.indarg then error "Cannot find induction type"; + let indsign = compute_scheme_signature evd scheme hyp0 ind_guess in let elim = ({ elimindex = Some(-1); elimbody = elimc },elimt) in - scheme, ElimUsing (elim,indsign) + scheme, ElimUsing (elim,indsign) in match scheme.indref with | None -> error_ind_scheme "" @@ -4251,9 +4251,9 @@ let recolle_clenv i params args elimclause gl = let lindmv = Array.map (fun x -> - match EConstr.kind elimclause.evd x with - | Meta mv -> mv - | _ -> user_err ~hdr:"elimination_clause" + match EConstr.kind elimclause.evd x with + | Meta mv -> mv + | _ -> user_err ~hdr:"elimination_clause" (str "The type of the elimination clause is not well-formed.")) arr in let k = match i with -1 -> Array.length lindmv - List.length args | _ -> i in @@ -4399,18 +4399,18 @@ let clear_unselected_context id inhyps cls = Proofview.Goal.enter begin fun gl -> if occur_var (Tacmach.New.pf_env gl) (Tacmach.New.project gl) id (Tacmach.New.pf_concl gl) && cls.concl_occs == NoOccurrences - then user_err + then user_err (str "Conclusion must be mentioned: it depends on " ++ Id.print id ++ str "."); match cls.onhyps with | Some hyps -> let to_erase d = let id' = NamedDecl.get_id d in - if Id.List.mem id' inhyps then (* if selected, do not erase *) None - else - (* erase if not selected and dependent on id or selected hyps *) - let test id = occur_var_in_decl (Tacmach.New.pf_env gl) (Tacmach.New.project gl) id d in - if List.exists test (id::inhyps) then Some id' else None in + if Id.List.mem id' inhyps then (* if selected, do not erase *) None + else + (* erase if not selected and dependent on id or selected hyps *) + let test id = occur_var_in_decl (Tacmach.New.pf_env gl) (Tacmach.New.project gl) id d in + if List.exists test (id::inhyps) then Some id' else None in let ids = List.map_filter to_erase (Proofview.Goal.hyps gl) in clear ids | None -> Proofview.tclUNIT () @@ -4591,7 +4591,7 @@ let induction_gen clear_flag isrec with_evars elim isrec with_evars info_arg elim id arg t inhyps cls (induction_with_atomization_of_ind_arg isrec with_evars elim names id) - end + end (* Induction on a list of arguments. First make induction arguments atomic (using letins), then do induction. The specificity here is @@ -4610,32 +4610,32 @@ let induction_gen_l isrec with_evars elim names lc = | [] -> Proofview.tclUNIT () | c::l' -> Proofview.tclEVARMAP >>= fun sigma -> - match EConstr.kind sigma c with - | Var id when not (mem_named_context_val id (Global.named_context_val ())) - && not with_evars -> + match EConstr.kind sigma c with + | Var id when not (mem_named_context_val id (Global.named_context_val ())) + && not with_evars -> let () = newlc:= id::!newlc in - atomize_list l' + atomize_list l' - | _ -> + | _ -> Proofview.Goal.enter begin fun gl -> let type_of = Tacmach.New.pf_unsafe_type_of gl in let sigma = Tacmach.New.project gl in Proofview.tclENV >>= fun env -> let x = - id_of_name_using_hdchar env sigma (type_of c) Anonymous in + id_of_name_using_hdchar env sigma (type_of c) Anonymous in let id = new_fresh_id Id.Set.empty x gl in - let newl' = List.map (fun r -> replace_term sigma c (mkVar id) r) l' in + let newl' = List.map (fun r -> replace_term sigma c (mkVar id) r) l' in let () = newlc:=id::!newlc in - Tacticals.New.tclTHEN - (letin_tac None (Name id) c None allHypsAndConcl) - (atomize_list newl') + Tacticals.New.tclTHEN + (letin_tac None (Name id) c None allHypsAndConcl) + (atomize_list newl') end in Tacticals.New.tclTHENLIST [ (atomize_list lc); (Proofview.tclUNIT () >>= fun () -> (* ensure newlc has been computed *) - induction_without_atomization isrec with_evars elim names !newlc) + induction_without_atomization isrec with_evars elim names !newlc) ] (* Induction either over a term, over a quantified premisse, or over @@ -4657,8 +4657,8 @@ let induction_destruct isrec with_evars (lc,elim) = if not (Option.is_empty cls) then error "'in' clause not supported here."; let _,c = force_destruction_arg false env sigma c in onInductionArg - (fun _clear_flag c -> - induction_gen_l isrec with_evars elim names + (fun _clear_flag c -> + induction_gen_l isrec with_evars elim names [with_no_bindings c,eqname]) c | _ -> (* standard induction *) @@ -4694,12 +4694,12 @@ let induction_destruct isrec with_evars (lc,elim) = let newlc = List.map (fun (x,(eqn,names),cls) -> if cls != None then error "'in' clause not yet supported here."; - match x with (* FIXME: should we deal with ElimOnIdent? *) + match x with (* FIXME: should we deal with ElimOnIdent? *) | _clear_flag,ElimOnConstr x -> if eqn <> None then error "'eqn' clause not supported here."; (with_no_bindings x,names) - | _ -> error "Don't know where to find some argument.") - lc in + | _ -> error "Don't know where to find some argument.") + lc in (* Check that "as", if any, is given only on the last argument *) let names,rest = List.sep_last (List.map snd newlc) in if List.exists (fun n -> not (Option.is_empty n)) rest then @@ -4729,10 +4729,10 @@ let elim_scheme_type elim t = match EConstr.kind clause.evd (last_arg clause.evd clause.templval.rebus) with | Meta mv -> let clause' = - (* t is inductive, then CUMUL or CONV is irrelevant *) - clenv_unify ~flags:(elim_flags ()) Reduction.CUMUL t + (* t is inductive, then CUMUL or CONV is irrelevant *) + clenv_unify ~flags:(elim_flags ()) Reduction.CUMUL t (clenv_meta_type clause mv) clause in - Clenvtac.res_pf clause' ~flags:(elim_flags ()) ~with_evars:false + Clenvtac.res_pf clause' ~flags:(elim_flags ()) ~with_evars:false | _ -> anomaly (Pp.str "elim_scheme_type.") end @@ -4815,7 +4815,7 @@ let prove_symmetry hdcncl eq_kind = (Tacticals.New.tclTHENLIST [ intro; Tacticals.New.onLastHyp simplest_case; - one_constructor 1 NoBindings ]) + one_constructor 1 NoBindings ]) let match_with_equation sigma c = Proofview.tclENV >>= fun env -> @@ -4915,9 +4915,9 @@ let prove_transitivity hdcncl eq_kind t = Tacticals.New.tclTHENFIRST (cut eq2) (Tacticals.New.tclTHENFIRST (cut eq1) (Tacticals.New.tclTHENLIST - [ Tacticals.New.tclDO 2 intro; - Tacticals.New.onLastHyp simplest_case; - assumption ])) + [ Tacticals.New.tclDO 2 intro; + Tacticals.New.onLastHyp simplest_case; + assumption ])) end let transitivity_red allowred t = @@ -4933,8 +4933,8 @@ let transitivity_red allowred t = Tacticals.New.tclTHEN (convert_concl ~check:false concl DEFAULTcast) (match t with - | None -> Tacticals.New.pf_constr_of_global eq_data.trans >>= eapply - | Some t -> Tacticals.New.pf_constr_of_global eq_data.trans >>= fun trans -> apply_list [trans; t]) + | None -> Tacticals.New.pf_constr_of_global eq_data.trans >>= eapply + | Some t -> Tacticals.New.pf_constr_of_global eq_data.trans >>= fun trans -> apply_list [trans; t]) | None,eq,eq_kind -> match t with | None -> Tacticals.New.tclZEROMSG (str"etransitivity not supported for this relation.") @@ -4981,8 +4981,8 @@ let unify ?(state=TransparentState.full) x y = try let core_flags = { (default_unify_flags ()).core_unify_flags with - modulo_delta = state; - modulo_conv_on_closed_terms = Some state} in + modulo_delta = state; + modulo_conv_on_closed_terms = Some state} in (* What to do on merge and subterm flags?? *) let flags = { (default_unify_flags ()) with core_unify_flags = core_flags; @@ -5021,7 +5021,7 @@ module New = struct let reduce_after_refine = reduce (Lazy {rBeta=true;rMatch=true;rFix=true;rCofix=true; - rZeta=false;rDelta=false;rConst=[]}) + rZeta=false;rDelta=false;rConst=[]}) {onhyps = Some []; concl_occs = AllOccurrences } let refine ~typecheck c = diff --git a/tactics/tactics.mli b/tactics/tactics.mli index d3c800df20..308399c5db 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -221,12 +221,12 @@ val eapply_with_bindings : constr with_bindings -> unit Proofview.tactic val cut_and_apply : constr -> unit Proofview.tactic val apply_in : - advanced_flag -> evars_flag -> Id.t -> + advanced_flag -> evars_flag -> Id.t -> (clear_flag * constr with_bindings CAst.t) list -> intro_pattern option -> unit Proofview.tactic val apply_delayed_in : - advanced_flag -> evars_flag -> Id.t -> + advanced_flag -> evars_flag -> Id.t -> (clear_flag * delayed_open_constr_with_bindings CAst.t) list -> intro_pattern option -> unit Proofview.tactic @@ -270,9 +270,9 @@ type elim_scheme = { args: rel_context; (** (xni, Ti_ni) ... (x1, Ti_1) *) nargs: int; (** number of arguments *) indarg: rel_declaration option; (** Some (H,I prm1..prmp x1...xni) - if HI is in premisses, None otherwise *) + if HI is in premisses, None otherwise *) concl: types; (** Qi x1...xni HI (f...), HI and (f...) - are optional and mutually exclusive *) + are optional and mutually exclusive *) indarg_in_concl: bool; (** true if HI appears at the end of conclusion *) farg_in_concl: bool; (** true if (f...) appears at the end of conclusion *) } diff --git a/tactics/term_dnet.ml b/tactics/term_dnet.ml index 58db147b10..7f2a6f94b5 100644 --- a/tactics/term_dnet.ml +++ b/tactics/term_dnet.ml @@ -66,8 +66,8 @@ struct | DInt _ -> str "INT" | DFloat _ -> str "FLOAT" | DCons ((t,dopt),tl) -> f t ++ (match dopt with - Some t' -> str ":=" ++ f t' - | None -> str "") ++ spc() ++ str "::" ++ spc() ++ f tl + Some t' -> str ":=" ++ f t' + | None -> str "") ++ spc() ++ str "::" ++ spc() ++ f tl | DNil -> str "[]" (* @@ -82,9 +82,9 @@ struct | DApp (t,u) -> DApp (f t,f u) | DCase (ci,p,c,bl) -> DCase (ci, f p, f c, Array.map f bl) | DFix (ia,i,ta,ca) -> - DFix (ia,i,Array.map f ta,Array.map f ca) + DFix (ia,i,Array.map f ta,Array.map f ca) | DCoFix(i,ta,ca) -> - DCoFix (i,Array.map f ta,Array.map f ca) + DCoFix (i,Array.map f ta,Array.map f ca) | DCons ((t,topt),u) -> DCons ((f t,Option.map f topt), f u) let compare_ci ci1 ci2 = @@ -175,9 +175,9 @@ struct | DApp (t,u) -> f (f acc t) u | DCase (ci,p,c,bl) -> Array.fold_left f (f (f acc p) c) bl | DFix (ia,i,ta,ca) -> - Array.fold_left f (Array.fold_left f acc ta) ca + Array.fold_left f (Array.fold_left f acc ta) ca | DCoFix(i,ta,ca) -> - Array.fold_left f (Array.fold_left f acc ta) ca + Array.fold_left f (Array.fold_left f acc ta) ca | DCons ((t,topt),u) -> f (Option.fold_left f (f acc t) topt) u let choose f = function @@ -199,17 +199,17 @@ struct match c1,c2 with | (DRel, DRel | DNil, DNil | DSort, DSort | DRef _, DRef _ | DInt _, DInt _ | DFloat _, DFloat _) -> acc - | (DCtx (c1,t1), DCtx (c2,t2) - | DApp (c1,t1), DApp (c2,t2) - | DLambda (c1,t1), DLambda (c2,t2)) -> f (f acc c1 c2) t1 t2 - | DCase (ci,p1,c1,bl1),DCase (_,p2,c2,bl2) -> - Array.fold_left2 f (f (f acc p1 p2) c1 c2) bl1 bl2 - | DFix (ia,i,ta1,ca1), DFix (_,_,ta2,ca2) -> - Array.fold_left2 f (Array.fold_left2 f acc ta1 ta2) ca1 ca2 - | DCoFix(i,ta1,ca1), DCoFix(_,ta2,ca2) -> - Array.fold_left2 f (Array.fold_left2 f acc ta1 ta2) ca1 ca2 - | DCons ((t1,topt1),u1), DCons ((t2,topt2),u2) -> - f (Option.fold_left2 f (f acc t1 t2) topt1 topt2) u1 u2 + | (DCtx (c1,t1), DCtx (c2,t2) + | DApp (c1,t1), DApp (c2,t2) + | DLambda (c1,t1), DLambda (c2,t2)) -> f (f acc c1 c2) t1 t2 + | DCase (ci,p1,c1,bl1),DCase (_,p2,c2,bl2) -> + Array.fold_left2 f (f (f acc p1 p2) c1 c2) bl1 bl2 + | DFix (ia,i,ta1,ca1), DFix (_,_,ta2,ca2) -> + Array.fold_left2 f (Array.fold_left2 f acc ta1 ta2) ca1 ca2 + | DCoFix(i,ta1,ca1), DCoFix(_,ta2,ca2) -> + Array.fold_left2 f (Array.fold_left2 f acc ta1 ta2) ca1 ca2 + | DCons ((t1,topt1),u1), DCons ((t2,topt2),u2) -> + f (Option.fold_left2 f (f acc t1 t2) topt1 topt2) u1 u2 | (DRel | DNil | DSort | DRef _ | DCtx _ | DApp _ | DLambda _ | DCase _ | DFix _ | DCoFix _ | DCons _ | DInt _ | DFloat _), _ -> assert false @@ -220,18 +220,18 @@ struct match c1,c2 with | (DRel, DRel | DSort, DSort | DNil, DNil | DRef _, DRef _ | DInt _, DInt _ | DFloat _, DFloat _) as cc -> - let (c,_) = cc in c - | DCtx (c1,t1), DCtx (c2,t2) -> DCtx (f c1 c2, f t1 t2) - | DLambda (t1,c1), DLambda (t2,c2) -> DLambda (f t1 t2, f c1 c2) - | DApp (t1,u1), DApp (t2,u2) -> DApp (f t1 t2,f u1 u2) - | DCase (ci,p1,c1,bl1), DCase (_,p2,c2,bl2) -> - DCase (ci, f p1 p2, f c1 c2, Array.map2 f bl1 bl2) - | DFix (ia,i,ta1,ca1), DFix (_,_,ta2,ca2) -> - DFix (ia,i,Array.map2 f ta1 ta2,Array.map2 f ca1 ca2) - | DCoFix (i,ta1,ca1), DCoFix (_,ta2,ca2) -> - DCoFix (i,Array.map2 f ta1 ta2,Array.map2 f ca1 ca2) - | DCons ((t1,topt1),u1), DCons ((t2,topt2),u2) -> - DCons ((f t1 t2,Option.lift2 f topt1 topt2), f u1 u2) + let (c,_) = cc in c + | DCtx (c1,t1), DCtx (c2,t2) -> DCtx (f c1 c2, f t1 t2) + | DLambda (t1,c1), DLambda (t2,c2) -> DLambda (f t1 t2, f c1 c2) + | DApp (t1,u1), DApp (t2,u2) -> DApp (f t1 t2,f u1 u2) + | DCase (ci,p1,c1,bl1), DCase (_,p2,c2,bl2) -> + DCase (ci, f p1 p2, f c1 c2, Array.map2 f bl1 bl2) + | DFix (ia,i,ta1,ca1), DFix (_,_,ta2,ca2) -> + DFix (ia,i,Array.map2 f ta1 ta2,Array.map2 f ca1 ca2) + | DCoFix (i,ta1,ca1), DCoFix (_,ta2,ca2) -> + DCoFix (i,Array.map2 f ta1 ta2,Array.map2 f ca1 ca2) + | DCons ((t1,topt1),u1), DCons ((t2,topt2),u2) -> + DCons ((f t1 t2,Option.lift2 f topt1 topt2), f u1 u2) | (DRel | DNil | DSort | DRef _ | DCtx _ | DApp _ | DLambda _ | DCase _ | DFix _ | DCoFix _ | DCons _ | DInt _ | DFloat _), _ -> assert false @@ -274,8 +274,8 @@ module Make = struct module TDnet : Dnet.S with type ident=Ident.t - and type 'a structure = 'a DTerm.t - and type meta = int + and type 'a structure = 'a DTerm.t + and type meta = int = Dnet.Make(DTerm)(Ident)(Int) type t = TDnet.t @@ -328,7 +328,7 @@ struct | App (f,ca) -> Array.fold_left (fun c a -> Term (DApp (c,a))) (pat_of_constr f) (Array.map pat_of_constr ca) - | Proj (p,c) -> + | Proj (p,c) -> Term (DApp (Term (DRef (ConstRef (Projection.constant p))), pat_of_constr c)) | Int i -> Term (DInt i) | Float f -> Term (DFloat f) @@ -392,16 +392,16 @@ struct let dpat = under_prod (empty_ctx dpat) in TDnet.Idset.fold (fun id acc -> - let c_id = Opt.reduce (Ident.constr_of id) in - let c_id = EConstr.of_constr c_id in - let (ctx,wc) = + let c_id = Opt.reduce (Ident.constr_of id) in + let c_id = EConstr.of_constr c_id in + let (ctx,wc) = try Termops.align_prod_letin Evd.empty whole_c c_id (* FIXME *) - with Invalid_argument _ -> [],c_id in - let wc,whole_c = if Opt.direction then whole_c,wc else wc,whole_c in - try + with Invalid_argument _ -> [],c_id in + let wc,whole_c = if Opt.direction then whole_c,wc else wc,whole_c in + try let _ = Termops.filtering Evd.empty ctx Reduction.CUMUL wc whole_c in id :: acc - with Termops.CannotFilter -> (* msgnl(str"recon "++Termops.print_constr_env (Global.env()) wc); *) acc + with Termops.CannotFilter -> (* msgnl(str"recon "++Termops.print_constr_env (Global.env()) wc); *) acc ) (TDnet.find_match dpat dn) [] (* diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml index b091ff3b4e..f8f046ae75 100644 --- a/tools/coq_makefile.ml +++ b/tools/coq_makefile.ml @@ -181,7 +181,7 @@ let generate_conf_subdirs oc sds = iter (fprintf oc "clean::\n\tcd \"%s\" && $(MAKE) clean\n") sds; iter (fprintf oc "archclean::\n\tcd \"%s\" && $(MAKE) archclean\n") sds; iter (fprintf oc "install-extra::\n\tcd \"%s\" && $(MAKE) install\n") sds - + let generate_conf_includes oc { ml_includes; r_includes; q_includes } = section oc "Path directives (-I, -R, -Q)."; @@ -307,7 +307,7 @@ let ensure_root_dir r_includes = source (here_path, "Top") :: r_includes } ;; -let warn_install_at_root_directory +let warn_install_at_root_directory ({ q_includes; r_includes; } as project) = let open CList in @@ -330,11 +330,11 @@ let check_overlapping_include { q_includes; r_includes } = let aux = function | [] -> () | {thing = { path; canonical_path }, _} :: l -> - if not (is_prefix pwd canonical_path) then - eprintf "Warning: %s (used in -R or -Q) is not a subdirectory of the current directory\n\n" path; + if not (is_prefix pwd canonical_path) then + eprintf "Warning: %s (used in -R or -Q) is not a subdirectory of the current directory\n\n" path; List.iter (fun {thing={ path = p; canonical_path = cp }, _} -> - if is_prefix canonical_path cp || is_prefix cp canonical_path then - eprintf "Warning: %s and %s overlap (used in -R or -Q)\n\n" + if is_prefix canonical_path cp || is_prefix cp canonical_path then + eprintf "Warning: %s and %s overlap (used in -R or -Q)\n\n" path p) l in aux (q_includes @ r_includes) diff --git a/tools/coq_tex.ml b/tools/coq_tex.ml index 371483b862..8077f166c8 100644 --- a/tools/coq_tex.ml +++ b/tools/coq_tex.ml @@ -118,9 +118,9 @@ let insert texfile coq_output result = let rec read_lines () = let s = input_line c_coq in if Str.string_match any_prompt s 0 then begin - last_read := s; [] + last_read := s; [] end else - s :: read_lines () in + s :: read_lines () in (first :: read_lines (), !nb) in let unhandled_output = ref None in let read_output () = @@ -225,7 +225,7 @@ let one_file texfile = extract texfile inputv; (* 2. run Coq on input *) let _ = Sys.command (Printf.sprintf "%s < %s > %s 2>&1" !image inputv - coq_output) + coq_output) in (* 3. insert Coq output into original file *) insert texfile coq_output result; @@ -244,21 +244,21 @@ let files = ref [] let parse_cl () = Arg.parse [ "-o", Arg.String (fun s -> output_specified := true; output := s), - "output-file Specify the resulting LaTeX file"; - "-n", Arg.Int (fun n -> linelen := n), - "line-width Set the line width"; - "-image", Arg.String (fun s -> image := s), - "coq-image Use coq-image as Coq command"; - "-w", Arg.Set cut_at_blanks, - " Try to cut lines at blanks"; - "-v", Arg.Set verbose, - " Verbose mode (show Coq answers on stdout)"; - "-sl", Arg.Set slanted, - " Coq answers in slanted font (only with LaTeX2e)"; - "-hrule", Arg.Set hrule, - " Coq parts are written between 2 horizontal lines"; - "-small", Arg.Set small, - " Coq parts are written in small font"; + "output-file Specify the resulting LaTeX file"; + "-n", Arg.Int (fun n -> linelen := n), + "line-width Set the line width"; + "-image", Arg.String (fun s -> image := s), + "coq-image Use coq-image as Coq command"; + "-w", Arg.Set cut_at_blanks, + " Try to cut lines at blanks"; + "-v", Arg.Set verbose, + " Verbose mode (show Coq answers on stdout)"; + "-sl", Arg.Set slanted, + " Coq answers in slanted font (only with LaTeX2e)"; + "-hrule", Arg.Set hrule, + " Coq parts are written between 2 horizontal lines"; + "-small", Arg.Set small, + " Coq parts are written in small font"; ] (fun s -> files := s :: !files) "coq-tex [options] file ..." diff --git a/tools/coqdep.ml b/tools/coqdep.ml index b9a8601d10..0528d73713 100644 --- a/tools/coqdep.ml +++ b/tools/coqdep.ml @@ -41,7 +41,7 @@ let warning_mult suf iter = if (Filename.dirname (file_name f d)) <> (Filename.dirname (file_name f d')) then begin coqdep_warning "the file %s is defined twice!" (f ^ suf) - end + end with Not_found -> () end; Hashtbl.add tab f d in @@ -56,20 +56,20 @@ let sort () = let cin = open_in (file ^ ".v") in let lb = Lexing.from_channel cin in try - while true do - match coq_action lb with - | Require (from, sl) -> - List.iter - (fun s -> + while true do + match coq_action lb with + | Require (from, sl) -> + List.iter + (fun s -> match search_v_known ?from s with | None -> () | Some f -> loop f) - sl - | _ -> () - done + sl + | _ -> () + done with Fin_fichier -> - close_in cin; - printf "%s%s " file !suffixe + close_in cin; + printf "%s%s " file !suffixe end in List.iter (fun (name,_) -> loop name) !vAccu @@ -85,18 +85,18 @@ let mL_dep_list b f = let chan = open_in f in let buf = Lexing.from_channel chan in try - while true do - let (Use_module str) = caml_action buf in - if str = b then begin + while true do + let (Use_module str) = caml_action buf in + if str = b then begin coqdep_warning "in file %s the notation %s. is useless !\n" f b - end else + end else if not (List.mem str !deja_vu) then addQueue deja_vu str - done; [] + done; [] with Fin_fichier -> begin - close_in chan; - let rl = List.rev !deja_vu in - Hashtbl.add dep_tab f rl; - rl + close_in chan; + let rl = List.rev !deja_vu in + Hashtbl.add dep_tab f rl; + rl end with Sys_error _ -> [] @@ -116,36 +116,36 @@ let traite_Declare f = let decl_list = ref ([] : string list) in let rec treat = function | s :: ll -> - let s' = basename_noext s in - (match search_ml_known s with - | Some mldir when not (List.mem s' !decl_list) -> - let fullname = file_name s' mldir in - let depl = mL_dep_list s (fullname ^ ".ml") in - treat depl; - decl_list := s :: !decl_list - | _ -> ()); - treat ll + let s' = basename_noext s in + (match search_ml_known s with + | Some mldir when not (List.mem s' !decl_list) -> + let fullname = file_name s' mldir in + let depl = mL_dep_list s (fullname ^ ".ml") in + treat depl; + decl_list := s :: !decl_list + | _ -> ()); + treat ll | [] -> () in try let chan = open_in f in let buf = Lexing.from_channel chan in - begin try - while true do - let tok = coq_action buf in - (match tok with - | Declare sl -> - decl_list := []; - treat sl; - decl_list := List.rev !decl_list; - if !option_D then - affiche_Declare f !decl_list - else if !decl_list <> sl then - warning_Declare f !decl_list - | _ -> ()) - done - with Fin_fichier -> () end; - close_in chan + begin try + while true do + let tok = coq_action buf in + (match tok with + | Declare sl -> + decl_list := []; + treat sl; + decl_list := List.rev !decl_list; + if !option_D then + affiche_Declare f !decl_list + else if !decl_list <> sl then + warning_Declare f !decl_list + | _ -> ()) + done + with Fin_fichier -> () end; + close_in chan with Sys_error _ -> () let declare_dependencies () = @@ -246,7 +246,7 @@ struct else let x = NSet.choose rem in let rem = NSet.remove x rem in - if NSet.mem x seen then + if NSet.mem x seen then aux rem seen else let seen = NSet.add x seen in diff --git a/tools/coqdep_common.ml b/tools/coqdep_common.ml index c5f38e716e..775c528176 100644 --- a/tools/coqdep_common.ml +++ b/tools/coqdep_common.ml @@ -631,13 +631,13 @@ let rec treat_file old_dirname old_name = Array.iter (treat_file (Some newdirname)) (Sys.readdir complete_name)) | S_REG -> (match get_extension name [".v";".ml";".mli";".mlg";".mllib";".mlpack"] with - | (base,".v") -> - let name = file_name base dirname - and absname = absolute_file_name base dirname in - addQueue vAccu (name, absname) + | (base,".v") -> + let name = file_name base dirname + and absname = absolute_file_name base dirname in + addQueue vAccu (name, absname) | (base,(".ml"|".mlg" as ext)) -> addQueue mlAccu (base,ext,dirname) - | (base,".mli") -> addQueue mliAccu (base,dirname) - | (base,".mllib") -> addQueue mllibAccu (base,dirname) - | (base,".mlpack") -> addQueue mlpackAccu (base,dirname) - | _ -> ()) + | (base,".mli") -> addQueue mliAccu (base,dirname) + | (base,".mllib") -> addQueue mllibAccu (base,dirname) + | (base,".mlpack") -> addQueue mlpackAccu (base,dirname) + | _ -> ()) | _ -> () diff --git a/tools/coqdoc/index.ml b/tools/coqdoc/index.ml index 8f82bee5c6..67a835957d 100644 --- a/tools/coqdoc/index.ml +++ b/tools/coqdoc/index.ml @@ -133,8 +133,8 @@ type 'a index = { let map f i = { i with idx_entries = List.map - (fun (c,l) -> (c, List.map (fun (s,x) -> (s,f s x)) l)) - i.idx_entries } + (fun (c,l) -> (c, List.map (fun (s,x) -> (s,f s x)) l)) + i.idx_entries } let compare_entries (s1,_) (s2,_) = Alpha.compare_string s1 s2 @@ -148,7 +148,7 @@ let sort_entries el = (fun ((s,_) as e) -> let c = Alpha.norm_char s.[0] in let c,l = - try c,Hashtbl.find t c with Not_found -> '*',Hashtbl.find t '*' in + try c,Hashtbl.find t c with Not_found -> '*',Hashtbl.find t '*' in Hashtbl.replace t c (e :: l)) el; let res = ref [] in @@ -208,22 +208,22 @@ let prepare_entry s = function let quoted = ref false in let l = String.length s - 1 in while !j <= l do - if not !quoted then begin - (match s.[!j] with - | '_' -> Bytes.set ntn !k ' '; incr k - | 'x' -> Bytes.set ntn !k '_'; incr k - | '\'' -> quoted := true - | _ -> assert false) - end - else - if s.[!j] = '\'' then - if (!j = l || s.[!j+1] = '_') then quoted := false - else (incr j; Bytes.set ntn !k s.[!j]; incr k) - else begin - Bytes.set ntn !k s.[!j]; - incr k - end; - incr j + if not !quoted then begin + (match s.[!j] with + | '_' -> Bytes.set ntn !k ' '; incr k + | 'x' -> Bytes.set ntn !k '_'; incr k + | '\'' -> quoted := true + | _ -> assert false) + end + else + if s.[!j] = '\'' then + if (!j = l || s.[!j+1] = '_') then quoted := false + else (incr j; Bytes.set ntn !k s.[!j]; incr k) + else begin + Bytes.set ntn !k s.[!j]; + incr k + end; + incr j done; let ntn = Bytes.sub_string ntn 0 !k in let ntn = if sc = "" then ntn else ntn ^ " (" ^ sc ^ ")" in @@ -246,8 +246,8 @@ let all_entries () = idx_entries = sort_entries !gl; idx_size = List.length !gl }, Hashtbl.fold (fun t e l -> (t, { idx_name = type_name t; - idx_entries = sort_entries e; - idx_size = List.length e }) :: l) bt [] + idx_entries = sort_entries e; + idx_size = List.length e }) :: l) bt [] let type_of_string = function | "def" | "coe" | "subclass" | "canonstruc" | "fix" | "cofix" @@ -297,16 +297,16 @@ let read_glob vfile f = let s = input_line c in let n = String.length s in if n > 0 then begin - match s.[0] with - | 'F' -> - cur_mod := String.sub s 1 (n - 1); - current_library := !cur_mod - | 'R' -> - (try - Scanf.sscanf s "R%d:%d %s %s %s %s" - (fun loc1 loc2 lib_dp sp id ty -> - for loc=loc1 to loc2 do - add_ref !cur_mod loc lib_dp sp id (type_of_string ty); + match s.[0] with + | 'F' -> + cur_mod := String.sub s 1 (n - 1); + current_library := !cur_mod + | 'R' -> + (try + Scanf.sscanf s "R%d:%d %s %s %s %s" + (fun loc1 loc2 lib_dp sp id ty -> + for loc=loc1 to loc2 do + add_ref !cur_mod loc lib_dp sp id (type_of_string ty); (* Also add an entry for each module mentioned in [lib_dp], * to use in interpolation. *) @@ -316,13 +316,13 @@ let read_glob vfile f = | _ -> thisPiece ^ "." ^ priorPieces in add_ref !cur_mod loc "" "" newPieces Library; newPieces) (Str.split (Str.regexp_string ".") lib_dp) "") - done) - with _ -> ()) - | _ -> - try Scanf.sscanf s "%s %d:%d %s %s" - (fun ty loc1 loc2 sp id -> + done) + with _ -> ()) + | _ -> + try Scanf.sscanf s "%s %d:%d %s %s" + (fun ty loc1 loc2 sp id -> add_def loc1 loc2 (type_of_string ty) sp id) - with Scanf.Scan_failure _ -> () + with Scanf.Scan_failure _ -> () end done; assert false diff --git a/tools/coqdoc/main.ml b/tools/coqdoc/main.ml index 3442ebb731..529706f153 100644 --- a/tools/coqdoc/main.ml +++ b/tools/coqdoc/main.ml @@ -132,8 +132,8 @@ let coq_module filename = (* otherwise, keep only base name *) | [] -> fname | (p, name) :: rem -> - try name_of_path p name dirname [fname] - with Not_found -> change_prefix rem + try name_of_path p name dirname [fname] + with Not_found -> change_prefix rem in change_prefix !paths @@ -159,22 +159,22 @@ let files_from_file f = let buf = Buffer.create 80 in let l = ref [] in try - while true do - match input_char ch with - | ' ' | '\t' | '\n' -> - if Buffer.length buf > 0 then l := (Buffer.contents buf) :: !l; - Buffer.clear buf - | c -> - Buffer.add_char buf c - done; [] + while true do + match input_char ch with + | ' ' | '\t' | '\n' -> + if Buffer.length buf > 0 then l := (Buffer.contents buf) :: !l; + Buffer.clear buf + | c -> + Buffer.add_char buf c + done; [] with End_of_file -> - List.rev !l + List.rev !l in try check_if_file_exists f; let ch = open_in f in let l = files_from_channel ch in - close_in ch;l + close_in ch;l with Sys_error s -> begin eprintf "coqdoc: cannot read from file %s (%s)\n" f s; exit 1 @@ -194,79 +194,79 @@ let parse () = | ("-nopreamble" | "--nopreamble" | "--no-preamble" | "-bodyonly" | "--bodyonly" | "--body-only") :: rem -> - header_trailer := false; parse_rec rem + header_trailer := false; parse_rec rem | ("-with-header" | "--with-header") :: f ::rem -> - header_trailer := true; header_file_spec := true; header_file := f; parse_rec rem + header_trailer := true; header_file_spec := true; header_file := f; parse_rec rem | ("-with-header" | "--with-header") :: [] -> - usage () + usage () | ("-with-footer" | "--with-footer") :: f ::rem -> - header_trailer := true; footer_file_spec := true; footer_file := f; parse_rec rem + header_trailer := true; footer_file_spec := true; footer_file := f; parse_rec rem | ("-with-footer" | "--with-footer") :: [] -> - usage () + usage () | ("-p" | "--preamble") :: s :: rem -> - Output.push_in_preamble s; parse_rec rem + Output.push_in_preamble s; parse_rec rem | ("-p" | "--preamble") :: [] -> - usage () + usage () | ("-noindex" | "--noindex" | "--no-index") :: rem -> - index := false; parse_rec rem + index := false; parse_rec rem | ("-multi-index" | "--multi-index") :: rem -> - multi_index := true; parse_rec rem + multi_index := true; parse_rec rem | ("-index" | "--index") :: s :: rem -> - Cdglobals.index_name := s; parse_rec rem + Cdglobals.index_name := s; parse_rec rem | ("-index" | "--index") :: [] -> - usage () + usage () | ("-toc" | "--toc" | "--table-of-contents") :: rem -> - toc := true; parse_rec rem + toc := true; parse_rec rem | ("-stdout" | "--stdout") :: rem -> - out_to := StdOut; parse_rec rem + out_to := StdOut; parse_rec rem | ("-o" | "--output") :: f :: rem -> - out_to := File (Filename.basename f); output_dir := Filename.dirname f; parse_rec rem + out_to := File (Filename.basename f); output_dir := Filename.dirname f; parse_rec rem | ("-o" | "--output") :: [] -> - usage () + usage () | ("-d" | "--directory") :: dir :: rem -> - output_dir := dir; parse_rec rem + output_dir := dir; parse_rec rem | ("-d" | "--directory") :: [] -> - usage () + usage () | ("-s" | "--short") :: rem -> - short := true; parse_rec rem + short := true; parse_rec rem | ("-l" | "-light" | "--light") :: rem -> - gallina := true; light := true; parse_rec rem + gallina := true; light := true; parse_rec rem | ("-g" | "-gallina" | "--gallina") :: rem -> - gallina := true; parse_rec rem + gallina := true; parse_rec rem | ("-t" | "-title" | "--title") :: s :: rem -> - title := s; parse_rec rem + title := s; parse_rec rem | ("-t" | "-title" | "--title") :: [] -> - usage () + usage () | ("-latex" | "--latex") :: rem -> - Cdglobals.target_language := LaTeX; parse_rec rem + Cdglobals.target_language := LaTeX; parse_rec rem | ("-pdf" | "--pdf") :: rem -> - Cdglobals.target_language := LaTeX; pdf := true; parse_rec rem + Cdglobals.target_language := LaTeX; pdf := true; parse_rec rem | ("-dvi" | "--dvi") :: rem -> - Cdglobals.target_language := LaTeX; dvi := true; parse_rec rem + Cdglobals.target_language := LaTeX; dvi := true; parse_rec rem | ("-ps" | "--ps") :: rem -> - Cdglobals.target_language := LaTeX; ps := true; parse_rec rem + Cdglobals.target_language := LaTeX; ps := true; parse_rec rem | ("-html" | "--html") :: rem -> - Cdglobals.target_language := HTML; parse_rec rem + Cdglobals.target_language := HTML; parse_rec rem | ("-texmacs" | "--texmacs") :: rem -> - Cdglobals.target_language := TeXmacs; parse_rec rem + Cdglobals.target_language := TeXmacs; parse_rec rem | ("-raw" | "--raw") :: rem -> - Cdglobals.target_language := Raw; parse_rec rem + Cdglobals.target_language := Raw; parse_rec rem | ("-charset" | "--charset") :: s :: rem -> - Cdglobals.charset := s; parse_rec rem + Cdglobals.charset := s; parse_rec rem | ("-charset" | "--charset") :: [] -> - usage () + usage () | ("-inputenc" | "--inputenc") :: s :: rem -> - Cdglobals.inputenc := s; parse_rec rem + Cdglobals.inputenc := s; parse_rec rem | ("-inputenc" | "--inputenc") :: [] -> - usage () + usage () | ("-raw-comments" | "--raw-comments") :: rem -> - Cdglobals.raw_comments := true; parse_rec rem + Cdglobals.raw_comments := true; parse_rec rem | ("-parse-comments" | "--parse-comments") :: rem -> - Cdglobals.parse_comments := true; parse_rec rem + Cdglobals.parse_comments := true; parse_rec rem | ("-plain-comments" | "--plain-comments") :: rem -> - Cdglobals.plain_comments := true; parse_rec rem + Cdglobals.plain_comments := true; parse_rec rem | ("-interpolate" | "--interpolate") :: rem -> - Cdglobals.interpolate := true; parse_rec rem + Cdglobals.interpolate := true; parse_rec rem | ("-toc-depth" | "--toc-depth") :: [] -> usage () | ("-toc-depth" | "--toc-depth") :: ds :: rem -> @@ -291,68 +291,68 @@ let parse () = parse_rec rem | ("-latin1" | "--latin1") :: rem -> - Cdglobals.set_latin1 (); parse_rec rem + Cdglobals.set_latin1 (); parse_rec rem | ("-utf8" | "--utf8") :: rem -> - Cdglobals.set_utf8 (); parse_rec rem + Cdglobals.set_utf8 (); parse_rec rem | ("-q" | "-quiet" | "--quiet") :: rem -> - quiet := true; parse_rec rem + quiet := true; parse_rec rem | ("-v" | "-verbose" | "--verbose") :: rem -> - quiet := false; parse_rec rem + quiet := false; parse_rec rem | ("-h" | "-help" | "-?" | "--help") :: rem -> - banner (); usage () + banner (); usage () | ("-V" | "-version" | "--version") :: _ -> - banner (); exit 0 + banner (); exit 0 | ("-vernac-file" | "--vernac-file") :: f :: rem -> - check_if_file_exists f; - add_file (Vernac_file (f, coq_module f)); parse_rec rem + check_if_file_exists f; + add_file (Vernac_file (f, coq_module f)); parse_rec rem | ("-vernac-file" | "--vernac-file") :: [] -> - usage () + usage () | ("-tex-file" | "--tex-file") :: f :: rem -> - add_file (Latex_file f); parse_rec rem + add_file (Latex_file f); parse_rec rem | ("-tex-file" | "--tex-file") :: [] -> - usage () + usage () | ("-files" | "--files" | "--files-from") :: f :: rem -> - List.iter (fun f -> add_file (what_file f)) (files_from_file f); - parse_rec rem + List.iter (fun f -> add_file (what_file f)) (files_from_file f); + parse_rec rem | ("-files" | "--files") :: [] -> - usage () + usage () | "-R" :: path :: log :: rem -> - add_path path log; parse_rec rem + add_path path log; parse_rec rem | "-R" :: ([] | [_]) -> - usage () + usage () | "-Q" :: path :: log :: rem -> - add_path path log; parse_rec rem + add_path path log; parse_rec rem | "-Q" :: ([] | [_]) -> - usage () + usage () | ("-glob-from" | "--glob-from") :: f :: rem -> - glob_source := GlobFile f; parse_rec rem + glob_source := GlobFile f; parse_rec rem | ("-glob-from" | "--glob-from") :: [] -> - usage () + usage () | ("-no-glob" | "--no-glob") :: rem -> - glob_source := NoGlob; parse_rec rem + glob_source := NoGlob; parse_rec rem | ("--no-externals" | "-no-externals" | "-noexternals") :: rem -> - Cdglobals.externals := false; parse_rec rem + Cdglobals.externals := false; parse_rec rem | ("--external" | "-external") :: u :: logicalpath :: rem -> - Index.add_external_library logicalpath u; parse_rec rem + Index.add_external_library logicalpath u; parse_rec rem | ("--coqlib" | "-coqlib") :: u :: rem -> - Cdglobals.coqlib := u; parse_rec rem + Cdglobals.coqlib := u; parse_rec rem | ("--coqlib" | "-coqlib") :: [] -> - usage () + usage () | ("--boot" | "-boot") :: rem -> - Cdglobals.coqlib_path := normalize_path ( + Cdglobals.coqlib_path := normalize_path ( Filename.concat (Filename.dirname Sys.executable_name) Filename.parent_dir_name ); parse_rec rem | ("--coqlib_path" | "-coqlib_path") :: d :: rem -> - Cdglobals.coqlib_path := d; parse_rec rem + Cdglobals.coqlib_path := d; parse_rec rem | ("--coqlib_path" | "-coqlib_path") :: [] -> - usage () + usage () | f :: rem -> - add_file (what_file f); parse_rec rem + add_file (what_file f); parse_rec rem in parse_rec (List.tl (Array.to_list Sys.argv)); List.rev !files @@ -424,13 +424,13 @@ let gen_mult_files l = let file = function | Vernac_file (f,m) -> let sub = if !lib_subtitles then Cpretty.detect_subtitle f m else None in - let hf = target_full_name m in + let hf = target_full_name m in Output.set_module m sub; - open_out_file hf; - if (!header_trailer) then Output.header (); - Cpretty.coq_file f m; - if (!header_trailer) then Output.trailer (); - close_out_file() + open_out_file hf; + if (!header_trailer) then Output.header (); + Cpretty.coq_file f m; + if (!header_trailer) then Output.trailer (); + close_out_file() | Latex_file _ -> () in List.iter file l; @@ -486,14 +486,14 @@ let produce_document l = List.iter index_module l; match !out_to with | StdOut -> - Cdglobals.out_channel := stdout; - gen_one_file l + Cdglobals.out_channel := stdout; + gen_one_file l | File f -> - open_out_file f; - gen_one_file l; - close_out_file() + open_out_file f; + gen_one_file l; + close_out_file() | MultFiles -> - gen_mult_files l + gen_mult_files l let produce_output fl = if not (!dvi || !ps || !pdf) then @@ -503,56 +503,56 @@ let produce_output fl = let texfile = Filename.temp_file "coqdoc" ".tex" in let basefile = Filename.chop_suffix texfile ".tex" in let final_out_to = !out_to in - out_to := File texfile; - output_dir := (Filename.dirname texfile); - produce_document fl; - - let latexexe = if !pdf then "pdflatex" else "latex" in - let latexcmd = - let file = Filename.basename texfile in - let file = - if !quiet then sprintf "'\\nonstopmode\\input{%s}'" file else file - in - sprintf "%s %s && %s %s 1>&2 %s" latexexe file latexexe file (if !quiet then "> /dev/null" else "") - in - let res = locally (Filename.dirname texfile) Sys.command latexcmd in - if res <> 0 then begin - eprintf "Couldn't run LaTeX successfully\n"; - clean_and_exit basefile res - end; - - let dvifile = basefile ^ ".dvi" in - if !dvi then - begin - match final_out_to with - | MultFiles | StdOut -> cat dvifile - | File f -> copy dvifile f - end; - let pdffile = basefile ^ ".pdf" in - if !pdf then + out_to := File texfile; + output_dir := (Filename.dirname texfile); + produce_document fl; + + let latexexe = if !pdf then "pdflatex" else "latex" in + let latexcmd = + let file = Filename.basename texfile in + let file = + if !quiet then sprintf "'\\nonstopmode\\input{%s}'" file else file + in + sprintf "%s %s && %s %s 1>&2 %s" latexexe file latexexe file (if !quiet then "> /dev/null" else "") + in + let res = locally (Filename.dirname texfile) Sys.command latexcmd in + if res <> 0 then begin + eprintf "Couldn't run LaTeX successfully\n"; + clean_and_exit basefile res + end; + + let dvifile = basefile ^ ".dvi" in + if !dvi then + begin + match final_out_to with + | MultFiles | StdOut -> cat dvifile + | File f -> copy dvifile f + end; + let pdffile = basefile ^ ".pdf" in + if !pdf then begin - match final_out_to with - | MultFiles | StdOut -> cat pdffile - | File f -> copy pdffile f - end; - if !ps then begin - let psfile = basefile ^ ".ps" - in - let command = - sprintf "dvips %s -o %s %s" dvifile psfile - (if !quiet then "> /dev/null 2>&1" else "") - in - let res = Sys.command command in - if res <> 0 then begin - eprintf "Couldn't run dvips successfully\n"; - clean_and_exit basefile res - end; - match final_out_to with - | MultFiles | StdOut -> cat psfile - | File f -> copy psfile f - end; - - clean_temp_files basefile + match final_out_to with + | MultFiles | StdOut -> cat pdffile + | File f -> copy pdffile f + end; + if !ps then begin + let psfile = basefile ^ ".ps" + in + let command = + sprintf "dvips %s -o %s %s" dvifile psfile + (if !quiet then "> /dev/null 2>&1" else "") + in + let res = Sys.command command in + if res <> 0 then begin + eprintf "Couldn't run dvips successfully\n"; + clean_and_exit basefile res + end; + match final_out_to with + | MultFiles | StdOut -> cat psfile + | File f -> copy psfile f + end; + + clean_temp_files basefile end diff --git a/tools/coqdoc/output.ml b/tools/coqdoc/output.ml index 02f0290802..5edf2b0d77 100644 --- a/tools/coqdoc/output.ml +++ b/tools/coqdoc/output.ml @@ -69,7 +69,7 @@ let is_keyword = let is_tactic = build_table [ "intro"; "intros"; "apply"; "rewrite"; "refine"; "case"; "clear"; "injection"; - "elimtype"; "progress"; "setoid_rewrite"; "left"; "right"; "constructor"; + "elimtype"; "progress"; "setoid_rewrite"; "left"; "right"; "constructor"; "econstructor"; "decide equality"; "abstract"; "exists"; "cbv"; "simple destruct"; "info"; "field"; "specialize"; "evar"; "solve"; "instantiate"; "info_auto"; "info_eauto"; "quote"; "eexact"; "autorewrite"; @@ -137,25 +137,25 @@ let initialize_tex_html () = (Tokens.ttree_add tt s l, match l' with None -> tt' | Some l' -> Tokens.ttree_add tt' s l')) [ "*" , "\\ensuremath{\\times}", if_utf8 "×"; - "|", "\\ensuremath{|}", None; - "->", "\\ensuremath{\\rightarrow}", if_utf8 "→"; - "->~", "\\ensuremath{\\rightarrow\\lnot}", None; - "->~~", "\\ensuremath{\\rightarrow\\lnot\\lnot}", None; - "<-", "\\ensuremath{\\leftarrow}", None; - "<->", "\\ensuremath{\\leftrightarrow}", if_utf8 "↔"; - "=>", "\\ensuremath{\\Rightarrow}", if_utf8 "⇒"; - "<=", "\\ensuremath{\\le}", if_utf8 "≤"; - ">=", "\\ensuremath{\\ge}", if_utf8 "≥"; - "<>", "\\ensuremath{\\not=}", if_utf8 "≠"; - "~", "\\ensuremath{\\lnot}", if_utf8 "¬"; - "/\\", "\\ensuremath{\\land}", if_utf8 "∧"; - "\\/", "\\ensuremath{\\lor}", if_utf8 "∨"; - "|-", "\\ensuremath{\\vdash}", None; - "forall", "\\ensuremath{\\forall}", if_utf8 "∀"; - "exists", "\\ensuremath{\\exists}", if_utf8 "∃"; - "Π", "\\ensuremath{\\Pi}", if_utf8 "Π"; - "λ", "\\ensuremath{\\lambda}", if_utf8 "λ"; - (* "fun", "\\ensuremath{\\lambda}" ? *) + "|", "\\ensuremath{|}", None; + "->", "\\ensuremath{\\rightarrow}", if_utf8 "→"; + "->~", "\\ensuremath{\\rightarrow\\lnot}", None; + "->~~", "\\ensuremath{\\rightarrow\\lnot\\lnot}", None; + "<-", "\\ensuremath{\\leftarrow}", None; + "<->", "\\ensuremath{\\leftrightarrow}", if_utf8 "↔"; + "=>", "\\ensuremath{\\Rightarrow}", if_utf8 "⇒"; + "<=", "\\ensuremath{\\le}", if_utf8 "≤"; + ">=", "\\ensuremath{\\ge}", if_utf8 "≥"; + "<>", "\\ensuremath{\\not=}", if_utf8 "≠"; + "~", "\\ensuremath{\\lnot}", if_utf8 "¬"; + "/\\", "\\ensuremath{\\land}", if_utf8 "∧"; + "\\/", "\\ensuremath{\\lor}", if_utf8 "∨"; + "|-", "\\ensuremath{\\vdash}", None; + "forall", "\\ensuremath{\\forall}", if_utf8 "∀"; + "exists", "\\ensuremath{\\exists}", if_utf8 "∃"; + "Π", "\\ensuremath{\\Pi}", if_utf8 "Π"; + "λ", "\\ensuremath{\\lambda}", if_utf8 "λ"; + (* "fun", "\\ensuremath{\\lambda}" ? *) ] (Tokens.empty_ttree,Tokens.empty_ttree) in token_tree_latex := tree_latex; token_tree_html := tree_html @@ -243,13 +243,13 @@ module Latex = struct let char c = match c with | '\\' -> - printf "\\symbol{92}" + printf "\\symbol{92}" | '$' | '#' | '%' | '&' | '{' | '}' | '_' -> - output_char '\\'; output_char c + output_char '\\'; output_char c | '^' | '~' -> - output_char '\\'; output_char c; printf "{}" + output_char '\\'; output_char c; printf "{}" | _ -> - output_char c + output_char c let label_char c = match c with | '_' -> output_char ' ' @@ -273,22 +273,22 @@ module Latex = struct fun s -> Buffer.clear buff; for i = 0 to String.length s - 1 do - match s.[i] with - | '\\' -> - Buffer.add_string buff "\\symbol{92}" - | '$' | '#' | '%' | '&' | '{' | '}' | '_' as c -> - Buffer.add_char buff '\\'; Buffer.add_char buff c - | '^' | '~' as c -> - Buffer.add_char buff '\\'; Buffer.add_char buff c; - Buffer.add_string buff "{}" + match s.[i] with + | '\\' -> + Buffer.add_string buff "\\symbol{92}" + | '$' | '#' | '%' | '&' | '{' | '}' | '_' as c -> + Buffer.add_char buff '\\'; Buffer.add_char buff c + | '^' | '~' as c -> + Buffer.add_char buff '\\'; Buffer.add_char buff c; + Buffer.add_string buff "{}" | '\'' -> if i < String.length s - 1 && s.[i+1] = '\'' then begin Buffer.add_char buff '\''; Buffer.add_char buff '{'; Buffer.add_char buff '}' end else Buffer.add_char buff '\'' - | c -> - Buffer.add_char buff c + | c -> + Buffer.add_char buff c done; Buffer.contents buff @@ -310,8 +310,8 @@ module Latex = struct let start_quote () = output_char '`'; output_char '`' let stop_quote () = output_char '\''; output_char '\'' - - let start_verbatim inline = + + let start_verbatim inline = if inline then printf "\\texttt{" else printf "\\begin{verbatim}" @@ -319,7 +319,7 @@ module Latex = struct if inline then printf "}" else printf "\\end{verbatim}\n" - let url addr name = + let url addr name = printf "%s\\footnote{\\url{%s}}" (match name with | None -> "" @@ -337,16 +337,16 @@ module Latex = struct let id = if fid <> "" then (m ^ "." ^ fid) else m in match find_module m with | Local -> - if typ = Variable then - printf "\\coqdoc%s{%s}" (type_name typ) s - else - (printf "\\coqref{"; label_ident id; - printf "}{\\coqdoc%s{%s}}" (type_name typ) s) + if typ = Variable then + printf "\\coqdoc%s{%s}" (type_name typ) s + else + (printf "\\coqref{"; label_ident id; + printf "}{\\coqdoc%s{%s}}" (type_name typ) s) | External m when !externals -> - printf "\\coqexternalref{"; label_ident fid; - printf "}{%s}{\\coqdoc%s{%s}}" (escaped m) (type_name typ) s + printf "\\coqexternalref{"; label_ident fid; + printf "}{%s}{\\coqdoc%s{%s}}" (escaped m) (type_name typ) s | External _ | Unknown -> - printf "\\coqdoc%s{%s}" (type_name typ) s + printf "\\coqdoc%s{%s}" (type_name typ) s let defref m id ty s = if ty <> Notation then @@ -360,9 +360,9 @@ module Latex = struct let reference s = function | Def (fullid,typ) -> - defref (get_module false) fullid typ s + defref (get_module false) fullid typ s | Ref (m,fullid,typ) -> - ident_ref m fullid typ s + ident_ref m fullid typ s (*s The sublexer buffers symbol characters and attached uninterpreted ident and try to apply special translation such as, @@ -407,7 +407,7 @@ module Latex = struct let translate s = match Tokens.translate s with Some s -> s | None -> escaped s - let keyword s loc = + let keyword s loc = printf "\\coqdockw{%s}" (translate s) let ident s loc = @@ -420,15 +420,15 @@ module Latex = struct reference (translate s) tag with Not_found -> if is_tactic s then - printf "\\coqdoctac{%s}" (translate s) + printf "\\coqdoctac{%s}" (translate s) else if is_keyword s then - printf "\\coqdockw{%s}" (translate s) + printf "\\coqdockw{%s}" (translate s) else if !Cdglobals.interpolate && !in_doc (* always a var otherwise *) then - try + try let tag = Index.find_string s in - reference (translate s) tag - with _ -> Tokens.output_tagged_ident_string s + reference (translate s) tag + with _ -> Tokens.output_tagged_ident_string s else Tokens.output_tagged_ident_string s let ident s l = @@ -528,40 +528,40 @@ module Html = struct if !header_trailer then if !header_file_spec then let cin = open_in !header_file in - try - while true do + try + while true do let s = input_line cin in - printf "%s\n" s - done + printf "%s\n" s + done with End_of_file -> close_in cin else - begin - printf "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"\n"; - printf "\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n"; - printf "<html xmlns=\"http://www.w3.org/1999/xhtml\">\n<head>\n"; - printf "<meta http-equiv=\"Content-Type\" content=\"text/html; charset=%s\" />\n" !charset; - printf "<link href=\"coqdoc.css\" rel=\"stylesheet\" type=\"text/css\" />\n"; - printf "<title>%s</title>\n</head>\n\n" !page_title; - printf "<body>\n\n<div id=\"page\">\n\n<div id=\"header\">\n</div>\n\n"; - printf "<div id=\"main\">\n\n" - end + begin + printf "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"\n"; + printf "\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n"; + printf "<html xmlns=\"http://www.w3.org/1999/xhtml\">\n<head>\n"; + printf "<meta http-equiv=\"Content-Type\" content=\"text/html; charset=%s\" />\n" !charset; + printf "<link href=\"coqdoc.css\" rel=\"stylesheet\" type=\"text/css\" />\n"; + printf "<title>%s</title>\n</head>\n\n" !page_title; + printf "<body>\n\n<div id=\"page\">\n\n<div id=\"header\">\n</div>\n\n"; + printf "<div id=\"main\">\n\n" + end let trailer () = if !header_trailer && !footer_file_spec then let cin = open_in !footer_file in - try - while true do + try + while true do let s = input_line cin in - printf "%s\n" s - done + printf "%s\n" s + done with End_of_file -> close_in cin else begin if !index && (get_module false) <> "Index" then printf "</div>\n\n<div id=\"footer\">\n<hr/><a href=\"%s.html\">Index</a>" !index_name; - printf "<hr/>This page has been generated by "; - printf "<a href=\"%s\">coqdoc</a>\n" Coq_config.wwwcoq; - printf "</div>\n\n</div>\n\n</body>\n</html>" + printf "<hr/>This page has been generated by "; + printf "<a href=\"%s\">coqdoc</a>\n" Coq_config.wwwcoq; + printf "</div>\n\n</div>\n\n</body>\n</html>" end let start_module () = @@ -595,12 +595,12 @@ module Html = struct fun s -> Buffer.clear buff; for i = 0 to String.length s - 1 do - match s.[i] with - | '<' -> Buffer.add_string buff "<" - | '>' -> Buffer.add_string buff ">" - | '&' -> Buffer.add_string buff "&" + match s.[i] with + | '<' -> Buffer.add_string buff "<" + | '>' -> Buffer.add_string buff ">" + | '&' -> Buffer.add_string buff "&" | '\"' -> Buffer.add_string buff """ - | c -> Buffer.add_char buff c + | c -> Buffer.add_char buff c done; Buffer.contents buff @@ -628,16 +628,16 @@ module Html = struct let start_quote () = char '"' let stop_quote () = start_quote () - let start_verbatim inline = + let start_verbatim inline = if inline then printf "<tt>" else printf "<pre>" - let stop_verbatim inline = - if inline then printf "</tt>" + let stop_verbatim inline = + if inline then printf "</tt>" else printf "</pre>\n" - let url addr name = - printf "<a href=\"%s\">%s</a>" addr + let url addr name = + printf "<a href=\"%s\">%s</a>" addr (match name with | Some n -> n | None -> addr) @@ -645,29 +645,29 @@ module Html = struct let ident_ref m fid typ s = match find_module m with | Local -> - printf "<a class=\"idref\" href=\"%s.html#%s\">" m (sanitize_name fid); - printf "<span class=\"id\" title=\"%s\">%s</span></a>" typ s + printf "<a class=\"idref\" href=\"%s.html#%s\">" m (sanitize_name fid); + printf "<span class=\"id\" title=\"%s\">%s</span></a>" typ s | External m when !externals -> - printf "<a class=\"idref\" href=\"%s.html#%s\">" m (sanitize_name fid); - printf "<span class=\"id\" title=\"%s\">%s</span></a>" typ s + printf "<a class=\"idref\" href=\"%s.html#%s\">" m (sanitize_name fid); + printf "<span class=\"id\" title=\"%s\">%s</span></a>" typ s | External _ | Unknown -> - printf "<span class=\"id\" title=\"%s\">%s</span>" typ s + printf "<span class=\"id\" title=\"%s\">%s</span>" typ s let reference s r = match r with | Def (fullid,ty) -> - printf "<a name=\"%s\">" (sanitize_name fullid); - printf "<span class=\"id\" title=\"%s\">%s</span></a>" (type_name ty) s + printf "<a name=\"%s\">" (sanitize_name fullid); + printf "<span class=\"id\" title=\"%s\">%s</span></a>" (type_name ty) s | Ref (m,fullid,ty) -> - ident_ref m fullid (type_name ty) s + ident_ref m fullid (type_name ty) s let output_sublexer_string doescape issymbchar tag s = let s = if doescape then escaped s else s in match tag with | Some ref -> reference s ref | None -> - if issymbchar then output_string s - else printf "<span class=\"id\" title=\"var\">%s</span>" s + if issymbchar then output_string s + else printf "<span class=\"id\" title=\"var\">%s</span>" s let sublexer c loc = let tag = @@ -686,7 +686,7 @@ module Html = struct let translate s = match Tokens.translate s with Some s -> s | None -> escaped s - let keyword s loc = + let keyword s loc = printf "<span class=\"id\" title=\"keyword\">%s</span>" (translate s) let ident s loc = @@ -697,14 +697,14 @@ module Html = struct reference (translate s) (Index.find (get_module false) loc) with Not_found -> if is_tactic s then - printf "<span class=\"id\" title=\"tactic\">%s</span>" (translate s) + printf "<span class=\"id\" title=\"tactic\">%s</span>" (translate s) else if is_keyword s then printf "<span class=\"id\" title=\"keyword\">%s</span>" (translate s) else if !Cdglobals.interpolate && !in_doc (* always a var otherwise *) then try reference (translate s) (Index.find_string s) - with Not_found -> Tokens.output_tagged_ident_string s + with Not_found -> Tokens.output_tagged_ident_string s else - Tokens.output_tagged_ident_string s + Tokens.output_tagged_ident_string s let proofbox () = printf "<font size=-2>☐</font>" @@ -748,7 +748,7 @@ module Html = struct let end_code () = end_coq (); start_doc () - let start_inline_coq () = + let start_inline_coq () = if !inline_notmono then printf "<span class=\"inlinecodenm\">" else printf "<span class=\"inlinecode\">" @@ -758,7 +758,7 @@ module Html = struct let end_inline_coq_block () = end_inline_coq () - let paragraph () = printf "\n<div class=\"paragraph\"> </div>\n\n" + let paragraph () = printf "\n<div class=\"paragraph\"> </div>\n\n" (* inference rules *) let inf_rule assumptions (_,_,midnm) conclusions = @@ -766,12 +766,12 @@ module Html = struct in a row with " "s. We do this to the assumptions so that people can put multiple rules on a line with nice formatting *) let replace_spaces str = - let rec copy a n = match n with 0 -> [] | n -> (a :: copy a (n - 1)) in + let rec copy a n = match n with 0 -> [] | n -> (a :: copy a (n - 1)) in let results = Str.full_split (Str.regexp "[' '][' '][' ']+") str in let strs = List.map (fun r -> match r with | Str.Text s -> [s] - | Str.Delim s -> - copy " " (String.length s)) + | Str.Delim s -> + copy " " (String.length s)) results in String.concat "" (List.concat strs) @@ -782,7 +782,7 @@ module Html = struct let end_assumption () = (printf " <td></td>\n"; printf "</td>\n") in - let rec print_assumptions hyps = + let rec print_assumptions hyps = match hyps with | [] -> start_assumption " " | [(_,hyp)] -> start_assumption hyp @@ -793,7 +793,7 @@ module Html = struct print_assumptions assumptions; printf " <td class=\"infrulenamecol\" rowspan=\"3\">\n"; (match midnm with - | None -> printf " \n </td>" + | None -> printf " \n </td>" | Some s -> printf " %s \n </td>" s); printf "</tr>\n"; printf "<tr class=\"infrulemiddle\">\n"; @@ -827,9 +827,9 @@ module Html = struct let cat = if category && idx <> "global" then "(" ^ idx ^ ")" else "" in printf "<a name=\"%s_%c\"></a><h2>%s %s</h2>\n" idx c (display_letter c) cat; List.iter - (fun (id,(text,link,t)) -> - let id' = prepare_entry id t in - printf "<a href=\"%s\">%s</a> %s<br/>\n" link id' text) l; + (fun (id,(text,link,t)) -> + let id' = prepare_entry id t in + printf "<a href=\"%s\">%s</a> %s<br/>\n" link id' text) l; printf "<br/><br/>" end @@ -840,35 +840,35 @@ module Html = struct let format_global_index = Index.map (fun s (m,t) -> - if t = Library then + if t = Library then let ln = !lib_name in if ln <> "" then "[" ^ String.lowercase_ascii ln ^ "]", m ^ ".html", t else - "[library]", m ^ ".html", t - else - sprintf "[%s, in <a href=\"%s.html\">%s</a>]" (type_name t) m m , - sprintf "%s.html#%s" m (sanitize_name s), t) + "[library]", m ^ ".html", t + else + sprintf "[%s, in <a href=\"%s.html\">%s</a>]" (type_name t) m m , + sprintf "%s.html#%s" m (sanitize_name s), t) let format_bytype_index = function | Library, idx -> - Index.map (fun id m -> "", m ^ ".html", Library) idx + Index.map (fun id m -> "", m ^ ".html", Library) idx | (t,idx) -> - Index.map - (fun s m -> - let text = sprintf "[in <a href=\"%s.html\">%s</a>]" m m in - (text, sprintf "%s.html#%s" m (sanitize_name s), t)) idx + Index.map + (fun s m -> + let text = sprintf "[in <a href=\"%s.html\">%s</a>]" m m in + (text, sprintf "%s.html#%s" m (sanitize_name s), t)) idx (* Impression de la table d'index *) let print_index_table_item i = printf "<tr>\n<td>%s Index</td>\n" (String.capitalize_ascii i.idx_name); List.iter (fun (c,l) -> - if l <> [] then - printf "<td><a href=\"%s\">%s</a></td>\n" (index_ref i c) - (display_letter c) - else - printf "<td>%s</td>\n" (display_letter c)) + if l <> [] then + printf "<td><a href=\"%s\">%s</a></td>\n" (index_ref i c) + (display_letter c) + else + printf "<td>%s</td>\n" (display_letter c)) i.idx_entries; let n = i.idx_size in printf "<td>(%d %s)</td>\n" n (if n > 1 then "entries" else "entry"); @@ -896,45 +896,45 @@ module Html = struct let make_multi_index () = let all_index = let glob,bt = Index.all_entries () in - (format_global_index glob) :: - (List.map format_bytype_index bt) in + (format_global_index glob) :: + (List.map format_bytype_index bt) in let print_table () = print_index_table all_index in List.iter (make_one_multi_index print_table) all_index let make_index () = let all_index = let glob,bt = Index.all_entries () in - (format_global_index glob) :: - (List.map format_bytype_index bt) in + (format_global_index glob) :: + (List.map format_bytype_index bt) in let print_table () = print_index_table all_index in let print_one_index i = if i.idx_size > 0 then begin printf "<hr/>\n<h1>%s Index</h1>\n" (String.capitalize_ascii i.idx_name); - all_letters i + all_letters i end in set_module "Index" None; if !title <> "" then printf "<h1>%s</h1>\n" !title; print_table (); if not (!multi_index) then - begin - List.iter print_one_index all_index; - printf "<hr/>"; print_table () - end + begin + List.iter print_one_index all_index; + printf "<hr/>"; print_table () + end let make_toc () = - let ln = !lib_name in + let ln = !lib_name in let make_toc_entry = function | Toc_library (m,sub) -> - stop_item (); - let ms = match sub with | None -> m | Some s -> m ^ ": " ^ s in + stop_item (); + let ms = match sub with | None -> m | Some s -> m ^ ": " ^ s in if ln = "" then - printf "<a href=\"%s.html\"><h2>%s</h2></a>\n" m ms + printf "<a href=\"%s.html\"><h2>%s</h2></a>\n" m ms else - printf "<a href=\"%s.html\"><h2>%s %s</h2></a>\n" m ln ms + printf "<a href=\"%s.html\"><h2>%s %s</h2></a>\n" m ln ms | Toc_section (n, f, r) -> - item n; - printf "<a href=\"%s\">" r; f (); printf "</a>\n" + item n; + printf "<a href=\"%s\">" r; f (); printf "</a>\n" in printf "<div id=\"toc\">\n"; Queue.iter make_toc_entry toc_q; @@ -990,7 +990,7 @@ module TeXmacs = struct let start_verbatim inline = in_doc := true; printf "<\\verbatim>" let stop_verbatim inline = in_doc := false; printf "</verbatim>" - let url addr name = + let url addr name = printf "%s<\\footnote><\\url>%s</url></footnote>" addr (match name with | None -> "" @@ -1126,7 +1126,7 @@ module Raw = struct let start_verbatim inline = () let stop_verbatim inline = () - let url addr name = + let url addr name = match name with | Some n -> printf "%s (%s)" n addr | None -> printf "%s" addr @@ -1285,7 +1285,7 @@ let verbatim_char inline = select (if inline then Latex.char else output_char) Html.char TeXmacs.char Raw.char let hard_verbatim_char = output_char -let url = +let url = select Latex.url Html.url TeXmacs.url Raw.url let start_quote = @@ -1293,15 +1293,15 @@ let start_quote = let stop_quote = select Latex.stop_quote Html.stop_quote TeXmacs.stop_quote Raw.stop_quote -let inf_rule_dumb assumptions (midsp,midln,midnm) conclusions = +let inf_rule_dumb assumptions (midsp,midln,midnm) conclusions = start_verbatim false; - let dumb_line = + let dumb_line = function (sp,ln) -> (String.iter char ((String.make sp ' ') ^ ln); char '\n') - in + in (List.iter dumb_line assumptions; - dumb_line (midsp, midln ^ (match midnm with - | Some s -> " " ^ s + dumb_line (midsp, midln ^ (match midnm with + | Some s -> " " ^ s | None -> "")); List.iter dumb_line conclusions); stop_verbatim false diff --git a/tools/coqdoc/output.mli b/tools/coqdoc/output.mli index ceed67fff2..62da608348 100644 --- a/tools/coqdoc/output.mli +++ b/tools/coqdoc/output.mli @@ -98,7 +98,7 @@ val url : string -> string option -> unit something smart we can just format the rule verbatim like the user did *) val inf_rule : (int * string) list - -> (int * string * (string option)) + -> (int * string * (string option)) -> (int * string) list -> unit diff --git a/tools/coqdoc/tokens.ml b/tools/coqdoc/tokens.ml index 5adc18e1a0..0e7071425f 100644 --- a/tools/coqdoc/tokens.ml +++ b/tools/coqdoc/tokens.ml @@ -104,45 +104,45 @@ let buffer_char is_symbolchar ctag c = restart_buffering () | Buffering (was_symbolchar,tag,translated,tt) -> if tag <> ctag then - (* A strong tag comes from Coq; if different Coq tags *) - (* hence, we don't try to see the chars as part of a single token *) - let translated = - match tt.node with - | Some tok -> Buffer.clear buff; tok - | None -> translated in - flush_buffer was_symbolchar tag translated; - restart_buffering () + (* A strong tag comes from Coq; if different Coq tags *) + (* hence, we don't try to see the chars as part of a single token *) + let translated = + match tt.node with + | Some tok -> Buffer.clear buff; tok + | None -> translated in + flush_buffer was_symbolchar tag translated; + restart_buffering () else - begin - (* If we change the category of characters (symbol vs ident) *) - (* we accept this as a possible token cut point and remember the *) - (* translated token up to that point *) - let translated = - if is_symbolchar <> was_symbolchar then - match tt.node with - | Some tok -> Buffer.clear buff; tok - | None -> translated - else translated in - (* We try to make a significant token from the current *) - (* buffer and the new character *) - try - let tt = ttree_descend tt c in - Buffer.add_char buff c; - Buffering (is_symbolchar,ctag,translated,tt) - with Not_found -> - (* No existing translation for the given set of chars *) - if is_symbolchar <> was_symbolchar then - (* If we changed the category of character read, we accept it *) - (* as a possible cut point and restart looking for a translation *) - (flush_buffer was_symbolchar tag translated; - restart_buffering ()) - else - (* If we did not change the category of character read, we do *) - (* not want to cut arbitrarily in the middle of the sequence of *) - (* symbol characters or identifier characters *) - (Buffer.add_char buff c; - Buffering (is_symbolchar,tag,translated,empty_ttree)) - end + begin + (* If we change the category of characters (symbol vs ident) *) + (* we accept this as a possible token cut point and remember the *) + (* translated token up to that point *) + let translated = + if is_symbolchar <> was_symbolchar then + match tt.node with + | Some tok -> Buffer.clear buff; tok + | None -> translated + else translated in + (* We try to make a significant token from the current *) + (* buffer and the new character *) + try + let tt = ttree_descend tt c in + Buffer.add_char buff c; + Buffering (is_symbolchar,ctag,translated,tt) + with Not_found -> + (* No existing translation for the given set of chars *) + if is_symbolchar <> was_symbolchar then + (* If we changed the category of character read, we accept it *) + (* as a possible cut point and restart looking for a translation *) + (flush_buffer was_symbolchar tag translated; + restart_buffering ()) + else + (* If we did not change the category of character read, we do *) + (* not want to cut arbitrarily in the middle of the sequence of *) + (* symbol characters or identifier characters *) + (Buffer.add_char buff c; + Buffering (is_symbolchar,tag,translated,empty_ttree)) + end and restart_buffering () = let tt = try ttree_descend !(!token_tree) c with Not_found -> empty_ttree in @@ -163,9 +163,9 @@ let flush_sublexer () = | Neutral -> () | Buffering (was_symbolchar,tag,translated,tt) -> let translated = - match tt.node with - | Some tok -> Buffer.clear buff; tok - | None -> translated in + match tt.node with + | Some tok -> Buffer.clear buff; tok + | None -> translated in flush_buffer was_symbolchar tag translated; translation_state := Neutral diff --git a/tools/coqworkmgr.ml b/tools/coqworkmgr.ml index 9f9c6dd5d0..343a61f44d 100644 --- a/tools/coqworkmgr.ml +++ b/tools/coqworkmgr.ml @@ -58,7 +58,7 @@ let read_fd fd s ~off ~len = let rec loop () = try Unix.read fd s off len with Unix.Unix_error(Unix.EAGAIN,_,_) -> loop () - in + in loop () let really_read_fd fd s off len = @@ -129,10 +129,10 @@ let chat s = try match parse_request (raw_input_line party.sock) with | Get n -> - if !cur_tokens < !max_tokens then allocate n party + if !cur_tokens < !max_tokens then allocate n party else Queue.push (n,party) queue | TryGet n -> - if !cur_tokens < !max_tokens then allocate n party + if !cur_tokens < !max_tokens then allocate n party else answer party Noluck | GiveBack n -> de_allocate n party | Ping -> @@ -192,7 +192,7 @@ let main () = let pid = Unix.fork () in if pid <> 0 then begin Printf.printf "COQWORKMGR_SOCK=%s\n%!" str; - exit 0 + exit 0 end else begin ignore(Unix.setsid ()); Unix.close Unix.stdin; diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml index 6ffb2ae815..ae37e40101 100644 --- a/toplevel/coqinit.ml +++ b/toplevel/coqinit.ml @@ -31,21 +31,21 @@ let load_rcfile ~rcfile ~state = Vernac.load_vernac ~echo:false ~interactive:false ~check:true ~state rcfile else raise (Sys_error ("Cannot read rcfile: "^ rcfile)) | None -> - try - let warn x = Feedback.msg_warning (str x) in - let inferedrc = List.find CUnix.file_readable_p [ - Envars.xdg_config_home warn / rcdefaultname^"."^Coq_config.version; - Envars.xdg_config_home warn / rcdefaultname; - Envars.home ~warn / "."^rcdefaultname^"."^Coq_config.version; - Envars.home ~warn / "."^rcdefaultname - ] in + try + let warn x = Feedback.msg_warning (str x) in + let inferedrc = List.find CUnix.file_readable_p [ + Envars.xdg_config_home warn / rcdefaultname^"."^Coq_config.version; + Envars.xdg_config_home warn / rcdefaultname; + Envars.home ~warn / "."^rcdefaultname^"."^Coq_config.version; + Envars.home ~warn / "."^rcdefaultname + ] in Vernac.load_vernac ~echo:false ~interactive:false ~check:true ~state inferedrc with Not_found -> state - (* - Flags.if_verbose - mSGNL (str ("No coqrc or coqrc."^Coq_config.version^ - " found. Skipping rcfile loading.")) - *) + (* + Flags.if_verbose + mSGNL (str ("No coqrc or coqrc."^Coq_config.version^ + " found. Skipping rcfile loading.")) + *) with reraise -> let reraise = CErrors.push reraise in let () = Feedback.msg_info (str"Load of rcfile failed.") in diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index 97f0e57d2e..e1748d5c1c 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -130,9 +130,9 @@ let print_highlight_location ib loc = let highlight_lines = match get_bols_of_loc ib (bp,ep) with | ([],(bl,el)) -> - let shift = blanch_utf8_string ib.str bl bp in - let span = String.length (blanch_utf8_string ib.str bp ep) in - (str"> " ++ str(Bytes.sub_string ib.str bl (el-bl-1)) ++ fnl () ++ + let shift = blanch_utf8_string ib.str bl bp in + let span = String.length (blanch_utf8_string ib.str bp ep) in + (str"> " ++ str(Bytes.sub_string ib.str bl (el-bl-1)) ++ fnl () ++ str"> " ++ str(shift) ++ str(String.make span '^')) | ((b1,e1)::ml,(bn,en)) -> let (d1,s1) = dotted_location (b1,bp) in @@ -144,7 +144,7 @@ let print_highlight_location ib loc = (str"> " ++ str(Bytes.sub_string ib.str bi (ei-bi)))) ml in let ln = (str"> " ++ str(Bytes.sub_string ib.str bn (ep-bn)) ++ str sn ++ str dn) in - (l1 ++ li ++ ln) + (l1 ++ li ++ ln) in highlight_lines diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index 5822a1a586..310ea62a1d 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -205,7 +205,7 @@ let build_beq_scheme mode kn = mkVar eid, Evd.empty_side_effects | Cast (x,_,_) -> aux (Term.applist (x,a)) | App _ -> assert false - | Ind ((kn',i as ind'),u) (*FIXME: universes *) -> + | Ind ((kn',i as ind'),u) (*FIXME: universes *) -> if MutInd.equal kn kn' then mkRel(eqA-nlist-i+nb_ind-1), Evd.empty_side_effects else begin try @@ -271,13 +271,13 @@ let build_beq_scheme mode kn = let n = Array.length constrsi in let ar = Array.make n (ff ()) in let eff = ref Evd.empty_side_effects in - for i=0 to n-1 do - let nb_cstr_args = List.length constrsi.(i).cs_args in + for i=0 to n-1 do + let nb_cstr_args = List.length constrsi.(i).cs_args in let ar2 = Array.make n (ff ()) in let constrsj = constrs (3+nparrec+nb_cstr_args) in - for j=0 to n-1 do - if Int.equal i j then - ar2.(j) <- let cc = (match nb_cstr_args with + for j=0 to n-1 do + if Int.equal i j then + ar2.(j) <- let cc = (match nb_cstr_args with | 0 -> tt () | _ -> let eqs = Array.make nb_cstr_args (tt ()) in for ndx = 0 to nb_cstr_args-1 do @@ -299,22 +299,22 @@ let build_beq_scheme mode kn = (eqs.(0)) (Array.sub eqs 1 (nb_cstr_args - 1)) ) - in + in (List.fold_left (fun a decl -> mkLambda (RelDecl.get_annot decl, RelDecl.get_type decl, a)) cc (constrsj.(j).cs_args) - ) - else ar2.(j) <- (List.fold_left (fun a decl -> + ) + else ar2.(j) <- (List.fold_left (fun a decl -> mkLambda (RelDecl.get_annot decl, RelDecl.get_type decl, a)) (ff ()) (constrsj.(j).cs_args) ) done; ar.(i) <- (List.fold_left (fun a decl -> mkLambda (RelDecl.get_annot decl, RelDecl.get_type decl, a)) - (mkCase (ci,do_predicate rel_list nb_cstr_args, - mkVar (Id.of_string "Y") ,ar2)) - (constrsi.(i).cs_args)) + (mkCase (ci,do_predicate rel_list nb_cstr_args, + mkVar (Id.of_string "Y") ,ar2)) + (constrsi.(i).cs_args)) done; mkNamedLambda (make_annot (Id.of_string "X") Sorts.Relevant) (mkFullInd ind (nb_ind-1+1)) ( mkNamedLambda (make_annot (Id.of_string "Y") Sorts.Relevant) (mkFullInd ind (nb_ind-1+2)) ( - mkCase (ci, do_predicate rel_list 0,mkVar (Id.of_string "X"),ar))), + mkCase (ci, do_predicate rel_list 0,mkVar (Id.of_string "X"),ar))), !eff in (* build_beq_scheme *) let names = Array.make nb_ind (make_annot Anonymous Sorts.Relevant) and @@ -333,10 +333,10 @@ let build_beq_scheme mode kn = (Array.init nb_ind (fun i -> let kelim = Inductive.elim_sort (mib,mib.mind_packets.(i)) in if not (Sorts.family_leq InSet kelim) then - raise (NonSingletonProp (kn,i)); + raise (NonSingletonProp (kn,i)); let fix = match mib.mind_finite with | CoFinite -> - raise NoDecidabilityCoInductive; + raise NoDecidabilityCoInductive; | Finite -> mkFix (((Array.make nb_ind 0),i),(names,types,cores)) | BiFinite -> @@ -405,13 +405,13 @@ let do_replace_lb mode lb_scheme_key aavoid narg p q = Proofview.tclUNIT (mkConst c, eff) with Not_found -> (* spiwack: the format of this error message should probably - be improved. *) + be improved. *) let err_msg = - (str "Leibniz->boolean:" ++ + (str "Leibniz->boolean:" ++ str "You have to declare the" ++ - str "decidability over " ++ + str "decidability over " ++ Printer.pr_econstr_env env sigma type_of_pq ++ - str " first.") + str " first.") in Tacticals.New.tclZEROMSG err_msg in @@ -470,20 +470,20 @@ let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt = then Tacticals.New.tclTHENLIST [Equality.replace t1 t2; Auto.default_auto ; aux q1 q2 ] else ( let bl_t1, eff = - try + try let c, eff = find_scheme bl_scheme_key (fst u) (*FIXME*) in mkConst c, eff with Not_found -> - (* spiwack: the format of this error message should probably - be improved. *) - let err_msg = - (str "boolean->Leibniz:" ++ + (* spiwack: the format of this error message should probably + be improved. *) + let err_msg = + (str "boolean->Leibniz:" ++ str "You have to declare the" ++ - str "decidability over " ++ + str "decidability over " ++ Printer.pr_econstr_env env sigma tt1 ++ - str " first.") - in - user_err err_msg + str " first.") + in + user_err err_msg in let bl_args = Array.append (Array.append v @@ -547,8 +547,8 @@ let eqI ind l = let list_id = list_id l in let eA = Array.of_list((List.map (fun (s,_,_,_) -> mkVar s) list_id)@ (List.map (fun (_,seq,_,_)-> mkVar seq) list_id )) - and e, eff = - try let c, eff = find_scheme beq_scheme_kind ind in mkConst c, eff + and e, eff = + try let c, eff = find_scheme beq_scheme_kind ind in mkConst c, eff with Not_found -> user_err ~hdr:"AutoIndDecl.eqI" (str "The boolean equality on " ++ Printer.pr_inductive (Global.env ()) ind ++ str " is needed."); in (if Array.equal Constr.equal eA [||] then e else mkApp(e,eA)), eff @@ -659,7 +659,7 @@ repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]). then Tacticals.New.tclTHEN (do_replace_bl mode bl_scheme_key ind - (!avoid) + (!avoid) nparrec (ca.(2)) (ca.(1))) Auto.default_auto @@ -683,7 +683,7 @@ let side_effect_of_mode = function let make_bl_scheme mode mind = let mib = Global.lookup_mind mind in if not (Int.equal (Array.length mib.mind_packets) 1) then - user_err + user_err (str "Automatic building of boolean->Leibniz lemmas not supported"); let ind = (mind,0) in let nparams = mib.mind_nparams in @@ -781,7 +781,7 @@ let compute_lb_tact mode lb_scheme_key ind lnamesparrec nparrec = Tacticals.New.tclORELSE reflexivity my_discr_tac ); my_inj_tac freshz; - intros; simpl_in_concl; + intros; simpl_in_concl; Auto.default_auto; Tacticals.New.tclREPEAT ( Tacticals.New.tclTHENLIST [apply (EConstr.of_constr (andb_true_intro())); @@ -796,7 +796,7 @@ let compute_lb_tact mode lb_scheme_key ind lnamesparrec nparrec = | App(c',ca') -> let n = Array.length ca' in do_replace_lb mode lb_scheme_key - (!avoid) + (!avoid) nparrec ca'.(n-2) ca'.(n-1) | _ -> @@ -813,7 +813,7 @@ let lb_scheme_kind_aux = ref (fun () -> failwith "Undefined") let make_lb_scheme mode mind = let mib = Global.lookup_mind mind in if not (Int.equal (Array.length mib.mind_packets) 1) then - user_err + user_err (str "Automatic building of Leibniz->boolean lemmas not supported"); let ind = (mind,0) in let nparams = mib.mind_nparams in @@ -943,48 +943,48 @@ let compute_dec_tact ind lnamesparrec nparrec = Proofview.tclEFFECTS eff; intros_using fresh_first_intros; intros_using [freshn;freshm]; - (*we do this so we don't have to prove the same goal twice *) + (*we do this so we don't have to prove the same goal twice *) assert_by (Name freshH) (EConstr.of_constr ( mkApp(sumbool(),[|eqtrue eqbnm; eqfalse eqbnm|]) - )) - (Tacticals.New.tclTHEN (destruct_on (EConstr.of_constr eqbnm)) Auto.default_auto); + )) + (Tacticals.New.tclTHEN (destruct_on (EConstr.of_constr eqbnm)) Auto.default_auto); Proofview.Goal.enter begin fun gl -> let freshH2 = fresh_id (Id.of_string "H") gl in - Tacticals.New.tclTHENS (destruct_on_using (EConstr.mkVar freshH) freshH2) [ - (* left *) - Tacticals.New.tclTHENLIST [ - simplest_left; + Tacticals.New.tclTHENS (destruct_on_using (EConstr.mkVar freshH) freshH2) [ + (* left *) + Tacticals.New.tclTHENLIST [ + simplest_left; apply (EConstr.of_constr (mkApp(blI,Array.map mkVar xargs))); Auto.default_auto ] ; - (*right *) + (*right *) Proofview.Goal.enter begin fun gl -> let freshH3 = fresh_id (Id.of_string "H") gl in Tacticals.New.tclTHENLIST [ - simplest_right ; + simplest_right ; unfold_constr (Coqlib.lib_ref "core.not.type"); intro; Equality.subst_all (); assert_by (Name freshH3) - (EConstr.of_constr (mkApp(eq,[|bb;mkApp(eqI,[|mkVar freshm;mkVar freshm|]);tt|]))) - (Tacticals.New.tclTHENLIST [ + (EConstr.of_constr (mkApp(eq,[|bb;mkApp(eqI,[|mkVar freshm;mkVar freshm|]);tt|]))) + (Tacticals.New.tclTHENLIST [ apply (EConstr.of_constr (mkApp(lbI,Array.map mkVar xargs))); Auto.default_auto - ]); - Equality.general_rewrite_bindings_in true - Locus.AllOccurrences true false + ]); + Equality.general_rewrite_bindings_in true + Locus.AllOccurrences true false (List.hd !avoid) ((EConstr.mkVar (List.hd (List.tl !avoid))), NoBindings ) true; my_discr_tac - ] + ] end - ] + ] end ] end diff --git a/vernac/class.ml b/vernac/class.ml index 766625a21a..3c43b125d1 100644 --- a/vernac/class.ml +++ b/vernac/class.ml @@ -96,8 +96,8 @@ let class_of_global = function | GlobRef.VarRef id -> CL_SECVAR id | GlobRef.ConstructRef _ as c -> user_err ~hdr:"class_of_global" - (str "Constructors, such as " ++ Printer.pr_global c ++ - str ", cannot be used as a class.") + (str "Constructors, such as " ++ Printer.pr_global c ++ + str ", cannot be used as a class.") (* lp est la liste (inverse'e) des arguments de la coercion @@ -144,7 +144,7 @@ let get_target t ind = | CL_CONST p when Recordops.is_primitive_projection p -> CL_PROJ (Option.get @@ Recordops.find_primitive_projection p) | x -> x - + let strength_of_cl = function | CL_CONST kn -> `GLOBAL | CL_SECVAR id -> `LOCAL @@ -188,8 +188,8 @@ let build_id_coercion idf_opt source poly = let val_f = it_mkLambda_or_LetIn (mkLambda (make_annot (Name Namegen.default_dependent_ident) Sorts.Relevant, - applistc vs (Context.Rel.to_extended_list mkRel 0 lams), - mkRel 1)) + applistc vs (Context.Rel.to_extended_list mkRel 0 lams), + mkRel 1)) lams in let typ_f = @@ -201,24 +201,24 @@ let build_id_coercion idf_opt source poly = let _ = if not (Reductionops.is_conv_leq env sigma - (Typing.unsafe_type_of env sigma (EConstr.of_constr val_f)) (EConstr.of_constr typ_f)) + (Typing.unsafe_type_of env sigma (EConstr.of_constr val_f)) (EConstr.of_constr typ_f)) then user_err (strbrk - "Cannot be defined as coercion (maybe a bad number of arguments).") + "Cannot be defined as coercion (maybe a bad number of arguments).") in let name = match idf_opt with | Some idf -> idf | None -> - let cl,u,_ = find_class_type sigma (EConstr.of_constr t) in - Id.of_string ("Id_"^(ident_key_of_class source)^"_"^ + let cl,u,_ = find_class_type sigma (EConstr.of_constr t) in + Id.of_string ("Id_"^(ident_key_of_class source)^"_"^ (ident_key_of_class cl)) in let univs = Evd.univ_entry ~poly sigma in let constr_entry = (* Cast is necessary to express [val_f] is identity *) DefinitionEntry (definition_entry ~types:typ_f ~univs - ~inline:true (mkCast (val_f, DEFAULTcast, typ_f))) + ~inline:true (mkCast (val_f, DEFAULTcast, typ_f))) in let kind = Decls.(IsDefinition IdentityCoercion) in let kn = declare_constant ~name ~kind constr_entry in diff --git a/vernac/egramcoq.ml b/vernac/egramcoq.ml index c9d9b65e04..e02f94629c 100644 --- a/vernac/egramcoq.ml +++ b/vernac/egramcoq.ml @@ -84,7 +84,7 @@ let error_level_assoc p current expected = | Gramlib.Gramext.LeftA -> str "left" | Gramlib.Gramext.RightA -> str "right" | Gramlib.Gramext.NonA -> str "non" in - user_err + user_err (str "Level " ++ int p ++ str " is already declared " ++ pr_assoc current ++ str " associative while it is now expected to be " ++ pr_assoc expected ++ str " associative.") @@ -104,29 +104,29 @@ let find_position_gen current ensure assoc lev = | (p,_,_ as pa)::l when p > n -> pa :: add_level (Some p) l | (p,a,reinit)::l when Int.equal p n -> if reinit then - let a' = create_assoc assoc in + let a' = create_assoc assoc in (init := Some (a',create_pos q); (p,a',false)::l) - else if admissible_assoc (a,assoc) then - raise Exit + else if admissible_assoc (a,assoc) then + raise Exit else - error_level_assoc p a (Option.get assoc) - | l -> after := q; (n,create_assoc assoc,ensure)::l + error_level_assoc p a (Option.get assoc) + | l -> after := q; (n,create_assoc assoc,ensure)::l in try - let updated = add_level None current in - let assoc = create_assoc assoc in + let updated = add_level None current in + let assoc = create_assoc assoc in begin match !init with | None -> - (* Create the entry *) - updated, (Some (create_pos !after), Some assoc, Some (constr_level n), None) + (* Create the entry *) + updated, (Some (create_pos !after), Some assoc, Some (constr_level n), None) | _ -> - (* The reinit flag has been updated *) + (* The reinit flag has been updated *) updated, (Some (Gramlib.Gramext.Level (constr_level n)), None, None, !init) end with - (* Nothing has changed *) + (* Nothing has changed *) Exit -> - (* Just inherit the existing associativity and name (None) *) + (* Just inherit the existing associativity and name (None) *) current, (Some (Gramlib.Gramext.Level (constr_level n)), None, None, None) let rec list_mem_assoc_triple x = function @@ -450,7 +450,7 @@ let rec ty_eval : type s a. (s, a, Loc.t -> s) ty_rule -> s gen_eval -> s env -> let constrlist, tail = List.chop (n - p) heads in constrlist :: env.constrlists, tail @ constrs in - ty_eval rem f { env with constrs; constrlists; } + ty_eval rem f { env with constrs; constrlists; } type ('s, 'a, 'r) mayrec_rule = | MayRecRNo : ('s, Extend.norec, 'a, 'r) Extend.rule -> ('s, 'a, 'r) mayrec_rule diff --git a/vernac/g_proofs.mlg b/vernac/g_proofs.mlg index 5cffa18511..03dfc576a1 100644 --- a/vernac/g_proofs.mlg +++ b/vernac/g_proofs.mlg @@ -63,14 +63,14 @@ GRAMMAR EXTEND Gram | IDENT "Abort"; IDENT "All" -> { VernacAbortAll } | IDENT "Abort"; id = identref -> { VernacAbort (Some id) } | IDENT "Existential"; n = natural; c = constr_body -> - { VernacSolveExistential (n,c) } + { VernacSolveExistential (n,c) } | IDENT "Admitted" -> { VernacEndProof Admitted } | IDENT "Qed" -> { VernacEndProof (Proved (Opaque,None)) } | IDENT "Save"; id = identref -> - { VernacEndProof (Proved (Opaque, Some id)) } + { VernacEndProof (Proved (Opaque, Some id)) } | IDENT "Defined" -> { VernacEndProof (Proved (Transparent,None)) } | IDENT "Defined"; id=identref -> - { VernacEndProof (Proved (Transparent,Some id)) } + { VernacEndProof (Proved (Transparent,Some id)) } | IDENT "Restart" -> { VernacRestart } | IDENT "Undo" -> { VernacUndo 1 } | IDENT "Undo"; n = natural -> { VernacUndo n } @@ -98,10 +98,10 @@ GRAMMAR EXTEND Gram | IDENT "Guarded" -> { VernacCheckGuard } (* Hints for Auto and EAuto *) | IDENT "Create"; IDENT "HintDb" ; - id = IDENT ; b = [ "discriminated" -> { true } | -> { false } ] -> - { VernacCreateHintDb (id, b) } + id = IDENT ; b = [ "discriminated" -> { true } | -> { false } ] -> + { VernacCreateHintDb (id, b) } | IDENT "Remove"; IDENT "Hints"; ids = LIST1 global; dbnames = opt_hintbases -> - { VernacRemoveHints (dbnames, ids) } + { VernacRemoveHints (dbnames, ids) } | IDENT "Hint"; h = hint; dbnames = opt_hintbases -> { VernacHints (dbnames, h) } ] ]; diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index 61de1bfd26..0515e88a15 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -200,9 +200,9 @@ GRAMMAR EXTEND Gram { (id,(bl,c)) } ] -> { VernacStartTheoremProof (thm, (id,(bl,c))::l) } | stre = assumption_token; nl = inline; bl = assum_list -> - { VernacAssumption (stre, nl, bl) } + { VernacAssumption (stre, nl, bl) } | tk = assumptions_token; nl = inline; bl = assum_list -> - { let (kwd,stre) = tk in + { let (kwd,stre) = tk in test_plural_form loc kwd bl; VernacAssumption (stre, nl, bl) } | d = def_token; id = ident_decl; b = def_body -> @@ -212,7 +212,7 @@ GRAMMAR EXTEND Gram (* Gallina inductive declarations *) | cum = OPT cumulativity_token; priv = private_token; f = finite_token; indl = LIST1 inductive_definition SEP "with" -> - { let (k,f) = f in + { let (k,f) = f in let indl=List.map (fun ((a,b,c,d),e) -> ((a,b,c,k,d),e)) indl in VernacInductive (cum, priv,f,indl) } | "Fixpoint"; recs = LIST1 rec_definition SEP "with" -> @@ -225,7 +225,7 @@ GRAMMAR EXTEND Gram { VernacCoFixpoint (DoDischarge, corecs) } | IDENT "Scheme"; l = LIST1 scheme SEP "with" -> { VernacScheme l } | IDENT "Combined"; IDENT "Scheme"; id = identref; IDENT "from"; - l = LIST1 identref SEP "," -> { VernacCombinedScheme (id, l) } + l = LIST1 identref SEP "," -> { VernacCombinedScheme (id, l) } | IDENT "Register"; g = global; "as"; quid = qualid -> { VernacRegister(g, RegisterCoqlib quid) } | IDENT "Register"; IDENT "Inline"; g = global -> @@ -370,7 +370,7 @@ GRAMMAR EXTEND Gram then (* FIXME: "red" will be applied to types in bl and Cast with remain *) let c = mkLambdaCN ~loc bl c in - DefineBody ([], red, c, None) + DefineBody ([], red, c, None) else (match c with | { CAst.v = CCast(c, CastConv t) } -> DefineBody (bl, red, c, Some t) @@ -384,7 +384,7 @@ GRAMMAR EXTEND Gram (([],mkLambdaCN ~loc bl c), None) else ((bl, c), Some t) in - DefineBody (bl, red, c, tyo) } + DefineBody (bl, red, c, tyo) } | bl = binders; ":"; t = lconstr -> { ProveBody (bl, t) } ] ] ; @@ -412,15 +412,15 @@ GRAMMAR EXTEND Gram [ [ oc = opt_coercion; id = ident_decl; indpar = binders; c = OPT [ ":"; c = lconstr -> { c } ]; lc=opt_constructors_or_fields; ntn = decl_notation -> - { (((oc,id),indpar,c,lc),ntn) } ] ] + { (((oc,id),indpar,c,lc),ntn) } ] ] ; constructor_list_or_record_decl: [ [ "|"; l = LIST1 constructor SEP "|" -> { Constructors l } | id = identref ; c = constructor_type; "|"; l = LIST0 constructor SEP "|" -> - { Constructors ((c id)::l) } + { Constructors ((c id)::l) } | id = identref ; c = constructor_type -> { Constructors [ c id ] } | cstr = identref; "{"; fs = record_fields; "}" -> - { RecordDecl (Some cstr,fs) } + { RecordDecl (Some cstr,fs) } | "{";fs = record_fields; "}" -> { RecordDecl (None,fs) } | -> { Constructors [] } ] ] ; @@ -436,7 +436,7 @@ GRAMMAR EXTEND Gram (* (co)-fixpoints *) rec_definition: [ [ id_decl = ident_decl; - bl = binders_fixannot; + bl = binders_fixannot; rtype = type_cstr; body_def = OPT [":="; def = lconstr -> { def } ]; notations = decl_notation -> { let binders, rec_order = bl in @@ -497,13 +497,13 @@ GRAMMAR EXTEND Gram t = lconstr -> { fun id -> (oc,AssumExpr (id,mkProdCN ~loc l t)) } | l = binders; oc = of_type_with_opt_coercion; t = lconstr; ":="; b = lconstr -> { fun id -> - (oc,DefExpr (id,mkLambdaCN ~loc l b,Some (mkProdCN ~loc l t))) } + (oc,DefExpr (id,mkLambdaCN ~loc l b,Some (mkProdCN ~loc l t))) } | l = binders; ":="; b = lconstr -> { fun id -> match b.CAst.v with - | CCast(b', (CastConv t|CastVM t|CastNative t)) -> - (None,DefExpr(id,mkLambdaCN ~loc l b',Some (mkProdCN ~loc l t))) + | CCast(b', (CastConv t|CastVM t|CastNative t)) -> + (None,DefExpr(id,mkLambdaCN ~loc l b',Some (mkProdCN ~loc l t))) | _ -> - (None,DefExpr(id,mkLambdaCN ~loc l b,None)) } ] ] + (None,DefExpr(id,mkLambdaCN ~loc l b,None)) } ] ] ; record_binder: [ [ id = name -> { (None,AssumExpr(id, CAst.make ~loc @@ CHole (None, IntroAnonymous, None))) } @@ -523,10 +523,10 @@ GRAMMAR EXTEND Gram constructor_type: [[ l = binders; t= [ coe = of_type_with_opt_coercion; c = lconstr -> - { fun l id -> (not (Option.is_empty coe),(id,mkProdCN ~loc l c)) } + { fun l id -> (not (Option.is_empty coe),(id,mkProdCN ~loc l c)) } | -> { fun l id -> (false,(id,mkProdCN ~loc l (CAst.make ~loc @@ CHole (None, IntroAnonymous, None)))) } ] - -> { t l } + -> { t l } ]] ; @@ -535,11 +535,11 @@ GRAMMAR EXTEND Gram ; of_type_with_opt_coercion: [ [ ":>>" -> { Some false } - | ":>"; ">" -> { Some false } - | ":>" -> { Some true } - | ":"; ">"; ">" -> { Some false } - | ":"; ">" -> { Some true } - | ":" -> { None } ] ] + | ":>"; ">" -> { Some false } + | ":>" -> { Some true } + | ":"; ">"; ">" -> { Some false } + | ":"; ">" -> { Some true } + | ":" -> { None } ] ] ; END @@ -573,16 +573,16 @@ GRAMMAR EXTEND Gram gallina_ext: [ [ (* Interactive module declaration *) IDENT "Module"; export = export_token; id = identref; - bl = LIST0 module_binder; sign = of_module_type; - body = is_module_expr -> - { VernacDefineModule (export, id, bl, sign, body) } + bl = LIST0 module_binder; sign = of_module_type; + body = is_module_expr -> + { VernacDefineModule (export, id, bl, sign, body) } | IDENT "Module"; "Type"; id = identref; - bl = LIST0 module_binder; sign = check_module_types; - body = is_module_type -> - { VernacDeclareModuleType (id, bl, sign, body) } + bl = LIST0 module_binder; sign = check_module_types; + body = is_module_type -> + { VernacDeclareModuleType (id, bl, sign, body) } | IDENT "Declare"; IDENT "Module"; export = export_token; id = identref; - bl = LIST0 module_binder; ":"; mty = module_type_inl -> - { VernacDeclareModule (export, id, bl, mty) } + bl = LIST0 module_binder; ":"; mty = module_type_inl -> + { VernacDeclareModule (export, id, bl, mty) } (* Section beginning *) | IDENT "Section"; id = identref -> { VernacBeginSection id } | IDENT "Chapter"; id = identref -> { VernacBeginSection id } @@ -598,14 +598,14 @@ GRAMMAR EXTEND Gram | IDENT "Require"; export = export_token; qidl = LIST1 global -> { VernacRequire (None, export, qidl) } | IDENT "From" ; ns = global ; IDENT "Require"; export = export_token - ; qidl = LIST1 global -> - { VernacRequire (Some ns, export, qidl) } + ; qidl = LIST1 global -> + { VernacRequire (Some ns, export, qidl) } | IDENT "Import"; qidl = LIST1 global -> { VernacImport (false,qidl) } | IDENT "Export"; qidl = LIST1 global -> { VernacImport (true,qidl) } | IDENT "Include"; e = module_type_inl; l = LIST0 ext_module_expr -> - { VernacInclude(e::l) } + { VernacInclude(e::l) } | IDENT "Include"; "Type"; e = module_type_inl; l = LIST0 ext_module_type -> - { warn_deprecated_include_type ~loc (); + { warn_deprecated_include_type ~loc (); VernacInclude(e::l) } ] ] ; export_token: @@ -670,7 +670,7 @@ GRAMMAR EXTEND Gram [ [ "Definition"; fqid = fullyqualid; udecl = OPT univ_decl; ":="; c = Constr.lconstr -> { CWith_Definition (fqid,udecl,c) } | IDENT "Module"; fqid = fullyqualid; ":="; qid = qualid -> - { CWith_Module (fqid,qid) } + { CWith_Module (fqid,qid) } ] ] ; module_type: @@ -695,7 +695,7 @@ GRAMMAR EXTEND Gram | "Type"; "*" -> { SsFwdClose SsType } ]] ; ssexpr: - [ "35" + [ "35" [ "-"; e = ssexpr -> { SsCompl e } ] | "50" [ e1 = ssexpr; "-"; e2 = ssexpr-> { SsSubstr(e1,e2) } @@ -754,25 +754,25 @@ GRAMMAR EXTEND Gram | IDENT "Instance"; namesup = instance_name; ":"; t = operconstr LEVEL "200"; - info = hint_info ; - props = [ ":="; "{"; r = record_declaration; "}" -> { Some (true,r) } | - ":="; c = lconstr -> { Some (false,c) } | -> { None } ] -> + info = hint_info ; + props = [ ":="; "{"; r = record_declaration; "}" -> { Some (true,r) } | + ":="; c = lconstr -> { Some (false,c) } | -> { None } ] -> { VernacInstance (fst namesup,snd namesup,t,props,info) } | IDENT "Existing"; IDENT "Instance"; id = global; info = hint_info -> - { VernacExistingInstance [id, info] } + { VernacExistingInstance [id, info] } | IDENT "Existing"; IDENT "Instances"; ids = LIST1 global; pri = OPT [ "|"; i = natural -> { i } ] -> { let info = { Typeclasses.hint_priority = pri; hint_pattern = None } in let insts = List.map (fun i -> (i, info)) ids in - VernacExistingInstance insts } + VernacExistingInstance insts } | IDENT "Existing"; IDENT "Class"; is = global -> { VernacExistingClass is } (* Arguments *) - | IDENT "Arguments"; qid = smart_global; + | IDENT "Arguments"; qid = smart_global; args = LIST0 argument_spec_block; more_implicits = OPT [ ","; impl = LIST1 @@ -802,18 +802,18 @@ GRAMMAR EXTEND Gram VernacArguments (qid, args, more_implicits, !slash_position, !ampersand_position, mods) } | IDENT "Implicit"; "Type"; bl = reserv_list -> - { VernacReserve bl } + { VernacReserve bl } | IDENT "Implicit"; IDENT "Types"; bl = reserv_list -> { test_plural_form_types loc "Implicit Types" bl; VernacReserve bl } - | IDENT "Generalizable"; - gen = [IDENT "All"; IDENT "Variables" -> { Some [] } - | IDENT "No"; IDENT "Variables" -> { None } - | ["Variable" -> { () } | IDENT "Variables" -> { () } ]; - idl = LIST1 identref -> { Some idl } ] -> - { VernacGeneralizable gen } ] ] + | IDENT "Generalizable"; + gen = [IDENT "All"; IDENT "Variables" -> { Some [] } + | IDENT "No"; IDENT "Variables" -> { None } + | ["Variable" -> { () } | IDENT "Variables" -> { () } ]; + idl = LIST1 identref -> { Some idl } ] -> + { VernacGeneralizable gen } ] ] ; arguments_modifier: [ [ IDENT "simpl"; IDENT "nomatch" -> { [`ReductionDontExposeCase] } @@ -927,7 +927,7 @@ GRAMMAR EXTEND Gram (* Hack! Should be in grammar_ext, but camlp5 factorizes badly *) | IDENT "Declare"; IDENT "Instance"; id = ident_decl; bl = binders; ":"; t = operconstr LEVEL "200"; - info = hint_info -> + info = hint_info -> { VernacDeclareInstance (id, bl, t, info) } (* Should be in syntax, but camlp5 would not factorize *) @@ -940,28 +940,28 @@ GRAMMAR EXTEND Gram | IDENT "Cd"; dir = ne_string -> { VernacChdir (Some dir) } | IDENT "Load"; verbosely = [ IDENT "Verbose" -> { true } | -> { false } ]; - s = [ s = ne_string -> { s } | s = IDENT -> { s } ] -> - { VernacLoad (verbosely, s) } + s = [ s = ne_string -> { s } | s = IDENT -> { s } ] -> + { VernacLoad (verbosely, s) } | IDENT "Declare"; IDENT "ML"; IDENT "Module"; l = LIST1 ne_string -> - { VernacDeclareMLModule l } + { VernacDeclareMLModule l } | IDENT "Locate"; l = locatable -> { VernacLocate l } (* Managing load paths *) | IDENT "Add"; IDENT "LoadPath"; dir = ne_string; alias = as_dirpath -> - { VernacAddLoadPath (false, dir, alias) } + { VernacAddLoadPath (false, dir, alias) } | IDENT "Add"; IDENT "Rec"; IDENT "LoadPath"; dir = ne_string; - alias = as_dirpath -> { VernacAddLoadPath (true, dir, alias) } + alias = as_dirpath -> { VernacAddLoadPath (true, dir, alias) } | IDENT "Remove"; IDENT "LoadPath"; dir = ne_string -> - { VernacRemoveLoadPath dir } + { VernacRemoveLoadPath dir } (* For compatibility *) | IDENT "AddPath"; dir = ne_string; "as"; alias = as_dirpath -> - { VernacAddLoadPath (false, dir, alias) } + { VernacAddLoadPath (false, dir, alias) } | IDENT "AddRecPath"; dir = ne_string; "as"; alias = as_dirpath -> - { VernacAddLoadPath (true, dir, alias) } + { VernacAddLoadPath (true, dir, alias) } | IDENT "DelPath"; dir = ne_string -> - { VernacRemoveLoadPath dir } + { VernacRemoveLoadPath dir } (* Type-Checking (pas dans le refman) *) | "Type"; c = lconstr -> { VernacGlobalCheck c } @@ -970,17 +970,17 @@ GRAMMAR EXTEND Gram | IDENT "Print"; p = printable -> { VernacPrint p } | IDENT "Print"; qid = smart_global; l = OPT univ_name_list -> { VernacPrint (PrintName (qid,l)) } | IDENT "Print"; IDENT "Module"; "Type"; qid = global -> - { VernacPrint (PrintModuleType qid) } + { VernacPrint (PrintModuleType qid) } | IDENT "Print"; IDENT "Module"; qid = global -> - { VernacPrint (PrintModule qid) } + { VernacPrint (PrintModule qid) } | IDENT "Print"; IDENT "Namespace" ; ns = dirpath -> { VernacPrint (PrintNamespace ns) } | IDENT "Inspect"; n = natural -> { VernacPrint (PrintInspect n) } | IDENT "Add"; IDENT "ML"; IDENT "Path"; dir = ne_string -> - { VernacAddMLPath (false, dir) } - | IDENT "Add"; IDENT "Rec"; IDENT "ML"; IDENT "Path"; dir = ne_string -> - { VernacAddMLPath (true, dir) } + { VernacAddMLPath (false, dir) } + | IDENT "Add"; IDENT "Rec"; IDENT "ML"; IDENT "Path"; dir = ne_string -> + { VernacAddMLPath (true, dir) } (* For acting on parameter tables *) | "Set"; table = option_table; v = option_setting -> @@ -989,7 +989,7 @@ GRAMMAR EXTEND Gram { VernacSetOption (false, table, OptionUnset) } | IDENT "Print"; IDENT "Table"; table = option_table -> - { VernacPrintOption table } + { VernacPrintOption table } | IDENT "Add"; table = IDENT; field = IDENT; v = LIST1 option_ref_value -> { VernacAddOption ([table;field], v) } @@ -1008,32 +1008,32 @@ GRAMMAR EXTEND Gram | IDENT "Remove"; table = IDENT; field = IDENT; v= LIST1 option_ref_value -> { VernacRemoveOption ([table;field], v) } | IDENT "Remove"; table = IDENT; v = LIST1 option_ref_value -> - { VernacRemoveOption ([table], v) } ]] + { VernacRemoveOption ([table], v) } ]] ; query_command: (* TODO: rapprocher Eval et Check *) [ [ IDENT "Eval"; r = red_expr; "in"; c = lconstr; "." -> { fun g -> VernacCheckMayEval (Some r, g, c) } | IDENT "Compute"; c = lconstr; "." -> - { fun g -> VernacCheckMayEval (Some (Genredexpr.CbvVm None), g, c) } + { fun g -> VernacCheckMayEval (Some (Genredexpr.CbvVm None), g, c) } | IDENT "Check"; c = lconstr; "." -> - { fun g -> VernacCheckMayEval (None, g, c) } + { fun g -> VernacCheckMayEval (None, g, c) } (* Searching the environment *) | IDENT "About"; qid = smart_global; l = OPT univ_name_list; "." -> { fun g -> VernacPrint (PrintAbout (qid,l,g)) } | IDENT "SearchHead"; c = constr_pattern; l = in_or_out_modules; "." -> - { fun g -> VernacSearch (SearchHead c,g, l) } + { fun g -> VernacSearch (SearchHead c,g, l) } | IDENT "SearchPattern"; c = constr_pattern; l = in_or_out_modules; "." -> - { fun g -> VernacSearch (SearchPattern c,g, l) } + { fun g -> VernacSearch (SearchPattern c,g, l) } | IDENT "SearchRewrite"; c = constr_pattern; l = in_or_out_modules; "." -> - { fun g -> VernacSearch (SearchRewrite c,g, l) } + { fun g -> VernacSearch (SearchRewrite c,g, l) } | IDENT "Search"; s = searchabout_query; l = searchabout_queries; "." -> - { let (sl,m) = l in fun g -> VernacSearch (SearchAbout (s::sl),g, m) } + { let (sl,m) = l in fun g -> VernacSearch (SearchAbout (s::sl),g, m) } (* compatibility: SearchAbout *) | IDENT "SearchAbout"; s = searchabout_query; l = searchabout_queries; "." -> - { fun g -> let (sl,m) = l in VernacSearch (SearchAbout (s::sl),g, m) } + { fun g -> let (sl,m) = l in VernacSearch (SearchAbout (s::sl),g, m) } (* compatibility: SearchAbout with "[ ... ]" *) | IDENT "SearchAbout"; "["; sl = LIST1 searchabout_query; "]"; - l = in_or_out_modules; "." -> + l = in_or_out_modules; "." -> { fun g -> VernacSearch (SearchAbout sl,g, l) } ] ] ; @@ -1043,7 +1043,7 @@ GRAMMAR EXTEND Gram | IDENT "Section"; s = global -> { PrintSectionContext s } | IDENT "Grammar"; ent = IDENT -> (* This should be in "syntax" section but is here for factorization*) - { PrintGrammar ent } + { PrintGrammar ent } | IDENT "Custom"; IDENT "Grammar"; ent = IDENT -> (* Should also be in "syntax" section *) { PrintCustomGrammar ent } @@ -1179,7 +1179,7 @@ GRAMMAR EXTEND Gram | IDENT "Declare"; IDENT "Reduction"; s = IDENT; ":="; r = red_expr -> - { VernacDeclareReduction (s,r) } + { VernacDeclareReduction (s,r) } (* factorized here, though relevant for syntax extensions *) @@ -1202,37 +1202,37 @@ GRAMMAR EXTEND Gram { VernacOpenCloseScope (false,sc) } | IDENT "Delimit"; IDENT "Scope"; sc = IDENT; "with"; key = IDENT -> - { VernacDelimiters (sc, Some key) } + { VernacDelimiters (sc, Some key) } | IDENT "Undelimit"; IDENT "Scope"; sc = IDENT -> - { VernacDelimiters (sc, None) } + { VernacDelimiters (sc, None) } | IDENT "Bind"; IDENT "Scope"; sc = IDENT; "with"; refl = LIST1 class_rawexpr -> { VernacBindScope (sc,refl) } | IDENT "Infix"; op = ne_lstring; ":="; p = constr; modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> { l } | -> { [] } ]; - sc = OPT [ ":"; sc = IDENT -> { sc } ] -> + sc = OPT [ ":"; sc = IDENT -> { sc } ] -> { VernacInfix ((op,modl),p,sc) } | IDENT "Notation"; id = identref; - idl = LIST0 ident; ":="; c = constr; b = only_parsing -> + idl = LIST0 ident; ":="; c = constr; b = only_parsing -> { VernacSyntacticDefinition (id,(idl,c),b) } | IDENT "Notation"; s = lstring; ":="; - c = constr; + c = constr; modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> { l } | -> { [] } ]; - sc = OPT [ ":"; sc = IDENT -> { sc } ] -> + sc = OPT [ ":"; sc = IDENT -> { sc } ] -> { VernacNotation (c,(s,modl),sc) } | IDENT "Format"; IDENT "Notation"; n = STRING; s = STRING; fmt = STRING -> { VernacNotationAddFormat (n,s,fmt) } | IDENT "Reserved"; IDENT "Infix"; s = ne_lstring; - l = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> { l } | -> { [] } ] -> + l = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> { l } | -> { [] } ] -> { let s = CAst.map (fun s -> "x '"^s^"' y") s in VernacSyntaxExtension (true,(s,l)) } | IDENT "Reserved"; IDENT "Notation"; - s = ne_lstring; - l = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> { l } | -> { [] } ] + s = ne_lstring; + l = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> { l } | -> { [] } ] -> { VernacSyntaxExtension (false, (s,l)) } (* "Print" "Grammar" and "Declare" "Scope" should be here but are in "command" entry in order diff --git a/vernac/himsg.ml b/vernac/himsg.ml index c335d3ad55..2e58bf4a93 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -223,21 +223,21 @@ let explain_elim_arity env sigma ind c pj okinds = let pki = Sorts.pr_sort_family ki in let pkp = Sorts.pr_sort_family kp in let explanation = match explanation with - | NonInformativeToInformative -> + | NonInformativeToInformative -> "proofs can be eliminated only to build proofs" - | StrongEliminationOnNonSmallType -> + | StrongEliminationOnNonSmallType -> "strong elimination on non-small inductive types leads to paradoxes" - | WrongArity -> - "wrong arity" in + | WrongArity -> + "wrong arity" in let ppar = pr_disjunction (fun s -> quote (Sorts.pr_sort_family s)) sorts in let ppt = pr_leconstr_env env sigma (snd (decompose_prod_assum sigma pj.uj_type)) in hov 0 - (str "the return type has sort" ++ spc () ++ ppt ++ spc () ++ - str "while it" ++ spc () ++ str "should be " ++ ppar ++ str ".") ++ + (str "the return type has sort" ++ spc () ++ ppt ++ spc () ++ + str "while it" ++ spc () ++ str "should be " ++ ppar ++ str ".") ++ fnl () ++ hov 0 - (str "Elimination of an inductive object of sort " ++ - pki ++ brk(1,0) ++ + (str "Elimination of an inductive object of sort " ++ + pki ++ brk(1,0) ++ str "is not allowed on a predicate in sort " ++ pkp ++ fnl () ++ str "because" ++ spc () ++ str explanation ++ str ".") | None -> @@ -254,11 +254,11 @@ let explain_case_not_inductive env sigma cj = let pct = pr_leconstr_env env sigma cj.uj_type in match EConstr.kind sigma cj.uj_type with | Evar _ -> - str "Cannot infer a type for this expression." + str "Cannot infer a type for this expression." | _ -> - str "The term" ++ brk(1,1) ++ pc ++ spc () ++ - str "has type" ++ brk(1,1) ++ pct ++ spc () ++ - str "which is not a (co-)inductive type." + str "The term" ++ brk(1,1) ++ pc ++ spc () ++ + str "has type" ++ brk(1,1) ++ pct ++ spc () ++ + str "which is not a (co-)inductive type." let explain_number_branches env sigma cj expn = let env = make_all_name_different env sigma in @@ -294,12 +294,12 @@ let explain_unification_error env sigma p1 p2 = function let rec aux p1 p2 = function | OccurCheck (evk,rhs) -> [str "cannot define " ++ quote (pr_existential_key sigma evk) ++ - strbrk " with term " ++ pr_leconstr_env env sigma rhs ++ + strbrk " with term " ++ pr_leconstr_env env sigma rhs ++ strbrk " that would depend on itself"] | NotClean ((evk,args),env,c) -> [str "cannot instantiate " ++ quote (pr_existential_key sigma evk) ++ strbrk " because " ++ pr_leconstr_env env sigma c ++ - strbrk " is not in its scope" ++ + strbrk " is not in its scope" ++ (if Array.is_empty args then mt() else strbrk ": available arguments are " ++ pr_sequence (pr_leconstr_env env sigma) (List.rev (Array.to_list args)))] @@ -316,7 +316,7 @@ let explain_unification_error env sigma p1 p2 = function else [] | MetaOccurInBody evk -> [str "instance for " ++ quote (pr_existential_key sigma evk) ++ - strbrk " refers to a metavariable - please report your example" ++ + strbrk " refers to a metavariable - please report your example" ++ strbrk "at " ++ str Coq_config.wwwbugtracker ++ str "."] | InstanceNotSameType (evk,env,t,u) -> let t, u = pr_explicit env sigma t u in @@ -326,9 +326,9 @@ let explain_unification_error env sigma p1 p2 = function t ++ strbrk " is a subtype of " ++ u] | UnifUnivInconsistency p -> if !Constrextern.print_universes then - [str "universe inconsistency: " ++ + [str "universe inconsistency: " ++ Univ.explain_universe_inconsistency (Termops.pr_evd_level sigma) p] - else + else [str "universe inconsistency"] | CannotSolveConstraint ((pb,env,t,u),e) -> let env = make_all_name_different env sigma in @@ -386,9 +386,9 @@ let explain_cant_apply_bad_type env sigma (n,exptyp,actualtyp) rator randl = if nargs>1 then str "The " ++ pr_nth n ++ str " term" else str "This term" in let appl = prvect_with_sep fnl - (fun c -> - let pc,pct = pr_ljudge_env env sigma c in - hov 2 (pc ++ spc () ++ str ": " ++ pct)) randl + (fun c -> + let pc,pct = pr_ljudge_env env sigma c in + hov 2 (pc ++ spc () ++ str ": " ++ pct)) randl in str "Illegal application: " ++ (* pe ++ *) fnl () ++ str "The term" ++ brk(1,1) ++ pr ++ spc () ++ @@ -406,10 +406,10 @@ let explain_cant_apply_not_functional env sigma rator randl = let pr = pr_leconstr_env env sigma rator.uj_val in let prt = pr_leconstr_env env sigma rator.uj_type in let appl = prvect_with_sep fnl - (fun c -> - let pc = pr_leconstr_env env sigma c.uj_val in - let pct = pr_leconstr_env env sigma c.uj_type in - hov 2 (pc ++ spc () ++ str ": " ++ pct)) randl + (fun c -> + let pc = pr_leconstr_env env sigma c.uj_val in + let pct = pr_leconstr_env env sigma c.uj_type in + hov 2 (pc ++ spc () ++ str ": " ++ pct)) randl in str "Illegal application (Non-functional construction): " ++ (* pe ++ *) fnl () ++ @@ -517,7 +517,7 @@ let explain_ill_formed_rec_body env sigma err names i fixenv vdefj = (try (* May fail with unresolved globals. *) let fixenv = make_all_name_different fixenv sigma in let pvd = pr_lconstr_env fixenv sigma vdefj.(i).uj_val in - str"Recursive definition is:" ++ spc () ++ pvd ++ str "." + str"Recursive definition is:" ++ spc () ++ pvd ++ str "." with e when CErrors.noncritical e -> mt ()) let explain_ill_typed_rec_body env sigma i names vdefj vargs = @@ -723,8 +723,8 @@ let explain_non_linear_unification env sigma m t = pr_lconstr_env env sigma t ++ str "." let explain_unsatisfied_constraints env sigma cst = - strbrk "Unsatisfied constraints: " ++ - Univ.pr_constraints (Termops.pr_evd_level sigma) cst ++ + strbrk "Unsatisfied constraints: " ++ + Univ.pr_constraints (Termops.pr_evd_level sigma) cst ++ spc () ++ str "(maybe a bugged tactic)." let explain_undeclared_universe env sigma l = @@ -841,7 +841,7 @@ let explain_unsatisfiable_constraints env sigma constr comp = | None -> Evar.Set.mem evk tcs | Some comp -> Evar.Set.mem evk tcs && Evar.Set.mem evk comp in - let undef = + let undef = let m = Evar.Map.filter is_kept undef in if Evar.Map.is_empty m then undef else m @@ -942,12 +942,12 @@ let explain_not_match_error = function str "Aliases to inductive types do not match" | CumulativeStatusExpected b -> let status b = if b then str"cumulative" else str"non-cumulative" in - str "a " ++ status b ++ str" declaration was expected, but a " ++ - status (not b) ++ str" declaration was found" + str "a " ++ status b ++ str" declaration was expected, but a " ++ + status (not b) ++ str" declaration was found" | PolymorphicStatusExpected b -> let status b = if b then str"polymorphic" else str"monomorphic" in - str "a " ++ status b ++ str" declaration was expected, but a " ++ - status (not b) ++ str" declaration was found" + str "a " ++ status b ++ str" declaration was expected, but a " ++ + status (not b) ++ str" declaration was found" | IncompatibleUniverses incon -> str"the universe constraints are inconsistent: " ++ Univ.explain_universe_inconsistency UnivNames.pr_with_global_universes incon diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml index a6c577a878..b2e1a5e796 100644 --- a/vernac/indschemes.ml +++ b/vernac/indschemes.ml @@ -118,7 +118,7 @@ let alarm what internal msg = | InternalTacticRequest -> (if debug then Feedback.msg_debug - (hov 0 msg ++ fnl () ++ what ++ str " not defined.")); None + (hov 0 msg ++ fnl () ++ what ++ str " not defined.")); None | _ -> Some msg let try_declare_scheme what f internal names kn = @@ -128,27 +128,27 @@ let try_declare_scheme what f internal names kn = let rec extract_exn = function Logic_monad.TacticFailure e -> extract_exn e | e -> e in let msg = match extract_exn (fst e) with | ParameterWithoutEquality cst -> - alarm what internal - (str "Boolean equality not found for parameter " ++ Printer.pr_global cst ++ - str".") + alarm what internal + (str "Boolean equality not found for parameter " ++ Printer.pr_global cst ++ + str".") | InductiveWithProduct -> - alarm what internal - (str "Unable to decide equality of functional arguments.") + alarm what internal + (str "Unable to decide equality of functional arguments.") | InductiveWithSort -> - alarm what internal - (str "Unable to decide equality of type arguments.") + alarm what internal + (str "Unable to decide equality of type arguments.") | NonSingletonProp ind -> - alarm what internal - (str "Cannot extract computational content from proposition " ++ - quote (Printer.pr_inductive (Global.env()) ind) ++ str ".") + alarm what internal + (str "Cannot extract computational content from proposition " ++ + quote (Printer.pr_inductive (Global.env()) ind) ++ str ".") | EqNotFound (ind',ind) -> - alarm what internal - (str "Boolean equality on " ++ - quote (Printer.pr_inductive (Global.env()) ind') ++ - strbrk " is missing.") + alarm what internal + (str "Boolean equality on " ++ + quote (Printer.pr_inductive (Global.env()) ind') ++ + strbrk " is missing.") | UndefinedCst s -> - alarm what internal - (strbrk "Required constant " ++ str s ++ str " undefined.") + alarm what internal + (strbrk "Required constant " ++ str s ++ str " undefined.") | AlreadyDeclared (kind, id) as exn -> let msg = CErrors.print exn in alarm what internal msg @@ -171,7 +171,7 @@ let try_declare_scheme what f internal names kn = str " is applied to an argument which is not a variable.") | e when CErrors.noncritical e -> alarm what internal - (str "Unexpected error during scheme creation: " ++ CErrors.print e) + (str "Unexpected error during scheme creation: " ++ CErrors.print e) | _ -> iraise e in match msg with @@ -370,10 +370,10 @@ requested let newref = CAst.make newid in ((newref,isdep,ind,z)::l1),l2 in - match t with - | CaseScheme (x,y,z) -> names "_case" "_case" x y z - | InductionScheme (x,y,z) -> names "_ind" "_rec" x y z - | EqualityScheme x -> l1,((None,smart_global_inductive x)::l2) + match t with + | CaseScheme (x,y,z) -> names "_case" "_case" x y z + | InductionScheme (x,y,z) -> names "_ind" "_rec" x y z + | EqualityScheme x -> l1,((None,smart_global_inductive x)::l2) let do_mutual_induction_scheme ?(force_mutual=false) lnamedepindsort = let lrecnames = List.map (fun ({CAst.v},_,_,_) -> v) lnamedepindsort @@ -382,13 +382,13 @@ let do_mutual_induction_scheme ?(force_mutual=false) lnamedepindsort = List.fold_right (fun (_,dep,ind,sort) (evd, l, inst) -> let evd, indu, inst = - match inst with - | None -> + match inst with + | None -> let _, ctx = Typeops.type_of_global_in_context env0 (GlobRef.IndRef ind) in let u, ctx = UnivGen.fresh_instance_from ctx None in let evd = Evd.from_ctx (UState.of_context_set ctx) in - evd, (ind,u), Some u - | Some ui -> evd, (ind, ui), inst + evd, (ind,u), Some u + | Some ui -> evd, (ind, ui), inst in (evd, (indu,dep,sort) :: l, inst)) lnamedepindsort (Evd.from_env env0,[],None) @@ -416,10 +416,10 @@ let get_common_underlying_mutual_inductive env = function | (_,ind')::_ -> raise (RecursionSchemeError (env, NotMutualInScheme (ind,ind'))) | [] -> - if not (List.distinct_f Int.compare (List.map snd (List.map snd all))) + if not (List.distinct_f Int.compare (List.map snd (List.map snd all))) then user_err Pp.(str "A type occurs twice"); - mind, - List.map_filter + mind, + List.map_filter (function (Some id,(_,i)) -> Some (i,id.CAst.v) | (None,_) -> None) all let do_scheme l = @@ -434,8 +434,8 @@ tried to declare different schemes at once *) if not (List.is_empty ischeme) then do_mutual_induction_scheme ischeme else let mind,l = get_common_underlying_mutual_inductive env escheme in - declare_beq_scheme_with l mind; - declare_eq_decidability_scheme_with l mind + declare_beq_scheme_with l mind; + declare_eq_decidability_scheme_with l mind ) (**********************************************************************) @@ -468,11 +468,11 @@ let build_combined_scheme env schemes = let (ctx, arity) = decompose_prod ty in let (_, last) = List.hd ctx in match Constr.kind last with - | App (ind, args) -> - let ind = destInd ind in - let (_,spec) = Inductive.lookup_mind_specif env (fst ind) in - ctx, ind, spec.mind_nrealargs - | _ -> ctx, destInd last, 0 + | App (ind, args) -> + let ind = destInd ind in + let (_,spec) = Inductive.lookup_mind_specif env (fst ind) in + ctx, ind, spec.mind_nrealargs + | _ -> ctx, destInd last, 0 in let (c, t) = List.hd defs in let ctx, ind, nargs = find_inductive t in diff --git a/vernac/locality.ml b/vernac/locality.ml index 5862f51b43..c31f722a61 100644 --- a/vernac/locality.ml +++ b/vernac/locality.ml @@ -69,8 +69,8 @@ let enforce_section_locality locality_flag = let make_module_locality = function | Some false -> if Global.sections_are_opened () then - CErrors.user_err Pp.(str - "This command does not support the Global option in sections."); + CErrors.user_err Pp.(str + "This command does not support the Global option in sections."); false | Some true -> true | None -> false diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index e754ead5dd..fd57901acd 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -131,37 +131,37 @@ let parse_format ({CAst.loc;v=str} : lstring) = (* Parse " // " *) | '/' when i+1 < len && str.[i+1] == '/' -> (* We discard the useless n spaces... *) - push_token (make_loc (i-n) (i+1)) (UnpCut PpFnl) + push_token (make_loc (i-n) (i+1)) (UnpCut PpFnl) (parse_token 1 (close_quotation i (i+2))) (* Parse " .. / .. " *) | '/' when i+1 < len -> - let p = spaces 0 (i+1) in - push_token (make_loc (i-n) (i+p)) (UnpCut (PpBrk (n,p))) + let p = spaces 0 (i+1) in + push_token (make_loc (i-n) (i+p)) (UnpCut (PpBrk (n,p))) (parse_token 1 (close_quotation i (i+p+1))) | c -> (* The spaces are real spaces *) push_white i n (match c with | '[' -> - if i+1 < len then match str.[i+1] with - (* Parse " [h .. ", *) - | 'h' when i+1 <= len && str.[i+2] == 'v' -> - (parse_box i (fun n -> PpHVB n) (i+3)) - (* Parse " [v .. ", *) - | 'v' -> - parse_box i (fun n -> PpVB n) (i+2) - (* Parse " [ .. ", *) - | ' ' | '\'' -> - parse_box i (fun n -> PpHOVB n) (i+1) - | _ -> user_err ?loc:(make_loc i i) Pp.(str "\"v\", \"hv\", \" \" expected after \"[\" in format.") - else user_err ?loc:(make_loc i i) Pp.(str "\"v\", \"hv\" or \" \" expected after \"[\" in format.") + if i+1 < len then match str.[i+1] with + (* Parse " [h .. ", *) + | 'h' when i+1 <= len && str.[i+2] == 'v' -> + (parse_box i (fun n -> PpHVB n) (i+3)) + (* Parse " [v .. ", *) + | 'v' -> + parse_box i (fun n -> PpVB n) (i+2) + (* Parse " [ .. ", *) + | ' ' | '\'' -> + parse_box i (fun n -> PpHOVB n) (i+1) + | _ -> user_err ?loc:(make_loc i i) Pp.(str "\"v\", \"hv\", \" \" expected after \"[\" in format.") + else user_err ?loc:(make_loc i i) Pp.(str "\"v\", \"hv\" or \" \" expected after \"[\" in format.") (* Parse "]" *) | ']' -> - ((i,[]) :: parse_token 1 (close_quotation i (i+1))) + ((i,[]) :: parse_token 1 (close_quotation i (i+1))) (* Parse a non formatting token *) | c -> - let n = nonspaces true 0 i in - push_token (make_loc i (i+n-1)) (UnpTerminal (String.sub str (i-1) (n+2))) - (parse_token 1 (close_quotation i (i+n)))) + let n = nonspaces true 0 i in + push_token (make_loc i (i+n-1)) (UnpTerminal (String.sub str (i-1) (n+2))) + (parse_token 1 (close_quotation i (i+n)))) else if Int.equal n 0 then [] else user_err ?loc:(make_loc (len-n) len) Pp.(str "Ending spaces non part of a format annotation.") @@ -174,7 +174,7 @@ let parse_format ({CAst.loc;v=str} : lstring) = if i < len then match str.[i] with (* Parse a ' *) | '\'' when i+1 >= len || str.[i+1] == ' ' -> - push_white (i-n) (n-k) (push_token (make_loc i (i+1)) (UnpTerminal "'") (parse_token 1 (i+1))) + push_white (i-n) (n-k) (push_token (make_loc i (i+1)) (UnpTerminal "'") (parse_token 1 (i+1))) (* Parse the beginning of a quoted expression *) | '\'' -> parse_quoted (n-k) (i+1) @@ -261,11 +261,11 @@ let rec get_notation_vars onlyprint = function | NonTerminal id :: sl -> let vars = get_notation_vars onlyprint sl in if Id.equal id ldots_var then vars else - (* don't check for nonlinearity if printing only, see Bug 5526 *) - if not onlyprint && Id.List.mem id vars then - user_err ~hdr:"Metasyntax.get_notation_vars" + (* don't check for nonlinearity if printing only, see Bug 5526 *) + if not onlyprint && Id.List.mem id vars then + user_err ~hdr:"Metasyntax.get_notation_vars" (str "Variable " ++ Id.print id ++ str " occurs more than once.") - else id::vars + else id::vars | (Terminal _ | Break _) :: sl -> get_notation_vars onlyprint sl | SProdList _ :: _ -> assert false @@ -393,23 +393,23 @@ let make_hunks etyps symbols from = let vars,typs = List.split etyps in let rec make b = function | NonTerminal m :: prods -> - let i = index_id m vars in + let i = index_id m vars in let u = unparsing_metavar i from typs in if is_next_non_terminal b prods then (None, u) :: add_break_if_none 1 b (make b prods) - else + else (None, u) :: make_with_space b prods | Terminal s :: prods when (* true to simulate presence of non-terminal *) b || List.exists is_non_terminal prods -> if (is_comma s || is_operator s) then (* Always a breakable space after comma or separator *) (None, UnpTerminal s) :: add_break_if_none 1 b (make b prods) - else if is_right_bracket s && is_next_terminal prods then + else if is_right_bracket s && is_next_terminal prods then (* Always no space after right bracked, but possibly a break *) (None, UnpTerminal s) :: add_break_if_none 0 b (make b prods) else if is_left_bracket s && is_next_non_terminal b prods then (None, UnpTerminal s) :: make b prods - else if not (is_next_break prods) then + else if not (is_next_break prods) then (* Add rigid space, no break, unless user asked for something *) (None, UnpTerminal (s^" ")) :: make b prods else @@ -426,20 +426,20 @@ let make_hunks etyps symbols from = add_break n (make b prods) | SProdList (m,sl) :: prods -> - let i = index_id m vars in - let typ = List.nth typs (i-1) in - let _,prec = precedence_of_entry_type from typ in + let i = index_id m vars in + let typ = List.nth typs (i-1) in + let _,prec = precedence_of_entry_type from typ in let sl' = (* If no separator: add a break *) - if List.is_empty sl then add_break 1 [] + if List.is_empty sl then add_break 1 [] (* We add NonTerminal for simulation but remove it afterwards *) else make true sl in - let hunk = match typ with - | ETConstr _ -> UnpListMetaVar (i,prec,List.map snd sl') - | ETBinder isopen -> - check_open_binder isopen sl m; - UnpBinderListMetaVar (i,isopen,List.map snd sl') - | _ -> assert false in + let hunk = match typ with + | ETConstr _ -> UnpListMetaVar (i,prec,List.map snd sl') + | ETBinder isopen -> + check_open_binder isopen sl m; + UnpBinderListMetaVar (i,isopen,List.map snd sl') + | _ -> assert false in (None, hunk) :: make_with_space b prods | [] -> [] @@ -552,11 +552,11 @@ let hunks_of_format (from,(vars,typs)) symfmt = if not (List.is_empty sl) then error_format ?loc:(find_prod_list_loc loc_slfmt fmt) (); let symbs, l = aux (symbs,rfmt) in let hunk = match typ with - | ETConstr _ -> UnpListMetaVar (i,prec,slfmt) - | ETBinder isopen -> - check_open_binder isopen sl m; - UnpBinderListMetaVar (i,isopen,slfmt) - | _ -> assert false in + | ETConstr _ -> UnpListMetaVar (i,prec,slfmt) + | ETBinder isopen -> + check_open_binder isopen sl m; + UnpBinderListMetaVar (i,isopen,slfmt) + | _ -> assert false in symbs, hunk :: l | symbs, [] -> symbs, [] | Break _ :: symbs, fmt -> warn_format_break (); aux (symbs,fmt) @@ -656,7 +656,7 @@ let make_production etyps symbols = (List.map (function Terminal s -> [CLexer.terminal s] | Break _ -> [] | _ -> anomaly (Pp.str "Found a non terminal token in recursive notation separator.")) sl) in - match List.assoc x etyps with + match List.assoc x etyps with | ETConstr (s,_,typ) -> let p,l' = include_possible_similar_trailing_pattern typ etyps sl l in expand_list_rule s typ tkl x 1 p (aux l') @@ -712,7 +712,7 @@ let pr_level ntn (from,fromlevel,args,typs) = prlist_with_sep pr_comma (pr_arg_level fromlevel) (List.combine args typs) let error_incompatible_level ntn oldprec prec = - user_err + user_err (str "Notation " ++ pr_notation ntn ++ str " is already defined" ++ spc() ++ pr_level ntn oldprec ++ spc() ++ str "while it is now required to be" ++ spc() ++ @@ -829,17 +829,17 @@ let interp_modifiers modl = let open NotationMods in let rec interp subtyps acc = function | [] -> subtyps, acc | SetEntryType (s,typ) :: l -> - let id = Id.of_string s in - if Id.List.mem_assoc id acc.etyps then - user_err ~hdr:"Metasyntax.interp_modifiers" + let id = Id.of_string s in + if Id.List.mem_assoc id acc.etyps then + user_err ~hdr:"Metasyntax.interp_modifiers" (str s ++ str " is already assigned to an entry or constr level."); interp subtyps { acc with etyps = (id,typ) :: acc.etyps; } l | SetItemLevel ([],bko,n) :: l -> interp subtyps acc l | SetItemLevel (s::idl,bko,n) :: l -> - let id = Id.of_string s in - if Id.List.mem_assoc id acc.etyps then - user_err ~hdr:"Metasyntax.interp_modifiers" + let id = Id.of_string s in + if Id.List.mem_assoc id acc.etyps then + user_err ~hdr:"Metasyntax.interp_modifiers" (str s ++ str " is already assigned to an entry or constr level."); interp ((id,bko,n)::subtyps) acc (SetItemLevel (idl,bko,n)::l) | SetLevel n :: l -> @@ -871,7 +871,7 @@ let interp_modifiers modl = let open NotationMods in user_err (str "Entry is already assigned to custom " ++ str s ++ (match acc.level with None -> mt () | Some lev -> str " at level " ++ int lev) ++ str "."); interp subtyps { acc with custom = InCustomEntry s; level = n } l | SetAssoc a :: l -> - if not (Option.is_empty acc.assoc) then user_err Pp.(str "An associativity is given more than once."); + if not (Option.is_empty acc.assoc) then user_err Pp.(str "An associativity is given more than once."); interp subtyps { acc with assoc = Some a; } l | SetOnlyParsing :: l -> interp subtyps { acc with only_parsing = true; } l @@ -880,7 +880,7 @@ let interp_modifiers modl = let open NotationMods in | SetCompatVersion v :: l -> interp subtyps { acc with compat = Some v; } l | SetFormat ("text",s) :: l -> - if not (Option.is_empty acc.format) then user_err Pp.(str "A format is given more than once."); + if not (Option.is_empty acc.format) then user_err Pp.(str "A format is given more than once."); interp subtyps { acc with format = Some s; } l | SetFormat (k,s) :: l -> interp subtyps { acc with extra = (k,s.CAst.v)::acc.extra; } l @@ -955,9 +955,9 @@ let join_auxiliary_recursive_types recvars etyps = | None, Some ytyp -> (x,ytyp)::typs | Some xtyp, Some ytyp when (=) xtyp ytyp -> typs (* FIXME *) | Some xtyp, Some ytyp -> - user_err - (strbrk "In " ++ Id.print x ++ str " .. " ++ Id.print y ++ - strbrk ", both ends have incompatible types.")) + user_err + (strbrk "In " ++ Id.print x ++ str " .. " ++ Id.print y ++ + strbrk ", both ends have incompatible types.")) recvars etyps let internalization_type_of_entry_type = function @@ -1103,7 +1103,7 @@ let find_precedence custom lev etyps symbols onlyprint = | (ETIdent | ETBigint | ETGlobal), _ -> begin match lev with | None -> - ([Feedback.msg_info ?loc:None ,strbrk "Setting notation at level 0."],0) + ([Feedback.msg_info ?loc:None ,strbrk "Setting notation at level 0."],0) | Some 0 -> ([],0) | _ -> @@ -1115,12 +1115,12 @@ let find_precedence custom lev etyps symbols onlyprint = user_err Pp.(str "Need an explicit level.") else [],Option.get lev with Not_found -> - if Option.is_empty lev then - user_err Pp.(str "A left-recursive notation must have an explicit level.") - else [],Option.get lev) + if Option.is_empty lev then + user_err Pp.(str "A left-recursive notation must have an explicit level.") + else [],Option.get lev) | Some (Terminal _) when last_is_terminal () -> if Option.is_empty lev then - ([Feedback.msg_info ?loc:None ,strbrk "Setting notation at level 0."], 0) + ([Feedback.msg_info ?loc:None ,strbrk "Setting notation at level 0."], 0) else [],Option.get lev | Some _ -> if Option.is_empty lev then user_err Pp.(str "Cannot determine the level."); @@ -1146,7 +1146,7 @@ let remove_curly_brackets l = let br',next' = skip_break [] l' in (match next' with | Terminal "}" as t2 :: l'' -> - if deb && List.is_empty l'' then [t1;x;t2] else begin + if deb && List.is_empty l'' then [t1;x;t2] else begin check_curly_brackets_notation_exists (); x :: aux false l'' end @@ -1565,7 +1565,7 @@ let add_notation ~local deprecation env c ({CAst.loc;v=df},modifiers) sc = Dumpglob.dump_notation (loc,df') sc true let add_notation_extra_printing_rule df k v = - let notk = + let notk = let _,_, symbs = analyze_notation_tokens ~onlyprint:true df in make_notation_key InConstrEntrySomeLevel symbs in add_notation_extra_printing_rule notk k v diff --git a/vernac/mltop.ml b/vernac/mltop.ml index 0130de2543..9c18441d9c 100644 --- a/vernac/mltop.ml +++ b/vernac/mltop.ml @@ -127,7 +127,7 @@ let ml_load s = | WithoutTop -> try Dynlink.loadfile s; s - with Dynlink.Error a -> + with Dynlink.Error a -> user_err ~hdr:"Mltop.load_object" (strbrk "while loading " ++ str s ++ strbrk ": " ++ str (Dynlink.error_message a)) @@ -147,7 +147,7 @@ let dir_ml_use s = | _ -> let moreinfo = if Sys.(backend_type = Native) then " Loading ML code works only in bytecode." - else "" + else "" in user_err ~hdr:"Mltop.dir_ml_use" (str "Could not load ML code." ++ str moreinfo) diff --git a/vernac/obligations.ml b/vernac/obligations.ml index 4ea34e2b60..76dbf1ad5a 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -61,39 +61,39 @@ let subst_evar_constr evm evs n idf t = let evar_info id = List.assoc_f Evar.equal id evs in let rec substrec (depth, fixrels) c = match EConstr.kind evm c with | Evar (k, args) -> - let { ev_name = (id, idstr) ; - ev_hyps = hyps ; ev_chop = chop } = - try evar_info k - with Not_found -> - anomaly ~label:"eterm" (Pp.str "existential variable " ++ int (Evar.repr k) ++ str " not found.") - in + let { ev_name = (id, idstr) ; + ev_hyps = hyps ; ev_chop = chop } = + try evar_info k + with Not_found -> + anomaly ~label:"eterm" (Pp.str "existential variable " ++ int (Evar.repr k) ++ str " not found.") + in seen := Int.Set.add id !seen; - (* Evar arguments are created in inverse order, - and we must not apply to defined ones (i.e. LetIn's) - *) - let args = - let n = match chop with None -> 0 | Some c -> c in - let (l, r) = List.chop n (List.rev (Array.to_list args)) in - List.rev r - in - let args = - let rec aux hyps args acc = + (* Evar arguments are created in inverse order, + and we must not apply to defined ones (i.e. LetIn's) + *) + let args = + let n = match chop with None -> 0 | Some c -> c in + let (l, r) = List.chop n (List.rev (Array.to_list args)) in + List.rev r + in + let args = + let rec aux hyps args acc = let open Context.Named.Declaration in - match hyps, args with - (LocalAssum _ :: tlh), (c :: tla) -> - aux tlh tla ((substrec (depth, fixrels) c) :: acc) - | (LocalDef _ :: tlh), (_ :: tla) -> - aux tlh tla acc - | [], [] -> acc - | _, _ -> acc (*failwith "subst_evars: invalid argument"*) - in aux hyps args [] - in - if List.exists + match hyps, args with + (LocalAssum _ :: tlh), (c :: tla) -> + aux tlh tla ((substrec (depth, fixrels) c) :: acc) + | (LocalDef _ :: tlh), (_ :: tla) -> + aux tlh tla acc + | [], [] -> acc + | _, _ -> acc (*failwith "subst_evars: invalid argument"*) + in aux hyps args [] + in + if List.exists (fun x -> match EConstr.kind evm x with | Rel n -> Int.List.mem n fixrels | _ -> false) args then - transparent := Id.Set.add idstr !transparent; + transparent := Id.Set.add idstr !transparent; EConstr.mkApp (idf idstr, Array.of_list args) | Fix _ -> EConstr.map_with_binders evm succfix substrec (depth, 1 :: fixrels) c @@ -122,22 +122,22 @@ let etype_of_evar evm evs hyps concl = let rec aux acc n = function decl :: tl -> let t', s, trans = subst_evar_constr evm evs n EConstr.mkVar (NamedDecl.get_type decl) in - let t'' = subst_vars acc 0 t' in - let rest, s', trans' = aux (NamedDecl.get_id decl :: acc) (succ n) tl in - let s' = Int.Set.union s s' in - let trans' = Id.Set.union trans trans' in - (match decl with + let t'' = subst_vars acc 0 t' in + let rest, s', trans' = aux (NamedDecl.get_id decl :: acc) (succ n) tl in + let s' = Int.Set.union s s' in + let trans' = Id.Set.union trans trans' in + (match decl with | LocalDef (id,c,_) -> let c', s'', trans'' = subst_evar_constr evm evs n EConstr.mkVar c in - let c' = subst_vars acc 0 c' in + let c' = subst_vars acc 0 c' in mkNamedProd_or_LetIn (LocalDef (id, c', t'')) rest, - Int.Set.union s'' s', - Id.Set.union trans'' trans' + Int.Set.union s'' s', + Id.Set.union trans'' trans' | LocalAssum (id,_) -> mkNamedProd_or_LetIn (LocalAssum (id, t'')) rest, s', trans') | [] -> let t', s, trans = subst_evar_constr evm evs n EConstr.mkVar concl in - subst_vars acc 0 t', s, trans + subst_vars acc 0 t', s, trans in aux [] 0 (List.rev hyps) let trunc_named_context n ctx = @@ -171,10 +171,10 @@ let evar_dependencies evm oev = let move_after (id, ev, deps as obl) l = let rec aux restdeps = function | (id', _, _) as obl' :: tl -> - let restdeps' = Evar.Set.remove id' restdeps in - if Evar.Set.is_empty restdeps' then - obl' :: obl :: tl - else obl' :: aux restdeps' tl + let restdeps' = Evar.Set.remove id' restdeps in + if Evar.Set.is_empty restdeps' then + obl' :: obl :: tl + else obl' :: aux restdeps' tl | [] -> [obl] in aux (Evar.Set.remove id deps) l @@ -182,10 +182,10 @@ let sort_dependencies evl = let rec aux l found list = match l with | (id, ev, deps) as obl :: tl -> - let found' = Evar.Set.union found (Evar.Set.singleton id) in - if Evar.Set.subset deps found' then - aux tl found' (obl :: list) - else aux (move_after obl tl) found list + let found' = Evar.Set.union found (Evar.Set.singleton id) in + if Evar.Set.subset deps found' then + aux tl found' (obl :: list) + else aux (move_after obl tl) found list | [] -> List.rev list in aux evl Evar.Set.empty [] @@ -204,54 +204,54 @@ let eterm_obligations env name evm fs ?status t ty = let evn = let i = ref (-1) in List.rev_map (fun (id, ev) -> incr i; - (id, (!i, Id.of_string - (Id.to_string name ^ "_obligation_" ^ string_of_int (succ !i))), - ev)) evl + (id, (!i, Id.of_string + (Id.to_string name ^ "_obligation_" ^ string_of_int (succ !i))), + ev)) evl in let evts = (* Remove existential variables in types and build the corresponding products *) List.fold_right (fun (id, (n, nstr), ev) l -> - let hyps = Evd.evar_filtered_context ev in + let hyps = Evd.evar_filtered_context ev in let hyps = trunc_named_context nc_len hyps in let evtyp, deps, transp = etype_of_evar evm l hyps ev.evar_concl in - let evtyp, hyps, chop = - match chop_product fs evtyp with - | Some t -> t, trunc_named_context fs hyps, fs - | None -> evtyp, hyps, 0 - in - let loc, k = evar_source id evm in - let status = match k with + let evtyp, hyps, chop = + match chop_product fs evtyp with + | Some t -> t, trunc_named_context fs hyps, fs + | None -> evtyp, hyps, 0 + in + let loc, k = evar_source id evm in + let status = match k with | Evar_kinds.QuestionMark { Evar_kinds.qm_obligation=o } -> o | _ -> match status with | Some o -> o | None -> Evar_kinds.Define (not (Program.get_proofs_transparency ())) in let force_status, status, chop = match status with - | Evar_kinds.Define true as stat -> - if not (Int.equal chop fs) then true, Evar_kinds.Define false, None - else false, stat, Some chop - | s -> false, s, None - in - let info = { ev_name = (n, nstr); - ev_hyps = hyps; ev_status = force_status, status; ev_chop = chop; - ev_src = loc, k; ev_typ = evtyp ; ev_deps = deps; ev_tac = None } - in (id, info) :: l) + | Evar_kinds.Define true as stat -> + if not (Int.equal chop fs) then true, Evar_kinds.Define false, None + else false, stat, Some chop + | s -> false, s, None + in + let info = { ev_name = (n, nstr); + ev_hyps = hyps; ev_status = force_status, status; ev_chop = chop; + ev_src = loc, k; ev_typ = evtyp ; ev_deps = deps; ev_tac = None } + in (id, info) :: l) evn [] in let t', _, transparent = (* Substitute evar refs in the term by variables *) subst_evar_constr evm evts 0 EConstr.mkVar t in let ty, _, _ = subst_evar_constr evm evts 0 EConstr.mkVar ty in - let evars = + let evars = List.map (fun (ev, info) -> let { ev_name = (_, name); ev_status = force_status, status; - ev_src = src; ev_typ = typ; ev_deps = deps; ev_tac = tac } = info + ev_src = src; ev_typ = typ; ev_deps = deps; ev_tac = tac } = info in let force_status, status = match status with - | Evar_kinds.Define true when Id.Set.mem name transparent -> - true, Evar_kinds.Define false - | _ -> force_status, status + | Evar_kinds.Define true when Id.Set.mem name transparent -> + true, Evar_kinds.Define false + | _ -> force_status, status in name, typ, src, (force_status, status), deps, tac) evts in let evnames = List.map (fun (ev, info) -> ev, snd info.ev_name) evts in @@ -303,20 +303,20 @@ let init_prog_info ?(opaque = false) ?hook n udecl b t ctx deps fixkind let obls', b = match b with | None -> - assert(Int.equal (Array.length obls) 0); - let n = Nameops.add_suffix n "_obligation" in - [| { obl_name = n; obl_body = None; - obl_location = Loc.tag Evar_kinds.InternalHole; obl_type = t; - obl_status = false, Evar_kinds.Expand; obl_deps = Int.Set.empty; - obl_tac = None } |], - mkVar n + assert(Int.equal (Array.length obls) 0); + let n = Nameops.add_suffix n "_obligation" in + [| { obl_name = n; obl_body = None; + obl_location = Loc.tag Evar_kinds.InternalHole; obl_type = t; + obl_status = false, Evar_kinds.Expand; obl_deps = Int.Set.empty; + obl_tac = None } |], + mkVar n | Some b -> - Array.mapi - (fun i (n, t, l, o, d, tac) -> + Array.mapi + (fun i (n, t, l, o, d, tac) -> { obl_name = n ; obl_body = None; - obl_location = l; obl_type = t; obl_status = o; - obl_deps = d; obl_tac = tac }) - obls, b + obl_location = l; obl_type = t; obl_status = o; + obl_deps = d; obl_tac = tac }) + obls, b in let ctx = UState.make_flexible_nonalgebraic ctx in { prg_name = n @@ -348,23 +348,23 @@ exception Found of program_info CEphemeron.key let map_first m = try ProgMap.iter (fun _ v -> - if snd (CEphemeron.get v).prg_obligations > 0 then - raise (Found v)) m; + if snd (CEphemeron.get v).prg_obligations > 0 then + raise (Found v)) m; assert(false) with Found x -> x let get_prog name = let prg_infos = get_prg_info_map () in match name with - Some n -> + Some n -> (try CEphemeron.get (ProgMap.find n prg_infos) - with Not_found -> raise (NoObligations (Some n))) + with Not_found -> raise (NoObligations (Some n))) | None -> - (let n = map_cardinal prg_infos in - match n with - 0 -> raise (NoObligations None) + (let n = map_cardinal prg_infos in + match n with + 0 -> raise (NoObligations None) | 1 -> CEphemeron.get (map_first prg_infos) - | _ -> + | _ -> let progs = Id.Set.elements (ProgMap.domain prg_infos) in let prog = List.hd progs in let progs = prlist_with_sep pr_comma Id.print progs in @@ -505,9 +505,9 @@ and obligation (user_num, name, typ) tac = let obls, rem = prg.prg_obligations in if num >= 0 && num < Array.length obls then let obl = obls.(num) in - match obl.obl_body with + match obl.obl_body with | None -> solve_obligation prg num tac - | Some r -> error "Obligation already solved" + | Some r -> error "Obligation already solved" else error (sprintf "Unknown obligation number %i" (succ num)) @@ -560,12 +560,12 @@ and solve_prg_obligations prg ?oblset tac = Array.iteri (fun i x -> if p i then match solve_obligation_by_tac !prgref obls' i tac with - | None -> () - | Some prg' -> - prgref := prg'; - let deps = dependencies obls i in - (set := Int.Set.union !set deps; - decr rem)) + | None -> () + | Some prg' -> + prgref := prg'; + let deps = dependencies obls i in + (set := Int.Set.union !set deps; + decr rem)) obls' in update_obls !prgref obls' !rem @@ -599,18 +599,18 @@ let show_obligations_of_prg ?(msg=true) prg = let showed = ref 5 in if msg then Feedback.msg_info (int rem ++ str " obligation(s) remaining: "); Array.iteri (fun i x -> - match x.obl_body with - | None -> - if !showed > 0 then ( - decr showed; - let x = subst_deps_obl obls x in + match x.obl_body with + | None -> + if !showed > 0 then ( + decr showed; + let x = subst_deps_obl obls x in let env = Global.env () in let sigma = Evd.from_env env in - Feedback.msg_info (str "Obligation" ++ spc() ++ int (succ i) ++ spc () ++ - str "of" ++ spc() ++ Id.print n ++ str ":" ++ spc () ++ + Feedback.msg_info (str "Obligation" ++ spc() ++ int (succ i) ++ spc () ++ + str "of" ++ spc() ++ Id.print n ++ str ":" ++ spc () ++ hov 1 (Printer.pr_constr_env env sigma x.obl_type ++ - str "." ++ fnl ()))) - | Some _ -> ()) + str "." ++ fnl ()))) + | Some _ -> ()) obls let show_obligations ?(msg=true) n = @@ -618,7 +618,7 @@ let show_obligations ?(msg=true) n = | None -> all_programs () | Some n -> try [ProgMap.find n (get_prg_info_map ())] - with Not_found -> raise (NoObligations (Some n)) + with Not_found -> raise (NoObligations (Some n)) in List.iter (fun x -> show_obligations_of_prg ~msg (CEphemeron.get x)) progs let show_term n = @@ -645,9 +645,9 @@ let add_definition ~name ?term t ctx ?(univdecl=UState.default_univ_decl) let () = Flags.if_verbose Feedback.msg_info (info ++ str ", generating " ++ int len ++ str (String.plural len " obligation")) in progmap_add name (CEphemeron.create prg); let res = auto_solve_obligations (Some name) tactic in - match res with + match res with | Remain rem -> Flags.if_verbose (fun () -> show_obligations ~msg:false (Some name)) (); res - | _ -> res) + | _ -> res) let add_mutual_definitions l ctx ?(univdecl=UState.default_univ_decl) ?tactic ~poly ?(scope=DeclareDef.Global Declare.ImportDefaultBehavior) ?(kind=Decls.Definition) ?(reduce=reduce) @@ -660,15 +660,15 @@ let add_mutual_definitions l ctx ?(univdecl=UState.default_univ_decl) ?tactic in progmap_add n (CEphemeron.create prg)) l; let _defined = List.fold_left (fun finished x -> - if finished then finished - else - let res = auto_solve_obligations (Some x) tactic in - match res with + if finished then finished + else + let res = auto_solve_obligations (Some x) tactic in + match res with | Defined _ -> (* If one definition is turned into a constant, - the whole block is defined. *) true - | _ -> false) - false deps + the whole block is defined. *) true + | _ -> false) + false deps in () let admit_prog prg = diff --git a/vernac/record.ml b/vernac/record.ml index b60bfdfa22..49a73271f0 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -71,8 +71,8 @@ let interp_fields_evars env sigma impls_env nots l = Option.cata (fun x -> on_snd (fun x -> Some (fst x)) @@ interp_casted_constr_evars_impls ~program_mode:false env sigma ~impls x t') (sigma,None) b in let impls = - match i with - | Anonymous -> impls + match i with + | Anonymous -> impls | Name id -> Id.Map.add id (compute_internalization_data env sigma Constrintern.Method t' impl) impls in let d = match b' with @@ -87,7 +87,7 @@ let compute_constructor_level evars env l = List.fold_right (fun d (env, univ) -> let univ = if is_local_assum d then - let s = Retyping.get_sort_of env evars (RelDecl.get_type d) in + let s = Retyping.get_sort_of env evars (RelDecl.get_type d) in Univ.sup (univ_of_sort s) univ else univ in (EConstr.push_rel d env, univ)) @@ -123,8 +123,8 @@ let typecheck_params_and_fields finite def poly pl ps records = | _ -> () in List.iter - (function CLocalDef (b, _, _) -> error default_binder_kind b - | CLocalAssum (ls, bk, ce) -> List.iter (error bk) ls + (function CLocalDef (b, _, _) -> error default_binder_kind b + | CLocalAssum (ls, bk, ce) -> List.iter (error bk) ls | CLocalPattern {CAst.loc} -> Loc.raise ?loc (Stream.Error "pattern with quote not allowed in record parameters")) ps in @@ -138,9 +138,9 @@ let typecheck_params_and_fields finite def poly pl ps records = let sigma, s = interp_type_evars ~program_mode:false env sigma ~impls:empty_internalization_env t in let sred = Reductionops.whd_allnolet env sigma s in (match EConstr.kind sigma sred with - | Sort s' -> + | Sort s' -> let s' = EConstr.ESorts.kind sigma s' in - (if poly then + (if poly then match Evd.is_sort_variable sigma s' with | Some l -> let sigma = Evd.make_flexible_variable sigma ~algebraic:true l in @@ -148,7 +148,7 @@ let typecheck_params_and_fields finite def poly pl ps records = | None -> (sigma, false), (s, s') else (sigma, false), (s, s')) - | _ -> user_err ?loc:(constr_loc t) (str"Sort expected.")) + | _ -> user_err ?loc:(constr_loc t) (str"Sort expected.")) | None -> let uvarkind = Evd.univ_flexible_alg in let sigma, s = Evd.new_sort_variable uvarkind sigma in @@ -184,8 +184,8 @@ let typecheck_params_and_fields finite def poly pl ps records = let sigma = Evd.set_leq_sort env_ar sigma (Sorts.sort_of_univ univ) sort in if Univ.is_small_univ univ && Option.cata (Evd.is_flexible_level sigma) false (Evd.is_sort_variable sigma sort) then - (* We can assume that the level in aritysort is not constrained - and clear it, if it is flexible *) + (* We can assume that the level in aritysort is not constrained + and clear it, if it is flexible *) Evd.set_eq_sort env_ar sigma Sorts.set sort, (univ, EConstr.mkSort (Sorts.sort_of_univ univ)) else sigma, (univ, typ) in @@ -220,24 +220,24 @@ message. The user might still want to name the field of the record. *) 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 + let s,have = if List.length projs > 1 then "s","were" else "","was" in (Id.print fi ++ - strbrk" cannot be defined because the projection" ++ str s ++ spc () ++ + strbrk" cannot be defined because the projection" ++ str s ++ spc () ++ prlist_with_sep pr_comma Id.print projs ++ spc () ++ str have ++ - strbrk " not defined.") + strbrk " not defined.") | BadTypedProj (fi,ctx,te) -> - match te with + match te with | ElimArity (_,_,_,Some (_,_,_,NonInformativeToInformative)) -> (Id.print fi ++ - strbrk" cannot be defined because it is informative and " ++ - Printer.pr_inductive (Global.env()) indsp ++ - strbrk " is not.") + strbrk" cannot be defined because it is informative and " ++ + Printer.pr_inductive (Global.env()) indsp ++ + strbrk " is not.") | ElimArity (_,_,_,Some (_,_,_,StrongEliminationOnNonSmallType)) -> - (Id.print fi ++ - strbrk" cannot be defined because it is large and " ++ - Printer.pr_inductive (Global.env()) indsp ++ - strbrk " is not.") - | _ -> + (Id.print fi ++ + strbrk" cannot be defined because it is large and " ++ + Printer.pr_inductive (Global.env()) indsp ++ + strbrk " is not.") + | _ -> (Id.print fi ++ strbrk " cannot be defined because it is not typable.") in if coe then user_err ~hdr:"structure" st; @@ -259,19 +259,19 @@ let subst_projection fid l c = let bad_projs = ref [] in let rec substrec depth c = match Constr.kind c with | Rel k -> - (* We are in context [[params;fields;x:ind;...depth...]] *) + (* We are in context [[params;fields;x:ind;...depth...]] *) if k <= depth+1 then - c + c else if k-depth-1 <= lv then - match List.nth l (k-depth-2) with - | Projection t -> lift depth t - | NoProjection (Name id) -> bad_projs := id :: !bad_projs; mkRel k - | NoProjection Anonymous -> + match List.nth l (k-depth-2) with + | Projection t -> lift depth t + | NoProjection (Name id) -> bad_projs := id :: !bad_projs; mkRel k + | NoProjection Anonymous -> user_err (str "Field " ++ Id.print fid ++ str " depends on the " ++ pr_nth (k-depth-1) ++ str " field which has no name.") else - mkRel (k-lv) + mkRel (k-lv) | _ -> Constr.map_with_binders succ substrec depth c in let c' = lift 1 c in (* to get [c] defined in ctxt [[params;fields;x:ind]] *) @@ -316,13 +316,13 @@ let declare_projections indsp ctx ?(kind=Decls.StructureComponent) binder_name f (fun (nfi,i,kinds,sp_projs,subst) flags decl impls -> let fi = RelDecl.get_name decl in let ti = RelDecl.get_type decl in - let (sp_projs,i,subst) = - match fi with - | Anonymous -> - (None::sp_projs,i,NoProjection fi::subst) - | Name fid -> try + let (sp_projs,i,subst) = + match fi with + | Anonymous -> + (None::sp_projs,i,NoProjection fi::subst) + | Name fid -> try let kn, term = - if is_local_assum decl && primitive then + if is_local_assum decl && primitive then let p = Projection.Repr.make indsp ~proj_npars:mib.mind_nparams ~proj_arg:i @@ -332,48 +332,48 @@ let declare_projections indsp ctx ?(kind=Decls.StructureComponent) binder_name f let kn = Projection.Repr.constant p in Declare.definition_message fid; kn, mkProj (Projection.make p false,mkRel 1) - else - let ccl = subst_projection fid subst ti in - let body = match decl with + else + let ccl = subst_projection fid subst ti in + let body = match decl with | LocalDef (_,ci,_) -> subst_projection fid subst ci | LocalAssum ({binder_relevance=rci},_) -> - (* [ccl] is defined in context [params;x:rp] *) - (* [ccl'] is defined in context [params;x:rp;x:rp] *) - let ccl' = liftn 1 2 ccl in + (* [ccl] is defined in context [params;x:rp] *) + (* [ccl'] is defined in context [params;x:rp;x:rp] *) + let ccl' = liftn 1 2 ccl in let p = mkLambda (x, lift 1 rp, ccl') in - let branch = it_mkLambda_or_LetIn (mkRel nfi) lifted_fields in + let branch = it_mkLambda_or_LetIn (mkRel nfi) lifted_fields in let ci = Inductiveops.make_case_info env indsp rci LetStyle in (* Record projections have no is *) mkCase (ci, p, mkRel 1, [|branch|]) in - let proj = + let proj = it_mkLambda_or_LetIn (mkLambda (x,rp,body)) paramdecls in - let projtyp = + let projtyp = it_mkProd_or_LetIn (mkProd (x,rp,ccl)) paramdecls in - try + try let entry = Declare.definition_entry ~univs:ctx ~types:projtyp proj in let kind = Decls.IsDefinition kind in let kn = declare_constant ~name:fid ~kind (Declare.DefinitionEntry entry) in - let constr_fip = - let proj_args = (*Rel 1 refers to "x"*) paramargs@[mkRel 1] in + let constr_fip = + let proj_args = (*Rel 1 refers to "x"*) paramargs@[mkRel 1] in applist (mkConstU (kn,u),proj_args) in Declare.definition_message fid; - kn, constr_fip + kn, constr_fip with Type_errors.TypeError (ctx,te) -> raise (NotDefinable (BadTypedProj (fid,ctx,te))) - in + in let refi = GlobRef.ConstRef kn in - Impargs.maybe_declare_manual_implicits false refi impls; + Impargs.maybe_declare_manual_implicits false refi impls; if flags.pf_subclass then begin let cl = Class.class_of_global (GlobRef.IndRef indsp) in Class.try_add_new_coercion_with_source refi ~local:false ~poly ~source:cl - end; - let i = if is_local_assum decl then i+1 else i in - (Some kn::sp_projs, i, Projection term::subst) + end; + let i = if is_local_assum decl then i+1 else i in + (Some kn::sp_projs, i, Projection term::subst) with NotDefinable why -> warning_or_error flags.pf_subclass indsp why; - (None::sp_projs,i,NoProjection fi::subst) in + (None::sp_projs,i,NoProjection fi::subst) in (nfi - 1, i, { Recordops.pk_name = fi ; pk_true_proj = is_local_assum decl ; pk_canonical = flags.pf_canonical } :: kinds, sp_projs, subst)) (List.length fields,0,[],[],[]) flags (List.rev fields) (List.rev fieldimpls) in (kinds,sp_projs) @@ -536,8 +536,8 @@ let declare_class def cumulative ubinders univs id idbuild paramimpls params uni in let coers = List.map2 (fun coe pri -> Option.map (fun b -> - if b then Backward, pri else Forward, pri) coe) - coers priorities + if b then Backward, pri else Forward, pri) coe) + coers priorities in let map ind = let l = List.map3 (fun decl b y -> RelDecl.get_name decl, b, y) @@ -615,11 +615,11 @@ let add_inductive_class env sigma ind = let r = Inductive.relevance_of_inductive env ind in { cl_univs = univs; cl_impl = GlobRef.IndRef ind; - cl_context = List.map (const None) ctx, ctx; + cl_context = List.map (const None) ctx, ctx; cl_props = [LocalAssum (make_annot Anonymous r, ty)]; - cl_projs = []; - cl_strict = !typeclasses_strict; - cl_unique = !typeclasses_unique } + cl_projs = []; + cl_strict = !typeclasses_strict; + cl_unique = !typeclasses_unique } in Classes.add_class env sigma k diff --git a/vernac/search.ml b/vernac/search.ml index 06554aae20..364dae7152 100644 --- a/vernac/search.ml +++ b/vernac/search.ml @@ -39,7 +39,7 @@ module SearchBlacklist = let key = ["Search";"Blacklist"] let title = "Current search blacklist : " let member_message s b = - str "Search blacklist does " ++ (if b then mt () else str "not ") ++ str "include " ++ str s + str "Search blacklist does " ++ (if b then mt () else str "not ") ++ str "include " ++ str s end) (* The functions iter_constructors and iter_declarations implement the behavior @@ -330,7 +330,7 @@ let interface_search ?pstate = in let match_subtype (pat, flag) = toggle - (Constr_matching.is_matching_appsubterm ~closed:false + (Constr_matching.is_matching_appsubterm ~closed:false env (Evd.from_env env) pat (EConstr.of_constr constr)) flag in let match_module (mdl, flag) = diff --git a/vernac/topfmt.ml b/vernac/topfmt.ml index 046defc26b..45f40b1258 100644 --- a/vernac/topfmt.ml +++ b/vernac/topfmt.ml @@ -368,12 +368,12 @@ let pr_loc loc = match fname with | Loc.ToplevelInput -> Loc.(str"Toplevel input, characters " ++ int loc.bp ++ - str"-" ++ int loc.ep ++ str":") + str"-" ++ int loc.ep ++ str":") | Loc.InFile fname -> Loc.(str"File " ++ str "\"" ++ str fname ++ str "\"" ++ - str", line " ++ int loc.line_nb ++ str", characters " ++ - int (loc.bp-loc.bol_pos) ++ str"-" ++ int (loc.ep-loc.bol_pos) ++ - str":") + str", line " ++ int loc.line_nb ++ str", characters " ++ + int (loc.bp-loc.bol_pos) ++ str"-" ++ int (loc.ep-loc.bol_pos) ++ + str":") let pr_phase ?loc () = match !default_phase, loc with diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 128c30908b..f56cc00c3b 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -176,7 +176,7 @@ let print_module qid = match globdir with DirModule Nametab.{ obj_dir; obj_mp; _ } -> Printmod.print_module ~mod_ops:Declaremods.mod_ops (Printmod.printable_body obj_dir) obj_mp - | _ -> raise Not_found + | _ -> raise Not_found with Not_found -> user_err (str"Unknown Module " ++ pr_qualid qid) @@ -696,11 +696,11 @@ let vernac_inductive ~atts cum lo finite indl = if Dumpglob.dump () then List.iter (fun (((coe,lid), _, _, _, cstrs), _) -> match cstrs with - | Constructors cstrs -> - Dumpglob.dump_definition lid false "ind"; - List.iter (fun (_, (lid, _)) -> - Dumpglob.dump_definition lid false "constr") cstrs - | _ -> () (* dumping is done by vernac_record (called below) *) ) + | Constructors cstrs -> + Dumpglob.dump_definition lid false "ind"; + List.iter (fun (_, (lid, _)) -> + Dumpglob.dump_definition lid false "constr") cstrs + | _ -> () (* dumping is done by vernac_record (called below) *) ) indl; let is_record = function @@ -780,7 +780,7 @@ let vernac_inductive ~atts cum lo finite indl = | [ ( id , bl , c , Class _, Constructors [l]), [] ] -> let f = let (coe, ({loc;v=id}, ce)) = l in - let coe' = if coe then Some true else None in + let coe' = if coe then Some true else None in (((coe', AssumExpr ((make ?loc @@ Name id), ce)), None), []) in vernac_record cum (Class true) atts.polymorphic finite [id, bl, c, None, [f]] *) @@ -829,11 +829,11 @@ let vernac_cofixpoint ~atts discharge l = let vernac_scheme l = if Dumpglob.dump () then List.iter (fun (lid, s) -> - Option.iter (fun lid -> Dumpglob.dump_definition lid false "def") lid; - match s with - | InductionScheme (_, r, _) + Option.iter (fun lid -> Dumpglob.dump_definition lid false "def") lid; + match s with + | InductionScheme (_, r, _) | CaseScheme (_, r, _) - | EqualityScheme r -> dump_global r) l; + | EqualityScheme r -> dump_global r) l; Indschemes.do_scheme l let vernac_combined_scheme lid l = @@ -845,15 +845,15 @@ let vernac_combined_scheme lid l = let vernac_universe ~poly l = if poly && not (Global.sections_are_opened ()) then user_err ~hdr:"vernac_universe" - (str"Polymorphic universes can only be declared inside sections, " ++ - str "use Monomorphic Universe instead"); + (str"Polymorphic universes can only be declared inside sections, " ++ + str "use Monomorphic Universe instead"); DeclareUniv.do_universe ~poly l let vernac_constraint ~poly l = if poly && not (Global.sections_are_opened ()) then user_err ~hdr:"vernac_constraint" - (str"Polymorphic universe constraints can only be declared" - ++ str " inside sections, use Monomorphic Constraint instead"); + (str"Polymorphic universe constraints can only be declared" + ++ str " inside sections, use Monomorphic Constraint instead"); DeclareUniv.do_constraint ~poly l (**********************) @@ -911,11 +911,11 @@ let vernac_define_module export {loc;v=id} (binders_ast : module_binder list) mt else (idl,ty)) binders_ast in let mp = Declaremods.declare_module - id binders_ast mty_ast_o mexpr_ast_l + id binders_ast mty_ast_o mexpr_ast_l in Dumpglob.dump_moddef ?loc mp "mod"; Flags.if_verbose Feedback.msg_info - (str "Module " ++ Id.print id ++ str " is defined"); + (str "Module " ++ Id.print id ++ str " is defined"); Option.iter (fun export -> vernac_import export [qualid_of_ident id]) export @@ -932,7 +932,7 @@ let vernac_declare_module_type {loc;v=id} binders_ast mty_sign mty_ast_l = match mty_ast_l with | [] -> let binders_ast,argsexport = - List.fold_right + List.fold_right (fun (export,idl,ty) (args,argsexport) -> (idl,ty)::args, (List.map (fun {v=i} -> export,i)idl)@argsexport) binders_ast ([],[]) in @@ -940,7 +940,7 @@ let vernac_declare_module_type {loc;v=id} binders_ast mty_sign mty_ast_l = let mp = Declaremods.start_modtype id binders_ast mty_sign in Dumpglob.dump_moddef ?loc mp "modtype"; Flags.if_verbose Feedback.msg_info - (str "Interactive Module Type " ++ Id.print id ++ str " started"); + (str "Interactive Module Type " ++ Id.print id ++ str " started"); List.iter (fun (export,id) -> Option.iter @@ -948,15 +948,15 @@ let vernac_declare_module_type {loc;v=id} binders_ast mty_sign mty_ast_l = ) argsexport | _ :: _ -> - let binders_ast = List.map + let binders_ast = List.map (fun (export,idl,ty) -> if not (Option.is_empty export) then user_err Pp.(str "Arguments of a functor definition can be imported only if the definition is interactive. Remove the \"Export\" and \"Import\" keywords from every functor argument.") else (idl,ty)) binders_ast in let mp = Declaremods.declare_modtype id binders_ast mty_sign mty_ast_l in Dumpglob.dump_moddef ?loc mp "modtype"; - Flags.if_verbose Feedback.msg_info - (str "Module Type " ++ Id.print id ++ str " is defined") + Flags.if_verbose Feedback.msg_info + (str "Module Type " ++ Id.print id ++ str " is defined") let vernac_end_modtype {loc;v=id} = let mp = Declaremods.end_modtype () in @@ -1157,12 +1157,12 @@ let vernac_chdir = function | None -> Feedback.msg_notice (str (Sys.getcwd())) | Some path -> begin - try Sys.chdir (expand path) - with Sys_error err -> - (* Cd is typically used to control the output directory of - extraction. A failed Cd could lead to overwriting .ml files - so we make it an error. *) - user_err Pp.(str ("Cd failed: " ^ err)) + try Sys.chdir (expand path) + with Sys_error err -> + (* Cd is typically used to control the output directory of + extraction. A failed Cd could lead to overwriting .ml files + so we make it an error. *) + user_err Pp.(str ("Cd failed: " ^ err)) end; Flags.if_verbose Feedback.msg_info (str (Sys.getcwd())) @@ -1357,8 +1357,8 @@ let () = optkey = ["Inline";"Level"]; optread = (fun () -> Some (Flags.get_inline_level ())); optwrite = (fun o -> - let lev = Option.default Flags.default_inline_level o in - Flags.set_inline_level lev) } + let lev = Option.default Flags.default_inline_level o in + Flags.set_inline_level lev) } let () = declare_bool_option @@ -1433,7 +1433,7 @@ let () = optwrite = CWarnings.set_flags } let () = - declare_string_option + declare_string_option { optdepr = false; optname = "native_compute profiler output"; optkey = ["NativeCompute"; "Profile"; "Filename"]; @@ -1599,7 +1599,7 @@ let vernac_check_may_eval ~pstate ~atts redexp glopt rc = pr_ne_evar_set (fnl () ++ str "where" ++ fnl ()) (mt ()) sigma l | Some r -> let (sigma,r_interp) = Hook.get f_interp_redexp env sigma r in - let redfun env evm c = + let redfun env evm c = let (redfun, _) = reduction_of_red_expr env r_interp in let (_, c) = redfun env evm c in c @@ -1656,8 +1656,8 @@ let print_about_hyp_globs ~pstate ?loc ref_or_by_not udecl glopt = (try get_nth_goal ~pstate 1, qualid_basename qid with _ -> raise NoHyp) | Some n,AN qid when qualid_is_ident qid -> (* goal number given, catch if wong *) (try get_nth_goal ~pstate n, qualid_basename qid - with - Failure _ -> user_err ?loc ~hdr:"print_about_hyp_globs" + with + Failure _ -> user_err ?loc ~hdr:"print_about_hyp_globs" (str "No such goal: " ++ int n ++ str ".")) | _ , _ -> raise NoHyp in let hyps = pf_hyps gl in @@ -1667,7 +1667,7 @@ let print_about_hyp_globs ~pstate ?loc ref_or_by_not udecl glopt = | LocalDef (_,bdy,_) ->"Constant (let in)" in let sigma, env = Pfedit.get_current_context pstate in v 0 (Id.print id ++ str":" ++ pr_econstr_env env sigma (NamedDecl.get_type decl) ++ fnl() ++ fnl() - ++ str natureofid ++ str " of the goal context.") + ++ str natureofid ++ str " of the goal context.") with (* fallback to globals *) | NoHyp | Not_found -> let sigma, env = get_current_or_global_context ~pstate in @@ -1730,7 +1730,7 @@ let vernac_print ~pstate ~atts = let cstr = printable_constr_of_global gr in let st = Conv_oracle.get_transp_state (Environ.oracle (Global.env())) in let nassums = - Assumptions.assumptions st ~add_opaque:o ~add_transparent:t gr cstr in + Assumptions.assumptions st ~add_opaque:o ~add_transparent:t gr cstr in Printer.pr_assumptionset env sigma nassums | PrintStrategy r -> print_strategy r | PrintRegistered -> print_registered () @@ -1756,12 +1756,12 @@ let interp_search_about_item env sigma = GlobSearchString s | SearchString (s,sc) -> try - let ref = - Notation.interp_notation_as_global_reference - (fun _ -> true) s sc in - GlobSearchSubPattern (Pattern.PRef ref) + let ref = + Notation.interp_notation_as_global_reference + (fun _ -> true) s sc in + GlobSearchSubPattern (Pattern.PRef ref) with UserError _ -> - user_err ~hdr:"interp_search_about_item" + user_err ~hdr:"interp_search_about_item" (str "Unable to interp \"" ++ str s ++ str "\" either as a reference or as an identifier component") (* 05f22a5d6d5b8e3e80f1a37321708ce401834430 introduced the |