Commit 75dd6ff6 authored by POTTIER Francois's avatar POTTIER Francois

Replaced the return type [void] with a new type [result].

Replaced the call to [read] with returning an [InputNeeded] result.
parent d380ff17
...@@ -13,13 +13,20 @@ module Make (T : TABLE) = struct ...@@ -13,13 +13,20 @@ module Make (T : TABLE) = struct
include T include T
type dummy =
(state, semantic_value, token) env
type env =
dummy
(* --------------------------------------------------------------------------- *) (* --------------------------------------------------------------------------- *)
(* The type [void] is empty. Many of the functions below have return type (* A continuation is returned to the user when the parser pauses itself. In
[void]. This guarantees that they never return a value. Instead, they normal mode, this happens when the parser wishes to request another token.
must stop by raising an exception: either [Accept] or [Error]. *) In error-handling mode, this happens when ... TEMPORARY *)
type void type result =
| InputNeeded of env
| Rejected
(* --------------------------------------------------------------------------- *) (* --------------------------------------------------------------------------- *)
...@@ -65,29 +72,28 @@ module Make (T : TABLE) = struct ...@@ -65,29 +72,28 @@ module Make (T : TABLE) = struct
[please_discard]. This flag is set when [s] is being entered by shifting [please_discard]. This flag is set when [s] is being entered by shifting
a terminal symbol and [s] does not have a default reduction on [#]. *) a terminal symbol and [s] does not have a default reduction on [#]. *)
let rec run env please_discard : void = let rec run env please_discard : result =
(* Log the fact that we just entered this state. *) (* Log the fact that we just entered this state. *)
if log then if log then
Log.state env.current; Log.state env.current;
(* If [please_discard] is set, discard a token and fetch the next one. (* If [please_discard] is set, we discard the current lookahead token and
This is done by jumping to [discard], which itself will jump to fetch the next one. In order to request a token from the user, we
[check_for_default_reduction]. If [please_discard] is not set, we skip return an [InputNeeded] continuation, which, when invoked by the user,
[discard] and jump directly to [check_for_default_reduction]. *) will take us to [discard]. If [please_discard] is not set, we skip this
step and jump directly to [check_for_default_reduction]. *)
if please_discard then if please_discard then
discard env InputNeeded env
else else
check_for_default_reduction env check_for_default_reduction env
(* [discard] takes a token off the input stream, queries the lexer (* [discard env triple] stores [triple] into [env.triple], overwriting
for a new one, and stores it into [env.triple], overwriting the the previous token. *)
previous token. *)
and discard env = and discard env triple =
let triple = env.read() in
if log then begin if log then begin
let (token, startp, endp) = triple in let (token, startp, endp) = triple in
Log.lookahead_token (T.token2terminal token) startp endp Log.lookahead_token (T.token2terminal token) startp endp
...@@ -107,7 +113,7 @@ module Make (T : TABLE) = struct ...@@ -107,7 +113,7 @@ module Make (T : TABLE) = struct
check_for_error_token (* there is none; continue below *) check_for_error_token (* there is none; continue below *)
env env
and check_for_error_token env : void = and check_for_error_token env =
(* There is no default reduction. Consult the current lookahead token (* There is no default reduction. Consult the current lookahead token
so as to determine which action should be taken. *) so as to determine which action should be taken. *)
...@@ -152,8 +158,7 @@ module Make (T : TABLE) = struct ...@@ -152,8 +158,7 @@ module Make (T : TABLE) = struct
(please_discard : bool) (please_discard : bool)
(terminal : terminal) (terminal : terminal)
(value : semantic_value) (value : semantic_value)
(s' : state) (s' : state) =
: void =
(* Log the transition. *) (* Log the transition. *)
...@@ -184,7 +189,7 @@ module Make (T : TABLE) = struct ...@@ -184,7 +189,7 @@ module Make (T : TABLE) = struct
(* Here, the lookahead token CAN be [error]. *) (* Here, the lookahead token CAN be [error]. *)
and reduce env (prod : production) : void = and reduce env (prod : production) =
(* Log a reduction event. *) (* Log a reduction event. *)
...@@ -228,7 +233,6 @@ module Make (T : TABLE) = struct ...@@ -228,7 +233,6 @@ module Make (T : TABLE) = struct
| None -> | None ->
initiate env initiate env
(* --------------------------------------------------------------------------- *) (* --------------------------------------------------------------------------- *)
(* The following functions deal with errors. *) (* The following functions deal with errors. *)
...@@ -237,7 +241,7 @@ module Make (T : TABLE) = struct ...@@ -237,7 +241,7 @@ module Make (T : TABLE) = struct
(* Here, the lookahead token CAN be [error]. *) (* Here, the lookahead token CAN be [error]. *)
and initiate env : void = and initiate env =
Log.initiating_error_handling(); Log.initiating_error_handling();
let (_, startp, endp) = env.triple in let (_, startp, endp) = env.triple in
let triple = (error_token, startp, endp) in let triple = (error_token, startp, endp) in
...@@ -246,7 +250,7 @@ module Make (T : TABLE) = struct ...@@ -246,7 +250,7 @@ module Make (T : TABLE) = struct
(* [error] handles errors. *) (* [error] handles errors. *)
and error env : void = and error env =
assert (let (token, _, _) = env.triple in token == error_token); assert (let (token, _, _) = env.triple in token == error_token);
(* Consult the column associated with the [error] pseudo-token in the (* Consult the column associated with the [error] pseudo-token in the
...@@ -290,7 +294,7 @@ module Make (T : TABLE) = struct ...@@ -290,7 +294,7 @@ module Make (T : TABLE) = struct
(* The stack is empty. Die. *) (* The stack is empty. Die. *)
raise Error Rejected
else begin else begin
...@@ -307,21 +311,11 @@ module Make (T : TABLE) = struct ...@@ -307,21 +311,11 @@ module Make (T : TABLE) = struct
(* --------------------------------------------------------------------------- *) (* --------------------------------------------------------------------------- *)
let entry let start
(s : state) (s : state)
(lexer : Lexing.lexbuf -> token) (read : unit -> token * Lexing.position * Lexing.position)
(lexbuf : Lexing.lexbuf)
: semantic_value = : semantic_value =
(* Wrap the lexer and lexbuf as a revised lexer. *)
let read () =
let token = lexer lexbuf in
let startp = lexbuf.Lexing.lex_start_p
and endp = lexbuf.Lexing.lex_curr_p in
(token, startp, endp)
in
(* Build an empty stack. This is a dummy cell, which is its own (* Build an empty stack. This is a dummy cell, which is its own
successor. Its fields other than [next] contain dummy values. *) successor. Its fields other than [next] contain dummy values. *)
...@@ -345,26 +339,50 @@ module Make (T : TABLE) = struct ...@@ -345,26 +339,50 @@ module Make (T : TABLE) = struct
(* Build an initial environment. *) (* Build an initial environment. *)
let env = { let env = {
read;
triple; triple;
stack = empty; stack = empty;
current = s; current = s;
} in } in
(* Run. Catch [Accept], which represents normal termination. Let [Error] (* The main loop. *)
escape. *)
try
(* If ocaml offered a [match/with] construct with zero branches, this is let rec loop result =
what we would use here, since the type [void] has zero cases. *) match result with
| InputNeeded env ->
let triple = read() in
loop (discard env triple)
| Rejected ->
raise Error
in
let (_ : void) = run env false in (* Catch [Accept], which represents normal termination. Let [Error] escape. *)
assert false (* cannot fail *)
try
loop (run env false)
with with
| Accept v -> | Accept v ->
v v
(* --------------------------------------------------------------------------- *)
(* Wrapping a lexer and lexbuf as a revised lexer. *)
let wrap lexer lexbuf : unit -> token * Lexing.position * Lexing.position =
fun () ->
let token = lexer lexbuf in
let startp = lexbuf.Lexing.lex_start_p
and endp = lexbuf.Lexing.lex_curr_p in
token, startp, endp
(* --------------------------------------------------------------------------- *)
let entry
(s : state)
(lexer : Lexing.lexbuf -> token)
(lexbuf : Lexing.lexbuf)
: semantic_value =
start s (wrap lexer lexbuf)
end end
...@@ -44,15 +44,11 @@ type ('state, 'semantic_value) stack = { ...@@ -44,15 +44,11 @@ type ('state, 'semantic_value) stack = {
(* --------------------------------------------------------------------------- *) (* --------------------------------------------------------------------------- *)
(* A parsing environment contains almost all of the automaton's state. (* A parsing environment contains all of the parser's state (except for the
(It contains everything except the current program point.) *) current program point). *)
type ('state, 'semantic_value, 'token) env = { type ('state, 'semantic_value, 'token) env = {
(* The lexer. *)
read: unit -> 'token * Lexing.position * Lexing.position;
(* The last token that was obtained from the lexer, together with its start (* The last token that was obtained from the lexer, together with its start
and end positions. In principle, this should be a legit token, but the and end positions. In principle, this should be a legit token, but the
engine disguises the [error] pseudo-token as an illegal inhabitant of the engine disguises the [error] pseudo-token as an illegal inhabitant of the
......
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