aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--checker/analyze.ml86
-rw-r--r--checker/analyze.mli21
-rw-r--r--checker/check.ml21
-rw-r--r--checker/check.mllib1
-rw-r--r--checker/votour.ml22
-rw-r--r--configure.ml16
-rw-r--r--default.nix2
-rw-r--r--dev/build/windows/patches_coq/coq_new.nsi2
-rw-r--r--doc/refman/Extraction.tex8
-rw-r--r--doc/refman/RefMan-ltac.tex9
-rw-r--r--plugins/extraction/ocaml.ml34
-rw-r--r--plugins/ltac/tacinterp.ml39
-rw-r--r--test-suite/output/Extraction_infix.out20
-rw-r--r--test-suite/output/Extraction_infix.v26
-rw-r--r--test-suite/output/Notations2.out6
-rw-r--r--test-suite/output/Notations2.v21
-rw-r--r--test-suite/output/ltac_missing_args.out40
-rw-r--r--vernac/vernacentries.ml9
-rw-r--r--vernac/vernacstate.ml28
19 files changed, 350 insertions, 61 deletions
diff --git a/checker/analyze.ml b/checker/analyze.ml
index df75d5b93c..7047d8a149 100644
--- a/checker/analyze.ml
+++ b/checker/analyze.ml
@@ -55,6 +55,55 @@ let magic_number = "\132\149\166\190"
(** Memory reification *)
+module LargeArray :
+sig
+ type 'a t
+ val empty : 'a t
+ val length : 'a t -> int
+ val make : int -> 'a -> 'a t
+ val get : 'a t -> int -> 'a
+ val set : 'a t -> int -> 'a -> unit
+end =
+struct
+
+ let max_length = Sys.max_array_length
+
+ type 'a t = 'a array array * 'a array
+ (** Invariants:
+ - All subarrays of the left array have length [max_length].
+ - The right array has length < [max_length].
+ *)
+
+ let empty = [||], [||]
+
+ let length (vl, vr) =
+ (max_length * Array.length vl) + Array.length vr
+
+ let make n x =
+ let k = n / max_length in
+ let r = n mod max_length in
+ let vl = Array.init k (fun _ -> Array.make max_length x) in
+ let vr = Array.make r x in
+ (vl, vr)
+
+ let get (vl, vr) n =
+ let k = n / max_length in
+ let r = n mod max_length in
+ let len = Array.length vl in
+ if k < len then vl.(k).(r)
+ else if k == len then vr.(r)
+ else invalid_arg "index out of bounds"
+
+ let set (vl, vr) n x =
+ let k = n / max_length in
+ let r = n mod max_length in
+ let len = Array.length vl in
+ if k < len then vl.(k).(r) <- x
+ else if k == len then vr.(r) <- x
+ else invalid_arg "index out of bounds"
+
+end
+
type repr =
| RInt of int
| RBlock of (int * int) (* tag × len *)
@@ -82,7 +131,7 @@ end
module type S =
sig
type input
- val parse : input -> (data * obj array)
+ val parse : input -> (data * obj LargeArray.t)
end
module Make(M : Input) =
@@ -261,7 +310,7 @@ let parse_object chan =
let parse chan =
let (magic, len, _, _, size) = parse_header chan in
let () = assert (magic = magic_number) in
- let memory = Array.make size (Struct ((-1), [||])) in
+ let memory = LargeArray.make size (Struct ((-1), [||])) in
let current_object = ref 0 in
let fill_obj = function
| RPointer n ->
@@ -272,7 +321,7 @@ let parse chan =
data, None
| RString s ->
let data = Ptr !current_object in
- let () = memory.(!current_object) <- String s in
+ let () = LargeArray.set memory !current_object (String s) in
let () = incr current_object in
data, None
| RBlock (tag, 0) ->
@@ -282,7 +331,7 @@ let parse chan =
| RBlock (tag, len) ->
let data = Ptr !current_object in
let nblock = Array.make len (Atm (-1)) in
- let () = memory.(!current_object) <- Struct (tag, nblock) in
+ let () = LargeArray.set memory !current_object (Struct (tag, nblock)) in
let () = incr current_object in
data, Some nblock
| RCode addr ->
@@ -343,3 +392,32 @@ module PString = Make(IString)
let parse_channel = PChannel.parse
let parse_string s = PString.parse (s, ref 0)
+
+let instantiate (p, mem) =
+ let len = LargeArray.length mem in
+ let ans = LargeArray.make len (Obj.repr 0) in
+ (** First pass: initialize the subobjects *)
+ for i = 0 to len - 1 do
+ let obj = match LargeArray.get mem i with
+ | Struct (tag, blk) -> Obj.new_block tag (Array.length blk)
+ | String str -> Obj.repr str
+ in
+ LargeArray.set ans i obj
+ done;
+ let get_data = function
+ | Int n -> Obj.repr n
+ | Ptr p -> LargeArray.get ans p
+ | Atm tag -> Obj.new_block tag 0
+ | Fun _ -> assert false (** We shouldn't serialize closures *)
+ in
+ (** Second pass: set the pointers *)
+ for i = 0 to len - 1 do
+ match LargeArray.get mem i with
+ | Struct (_, blk) ->
+ let obj = LargeArray.get ans i in
+ for k = 0 to Array.length blk - 1 do
+ Obj.set_field obj k (get_data blk.(k))
+ done
+ | String _ -> ()
+ done;
+ get_data p
diff --git a/checker/analyze.mli b/checker/analyze.mli
index 42efcf01df..9c837643fa 100644
--- a/checker/analyze.mli
+++ b/checker/analyze.mli
@@ -8,8 +8,20 @@ type obj =
| Struct of int * data array (* tag × data *)
| String of string
-val parse_channel : in_channel -> (data * obj array)
-val parse_string : string -> (data * obj array)
+module LargeArray :
+sig
+ type 'a t
+ val empty : 'a t
+ val length : 'a t -> int
+ val make : int -> 'a -> 'a t
+ val get : 'a t -> int -> 'a
+ val set : 'a t -> int -> 'a -> unit
+end
+(** A data structure similar to arrays but allowing to overcome the 2^22 length
+ limitation on 32-bit architecture. *)
+
+val parse_channel : in_channel -> (data * obj LargeArray.t)
+val parse_string : string -> (data * obj LargeArray.t)
(** {6 Functorized version} *)
@@ -26,10 +38,13 @@ end
module type S =
sig
type input
- val parse : input -> (data * obj array)
+ val parse : input -> (data * obj LargeArray.t)
(** Return the entry point and the reification of the memory out of a
marshalled structure. *)
end
module Make (M : Input) : S with type input = M.t
(** Functorized version of the previous code. *)
+
+val instantiate : data * obj LargeArray.t -> Obj.t
+(** Create the OCaml object out of the reified representation. *)
diff --git a/checker/check.ml b/checker/check.ml
index 21fdba1faf..44105aa72f 100644
--- a/checker/check.ml
+++ b/checker/check.ml
@@ -308,18 +308,27 @@ let name_clash_message dir mdir f =
(* Dependency graph *)
let depgraph = ref LibraryMap.empty
+let marshal_in_segment f ch =
+ try
+ let stop = input_binary_int ch in
+ let v = Analyze.instantiate (Analyze.parse_channel ch) in
+ let digest = Digest.input ch in
+ Obj.obj v, stop, digest
+ with _ ->
+ user_err (str "Corrupted file " ++ quote (str f))
+
let intern_from_file (dir, f) =
Flags.if_verbose chk_pp (str"[intern "++str f++str" ...");
let (sd,md,table,opaque_csts,digest) =
try
let ch = System.with_magic_number_check raw_intern_library f in
- let (sd:Cic.summary_disk), _, digest = System.marshal_in_segment f ch in
- let (md:Cic.library_disk), _, digest = System.marshal_in_segment f ch in
- let (opaque_csts:'a option), _, udg = System.marshal_in_segment f ch in
- let (discharging:'a option), _, _ = System.marshal_in_segment f ch in
- let (tasks:'a option), _, _ = System.marshal_in_segment f ch in
+ let (sd:Cic.summary_disk), _, digest = marshal_in_segment f ch in
+ let (md:Cic.library_disk), _, digest = marshal_in_segment f ch in
+ let (opaque_csts:'a option), _, udg = marshal_in_segment f ch in
+ let (discharging:'a option), _, _ = marshal_in_segment f ch in
+ let (tasks:'a option), _, _ = marshal_in_segment f ch in
let (table:Cic.opaque_table), pos, checksum =
- System.marshal_in_segment f ch in
+ marshal_in_segment f ch in
(* Verification of the final checksum *)
let () = close_in ch in
let ch = open_in_bin f in
diff --git a/checker/check.mllib b/checker/check.mllib
index 488507a13f..f79ba66e35 100644
--- a/checker/check.mllib
+++ b/checker/check.mllib
@@ -1,5 +1,6 @@
Coq_config
+Analyze
Hook
Terminal
Canary
diff --git a/checker/votour.ml b/checker/votour.ml
index b7c898232b..77c9999c42 100644
--- a/checker/votour.ml
+++ b/checker/votour.ml
@@ -77,8 +77,8 @@ struct
type obj = data
- let memory = ref [||]
- let sizes = ref [||]
+ let memory = ref LargeArray.empty
+ let sizes = ref LargeArray.empty
(** size, in words *)
let ws = Sys.word_size / 8
@@ -86,10 +86,10 @@ struct
let rec init_size seen k = function
| Int _ | Atm _ | Fun _ -> k 0
| Ptr p ->
- if seen.(p) then k 0
+ if LargeArray.get seen p then k 0
else
- let () = seen.(p) <- true in
- match (!memory).(p) with
+ let () = LargeArray.set seen p true in
+ match LargeArray.get !memory p with
| Struct (tag, os) ->
let len = Array.length os in
let rec fold i accu k =
@@ -97,30 +97,30 @@ struct
else
init_size seen (fun n -> fold (succ i) (accu + 1 + n) k) os.(i)
in
- fold 0 1 (fun size -> let () = (!sizes).(p) <- size in k size)
+ fold 0 1 (fun size -> let () = LargeArray.set !sizes p size in k size)
| String s ->
let size = 2 + (String.length s / ws) in
- let () = (!sizes).(p) <- size in
+ let () = LargeArray.set !sizes p size in
k size
let size = function
| Int _ | Atm _ | Fun _ -> 0
- | Ptr p -> (!sizes).(p)
+ | Ptr p -> LargeArray.get !sizes p
let repr = function
| Int i -> INT i
| Atm t -> BLOCK (t, [||])
| Fun _ -> OTHER
| Ptr p ->
- match (!memory).(p) with
+ match LargeArray.get !memory p with
| Struct (tag, os) -> BLOCK (tag, os)
| String s -> STRING s
let input ch =
let obj, mem = parse_channel ch in
let () = memory := mem in
- let () = sizes := Array.make (Array.length mem) (-1) in
- let seen = Array.make (Array.length mem) false in
+ let () = sizes := LargeArray.make (LargeArray.length mem) (-1) in
+ let seen = LargeArray.make (LargeArray.length mem) false in
let () = init_size seen ignore obj in
obj
diff --git a/configure.ml b/configure.ml
index 1ccb691067..e14eeac7b8 100644
--- a/configure.ml
+++ b/configure.ml
@@ -678,6 +678,22 @@ let operating_system, osdeplibs =
else
(try Sys.getenv "OS" with Not_found -> ""), osdeplibs
+(** Num library *)
+
+(* since 4.06, the Num library is no longer distributed with OCaml (replaced
+ by Zarith)
+*)
+
+let check_for_numlib () =
+ if caml_version_nums >= [4;6;0] then
+ let numlib,_ = tryrun "ocamlfind" ["query";"num"] in
+ match numlib with
+ | "" ->
+ die "Num library not installed, required for OCaml 4.06 or later"
+ | _ -> printf "You have the Num library installed. Good!\n"
+
+let numlib =
+ check_for_numlib ()
(** * lablgtk2 and CoqIDE *)
diff --git a/default.nix b/default.nix
index 9efabdbc2d..86f86ff99b 100644
--- a/default.nix
+++ b/default.nix
@@ -49,6 +49,8 @@ stdenv.mkDerivation rec {
rsync
which
+ ] else []) ++ (if lib.inNixShell then [
+ ocamlPackages.merlin
] else []);
src =
diff --git a/dev/build/windows/patches_coq/coq_new.nsi b/dev/build/windows/patches_coq/coq_new.nsi
index b88aa066d8..48f1d3759b 100644
--- a/dev/build/windows/patches_coq/coq_new.nsi
+++ b/dev/build/windows/patches_coq/coq_new.nsi
@@ -188,7 +188,7 @@ SectionEnd
Section "Uninstall"
; Files and folders
RMDir /r "$INSTDIR\bin"
- RMDir /r "$INSTDIR\dev"
+ RMDir /r "$INSTDIR\doc"
RMDir /r "$INSTDIR\etc"
RMDir /r "$INSTDIR\lib"
RMDir /r "$INSTDIR\libocaml"
diff --git a/doc/refman/Extraction.tex b/doc/refman/Extraction.tex
index 83e866e9f3..79060e6062 100644
--- a/doc/refman/Extraction.tex
+++ b/doc/refman/Extraction.tex
@@ -391,9 +391,11 @@ Extract Inductive bool => "bool" [ "true" "false" ].
Extract Inductive sumbool => "bool" [ "true" "false" ].
\end{coq_example}
-\noindent If an inductive constructor or type has arity 2 and the corresponding
-string is enclosed by parenthesis, then the rest of the string is used
-as infix constructor or type.
+\noindent When extracting to {\ocaml}, if an inductive constructor or type
+has arity 2 and the corresponding string is enclosed by parentheses,
+and the string meets {\ocaml}'s lexical criteria for an infix symbol,
+then the rest of the string is used as infix constructor or type.
+
\begin{coq_example}
Extract Inductive list => "list" [ "[]" "(::)" ].
Extract Inductive prod => "(*)" [ "(,)" ].
diff --git a/doc/refman/RefMan-ltac.tex b/doc/refman/RefMan-ltac.tex
index 5fb4585884..7034c56081 100644
--- a/doc/refman/RefMan-ltac.tex
+++ b/doc/refman/RefMan-ltac.tex
@@ -311,10 +311,11 @@ A sequence is an expression of the following form:
\begin{quote}
{\tacexpr}$_1$ {\tt ;} {\tacexpr}$_2$
\end{quote}
-The expressions {\tacexpr}$_1$ and {\tacexpr}$_2$ are evaluated
-to $v_1$ and $v_2$ which have to be tactic values. The tactic $v_1$ is
-then applied and $v_2$ is applied to the goals generated by the
-application of $v_1$. Sequence is left-associative.
+The expression {\tacexpr}$_1$ is evaluated to $v_1$, which must be
+a tactic value. The tactic $v_1$ is applied to the current goal,
+possibly producing more goals. Then {\tacexpr}$_2$ is evaluated to
+produce $v_2$, which must be a tactic value. The tactic $v_2$ is applied to
+all the goals produced by the prior application. Sequence is associative.
\subsubsection[Local application of tactics]{Local application of tactics\tacindex{[>\ldots$\mid$\ldots$\mid$\ldots]}\tacindex{;[\ldots$\mid$\ldots$\mid$\ldots]}\index{Tacticals![> \mid ]@{\tt {\tac$_0$};[{\tac$_1$}$\mid$\ldots$\mid$\tac$_n$]}}\index{Tacticals!; [ \mid ]@{\tt {\tac$_0$};[{\tac$_1$}$\mid$\ldots$\mid$\tac$_n$]}}}
%\tacindex{; [ | ]}
diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml
index 9cbc3fd713..5d0f9c167e 100644
--- a/plugins/extraction/ocaml.ml
+++ b/plugins/extraction/ocaml.ml
@@ -100,11 +100,41 @@ let pp_global k r = str (str_global k r)
let pp_modname mp = str (Common.pp_module mp)
+(* grammar from OCaml 4.06 manual, "Prefix and infix symbols" *)
+
+let infix_symbols =
+ ['=' ; '<' ; '>' ; '@' ; '^' ; ';' ; '&' ; '+' ; '-' ; '*' ; '/' ; '$' ; '%' ]
+let operator_chars =
+ [ '!' ; '$' ; '%' ; '&' ; '*' ; '+' ; '-' ; '.' ; '/' ; ':' ; '<' ; '=' ; '>' ; '?' ; '@' ; '^' ; '|' ; '~' ]
+
+(* infix ops in OCaml, but disallowed by preceding grammar *)
+
+let builtin_infixes =
+ [ "::" ; "," ]
+
+let substring_all_opchars s start stop =
+ let rec check_char i =
+ if i >= stop then true
+ else
+ List.mem s.[i] operator_chars && check_char (i+1)
+ in
+ check_char start
+
let is_infix r =
is_inline_custom r &&
(let s = find_custom r in
- let l = String.length s in
- l >= 2 && s.[0] == '(' && s.[l-1] == ')')
+ let len = String.length s in
+ len >= 3 &&
+ (* parenthesized *)
+ (s.[0] == '(' && s.[len-1] == ')' &&
+ let inparens = String.trim (String.sub s 1 (len - 2)) in
+ let inparens_len = String.length inparens in
+ (* either, begins with infix symbol, any remainder is all operator chars *)
+ (List.mem inparens.[0] infix_symbols && substring_all_opchars inparens 1 inparens_len) ||
+ (* or, starts with #, at least one more char, all are operator chars *)
+ (inparens.[0] == '#' && inparens_len >= 2 && substring_all_opchars inparens 1 inparens_len) ||
+ (* or, is an OCaml built-in infix *)
+ (List.mem inparens builtin_infixes)))
let get_infix r =
let s = find_custom r in
diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml
index 1a8ec6d6f6..14b79d73ed 100644
--- a/plugins/ltac/tacinterp.ml
+++ b/plugins/ltac/tacinterp.ml
@@ -1380,13 +1380,38 @@ and tactic_of_value ist vle =
extra = TacStore.set ist.extra f_trace []; } in
let tac = name_if_glob appl (eval_tactic ist t) in
Profile_ltac.do_profile "tactic_of_value" trace (catch_error_tac trace tac)
- | VFun (_, _, _,vars,_) ->
- let numargs = List.length vars in
- Tacticals.New.tclZEROMSG
- (str "A fully applied tactic is expected:" ++ spc() ++ Pp.str "missing " ++
- Pp.str (String.plural numargs "argument") ++ Pp.str " for " ++
- Pp.str (String.plural numargs "variable") ++ Pp.str " " ++
- pr_enum Name.print vars ++ Pp.str ".")
+ | VFun (appl,_,vmap,vars,_) ->
+ let tactic_nm =
+ match appl with
+ UnnamedAppl -> "An unnamed user-defined tactic"
+ | GlbAppl apps ->
+ let nms = List.map (fun (kn,_) -> Names.KerName.to_string kn) apps in
+ match nms with
+ [] -> assert false
+ | kn::_ -> "The user-defined tactic \"" ^ kn ^ "\"" (* TODO: when do we not have a singleton? *)
+ in
+ let numargs = List.length vars in
+ let givenargs =
+ List.map (fun (arg,_) -> Names.Id.to_string arg) (Names.Id.Map.bindings vmap) in
+ let numgiven = List.length givenargs in
+ Tacticals.New.tclZEROMSG
+ (Pp.str tactic_nm ++ Pp.str " was not fully applied:" ++ spc() ++
+ (match numargs with
+ 0 -> assert false
+ | 1 ->
+ Pp.str "There is a missing argument for variable " ++
+ (Name.print (List.hd vars))
+ | _ -> Pp.str "There are missing arguments for variables " ++
+ pr_enum Name.print vars) ++ Pp.pr_comma () ++
+ match numgiven with
+ 0 ->
+ Pp.str "no arguments at all were provided."
+ | 1 ->
+ Pp.str "an argument was provided for variable " ++
+ Pp.str (List.hd givenargs) ++ Pp.str "."
+ | _ ->
+ Pp.str "arguments were provided for variables " ++
+ pr_enum Pp.str givenargs ++ Pp.str ".")
| VRec _ -> Tacticals.New.tclZEROMSG (str "A fully applied tactic is expected.")
else if has_type vle (topwit wit_tactic) then
let tac = out_gen (topwit wit_tactic) vle in
diff --git a/test-suite/output/Extraction_infix.out b/test-suite/output/Extraction_infix.out
new file mode 100644
index 0000000000..29d50775a9
--- /dev/null
+++ b/test-suite/output/Extraction_infix.out
@@ -0,0 +1,20 @@
+(** val test : foo **)
+
+let test =
+ (fun (b, p) -> bar) (True, False)
+(** val test : foo **)
+
+let test =
+ True@@?False
+(** val test : foo **)
+
+let test =
+ True#^^False
+(** val test : foo **)
+
+let test =
+ True@?:::False
+(** val test : foo **)
+
+let test =
+ True @?::: False
diff --git a/test-suite/output/Extraction_infix.v b/test-suite/output/Extraction_infix.v
new file mode 100644
index 0000000000..fe5926a36a
--- /dev/null
+++ b/test-suite/output/Extraction_infix.v
@@ -0,0 +1,26 @@
+(* @herbelin's example for issue #6212 *)
+
+Require Import Extraction.
+Inductive I := C : bool -> bool -> I.
+Definition test := C true false.
+
+(* the parentheses around the function wrong signalled an infix operator *)
+
+Extract Inductive I => "foo" [ "(fun (b, p) -> bar)" ].
+Extraction test.
+
+(* some bonafide infix operators *)
+
+Extract Inductive I => "foo" [ "(@@?)" ].
+Extraction test.
+
+Extract Inductive I => "foo" [ "(#^^)" ].
+Extraction test.
+
+Extract Inductive I => "foo" [ "(@?:::)" ].
+Extraction test.
+
+(* allow whitespace around infix operator *)
+
+Extract Inductive I => "foo" [ "( @?::: )" ].
+Extraction test.
diff --git a/test-suite/output/Notations2.out b/test-suite/output/Notations2.out
index 1ec701ae81..f57cc163d0 100644
--- a/test-suite/output/Notations2.out
+++ b/test-suite/output/Notations2.out
@@ -84,3 +84,9 @@ a≡
: Set
.α
: Set
+# a : .α =>
+# b : .α =>
+let res := 0 in
+for i from 0 to a updating (res)
+{{for j from 0 to b updating (res) {{S res}};; res}};; res
+ : .α -> .α -> .α
diff --git a/test-suite/output/Notations2.v b/test-suite/output/Notations2.v
index ceb29d1b9e..9ca180c9df 100644
--- a/test-suite/output/Notations2.v
+++ b/test-suite/output/Notations2.v
@@ -145,3 +145,24 @@ Check .a≡.
Notation ".α" := nat.
Check nat.
Check .α.
+
+(* A test for #6304 *)
+
+Module M6304.
+Notation "'for' m 'from' 0 'to' N 'updating' ( s1 ) {{ b }} ;; rest" :=
+ (let s1 :=
+ (fix rec(n: nat) := match n with
+ | 0 => s1
+ | S m => let s1 := rec m in b
+ end) N
+ in rest)
+ (at level 20).
+
+Check fun (a b : nat) =>
+ let res := 0 in
+ for i from 0 to a updating (res) {{
+ for j from 0 to b updating (res) {{ S res }};;
+ res
+ }};; res.
+
+End M6304.
diff --git a/test-suite/output/ltac_missing_args.out b/test-suite/output/ltac_missing_args.out
index 172612405f..7326f137c2 100644
--- a/test-suite/output/ltac_missing_args.out
+++ b/test-suite/output/ltac_missing_args.out
@@ -1,20 +1,40 @@
The command has indeed failed with message:
-A fully applied tactic is expected: missing argument for variable x.
+The user-defined tactic "Top.foo" was not fully applied:
+There is a missing argument for variable x,
+no arguments at all were provided.
The command has indeed failed with message:
-A fully applied tactic is expected: missing argument for variable x.
+The user-defined tactic "Top.bar" was not fully applied:
+There is a missing argument for variable x,
+no arguments at all were provided.
The command has indeed failed with message:
-A fully applied tactic is expected: missing arguments for variables y and _.
+The user-defined tactic "Top.bar" was not fully applied:
+There are missing arguments for variables y and _,
+an argument was provided for variable x.
The command has indeed failed with message:
-A fully applied tactic is expected: missing argument for variable x.
+The user-defined tactic "Top.baz" was not fully applied:
+There is a missing argument for variable x,
+no arguments at all were provided.
The command has indeed failed with message:
-A fully applied tactic is expected: missing argument for variable x.
+The user-defined tactic "Top.qux" was not fully applied:
+There is a missing argument for variable x,
+no arguments at all were provided.
The command has indeed failed with message:
-A fully applied tactic is expected: missing argument for variable _.
+The user-defined tactic "Top.mydo" was not fully applied:
+There is a missing argument for variable _,
+no arguments at all were provided.
The command has indeed failed with message:
-A fully applied tactic is expected: missing argument for variable _.
+An unnamed user-defined tactic was not fully applied:
+There is a missing argument for variable _,
+no arguments at all were provided.
The command has indeed failed with message:
-A fully applied tactic is expected: missing argument for variable _.
+An unnamed user-defined tactic was not fully applied:
+There is a missing argument for variable _,
+no arguments at all were provided.
The command has indeed failed with message:
-A fully applied tactic is expected: missing argument for variable x.
+The user-defined tactic "Top.rec" was not fully applied:
+There is a missing argument for variable x,
+no arguments at all were provided.
The command has indeed failed with message:
-A fully applied tactic is expected: missing argument for variable x.
+An unnamed user-defined tactic was not fully applied:
+There is a missing argument for variable x,
+an argument was provided for variable tac.
diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml
index f8ec05fdbf..63768d9b88 100644
--- a/vernac/vernacentries.ml
+++ b/vernac/vernacentries.ml
@@ -2268,5 +2268,10 @@ let interp ?(verbosely=true) ?proof ~st (loc,c) =
comments on the PR *)
let interp ?verbosely ?proof ~st cmd =
Vernacstate.unfreeze_interp_state st;
- interp ?verbosely ?proof ~st cmd;
- Vernacstate.freeze_interp_state `No
+ try
+ interp ?verbosely ?proof ~st cmd;
+ Vernacstate.freeze_interp_state `No
+ with exn ->
+ let exn = CErrors.push exn in
+ Vernacstate.invalidate_cache ();
+ iraise exn
diff --git a/vernac/vernacstate.ml b/vernac/vernacstate.ml
index 4a1ae14e3c..4980333b5d 100644
--- a/vernac/vernacstate.ml
+++ b/vernac/vernacstate.ml
@@ -12,18 +12,30 @@ type t = {
shallow : bool (* is the state trimmed down (libstack) *)
}
-let s_cache = ref (States.freeze ~marshallable:`No)
-let s_proof = ref (Proof_global.freeze ~marshallable:`No)
+let s_cache = ref None
+let s_proof = ref None
let invalidate_cache () =
- s_cache := Obj.magic 0;
- s_proof := Obj.magic 0
+ s_cache := None;
+ s_proof := None
+
+let update_cache rf v =
+ rf := Some v; v
+
+let do_if_not_cached rf f v =
+ match !rf with
+ | None ->
+ rf := Some v; f v
+ | Some vc when vc != v ->
+ rf := Some v; f v
+ | Some _ ->
+ ()
let freeze_interp_state marshallable =
- { system = (s_cache := States.freeze ~marshallable; !s_cache);
- proof = (s_proof := Proof_global.freeze ~marshallable; !s_proof);
+ { system = update_cache s_cache (States.freeze ~marshallable);
+ proof = update_cache s_proof (Proof_global.freeze ~marshallable);
shallow = marshallable = `Shallow }
let unfreeze_interp_state { system; proof } =
- if (!s_cache != system) then (s_cache := system; States.unfreeze system);
- if (!s_proof != proof) then (s_proof := proof; Proof_global.unfreeze proof)
+ do_if_not_cached s_cache States.unfreeze system;
+ do_if_not_cached s_proof Proof_global.unfreeze proof
generated by cgit v1.2.3 (git 2.25.1) at 2026-03-09 07:17:35 +0000