summaryrefslogtreecommitdiff
path: root/toplevel
diff options
context:
space:
mode:
Diffstat (limited to 'toplevel')
-rw-r--r--toplevel/coqargs.ml51
-rw-r--r--toplevel/coqargs.mli4
-rw-r--r--toplevel/coqinit.ml32
-rw-r--r--toplevel/coqinit.mli4
-rw-r--r--toplevel/coqloop.ml217
-rw-r--r--toplevel/coqloop.mli17
-rw-r--r--toplevel/coqtop.ml220
-rw-r--r--toplevel/coqtop.mli24
-rw-r--r--toplevel/coqtop_byte_bin.ml34
-rw-r--r--toplevel/g_toplevel.mlg54
-rw-r--r--toplevel/toplevel.mllib4
-rw-r--r--toplevel/usage.ml3
-rw-r--r--toplevel/vernac.ml36
-rw-r--r--toplevel/vernac.mli5
-rw-r--r--toplevel/workerLoop.ml29
-rw-r--r--toplevel/workerLoop.mli (renamed from toplevel/coqtop_opt_bin.ml)10
16 files changed, 413 insertions, 331 deletions
diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml
index eacd1dcf..01056b6a 100644
--- a/toplevel/coqargs.ml
+++ b/toplevel/coqargs.ml
@@ -10,8 +10,8 @@
let warning s = Flags.(with_option warn Feedback.msg_warning (Pp.strbrk s))
-let fatal_error ?extra exn =
- Topfmt.print_err_exn ?extra exn;
+let fatal_error exn =
+ Topfmt.print_err_exn Topfmt.ParsingCommandLine exn;
let exit_code = if CErrors.(is_anomaly exn || not (handled exn)) then 129 else 1 in
exit exit_code
@@ -52,7 +52,6 @@ type coq_cmdopts = {
compilation_mode : compilation_mode;
toplevel_name : Names.DirPath.t;
- toploop : string option;
compile_list: (string * bool) list; (* bool is verbosity *)
compilation_output_name : string option;
@@ -69,6 +68,7 @@ type coq_cmdopts = {
impredicative_set : Declarations.set_predicativity;
stm_flags : Stm.AsyncOpts.stm_opt;
debug : bool;
+ diffs_set : bool;
time : bool;
filter_opts : bool;
@@ -81,6 +81,8 @@ type coq_cmdopts = {
print_config: bool;
output_context : bool;
+ print_emacs : bool;
+
inputstate : string option;
outputstate : string option;
@@ -100,7 +102,6 @@ let init_args = {
compilation_mode = BuildVo;
toplevel_name = Names.(DirPath.make [Id.of_string "Top"]);
- toploop = None;
compile_list = [];
compilation_output_name = None;
@@ -117,6 +118,7 @@ let init_args = {
impredicative_set = Declarations.PredicativeSet;
stm_flags = Stm.AsyncOpts.default_opts;
debug = false;
+ diffs_set = false;
time = false;
filter_opts = false;
@@ -129,6 +131,8 @@ let init_args = {
print_config = false;
output_context = false;
+ print_emacs = false;
+
inputstate = None;
outputstate = None;
}
@@ -148,9 +152,9 @@ let add_vo_require opts d p export =
let add_compat_require opts v =
match v with
- | Flags.V8_6 -> add_vo_require opts "Coq.Compat.Coq86" None (Some false)
| Flags.V8_7 -> add_vo_require opts "Coq.Compat.Coq87" None (Some false)
- | Flags.Current -> add_vo_require opts "Coq.Compat.Coq88" None (Some false)
+ | Flags.V8_8 -> add_vo_require opts "Coq.Compat.Coq88" None (Some false)
+ | Flags.Current -> add_vo_require opts "Coq.Compat.Coq89" None (Some false)
let set_batch_mode opts =
Flags.quiet := true;
@@ -191,11 +195,8 @@ let set_vio_checking_j opts opt j =
(** Options for proof general *)
let set_emacs opts =
- if not (Option.is_empty opts.toploop) then
- CErrors.user_err Pp.(str "Flag -emacs is incompatible with a custom toplevel loop");
- Coqloop.print_emacs := true;
Printer.enable_goal_tags_printing := true;
- { opts with color = `OFF }
+ { opts with color = `OFF; print_emacs = true }
let set_color opts = function
| "yes" | "on" -> { opts with color = `ON }
@@ -310,12 +311,9 @@ let usage batch =
let lp = Coqinit.toplevel_init_load_path () in
(* Necessary for finding the toplevels below *)
List.iter Mltop.add_coq_path lp;
- if batch then Usage.print_usage_coqc ()
- else begin
- Mltop.load_ml_objects_raw_rex
- (Str.regexp (if Mltop.is_native then "^.*top.cmxs$" else "^.*top.cma$"));
- Usage.print_usage_coqtop ()
- end
+ if batch
+ then Usage.print_usage_coqc ()
+ else Usage.print_usage_coqtop ()
(* Main parsing routine *)
let parse_args arglist : coq_cmdopts * string list =
@@ -401,7 +399,7 @@ let parse_args arglist : coq_cmdopts * string list =
}}
|"-async-proofs-worker-priority" ->
- WorkerLoop.async_proofs_worker_priority := get_priority opt (next ());
+ CoqworkmgrApi.async_proofs_worker_priority := get_priority opt (next ());
oval
|"-async-proofs-private-flags" ->
@@ -427,7 +425,7 @@ let parse_args arglist : coq_cmdopts * string list =
|"-worker-id" -> set_worker_id opt (next ()); oval
|"-compat" ->
- let v = G_vernac.parse_compat_version ~allow_old:false (next ()) in
+ let v = G_vernac.parse_compat_version (next ()) in
Flags.compat_version := v;
add_compat_require oval v
@@ -500,11 +498,6 @@ let parse_args arglist : coq_cmdopts * string list =
let oval = add_compile oval false (next ()) in
{ oval with compilation_mode = Vio2Vo }
- |"-toploop" ->
- if !Coqloop.print_emacs then
- CErrors.user_err Pp.(str "Flags -toploop and -emacs are incompatible");
- { oval with toploop = Some (next ()) }
-
|"-w" | "-W" ->
let w = next () in
if w = "none" then
@@ -535,15 +528,15 @@ let parse_args arglist : coq_cmdopts * string list =
|"-color" -> set_color oval (next ())
|"-config"|"--config" -> { oval with print_config = true }
|"-debug" -> Coqinit.set_debug (); oval
+ |"-diffs" -> let opt = next () in
+ if List.exists (fun x -> opt = x) ["off"; "on"; "removed"] then
+ Proof_diffs.write_diffs_option opt
+ else
+ (prerr_endline ("Error: on|off|removed expected after -diffs"); exit 1);
+ { oval with diffs_set = true }
|"-stm-debug" -> Stm.stm_debug := true; oval
|"-emacs" -> set_emacs oval
|"-filteropts" -> { oval with filter_opts = true }
- |"-ideslave" ->
- if !Coqloop.print_emacs then
- CErrors.user_err Pp.(str "Flags -ideslave and -emacs are incompatible");
- Flags.ide_slave := true;
- { oval with toploop = Some "coqidetop" }
-
|"-impredicative-set" ->
{ oval with impredicative_set = Declarations.ImpredicativeSet }
|"-indices-matter" -> Indtypes.enforce_indices_matter (); oval
diff --git a/toplevel/coqargs.mli b/toplevel/coqargs.mli
index de9b6a68..7b0cdcf1 100644
--- a/toplevel/coqargs.mli
+++ b/toplevel/coqargs.mli
@@ -27,7 +27,6 @@ type coq_cmdopts = {
compilation_mode : compilation_mode;
toplevel_name : Names.DirPath.t;
- toploop : string option;
compile_list: (string * bool) list; (* bool is verbosity *)
compilation_output_name : string option;
@@ -44,6 +43,7 @@ type coq_cmdopts = {
impredicative_set : Declarations.set_predicativity;
stm_flags : Stm.AsyncOpts.stm_opt;
debug : bool;
+ diffs_set : bool;
time : bool;
filter_opts : bool;
@@ -56,6 +56,8 @@ type coq_cmdopts = {
print_config: bool;
output_context : bool;
+ print_emacs : bool;
+
inputstate : string option;
outputstate : string option;
diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml
index 96a0bd5e..e1d35e53 100644
--- a/toplevel/coqinit.ml
+++ b/toplevel/coqinit.ml
@@ -23,12 +23,12 @@ let set_debug () =
let rcdefaultname = "coqrc"
-let load_rcfile ~rcfile ~time ~state =
+let load_rcfile ~rcfile ~state =
try
match rcfile with
| Some rcfile ->
if CUnix.file_readable_p rcfile then
- Vernac.load_vernac ~time ~echo:false ~interactive:false ~check:true ~state rcfile
+ Vernac.load_vernac ~echo:false ~interactive:false ~check:true ~state rcfile
else raise (Sys_error ("Cannot read rcfile: "^ rcfile))
| None ->
try
@@ -39,7 +39,7 @@ let load_rcfile ~rcfile ~time ~state =
Envars.home ~warn / "."^rcdefaultname^"."^Coq_config.version;
Envars.home ~warn / "."^rcdefaultname
] in
- Vernac.load_vernac ~time ~echo:false ~interactive:false ~check:true ~state inferedrc
+ Vernac.load_vernac ~echo:false ~interactive:false ~check:true ~state inferedrc
with Not_found -> state
(*
Flags.if_verbose
@@ -75,16 +75,12 @@ let ml_path_if c p =
let f x = { recursive = false; path_spec = MlPath x } in
if c then List.map f p else []
-(* LoadPath for toploop toplevels *)
+(* LoadPath for developers *)
let toplevel_init_load_path () =
let coqlib = Envars.coqlib () in
(* NOTE: These directories are searched from last to first *)
(* first, developer specific directory to open *)
- ml_path_if Coq_config.local [coqlib/"dev"] @
-
- (* main loops *)
- ml_path_if (Coq_config.local || !Flags.boot) [coqlib/"stm"; coqlib/"ide"] @
- ml_path_if (System.exists_dir (coqlib/"toploop")) [coqlib/"toploop"]
+ ml_path_if Coq_config.local [coqlib/"dev"]
(* LoadPath for Coq user libraries *)
let libs_init_load_path ~load_init =
@@ -96,6 +92,14 @@ let libs_init_load_path ~load_init =
let coqpath = Envars.coqpath in
let coq_path = Names.DirPath.make [Libnames.coq_root] in
+ (* current directory (not recursively!) *)
+ [ { recursive = false;
+ path_spec = VoPath { unix_path = ".";
+ coq_path = Libnames.default_root_prefix;
+ implicit = false;
+ has_ml = AddTopML }
+ } ] @
+
(* then standard library and plugins *)
[build_stdlib_path ~load_init ~unix_path:(coqlib/"theories") ~coq_path ~with_ml:false;
build_stdlib_path ~load_init ~unix_path:(coqlib/"plugins") ~coq_path ~with_ml:true ] @
@@ -106,15 +110,7 @@ let libs_init_load_path ~load_init =
) @
(* then directories in XDG_DATA_DIRS and XDG_DATA_HOME and COQPATH *)
- List.map (fun s -> build_userlib_path ~unix_path:s) (xdg_dirs @ coqpath) @
-
- (* then current directory (not recursively!) *)
- [ { recursive = false;
- path_spec = VoPath { unix_path = ".";
- coq_path = Libnames.default_root_prefix;
- implicit = false;
- has_ml = AddTopML }
- } ]
+ List.map (fun s -> build_userlib_path ~unix_path:s) (xdg_dirs @ coqpath)
(* Initialises the Ocaml toplevel before launching it, so that it can
find the "include" file in the *source* directory *)
diff --git a/toplevel/coqinit.mli b/toplevel/coqinit.mli
index 71b5523c..c891e736 100644
--- a/toplevel/coqinit.mli
+++ b/toplevel/coqinit.mli
@@ -12,12 +12,12 @@
val set_debug : unit -> unit
-val load_rcfile : rcfile:(string option) -> time:bool -> state:Vernac.State.t -> Vernac.State.t
+val load_rcfile : rcfile:(string option) -> state:Vernac.State.t -> Vernac.State.t
val init_ocaml_path : unit -> unit
(* LoadPath for toploop toplevels *)
-val toplevel_init_load_path : unit -> Mltop.coq_path list
+val toplevel_init_load_path : unit -> Mltop.coq_path list
(* LoadPath for Coq user libraries *)
val libs_init_load_path : load_init:bool -> Mltop.coq_path list
diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml
index 3239d360..59a464a2 100644
--- a/toplevel/coqloop.ml
+++ b/toplevel/coqloop.ml
@@ -23,7 +23,7 @@ type input_buffer = {
mutable str : Bytes.t; (* buffer of already read characters *)
mutable len : int; (* number of chars in the buffer *)
mutable bols : int list; (* offsets in str of beginning of lines *)
- mutable tokens : Pcoq.Gram.coq_parsable; (* stream of tokens *)
+ mutable tokens : Pcoq.Parsable.t; (* stream of tokens *)
mutable start : int } (* stream count of the first char of the buffer *)
(* Double the size of the buffer. *)
@@ -76,7 +76,7 @@ let reset_input_buffer doc ic ibuf =
ibuf.str <- Bytes.empty;
ibuf.len <- 0;
ibuf.bols <- [];
- ibuf.tokens <- Pcoq.Gram.parsable (Stream.from (prompt_char doc ic ibuf));
+ ibuf.tokens <- Pcoq.Parsable.make (Stream.from (prompt_char doc ic ibuf));
ibuf.start <- 0
(* Functions to print underlined locations from an input buffer. *)
@@ -150,29 +150,28 @@ let print_highlight_location ib loc =
let valid_buffer_loc ib loc =
let (b,e) = Loc.unloc loc in b-ib.start >= 0 && e-ib.start < ib.len && b<=e
-
(* Toplevel error explanation. *)
-let error_info_for_buffer ?loc buf =
- Option.map (fun loc ->
+let error_info_for_buffer ?loc phase buf =
+ match loc with
+ | None -> Topfmt.pr_phase ?loc phase
+ | Some loc ->
let fname = loc.Loc.fname in
- let hl, loc =
(* We are in the toplevel *)
- match fname with
- | Loc.ToplevelInput ->
- let nloc = adjust_loc_buf buf loc in
- if valid_buffer_loc buf loc then
- (fnl () ++ print_highlight_location buf nloc, nloc)
- (* in the toplevel, but not a valid buffer *)
- else (mt (), nloc)
- (* we are in batch mode, don't adjust location *)
- | Loc.InFile _ ->
- (mt (), loc)
- in Topfmt.pr_loc loc ++ hl
- ) loc
+ match fname with
+ | Loc.ToplevelInput ->
+ let nloc = adjust_loc_buf buf loc in
+ if valid_buffer_loc buf loc then
+ match Topfmt.pr_phase ~loc:nloc phase with
+ | None -> None
+ | Some hd -> Some (hd ++ fnl () ++ print_highlight_location buf nloc)
+ (* in the toplevel, but not a valid buffer *)
+ else Topfmt.pr_phase ~loc phase
+ (* we are in batch mode, don't adjust location *)
+ | Loc.InFile _ -> Topfmt.pr_phase ~loc phase
(* Actual printing routine *)
-let print_error_for_buffer ?loc lvl msg buf =
- let pre_hdr = error_info_for_buffer ?loc buf in
+let print_error_for_buffer ?loc phase lvl msg buf =
+ let pre_hdr = error_info_for_buffer ?loc phase buf in
if !print_emacs
then Topfmt.emacs_logger ?pre_hdr lvl msg
else Topfmt.std_logger ?pre_hdr lvl msg
@@ -229,7 +228,7 @@ let top_buffer =
str = Bytes.empty;
len = 0;
bols = [];
- tokens = Pcoq.Gram.parsable (Stream.of_list []);
+ tokens = Pcoq.Parsable.make (Stream.of_list []);
start = 0 }
let set_prompt prompt =
@@ -254,15 +253,15 @@ let parse_to_dot =
let rec discard_to_dot () =
try
- Pcoq.Gram.entry_parse parse_to_dot top_buffer.tokens
+ Pcoq.Entry.parse parse_to_dot top_buffer.tokens
with
| Token.Error _ | CLexer.Error.E _ -> discard_to_dot ()
| Stm.End_of_input -> raise Stm.End_of_input
| e when CErrors.noncritical e -> ()
let read_sentence ~state input =
- let open Vernac.State in
- try Stm.parse_sentence ~doc:state.doc state.sid input
+ (* XXX: careful with ignoring the state Eugene!*)
+ try G_toplevel.parse_toplevel input
with reraise ->
let reraise = CErrors.push reraise in
discard_to_dot ();
@@ -282,7 +281,7 @@ let extract_default_loc loc doc_id sid : Loc.t option =
with _ -> loc
(** Coqloop Console feedback handler *)
-let coqloop_feed (fb : Feedback.feedback) = let open Feedback in
+let coqloop_feed phase (fb : Feedback.feedback) = let open Feedback in
match fb.contents with
| Processed -> ()
| Incomplete -> ()
@@ -301,43 +300,9 @@ let coqloop_feed (fb : Feedback.feedback) = let open Feedback in
(* TopErr.print_error_for_buffer ?loc lvl msg top_buffer *)
| Message (Warning,loc,msg) ->
let loc = extract_default_loc loc fb.doc_id fb.span_id in
- TopErr.print_error_for_buffer ?loc Warning msg top_buffer
+ TopErr.print_error_for_buffer ?loc phase Warning msg top_buffer
| Message (lvl,loc,msg) ->
- TopErr.print_error_for_buffer ?loc lvl msg top_buffer
-
-(** [do_vernac] reads and executes a toplevel phrase, and print error
- messages when an exception is raised, except for the following:
- - Drop: kill the Coq toplevel, going down to the Caml toplevel if it exists.
- Otherwise, exit.
- - End_of_input: Ctrl-D was typed in, we will quit.
-
- In particular, this is normally the only place where a Sys.Break
- is caught and handled (i.e. not re-raised).
-*)
-
-let do_vernac ~time ~state =
- let open Vernac.State in
- top_stderr (fnl());
- if !print_emacs then top_stderr (str (top_buffer.prompt state.doc));
- resynch_buffer top_buffer;
- try
- let input = (top_buffer.tokens, None) in
- Vernac.process_expr ~time ~state (read_sentence ~state (fst input))
- with
- | Stm.End_of_input | CErrors.Quit ->
- top_stderr (fnl ()); raise CErrors.Quit
- | CErrors.Drop -> (* Last chance *)
- if Mltop.is_ocaml_top() then raise CErrors.Drop
- else (Feedback.msg_warning (str "There is no ML toplevel."); state)
- (* Exception printing should be done by the feedback listener,
- however this is not yet ready so we rely on the exception for
- now. *)
- | any ->
- let (e, info) = CErrors.push any in
- let loc = Loc.get_loc info in
- let msg = CErrors.iprint (e, info) in
- TopErr.print_error_for_buffer ?loc Feedback.Error msg top_buffer;
- state
+ TopErr.print_error_for_buffer ?loc phase lvl msg top_buffer
(** Main coq loop : read vernacular expressions until Drop is entered.
Ctrl-C is handled internally as Sys.Break instead of aborting Coq.
@@ -353,12 +318,6 @@ let loop_flush_all () =
Format.pp_print_flush !Topfmt.std_ft ();
Format.pp_print_flush !Topfmt.err_ft ()
-let pr_open_cur_subgoals () =
- try
- let proof = Proof_global.give_me_the_proof () in
- Printer.pr_open_subgoals ~proof
- with Proof_global.NoCurrentProof -> Pp.str ""
-
(* Goal equality heuristic. *)
let pequal cmp1 cmp2 (a1,a2) (b1,b2) = cmp1 a1 b1 && cmp2 a2 b2
let evleq e1 e2 = CList.equal Evar.equal e1 e2
@@ -369,53 +328,117 @@ let cproof p1 p2 =
CList.equal Evar.equal a3 b3 &&
CList.equal Evar.equal a4 b4
+let drop_last_doc = ref None
+
+(* todo: could add other Set/Unset commands, such as "Printing Universes" *)
+let print_anyway_opts = [
+ [ "Diffs" ];
+ ]
+
+let print_anyway c =
+ let open Vernacexpr in
+ match c with
+ | VernacExpr (_, VernacSetOption (_, opt, _))
+ | VernacExpr (_, VernacUnsetOption (_, opt)) ->
+ List.mem opt print_anyway_opts
+ | _ -> false
+
(* We try to behave better when goal printing raises an exception
[usually Ctrl-C]
This is mostly a hack as we should protect printing in a more
generic way, but that'll do for now *)
-let top_goal_print oldp newp =
+let top_goal_print ~doc c oldp newp =
try
let proof_changed = not (Option.equal cproof oldp newp) in
- let print_goals = not !Flags.quiet &&
- proof_changed && Proof_global.there_are_pending_proofs () in
- if print_goals then Feedback.msg_notice (pr_open_cur_subgoals ())
+ let print_goals = proof_changed && Proof_global.there_are_pending_proofs () ||
+ print_anyway c in
+ if not !Flags.quiet && print_goals then begin
+ let dproof = Stm.get_prev_proof ~doc (Stm.get_current_state ~doc) in
+ Printer.print_and_diff dproof newp
+ end
with
- | CErrors.Drop | CErrors.Quit as exn -> raise exn
| exn ->
let (e, info) = CErrors.push exn in
let loc = Loc.get_loc info in
let msg = CErrors.iprint (e, info) in
- TopErr.print_error_for_buffer ?loc Feedback.Error msg top_buffer
+ TopErr.print_error_for_buffer ?loc Topfmt.InteractiveLoop Feedback.Error msg top_buffer
-let drop_last_doc = ref None
+(* Careful to keep this loop tail-rec *)
+let rec vernac_loop ~state =
+ let open CAst in
+ let open Vernac.State in
+ let open G_toplevel in
+ loop_flush_all ();
+ top_stderr (fnl());
+ if !print_emacs then top_stderr (str (top_buffer.prompt state.doc));
+ resynch_buffer top_buffer;
+ (* execute one command *)
+ try
+ let input = top_buffer.tokens in
+ match read_sentence ~state input with
+ | {v=VernacBacktrack(bid,_,_)} ->
+ let bid = Stateid.of_int bid in
+ let doc, res = Stm.edit_at ~doc:state.doc bid in
+ assert (res = `NewTip);
+ let state = { state with doc; sid = bid } in
+ vernac_loop ~state
+
+ | {v=VernacQuit} ->
+ exit 0
+ | {v=VernacDrop} ->
+ if Mltop.is_ocaml_top()
+ then (drop_last_doc := Some state; state)
+ else (Feedback.msg_warning (str "There is no ML toplevel."); vernac_loop ~state)
+ | {v=VernacControl c; loc} ->
+ let nstate = Vernac.process_expr ~state (make ?loc c) in
+ top_goal_print ~doc:state.doc c state.proof nstate.proof;
+ vernac_loop ~state:nstate
+ with
+ | Stm.End_of_input ->
+ top_stderr (fnl ()); exit 0
+ (* Exception printing should be done by the feedback listener,
+ however this is not yet ready so we rely on the exception for
+ now. *)
+ | any ->
+ let (e, info) = CErrors.push any in
+ let loc = Loc.get_loc info in
+ let msg = CErrors.iprint (e, info) in
+ TopErr.print_error_for_buffer ?loc Topfmt.InteractiveLoop Feedback.Error msg top_buffer;
+ vernac_loop ~state
-let rec loop ~time ~state =
+let rec loop ~state =
let open Vernac.State in
Sys.catch_break true;
try
reset_input_buffer state.doc stdin top_buffer;
- (* Be careful to keep this loop tail-recursive *)
- let rec vernac_loop ~state =
- let nstate = do_vernac ~time ~state in
- top_goal_print state.proof nstate.proof;
- loop_flush_all ();
- vernac_loop ~state:nstate
- in vernac_loop ~state
+ vernac_loop ~state
with
- | CErrors.Drop ->
- (* Due to using exceptions as a form of control, state here goes
- out of sync as [do_vernac] will never return. We must thus do
- this hack until we make `Drop` a toplevel-only command. See
- bug #6872. *)
- let state = { state with sid = Stm.get_current_state ~doc:state.doc } in
- drop_last_doc := Some state;
- state
- | CErrors.Quit -> exit 0
| any ->
- top_stderr (str "Anomaly: main loop exited with exception: " ++
- str (Printexc.to_string any) ++
- fnl() ++
- str"Please report" ++
- strbrk" at " ++ str Coq_config.wwwbugtracker ++ str ".");
- loop ~time ~state
+ top_stderr
+ (hov 0 (str "Anomaly: main loop exited with exception:" ++ spc () ++
+ str (Printexc.to_string any)) ++ spc () ++
+ hov 0 (str "Please report at " ++ str Coq_config.wwwbugtracker ++ str "."));
+ loop ~state
+
+(* Default toplevel loop *)
+let warning s = Flags.(with_option warn Feedback.msg_warning (strbrk s))
+
+let drop_args = ref None
+let loop ~opts ~state =
+ drop_args := Some opts;
+ let open Coqargs in
+ print_emacs := opts.print_emacs;
+ (* We initialize the console only if we run the toploop_run *)
+ let tl_feed = Feedback.add_feeder (coqloop_feed Topfmt.InteractiveLoop) in
+ if Dumpglob.dump () then begin
+ Flags.if_verbose warning "Dumpglob cannot be used in interactive mode.";
+ Dumpglob.noglob ()
+ end;
+ let _ = loop ~state in
+ (* Initialise and launch the Ocaml toplevel *)
+ Coqinit.init_ocaml_path();
+ Mltop.ocaml_toploop();
+ (* We delete the feeder after the OCaml toploop has ended so users
+ of Drop can see the feedback. *)
+ Feedback.del_feeder tl_feed
diff --git a/toplevel/coqloop.mli b/toplevel/coqloop.mli
index bbb9b138..b11f13d3 100644
--- a/toplevel/coqloop.mli
+++ b/toplevel/coqloop.mli
@@ -10,9 +10,6 @@
(** The Coq toplevel loop. *)
-(** -emacs option: printing includes emacs tags. *)
-val print_emacs : bool ref
-
(** A buffer for the character read from a channel. We store the command
* entered to be able to report errors without pretty-printing. *)
@@ -21,7 +18,7 @@ type input_buffer = {
mutable str : Bytes.t; (** buffer of already read characters *)
mutable len : int; (** number of chars in the buffer *)
mutable bols : int list; (** offsets in str of begining of lines *)
- mutable tokens : Pcoq.Gram.coq_parsable; (** stream of tokens *)
+ mutable tokens : Pcoq.Parsable.t; (** stream of tokens *)
mutable start : int } (** stream count of the first char of the buffer *)
(** The input buffer of stdin. *)
@@ -30,13 +27,11 @@ val top_buffer : input_buffer
val set_prompt : (unit -> string) -> unit
(** Toplevel feedback printer. *)
-val coqloop_feed : Feedback.feedback -> unit
-
-(** Parse and execute one vernac command. *)
-val do_vernac : time:bool -> state:Vernac.State.t -> Vernac.State.t
-
-(** Main entry point of Coq: read and execute vernac commands. *)
-val loop : time:bool -> state:Vernac.State.t -> Vernac.State.t
+val coqloop_feed : Topfmt.execution_phase -> Feedback.feedback -> unit
(** Last document seen after `Drop` *)
val drop_last_doc : Vernac.State.t option ref
+val drop_args : Coqargs.coq_cmdopts option ref
+
+(** Main entry point of Coq: read and execute vernac commands. *)
+val loop : opts:Coqargs.coq_cmdopts -> state:Vernac.State.t -> unit
diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml
index 943b66f6..09ecb7ec 100644
--- a/toplevel/coqtop.ml
+++ b/toplevel/coqtop.ml
@@ -30,29 +30,14 @@ let print_header () =
Feedback.msg_notice (str "Welcome to Coq " ++ str ver ++ str " (" ++ str rev ++ str ")");
flush_all ()
-let warning s = Flags.(with_option warn Feedback.msg_warning (strbrk s))
-
(* Feedback received in the init stage, this is different as the STM
will not be generally be initialized, thus stateid, etc... may be
bogus. For now we just print to the console too *)
-let coqtop_init_feed = Coqloop.coqloop_feed
-
-(* Default toplevel loop *)
-let console_toploop_run opts ~state =
- (* We initialize the console only if we run the toploop_run *)
- let tl_feed = Feedback.add_feeder Coqloop.coqloop_feed in
- if Dumpglob.dump () then begin
- Flags.if_verbose warning "Dumpglob cannot be used in interactive mode.";
- Dumpglob.noglob ()
- end;
- let _ = Coqloop.loop ~time:opts.time ~state in
- (* Initialise and launch the Ocaml toplevel *)
- Coqinit.init_ocaml_path();
- Mltop.ocaml_toploop();
- (* We let the feeder in place for users of Drop *)
- Feedback.del_feeder tl_feed
+let coqtop_init_feed = Coqloop.coqloop_feed Topfmt.Initialization
-let toploop_run = ref console_toploop_run
+let coqtop_doc_feed = Coqloop.coqloop_feed Topfmt.LoadingPrelude
+
+let coqtop_rcfile_feed = Coqloop.coqloop_feed Topfmt.LoadingRcFile
let memory_stat = ref false
let print_memory_stat () =
@@ -95,15 +80,22 @@ let load_vernacular opts ~state =
(fun state (f_in, echo) ->
let s = Loadpath.locate_file f_in in
(* Should make the beautify logic clearer *)
- let load_vernac f = Vernac.load_vernac ~time:opts.time ~echo ~interactive:false ~check:true ~state f in
+ let load_vernac f = Vernac.load_vernac ~echo ~interactive:false ~check:true ~state f in
if !Flags.beautify
then Flags.with_option Flags.beautify_file load_vernac f_in
else load_vernac s
) state (List.rev opts.load_vernacular_list)
-let load_init_vernaculars opts ~state =
- let state = if opts.load_rcfile then
- Coqinit.load_rcfile ~rcfile:opts.rcfile ~time:opts.time ~state
+let load_init_vernaculars cur_feeder opts ~state =
+ let state =
+ if opts.load_rcfile then begin
+ Feedback.del_feeder !cur_feeder;
+ let rc_feeder = Feedback.add_feeder coqtop_rcfile_feed in
+ let state = Coqinit.load_rcfile ~rcfile:opts.rcfile ~state in
+ Feedback.del_feeder rc_feeder;
+ cur_feeder := Feedback.add_feeder coqtop_init_feed;
+ state
+ end
else begin
Flags.if_verbose Feedback.msg_info (str"Skipping rcfile loading.");
state
@@ -147,8 +139,8 @@ let fatal_error msg =
flush_all ();
exit 1
-let fatal_error_exn ?extra exn =
- Topfmt.print_err_exn ?extra exn;
+let fatal_error_exn exn =
+ Topfmt.print_err_exn Topfmt.Initialization exn;
flush_all ();
let exit_code =
if CErrors.(is_anomaly exn || not (handled exn)) then 129 else 1
@@ -194,7 +186,7 @@ let ensure_exists f =
fatal_error (hov 0 (str "Can't find file" ++ spc () ++ str f))
(* Compile a vernac file *)
-let compile opts ~echo ~f_in ~f_out =
+let compile cur_feeder opts ~echo ~f_in ~f_out =
let open Vernac.State in
let check_pending_proofs () =
let pfs = Proof_global.get_all_proof_names () in
@@ -218,13 +210,18 @@ let compile opts ~echo ~f_in ~f_out =
| None -> long_f_dot_v ^ "o"
| Some f -> ensure_vo long_f_dot_v f in
- let doc, sid = Stm.(new_doc
+ Feedback.del_feeder !cur_feeder;
+ let doc_feeder = Feedback.add_feeder coqtop_doc_feed in
+ let doc, sid =
+ Stm.(new_doc
{ doc_type = VoDoc long_f_dot_vo;
iload_path; require_libs; stm_options;
}) in
+ Feedback.del_feeder doc_feeder;
+ cur_feeder := Feedback.add_feeder coqtop_init_feed;
- let state = { doc; sid; proof = None } in
- let state = load_init_vernaculars opts ~state in
+ let state = { doc; sid; proof = None; time = opts.time } in
+ let state = load_init_vernaculars cur_feeder opts ~state in
let ldir = Stm.get_ldir ~doc:state.doc in
Aux_file.(start_aux_file
~aux_file:(aux_file_name_for long_f_dot_vo)
@@ -232,7 +229,7 @@ let compile opts ~echo ~f_in ~f_out =
Dumpglob.start_dump_glob ~vfile:long_f_dot_v ~vofile:long_f_dot_vo;
Dumpglob.dump_string ("F" ^ Names.DirPath.to_string ldir ^ "\n");
let wall_clock1 = Unix.gettimeofday () in
- let state = Vernac.load_vernac ~time:opts.time ~echo ~check:true ~interactive:false ~state long_f_dot_v in
+ let state = Vernac.load_vernac ~echo ~check:true ~interactive:false ~state long_f_dot_v in
let _doc = Stm.join ~doc:state.doc in
let wall_clock2 = Unix.gettimeofday () in
check_pending_proofs ();
@@ -265,15 +262,20 @@ let compile opts ~echo ~f_in ~f_out =
async_proofs_tac_error_resilience = `None;
} in
- let doc, sid = Stm.(new_doc
+ Feedback.del_feeder !cur_feeder;
+ let doc_feeder = Feedback.add_feeder coqtop_doc_feed in
+ let doc, sid =
+ Stm.(new_doc
{ doc_type = VioDoc long_f_dot_vio;
iload_path; require_libs; stm_options;
}) in
+ Feedback.del_feeder doc_feeder;
+ cur_feeder := Feedback.add_feeder coqtop_init_feed;
- let state = { doc; sid; proof = None } in
- let state = load_init_vernaculars opts ~state in
+ let state = { doc; sid; proof = None; time = opts.time } in
+ let state = load_init_vernaculars cur_feeder opts ~state in
let ldir = Stm.get_ldir ~doc:state.doc in
- let state = Vernac.load_vernac ~time:opts.time ~echo ~check:false ~interactive:false ~state long_f_dot_v in
+ let state = Vernac.load_vernac ~echo ~check:false ~interactive:false ~state long_f_dot_v in
let doc = Stm.finish ~doc:state.doc in
check_pending_proofs ();
let _doc = Stm.snapshot_vio ~doc ldir long_f_dot_vio in
@@ -288,22 +290,22 @@ let compile opts ~echo ~f_in ~f_out =
let univs, proofs = Stm.finish_tasks lfdv univs disch proofs tasks in
Library.save_library_raw lfdv sum lib univs proofs
-let compile opts ~echo ~f_in ~f_out =
+let compile cur_feeder opts ~echo ~f_in ~f_out =
ignore(CoqworkmgrApi.get 1);
- compile opts ~echo ~f_in ~f_out;
+ compile cur_feeder opts ~echo ~f_in ~f_out;
CoqworkmgrApi.giveback 1
-let compile_file opts (f_in, echo) =
+let compile_file cur_feeder opts (f_in, echo) =
let f_out = opts.compilation_output_name in
if !Flags.beautify then
Flags.with_option Flags.beautify_file
- (fun f_in -> compile opts ~echo ~f_in ~f_out) f_in
+ (fun f_in -> compile cur_feeder opts ~echo ~f_in ~f_out) f_in
else
- compile opts ~echo ~f_in ~f_out
+ compile cur_feeder opts ~echo ~f_in ~f_out
-let compile_files opts =
+let compile_files cur_feeder opts =
let compile_list = List.rev opts.compile_list in
- List.iter (compile_file opts) compile_list
+ List.iter (compile_file cur_feeder opts) compile_list
(******************************************************************************)
(* VIO Dispatching *)
@@ -337,8 +339,8 @@ let do_vio opts =
(******************************************************************************)
(* Color Options *)
(******************************************************************************)
-let init_color color_mode =
- let has_color = match color_mode with
+let init_color opts =
+ let has_color = match opts.color with
| `OFF -> false
| `ON -> true
| `AUTO ->
@@ -348,32 +350,23 @@ let init_color color_mode =
its TERM variable is set to "dumb". *)
try Sys.getenv "TERM" <> "dumb" with Not_found -> false
in
- if has_color then begin
- let colors = try Some (Sys.getenv "COQ_COLORS") with Not_found -> None in
- match colors with
- | None ->
- (** Default colors *)
- Topfmt.default_styles ();
- Topfmt.init_terminal_output ~color:true
- | Some "" ->
- (** No color output *)
- Topfmt.init_terminal_output ~color:false
- | Some s ->
- (** Overwrite all colors *)
- Topfmt.parse_color_config s;
- Topfmt.init_terminal_output ~color:true
- end
- else
- Topfmt.init_terminal_output ~color:false
-
-let toploop_init = ref begin fun opts x ->
- let () = init_color opts.color in
- let () = CoqworkmgrApi.init !WorkerLoop.async_proofs_worker_priority in
- x
- end
+ let term_color =
+ if has_color then begin
+ let colors = try Some (Sys.getenv "COQ_COLORS") with Not_found -> None in
+ match colors with
+ | None -> Topfmt.default_styles (); true (** Default colors *)
+ | Some "" -> false (** No color output *)
+ | Some s -> Topfmt.parse_color_config s; true (** Overwrite all colors *)
+ end
+ else
+ false
+ in
+ if Proof_diffs.show_diffs () && not term_color && not opts.batch_mode then
+ (prerr_endline "Error: -diffs requires enabling -color"; exit 1);
+ Topfmt.init_terminal_output ~color:term_color
let print_style_tags opts =
- let () = init_color opts.color in
+ let () = init_color opts in
let tags = Topfmt.dump_tags () in
let iter (t, st) =
let opt = Terminal.eval st ^ t ^ Terminal.reset ^ "\n" in
@@ -391,7 +384,7 @@ let print_style_tags opts =
(** GC tweaking *)
(** Coq is a heavy user of persistent data structures and symbolic ASTs, so the
- minor heap is heavily sollicited. Unfortunately, the default size is far too
+ minor heap is heavily solicited. Unfortunately, the default size is far too
small, so we enlarge it a lot (128 times larger).
To better handle huge memory consumers, we also augment the default major
@@ -414,14 +407,14 @@ let init_gc () =
Gc.space_overhead = 120}
(** Main init routine *)
-let init_toplevel arglist =
+let init_toplevel custom_init arglist =
(* Coq's init process, phase 1:
OCaml parameters, basic structures, and IO
*)
CProfile.init_profile ();
init_gc ();
Sys.catch_break false; (* Ctrl-C is fatal during the initialisation *)
- let init_feeder = Feedback.add_feeder coqtop_init_feed in
+ let init_feeder = ref (Feedback.add_feeder coqtop_init_feed) in
Lib.init();
(* Coq's init process, phase 2:
@@ -436,20 +429,30 @@ let init_toplevel arglist =
* early since the master waits us to connect back *)
Spawned.init_channels ();
Envars.set_coqlib ~fail:(fun msg -> CErrors.user_err Pp.(str msg));
- if opts.print_where then (print_endline(Envars.coqlib ()); exit(exitcode opts));
- if opts.print_config then (Envars.print_config stdout Coq_config.all_src_dirs; exit (exitcode opts));
- if opts.print_tags then (print_style_tags opts; exit (exitcode opts));
- if opts.filter_opts then (print_string (String.concat "\n" extras); exit 0);
+ if opts.print_where then begin
+ print_endline (Envars.coqlib ());
+ exit (exitcode opts)
+ end;
+ if opts.print_config then begin
+ Envars.print_config stdout Coq_config.all_src_dirs;
+ exit (exitcode opts)
+ end;
+ if opts.print_tags then begin
+ print_style_tags opts;
+ exit (exitcode opts)
+ end;
+ if opts.filter_opts then begin
+ print_string (String.concat "\n" extras);
+ exit 0;
+ end;
let top_lp = Coqinit.toplevel_init_load_path () in
List.iter Mltop.add_coq_path top_lp;
- Option.iter Mltop.load_ml_object_raw opts.toploop;
- let extras = !toploop_init opts extras in
+ let opts, extras = custom_init ~opts extras in
if not (CList.is_empty extras) then begin
prerr_endline ("Don't know what to do with "^String.concat " " extras);
prerr_endline "See -help for the list of supported options";
exit 1
end;
- Flags.if_verbose print_header ();
Mltop.init_known_plugins ();
Global.set_engagement opts.impredicative_set;
@@ -478,41 +481,54 @@ let init_toplevel arglist =
let iload_path = build_load_path opts in
let require_libs = require_libs opts in
let stm_options = opts.stm_flags in
- try
- let open Vernac.State in
- let doc, sid =
- Stm.(new_doc
- { doc_type = Interactive opts.toplevel_name;
- iload_path; require_libs; stm_options;
- }) in
- let state = { doc; sid; proof = None } in
- Some (load_init_vernaculars opts ~state), opts
- with any -> flush_all(); fatal_error_exn any
+ let open Vernac.State in
+ Feedback.del_feeder !init_feeder;
+ let doc_feeder = Feedback.add_feeder coqtop_doc_feed in
+ let doc, sid =
+ Stm.(new_doc
+ { doc_type = Interactive opts.toplevel_name;
+ iload_path; require_libs; stm_options;
+ }) in
+ Feedback.del_feeder doc_feeder;
+ init_feeder := Feedback.add_feeder coqtop_init_feed;
+ let state = { doc; sid; proof = None; time = opts.time } in
+ Some (load_init_vernaculars init_feeder opts ~state), opts
(* Non interactive: we perform a sequence of compilation steps *)
end else begin
- try
- compile_files opts;
- (* Careful this will modify the load-path and state so after
- this point some stuff may not be safe anymore. *)
- do_vio opts;
- (* Allow the user to output an arbitrary state *)
- outputstate opts;
- None, opts
- with any -> flush_all(); fatal_error_exn any
+ compile_files init_feeder opts;
+ (* Careful this will modify the load-path and state so after
+ this point some stuff may not be safe anymore. *)
+ do_vio opts;
+ (* Allow the user to output an arbitrary state *)
+ outputstate opts;
+ None, opts
end;
with any ->
flush_all();
- let extra = Some (str "Error during initialization: ") in
- fatal_error_exn ?extra any
+ fatal_error_exn any
end in
- Feedback.del_feeder init_feeder;
+ Feedback.del_feeder !init_feeder;
res
-let start () =
- match init_toplevel (List.tl (Array.to_list Sys.argv)) with
+type custom_toplevel = {
+ init : opts:coq_cmdopts -> string list -> coq_cmdopts * string list;
+ run : opts:coq_cmdopts -> state:Vernac.State.t -> unit;
+}
+
+let coqtop_init ~opts extra =
+ init_color opts;
+ CoqworkmgrApi.(init !async_proofs_worker_priority);
+ if CList.is_empty extra then
+ Flags.if_verbose print_header ();
+ opts, extra
+
+let coqtop_toplevel = { init = coqtop_init; run = Coqloop.loop; }
+
+let start_coq custom =
+ match init_toplevel custom.init (List.tl (Array.to_list Sys.argv)) with
(* Batch mode *)
| Some state, opts when not opts.batch_mode ->
- !toploop_run opts ~state;
+ custom.run ~opts ~state;
exit 1
| _ , opts ->
flush_all();
diff --git a/toplevel/coqtop.mli b/toplevel/coqtop.mli
index 056279bb..641448f1 100644
--- a/toplevel/coqtop.mli
+++ b/toplevel/coqtop.mli
@@ -8,15 +8,21 @@
(* * (see LICENSE file for the text of the license) *)
(************************************************************************)
-(** The Coq main module. The following function [start] will parse the
- command line, print the banner, initialize the load path, load the input
- state, load the files given on the command line, load the resource file,
- produce the output state if any, and finally will launch [Coqloop.loop]. *)
+(** Definition of custom toplevels.
+ [init] is used to do custom command line argument parsing.
+ [run] launches a custom toplevel.
+*)
+type custom_toplevel = {
+ init : opts:Coqargs.coq_cmdopts -> string list -> Coqargs.coq_cmdopts * string list;
+ run : opts:Coqargs.coq_cmdopts -> state:Vernac.State.t -> unit;
+}
-val init_toplevel : string list -> Vernac.State.t option * Coqargs.coq_cmdopts
+val coqtop_toplevel : custom_toplevel
-val start : unit -> unit
+(** The Coq main module. [start custom] will parse the command line,
+ print the banner, initialize the load path, load the input state,
+ load the files given on the command line, load the resource file,
+ produce the output state if any, and finally will launch
+ [custom.run]. *)
-(* For other toploops *)
-val toploop_init : (Coqargs.coq_cmdopts -> string list -> string list) ref
-val toploop_run : (Coqargs.coq_cmdopts -> state:Vernac.State.t -> unit) ref
+val start_coq : custom_toplevel -> unit
diff --git a/toplevel/coqtop_byte_bin.ml b/toplevel/coqtop_byte_bin.ml
deleted file mode 100644
index 0b65cebb..00000000
--- a/toplevel/coqtop_byte_bin.ml
+++ /dev/null
@@ -1,34 +0,0 @@
-(************************************************************************)
-(* * The Coq Proof Assistant / The Coq Development Team *)
-(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *)
-(* <O___,, * (see CREDITS file for the list of authors) *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(* * (see LICENSE file for the text of the license) *)
-(************************************************************************)
-
-let drop_setup () =
- begin try
- (* Enable rectypes in the toplevel if it has the directive #rectypes *)
- begin match Hashtbl.find Toploop.directive_table "rectypes" with
- | Toploop.Directive_none f -> f ()
- | _ -> ()
- end
- with
- | Not_found -> ()
- end;
- let ppf = Format.std_formatter in
- Mltop.(set_top
- { load_obj = (fun f -> if not (Topdirs.load_file ppf f)
- then CErrors.user_err Pp.(str ("Could not load plugin "^f))
- );
- use_file = Topdirs.dir_use ppf;
- add_dir = Topdirs.dir_directory;
- ml_loop = (fun () -> Toploop.loop ppf);
- })
-
-(* Main coqtop initialization *)
-let _ =
- drop_setup ();
- Coqtop.start()
diff --git a/toplevel/g_toplevel.mlg b/toplevel/g_toplevel.mlg
new file mode 100644
index 00000000..5aba3d6b
--- /dev/null
+++ b/toplevel/g_toplevel.mlg
@@ -0,0 +1,54 @@
+(************************************************************************)
+(* * The Coq Proof Assistant / The Coq Development Team *)
+(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *)
+(* <O___,, * (see CREDITS file for the list of authors) *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(* * (see LICENSE file for the text of the license) *)
+(************************************************************************)
+
+{
+open Pcoq
+open Pcoq.Prim
+open Vernacexpr
+
+(* Vernaculars specific to the toplevel *)
+type vernac_toplevel =
+ | VernacBacktrack of int * int * int
+ | VernacDrop
+ | VernacQuit
+ | VernacControl of vernac_control
+
+module Toplevel_ : sig
+ val vernac_toplevel : vernac_toplevel CAst.t Entry.t
+end = struct
+ let gec_vernac s = Entry.create ("toplevel:" ^ s)
+ let vernac_toplevel = gec_vernac "vernac_toplevel"
+end
+
+open Toplevel_
+
+}
+
+GRAMMAR EXTEND Gram
+ GLOBAL: vernac_toplevel;
+ vernac_toplevel: FIRST
+ [ [ IDENT "Drop"; "." -> { CAst.make VernacDrop }
+ | IDENT "Quit"; "." -> { CAst.make VernacQuit }
+ | IDENT "Backtrack"; n = natural ; m = natural ; p = natural; "." ->
+ { CAst.make (VernacBacktrack (n,m,p)) }
+ | cmd = Pvernac.main_entry ->
+ { match cmd with
+ | None -> raise Stm.End_of_input
+ | Some (loc,c) -> CAst.make ~loc (VernacControl c) }
+ ]
+ ]
+ ;
+END
+
+{
+
+let parse_toplevel pa = Pcoq.Entry.parse vernac_toplevel pa
+
+}
diff --git a/toplevel/toplevel.mllib b/toplevel/toplevel.mllib
index 9fb2e33d..597173e5 100644
--- a/toplevel/toplevel.mllib
+++ b/toplevel/toplevel.mllib
@@ -1,6 +1,8 @@
Vernac
Usage
-Coqloop
Coqinit
Coqargs
+G_toplevel
+Coqloop
Coqtop
+WorkerLoop
diff --git a/toplevel/usage.ml b/toplevel/usage.ml
index 504ffa52..d85fed5f 100644
--- a/toplevel/usage.ml
+++ b/toplevel/usage.ml
@@ -72,7 +72,8 @@ let print_usage_channel co command =
\n -boot boot mode (implies -q and -batch)\
\n -bt print backtraces (requires configure debug flag)\
\n -debug debug mode (implies -bt)\
-\n -stm-debug STM debug mode (will trace every transaction) \
+\n -diffs (on|off|removed) highlight differences between proof steps\
+\n -stm-debug STM debug mode (will trace every transaction)\
\n -emacs tells Coq it is executed under Emacs\
\n -noglob do not dump globalizations\
\n -dump-glob f dump globalizations in file f (to be used by coqdoc)\
diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml
index fdd0d4ed..c914bbec 100644
--- a/toplevel/vernac.ml
+++ b/toplevel/vernac.ml
@@ -28,10 +28,6 @@ let checknav_deep {CAst.loc;v=ast} =
if is_deep_navigation_vernac ast then
CErrors.user_err ?loc (str "Navigation commands forbidden in nested commands.")
-let disable_drop = function
- | Drop -> CErrors.user_err Pp.(str "Drop is forbidden.")
- | e -> e
-
(* Echo from a buffer based on position.
XXX: Should move to utility file. *)
let vernac_echo ?loc in_chan = let open Loc in
@@ -80,17 +76,21 @@ module State = struct
doc : Stm.doc;
sid : Stateid.t;
proof : Proof.t option;
+ time : bool;
}
end
-let interp_vernac ~time ~check ~interactive ~state ({CAst.loc;_} as com) =
+let interp_vernac ~check ~interactive ~state ({CAst.loc;_} as com) =
let open State in
try
(* The -time option is only supported from console-based clients
due to the way it prints. *)
- if time then print_cmd_header com;
- let com = if time then CAst.make ?loc @@ VernacTime(time,com) else com in
+ let com = if state.time
+ then begin
+ print_cmd_header com;
+ CAst.make ?loc @@ VernacTime(state.time,com)
+ end else com in
let doc, nsid, ntip = Stm.add ~doc:state.doc ~ontop:state.sid (not !Flags.quiet) com in
(* Main STM interaction *)
@@ -102,7 +102,7 @@ let interp_vernac ~time ~check ~interactive ~state ({CAst.loc;_} as com) =
(* Stm.observe nsid; *)
let ndoc = if check then Stm.finish ~doc else doc in
let new_proof = Proof_global.give_me_the_proof_opt () in
- { doc = ndoc; sid = nsid; proof = new_proof }
+ { state with doc = ndoc; sid = nsid; proof = new_proof; }
with reraise ->
(* XXX: In non-interactive mode edit_at seems to do very weird
things, so we better avoid it while we investigate *)
@@ -115,13 +115,13 @@ let interp_vernac ~time ~check ~interactive ~state ({CAst.loc;_} as com) =
end in iraise (reraise, info)
(* Load a vernac file. CErrors are annotated with file and location *)
-let load_vernac_core ~time ~echo ~check ~interactive ~state file =
+let load_vernac_core ~echo ~check ~interactive ~state file =
(* Keep in sync *)
let in_chan = open_utf8_file_in file in
let in_echo = if echo then Some (open_utf8_file_in file) else None in
let input_cleanup () = close_in in_chan; Option.iter close_in in_echo in
- let in_pa = Pcoq.Gram.parsable ~file:(Loc.InFile file) (Stream.of_channel in_chan) in
+ let in_pa = Pcoq.Parsable.make ~file:(Loc.InFile file) (Stream.of_channel in_chan) in
let rstate = ref state in
(* For beautify, list of parsed sids *)
let rids = ref [] in
@@ -154,22 +154,22 @@ let load_vernac_core ~time ~echo ~check ~interactive ~state file =
Option.iter (vernac_echo ?loc) in_echo;
checknav_simple ast;
- let state = Flags.silently (interp_vernac ~time ~check ~interactive ~state:!rstate) ast in
+ let state = Flags.silently (interp_vernac ~check ~interactive ~state:!rstate) ast in
rids := state.sid :: !rids;
rstate := state;
done;
input_cleanup ();
- !rstate, !rids, Pcoq.Gram.comment_state in_pa
+ !rstate, !rids, Pcoq.Parsable.comment_state in_pa
with any -> (* whatever the exception *)
let (e, info) = CErrors.push any in
input_cleanup ();
match e with
- | Stm.End_of_input -> !rstate, !rids, Pcoq.Gram.comment_state in_pa
- | reraise -> iraise (disable_drop e, info)
+ | Stm.End_of_input -> !rstate, !rids, Pcoq.Parsable.comment_state in_pa
+ | reraise -> iraise (e, info)
-let process_expr ~time ~state loc_ast =
+let process_expr ~state loc_ast =
checknav_deep loc_ast;
- interp_vernac ~time ~interactive:true ~check:true ~state loc_ast
+ interp_vernac ~interactive:true ~check:true ~state loc_ast
(******************************************************************************)
(* Beautify-specific code *)
@@ -220,8 +220,8 @@ let beautify_pass ~doc ~comments ~ids ~filename =
(* Main driver for file loading. For now, we only do one beautify
pass. *)
-let load_vernac ~time ~echo ~check ~interactive ~state filename =
- let ostate, ids, comments = load_vernac_core ~time ~echo ~check ~interactive ~state filename in
+let load_vernac ~echo ~check ~interactive ~state filename =
+ let ostate, ids, comments = load_vernac_core ~echo ~check ~interactive ~state filename in
(* Pass for beautify *)
if !Flags.beautify then beautify_pass ~doc:ostate.State.doc ~comments ~ids:List.(rev ids) ~filename;
(* End pass *)
diff --git a/toplevel/vernac.mli b/toplevel/vernac.mli
index 51758642..12695402 100644
--- a/toplevel/vernac.mli
+++ b/toplevel/vernac.mli
@@ -15,6 +15,7 @@ module State : sig
doc : Stm.doc;
sid : Stateid.t;
proof : Proof.t option;
+ time : bool;
}
end
@@ -23,10 +24,10 @@ end
expected to handle and print errors in form of exceptions, however
care is taken so the state machine is left in a consistent
state. *)
-val process_expr : time:bool -> state:State.t -> Vernacexpr.vernac_control CAst.t -> State.t
+val process_expr : state:State.t -> Vernacexpr.vernac_control CAst.t -> State.t
(** [load_vernac echo sid file] Loads [file] on top of [sid], will
echo the commands if [echo] is set. Callers are expected to handle
and print errors in form of exceptions. *)
-val load_vernac : time:bool -> echo:bool -> check:bool -> interactive:bool ->
+val load_vernac : echo:bool -> check:bool -> interactive:bool ->
state:State.t -> string -> State.t
diff --git a/toplevel/workerLoop.ml b/toplevel/workerLoop.ml
new file mode 100644
index 00000000..ee6d5e88
--- /dev/null
+++ b/toplevel/workerLoop.ml
@@ -0,0 +1,29 @@
+(************************************************************************)
+(* * The Coq Proof Assistant / The Coq Development Team *)
+(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *)
+(* <O___,, * (see CREDITS file for the list of authors) *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(* * (see LICENSE file for the text of the license) *)
+(************************************************************************)
+
+let rec parse = function
+ | "--xml_format=Ppcmds" :: rest -> parse rest
+ | x :: rest -> x :: parse rest
+ | [] -> []
+
+let arg_init init ~opts extra_args =
+ let extra_args = parse extra_args in
+ Flags.quiet := true;
+ init ();
+ CoqworkmgrApi.(init !async_proofs_worker_priority);
+ opts, extra_args
+
+let start ~init ~loop =
+ let open Coqtop in
+ let custom = {
+ init = arg_init init;
+ run = (fun ~opts:_ ~state:_ -> loop ());
+ } in
+ start_coq custom
diff --git a/toplevel/coqtop_opt_bin.ml b/toplevel/workerLoop.mli
index ea4c0ea5..e497dee6 100644
--- a/toplevel/coqtop_opt_bin.ml
+++ b/toplevel/workerLoop.mli
@@ -8,9 +8,7 @@
(* * (see LICENSE file for the text of the license) *)
(************************************************************************)
-let drop_setup () = Mltop.remove ()
-
-(* Main coqtop initialization *)
-let _ =
- drop_setup ();
- Coqtop.start()
+(* Register a STM worker *)
+val start :
+ init:(unit -> unit) ->
+ loop:(unit -> unit) -> unit
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-17 09:04:12 +0000