Commit d91957a2 authored by POTTIER Francois's avatar POTTIER Francois

Split [start] into [start] and [loop].

parent b74d39ed
...@@ -73,6 +73,11 @@ module Make (T : TABLE) = struct ...@@ -73,6 +73,11 @@ 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 [#]. *)
(* The following recursive group of functions are tail recursive, produce a
result of type [result], and cannot raise an exception. A semantic action
can raise [Accept] or [Error], but these exceptions are immediately caught
within [reduce]. *)
let rec run env please_discard : result = 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. *)
...@@ -312,6 +317,10 @@ module Make (T : TABLE) = struct ...@@ -312,6 +317,10 @@ module Make (T : TABLE) = struct
(* --------------------------------------------------------------------------- *) (* --------------------------------------------------------------------------- *)
(* End of the nest of tail recursive functions. *)
(* --------------------------------------------------------------------------- *)
(* [offer result triple] is supposed to be invoked by the user in response (* [offer result triple] is supposed to be invoked by the user in response
to [result], which must be an [InputNeeded] result. *) to [result], which must be an [InputNeeded] result. *)
...@@ -332,10 +341,7 @@ module Make (T : TABLE) = struct ...@@ -332,10 +341,7 @@ module Make (T : TABLE) = struct
(* TEMPORARY comment *) (* TEMPORARY comment *)
let start let start (s : state) : result =
(s : state)
(read : unit -> token * Lexing.position * Lexing.position)
: semantic_value =
(* 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.
...@@ -358,28 +364,30 @@ module Make (T : TABLE) = struct ...@@ -358,28 +364,30 @@ module Make (T : TABLE) = struct
current = s; current = s;
} in } in
(* The main loop. *) (* Begin parsing. *)
let rec loop result = run env true
match result with
| InputNeeded _ ->
let triple = read() in
loop (offer result triple)
| Accepted v ->
v
| Rejected ->
raise Error
in
(* Let the exception [Error] escape. *) (* The main loop. *)
loop (run env true) type reader =
unit -> token * Lexing.position * Lexing.position
let rec loop (read : reader) result =
match result with
| InputNeeded _ ->
let triple = read() in
loop read (offer result triple)
| Accepted v ->
v
| Rejected ->
raise Error
(* --------------------------------------------------------------------------- *) (* --------------------------------------------------------------------------- *)
(* Wrapping a lexer and lexbuf as a revised lexer. *) (* Wrapping a lexer and lexbuf as a reader. *)
let wrap lexer lexbuf : unit -> token * Lexing.position * Lexing.position = let wrap lexer lexbuf : reader =
fun () -> fun () ->
let token = lexer lexbuf in let token = lexer lexbuf in
let startp = lexbuf.Lexing.lex_start_p let startp = lexbuf.Lexing.lex_start_p
...@@ -394,7 +402,7 @@ module Make (T : TABLE) = struct ...@@ -394,7 +402,7 @@ module Make (T : TABLE) = struct
(lexbuf : Lexing.lexbuf) (lexbuf : Lexing.lexbuf)
: semantic_value = : semantic_value =
start s (wrap lexer lexbuf) loop (wrap lexer lexbuf) (start s)
end end
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