Commit 4a073863 authored by POTTIER Francois's avatar POTTIER Francois

Parameterize the type [env] with ['a] again, so [input_needed] is safe.

parent afed59db
...@@ -27,7 +27,7 @@ module Make (T : TABLE) = struct ...@@ -27,7 +27,7 @@ module Make (T : TABLE) = struct
include T include T
type env = type 'a env =
(state, semantic_value, token) EngineTypes.env (state, semantic_value, token) EngineTypes.env
(* --------------------------------------------------------------------------- *) (* --------------------------------------------------------------------------- *)
...@@ -40,11 +40,16 @@ module Make (T : TABLE) = struct ...@@ -40,11 +40,16 @@ module Make (T : TABLE) = struct
(i.e., continuations) that do not make sense. (Such continuations could (i.e., continuations) that do not make sense. (Such continuations could
potentially violate the LR invariant and lead to crashes.) *) potentially violate the LR invariant and lead to crashes.) *)
(* 2017/03/29 Although [checkpoint] is a private type, we now expose a
constructor function, [input_needed]. This function allows manufacturing
a checkpoint out of an environment. For this reason, the type [env] must
also be parameterized with ['a]. *)
type 'a checkpoint = type 'a checkpoint =
| InputNeeded of env | InputNeeded of 'a env
| Shifting of env * env * bool | Shifting of 'a env * 'a env * bool
| AboutToReduce of env * production | AboutToReduce of 'a env * production
| HandlingError of env | HandlingError of 'a env
| Accepted of 'a | Accepted of 'a
| Rejected | Rejected
...@@ -736,7 +741,7 @@ module Make (T : TABLE) = struct ...@@ -736,7 +741,7 @@ module Make (T : TABLE) = struct
(* TEMPORARY comment *) (* TEMPORARY comment *)
(* TEMPORARY add calls to new [Log] functions? : log [pop], [feed], [force] *) (* TEMPORARY add calls to new [Log] functions? : log [pop], [feed], [force] *)
let pop (env : env) : env option = let pop (env : 'a env) : 'a env option =
let cell = env.stack in let cell = env.stack in
let next = cell.next in let next = cell.next in
if next == cell then if next == cell then
...@@ -754,7 +759,7 @@ module Make (T : TABLE) = struct ...@@ -754,7 +759,7 @@ module Make (T : TABLE) = struct
by calling [run env] or [initiate env]. Instead, it returns [env] to the by calling [run env] or [initiate env]. Instead, it returns [env] to the
user, or raises [Error]. *) user, or raises [Error]. *)
let force_reduction prod (env : env) : env = let force_reduction prod (env : 'a env) : 'a env =
(* Check if this reduction is permitted. This check is REALLY important. (* Check if this reduction is permitted. This check is REALLY important.
The stack must have the correct shape: that is, it must be sufficiently The stack must have the correct shape: that is, it must be sufficiently
high, and must contain semantic values of appropriate types, otherwise high, and must contain semantic values of appropriate types, otherwise
...@@ -784,7 +789,7 @@ module Make (T : TABLE) = struct ...@@ -784,7 +789,7 @@ module Make (T : TABLE) = struct
(not really problematic? but worth noting) (not really problematic? but worth noting)
- for type safety, should correlate 'a env with 'a checkpoint - for type safety, should correlate 'a env with 'a checkpoint
*) *)
let input_needed (env : env) : 'a checkpoint = let input_needed (env : 'a env) : 'a checkpoint =
InputNeeded env InputNeeded env
end end
...@@ -21,7 +21,7 @@ module Make (T : TABLE) ...@@ -21,7 +21,7 @@ module Make (T : TABLE)
and type token = T.token and type token = T.token
and type semantic_value = T.semantic_value and type semantic_value = T.semantic_value
and type production = T.production and type production = T.production
and type env = (T.state, T.semantic_value, T.token) EngineTypes.env and type 'a env = (T.state, T.semantic_value, T.token) EngineTypes.env
(* We would prefer not to expose the definition of the type [env]. (* We would prefer not to expose the definition of the type [env].
However, it must be exposed because some of the code in the However, it must be exposed because some of the code in the
......
...@@ -47,15 +47,27 @@ module type INCREMENTAL_ENGINE = sig ...@@ -47,15 +47,27 @@ module type INCREMENTAL_ENGINE = sig
(* [HandlingError] is an intermediate checkpoint. It means that the parser has (* [HandlingError] is an intermediate checkpoint. It means that the parser has
detected an error and is currently handling it, in several steps. *) detected an error and is currently handling it, in several steps. *)
type env (* A value of type ['a env] represents a configuration of the automaton:
current state, stack, lookahead token, etc. The parameter ['a] is the
type of the semantic value that will eventually be produced if the parser
succeeds. *)
(* In normal operation, the parser works with checkpoints: see the functions
[offer] and [resume]. However, it is also possible to work directly with
environments (see the functions [pop], [force_reduction], and [feed]) and
to reconstruct a checkpoint out of an environment (see [input_needed]).
This is considered advanced functionality; its purpose is to allow error
recovery strategies to be programmed by the user. *)
type 'a env
type production type production
type 'a checkpoint = private type 'a checkpoint = private
| InputNeeded of env | InputNeeded of 'a env
| Shifting of env * env * bool | Shifting of 'a env * 'a env * bool
| AboutToReduce of env * production | AboutToReduce of 'a env * production
| HandlingError of env | HandlingError of 'a env
| Accepted of 'a | Accepted of 'a
| Rejected | Rejected
...@@ -150,7 +162,7 @@ module type INCREMENTAL_ENGINE = sig ...@@ -150,7 +162,7 @@ module type INCREMENTAL_ENGINE = sig
their side-effects be harmless (replayable). *) their side-effects be harmless (replayable). *)
val loop_test: val loop_test:
(env -> 'accu -> 'accu) -> ('a env -> 'accu -> 'accu) ->
'a checkpoint -> 'accu -> 'accu 'a checkpoint -> 'accu -> 'accu
(* The function [loop_test] can be used, after an error has been detected, to (* The function [loop_test] can be used, after an error has been detected, to
...@@ -175,7 +187,7 @@ module type INCREMENTAL_ENGINE = sig ...@@ -175,7 +187,7 @@ module type INCREMENTAL_ENGINE = sig
amounts to pretending that the (terminal or nonterminal) symbol that amounts to pretending that the (terminal or nonterminal) symbol that
corresponds to this stack cell has not been read. *) corresponds to this stack cell has not been read. *)
val pop: env -> env option val pop: 'a env -> 'a env option
(* [force_reduction prod env] should be called only if in the current state (* [force_reduction prod env] should be called only if in the current state
(as determined by [env]) the parser is capable of reducing the production (as determined by [env]) the parser is capable of reducing the production
...@@ -184,7 +196,7 @@ module type INCREMENTAL_ENGINE = sig ...@@ -184,7 +196,7 @@ module type INCREMENTAL_ENGINE = sig
effects!) and the automaton makes a goto (nonterminal) transition. If effects!) and the automaton makes a goto (nonterminal) transition. If
this condition is not satisfied, [Invalid_argument _] is raised. *) this condition is not satisfied, [Invalid_argument _] is raised. *)
val force_reduction: production -> env -> env val force_reduction: production -> 'a env -> 'a env
(* [input_needed env] returns [InputNeeded env]. That is, out of an [env] (* [input_needed env] returns [InputNeeded env]. That is, out of an [env]
that might have been obtained via a series of calls to the functions that might have been obtained via a series of calls to the functions
...@@ -200,7 +212,7 @@ module type INCREMENTAL_ENGINE = sig ...@@ -200,7 +212,7 @@ module type INCREMENTAL_ENGINE = sig
Menhir's new error reporting facility, this could cause the parser to Menhir's new error reporting facility, this could cause the parser to
reach an error state for which no error message has been prepared. *) reach an error state for which no error message has been prepared. *)
val input_needed: env -> 'a checkpoint val input_needed: 'a env -> 'a checkpoint
(* The abstract type ['a lr1state] describes the non-initial states of the (* The abstract type ['a lr1state] describes the non-initial states of the
LR(1) automaton. The index ['a] represents the type of the semantic value LR(1) automaton. The index ['a] represents the type of the semantic value
...@@ -237,20 +249,20 @@ module type INCREMENTAL_ENGINE = sig ...@@ -237,20 +249,20 @@ module type INCREMENTAL_ENGINE = sig
automaton's current state is the one found in the top element of the automaton's current state is the one found in the top element of the
stack. *) stack. *)
val stack: env -> stack val stack: 'a env -> stack
(* These are the start and end positions of the current lookahead token. If (* These are the start and end positions of the current lookahead token. If
invoked in an initial state, this function returns a pair of twice the invoked in an initial state, this function returns a pair of twice the
initial position. *) initial position. *)
val positions: env -> Lexing.position * Lexing.position val positions: 'a env -> Lexing.position * Lexing.position
(* This tells whether the parser is about to perform a default reduction. (* This tells whether the parser is about to perform a default reduction.
In particular, when applied to an environment taken from a result of In particular, when applied to an environment taken from a result of
the form [AboutToReduce (env, prod)], this tells whether the reduction the form [AboutToReduce (env, prod)], this tells whether the reduction
that is about to take place is a default reduction. *) that is about to take place is a default reduction. *)
val has_default_reduction: env -> bool val has_default_reduction: 'a env -> bool
end end
...@@ -369,7 +381,7 @@ module type INSPECTION = sig ...@@ -369,7 +381,7 @@ module type INSPECTION = sig
(* The type [env] is meant to be the same as in [INCREMENTAL_ENGINE]. *) (* The type [env] is meant to be the same as in [INCREMENTAL_ENGINE]. *)
type env type 'a env
(* [feed symbol startp semv endp env] forces the parser to consume the (* [feed symbol startp semv endp env] forces the parser to consume the
(terminal or nonterminal) symbol [symbol], accompanied with the semantic (terminal or nonterminal) symbol [symbol], accompanied with the semantic
...@@ -379,7 +391,7 @@ module type INSPECTION = sig ...@@ -379,7 +391,7 @@ module type INSPECTION = sig
determined by [env]) has an outgoing transition labeled with [symbol]. determined by [env]) has an outgoing transition labeled with [symbol].
Otherwise, [Invalid_argument _] is raised. *) Otherwise, [Invalid_argument _] is raised. *)
val feed: 'a symbol -> Lexing.position -> 'a -> Lexing.position -> env -> env val feed: 'a symbol -> Lexing.position -> 'a -> Lexing.position -> 'b env -> 'b env
end end
...@@ -392,6 +404,6 @@ module type EVERYTHING = sig ...@@ -392,6 +404,6 @@ module type EVERYTHING = sig
include INSPECTION include INSPECTION
with type 'a lr1state := 'a lr1state with type 'a lr1state := 'a lr1state
with type production := production with type production := production
with type env := env with type 'a env := 'a env
end end
...@@ -48,7 +48,7 @@ module Make ...@@ -48,7 +48,7 @@ module Make
with type terminal = int with type terminal = int
and type nonterminal = int and type nonterminal = int
and type semantic_value = Obj.t) and type semantic_value = Obj.t)
(E : sig type env = (ET.state, ET.semantic_value, ET.token) EngineTypes.env end) (E : sig type 'a env = (ET.state, ET.semantic_value, ET.token) EngineTypes.env end)
= struct = struct
(* Including [IT] is an easy way of inheriting the definitions of the types (* Including [IT] is an easy way of inheriting the definitions of the types
...@@ -234,7 +234,7 @@ module Make ...@@ -234,7 +234,7 @@ module Make
let feed_failure () = let feed_failure () =
invalid_arg "feed: outgoing transition does not exist" invalid_arg "feed: outgoing transition does not exist"
let feed_nonterminal nt startp semv endp (env : E.env) = let feed_nonterminal nt startp semv endp (env : _ E.env) =
let source : state = env.current in let source : state = env.current in
match ET.maybe_goto_nt source nt with match ET.maybe_goto_nt source nt with
| None -> | None ->
......
...@@ -38,11 +38,11 @@ module Make ...@@ -38,11 +38,11 @@ module Make
with type terminal = int with type terminal = int
and type nonterminal = int and type nonterminal = int
and type semantic_value = Obj.t) and type semantic_value = Obj.t)
(E : sig type env = (ET.state, ET.semantic_value, ET.token) EngineTypes.env end) (E : sig type 'a env = (ET.state, ET.semantic_value, ET.token) EngineTypes.env end)
: IncrementalEngine.INSPECTION : IncrementalEngine.INSPECTION
with type 'a terminal := 'a IT.terminal with type 'a terminal := 'a IT.terminal
and type 'a nonterminal := 'a IT.nonterminal and type 'a nonterminal := 'a IT.nonterminal
and type 'a lr1state := 'a IT.lr1state and type 'a lr1state := 'a IT.lr1state
and type production := int and type production := int
and type env := E.env and type 'a env := 'a E.env
...@@ -66,12 +66,11 @@ module Make ...@@ -66,12 +66,11 @@ module Make
as a number; then the list of its LR(0) items is printed. (Ending with as a number; then the list of its LR(0) items is printed. (Ending with
a newline.) *) a newline.) *)
val print_current_state: env -> unit val print_current_state: 'a env -> unit
(* Printing a summary of the stack and current state. This function just (* Printing a summary of the stack and current state. This function just
calls [print_stack] and [print_current_state] in succession. *) calls [print_stack] and [print_current_state] in succession. *)
val print_env: env -> unit val print_env: 'a env -> unit
end end
...@@ -118,7 +118,7 @@ let inspection_api grammar () = ...@@ -118,7 +118,7 @@ let inspection_api grammar () =
[], "production", TypApp ("production", []); [], "production", TypApp ("production", []);
[ a ], TokenType.tctokengadt, TokenType.ttokengadt (TypVar a); [ a ], TokenType.tctokengadt, TokenType.ttokengadt (TypVar a);
[ a ], NonterminalType.tcnonterminalgadt, NonterminalType.tnonterminalgadt (TypVar a); [ a ], NonterminalType.tcnonterminalgadt, NonterminalType.tnonterminalgadt (TypVar a);
[], "env", TypApp ("env", []); [ a ], "env", TypApp ("env", [ TypVar a ]);
] ]
) :: ) ::
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment