Commit 1cef5c66 authored by POTTIER Francois's avatar POTTIER Francois

Modified [Engine] to explicitly recognize start productions and accept.

  This removes the need for the exception [Accept].
Modified the table back-end to include the number of start productions
  as part of the generated tables.
parent e95b420b
......@@ -62,8 +62,8 @@ module Make (T : TABLE) = struct
(* The following recursive group of functions are tail recursive, produce a
result of type [semantic_value result], and cannot raise an exception. A
semantic action can raise [Accept] or [Error], but these exceptions are
immediately caught within [reduce]. *)
semantic action can raise [Error], but this exception is immediately
caught within [reduce]. *)
let rec run env please_discard : semantic_value result =
......@@ -185,14 +185,23 @@ module Make (T : TABLE) = struct
(* The function [announce_reduce] stops the parser and returns a result
which allows the parser to be resumed by calling [reduce]. *)
(* Only ordinary productions are exposed to the user. Start productions
are not exposed to the user. Reducing a start production simply leads
to the successful termination of the parser. *)
and announce_reduce env (prod : production) =
AboutToReduce (env, prod)
if T.is_start prod then
accept env prod
else
AboutToReduce (env, prod)
(* The function [reduce] takes care of reductions. It is invoked by
[resume] after an [AboutToReduce] event has been produced. *)
(* Here, the lookahead token CAN be [error]. *)
(* The production [prod] CANNOT be a start production. *)
and reduce env (prod : production) =
(* Log a reduction event. *)
......@@ -202,14 +211,11 @@ module Make (T : TABLE) = struct
(* Invoke the semantic action. The semantic action is responsible for
truncating the stack and pushing a new cell onto the stack, which
contains a new semantic value. It can raise [Accept] or [Error]. *)
contains a new semantic value. It can raise [Error]. *)
(* If the semantic action terminates normally, it returns a new stack,
which becomes the current stack. *)
(* If the semantic action raises [Accept], we catch it and produce an
[Accepted] result. *)
(* If the semantic action raises [Error], we catch it and initiate error
handling. *)
......@@ -230,12 +236,18 @@ module Make (T : TABLE) = struct
let env = { env with stack; current } in
run env false
| exception Accept v ->
Accepted v
| exception Error ->
initiate env
and accept env prod =
(* Log an accept event. *)
if log then
Log.reduce_or_accept prod;
(* Extract the semantic value out of the stack. *)
let v = env.stack.semv in
(* Finish. *)
Accepted v
(* --------------------------------------------------------------------------- *)
(* The following functions deal with errors. *)
......@@ -375,7 +387,7 @@ module Make (T : TABLE) = struct
(* In reality, [offer] and [resume] accept an argument of type
[semantic_value result] and produce a result of the same type. The choice
of [semantic_value] is forced by the fact that this is the parameter of
the exception [Accept]. *)
the result [Accepted]. *)
(* We change this as follows. *)
......
......@@ -189,6 +189,10 @@ module type TABLE = sig
val goto: state -> production -> state
(* [is_start prod] tells whether the production [prod] is a start production. *)
val is_start: production -> bool
(* By convention, a semantic action is responsible for:
1. fetching whatever semantic values and positions it needs off the stack;
......@@ -210,15 +214,8 @@ module type TABLE = sig
semantic actions would be variadic: not all semantic actions would have
the same number of arguments. The rest follows rather naturally. *)
(* If production [prod] is an accepting production, then the semantic action
is responsible for raising exception [Accept], instead of returning
normally. This convention allows us to not distinguish between regular
productions and accepting productions. All we have to do is catch that
exception at top level. *)
(* Semantic actions are allowed to raise [Error]. *)
exception Accept of semantic_value
exception Error
type semantic_action =
......
......@@ -324,6 +324,11 @@ module Production : sig
val is_start: index -> bool
(* The integer [start] is published so as to allow the table back-end
to produce code for [is_start]. It should not be used otherwise. *)
val start: int
(* This produces a string representation of a production. It should
never be applied to a start production, as we do not wish users
to become aware of the existence of these extra productions. *)
......
......@@ -79,94 +79,84 @@ module T = struct
open MenhirLib.EngineTypes
exception Accept of semantic_value
exception Error
(* By convention, a semantic action returns a new stack. It does not
affect [env]. *)
let is_start =
Production.is_start
type semantic_action =
(state, semantic_value, token) env -> (state, semantic_value) stack
let semantic_action (prod : production) : semantic_action =
fun env ->
(* Check whether [prod] is a start production. *)
match Production.classify prod with
(* If it is one, accept. Start productions are of the form S' ->
S, where S is a non-terminal symbol, so the desired semantic
value is found within the top cell of the stack. *)
| Some _ ->
raise (Accept env.stack.semv)
(* If it is not, reduce. Pop a suffix of the stack, and use it
to construct a new concrete syntax tree node. *)
| None ->
let n = Production.length prod in
let values : semantic_value array =
Array.make n CstError (* dummy *)
and startp =
ref Lexing.dummy_pos
and endp=
ref Lexing.dummy_pos
and current =
ref env.current
and stack =
ref env.stack
in
(* We now enter a loop to pop [k] stack cells and (after that) push
a new cell onto the stack. *)
(* This loop does not update [env.current]. Instead, the state in
the newly pushed stack cell will be used (by our caller) as a
basis for a goto transition, and [env.current] will be updated
(if necessary) then. *)
for k = n downto 1 do
(* Fetch a semantic value. *)
values.(k - 1) <- !stack.semv;
(* Pop one cell. The stack must be non-empty. As we pop a cell,
change the automaton's current state to the one stored within
the cell. (It is sufficient to do this only when [k] is 1,
since the last write overwrites any and all previous writes.)
If this is the first (last) cell that we pop, update [endp]
([startp]). *)
let next = !stack.next in
assert (!stack != next);
if k = n then begin
endp := !stack.endp
end;
if k = 1 then begin
current := !stack.state;
startp := !stack.startp
end;
stack := next
done;
(* Done popping. *)
(* Construct and push a new stack cell. The associated semantic
value is a new concrete syntax tree. *)
{
state = !current;
semv = CstNonTerminal (prod, values);
startp = !startp;
endp = !endp;
next = !stack
}
assert (not (Production.is_start prod));
(* Reduce. Pop a suffix of the stack, and use it to construct a
new concrete syntax tree node. *)
let n = Production.length prod in
let values : semantic_value array =
Array.make n CstError (* dummy *)
and startp =
ref Lexing.dummy_pos
and endp=
ref Lexing.dummy_pos
and current =
ref env.current
and stack =
ref env.stack
in
(* We now enter a loop to pop [k] stack cells and (after that) push
a new cell onto the stack. *)
(* This loop does not update [env.current]. Instead, the state in
the newly pushed stack cell will be used (by our caller) as a
basis for a goto transition, and [env.current] will be updated
(if necessary) then. *)
for k = n downto 1 do
(* Fetch a semantic value. *)
values.(k - 1) <- !stack.semv;
(* Pop one cell. The stack must be non-empty. As we pop a cell,
change the automaton's current state to the one stored within
the cell. (It is sufficient to do this only when [k] is 1,
since the last write overwrites any and all previous writes.)
If this is the first (last) cell that we pop, update [endp]
([startp]). *)
let next = !stack.next in
assert (!stack != next);
if k = n then begin
endp := !stack.endp
end;
if k = 1 then begin
current := !stack.state;
startp := !stack.startp
end;
stack := next
done;
(* Done popping. *)
(* Construct and push a new stack cell. The associated semantic
value is a new concrete syntax tree. *)
{
state = !current;
semv = CstNonTerminal (prod, values);
startp = !startp;
endp = !endp;
next = !stack
}
let log = true
......
......@@ -28,9 +28,6 @@ let make_symbol =
let make_inspection =
menhirlib ^ ".InspectionTableInterpreter.Make"
let accept =
tableInterpreter ^ ".Accept"
let engineTypes =
menhirlib ^ ".EngineTypes"
......@@ -78,6 +75,54 @@ let more =
(* ------------------------------------------------------------------------ *)
(* Statistics. *)
(* Integer division, rounded up. *)
let div a b =
if a mod b = 0 then a / b else a / b + 1
(* [size] provides a rough measure of the size of its argument, in words.
The [unboxed] parameter is true if we have already counted 1 for the
pointer to the object. *)
let rec size unboxed = function
| EIntConst _
| ETuple []
| EData (_, []) ->
if unboxed then 0 else 1
| EStringConst s ->
1 + div (String.length s * 8) Sys.word_size
| ETuple es
| EData (_, es)
| EArray es ->
1 + List.length es + List.fold_left (fun s e -> s + size true e) 0 es
| _ ->
assert false (* not implemented *)
let size =
size false
(* Optionally, print a measure of each of the tables that we are defining. *)
let define (name, expr) = {
valpublic = true;
valpat = PVar name;
valval = expr
}
let define_and_measure (x, e) =
Error.logC 1 (fun f ->
fprintf f
"The %s table occupies roughly %d bytes.\n"
x
(size e * (Sys.word_size / 8))
);
define (x, e)
(* ------------------------------------------------------------------------ *)
(* Code generation for semantic actions. *)
(* The functions [reducecellparams] and [reducebody] are adpated from
......@@ -194,7 +239,7 @@ let reducebody prod =
sprintf "Accepting %s" (Nonterminal.print false nt),
blet (
[ pat, EVar stack ],
ERaise (EData (accept, [ EVar ids.(0) ]))
ERaise (EData ("Not_found", [])) (* TEMPORARY *)
)
)
......@@ -268,6 +313,14 @@ let semantic_action prod =
)
(* Export the number of start productions. *)
let start_def =
define (
"start",
EIntConst Production.start
)
(* ------------------------------------------------------------------------ *)
(* Table encodings. *)
......@@ -342,54 +395,6 @@ let encode_symbol_option = function
(* ------------------------------------------------------------------------ *)
(* Statistics. *)
(* Integer division, rounded up. *)
let div a b =
if a mod b = 0 then a / b else a / b + 1
(* [size] provides a rough measure of the size of its argument, in words.
The [unboxed] parameter is true if we have already counted 1 for the
pointer to the object. *)
let rec size unboxed = function
| EIntConst _
| ETuple []
| EData (_, []) ->
if unboxed then 0 else 1
| EStringConst s ->
1 + div (String.length s * 8) Sys.word_size
| ETuple es
| EData (_, es)
| EArray es ->
1 + List.length es + List.fold_left (fun s e -> s + size true e) 0 es
| _ ->
assert false (* not implemented *)
let size =
size false
(* Optionally, print a measure of each of the tables that we are defining. *)
let define (name, expr) = {
valpublic = true;
valpat = PVar name;
valval = expr
}
let define_and_measure (x, e) =
Error.logC 1 (fun f ->
fprintf f
"The %s table occupies roughly %d bytes.\n"
x
(size e * (Sys.word_size / 8))
);
define (x, e)
(* ------------------------------------------------------------------------ *)
(* Table compression. *)
(* Our sparse, two-dimensional tables are turned into one-dimensional tables
......@@ -955,6 +960,7 @@ let program =
token2value;
default_reduction;
error;
start_def;
action;
lhs;
goto;
......
......@@ -94,6 +94,11 @@ module type TABLES = sig
val goto: PackedIntArray.t * PackedIntArray.t
(* The number of start productions. A production [prod] is a start production
if and only if [prod < start] holds. *)
val start: int
(* A one-dimensional semantic action table maps productions to semantic
actions. The calling convention for semantic actions is described in
[EngineTypes]. *)
......
......@@ -7,8 +7,6 @@
here, as it ensures that each parser gets its own, distinct [Error]
exception. This is consistent with the code-based back-end. *)
exception Accept of Obj.t
(* This functor is invoked by the generated parser. *)
module Make (T : TableFormat.TABLES)
......@@ -48,6 +46,9 @@ module Make (T : TableFormat.TABLES)
nodefred env
else
defred env (code - 1)
let is_start prod =
prod < T.start
(* This auxiliary function helps access a compressed, two-dimensional
matrix, like the action and goto tables. *)
......@@ -89,9 +90,6 @@ module Make (T : TableFormat.TABLES)
(* code = 1 + state *)
code - 1
exception Accept =
Accept
exception Error =
T.Error
......
(* This module instantiates the generic [Engine] with a thin decoding layer
for the generated tables. Like [Engine], it is part of [MenhirLib]. *)
(* The exception [Accept] is pre-declared here: this obviates the need
for generating its definition. The exception [Error] is declared
within the generated parser. This is preferable to pre-declaring it
here, as it ensures that each parser gets its own, distinct [Error]
exception. This is consistent with the code-based back-end. *)
exception Accept of Obj.t
(* The exception [Error] is declared within the generated parser. This is
preferable to pre-declaring it here, as it ensures that each parser gets
its own, distinct [Error] exception. This is consistent with the code-based
back-end. *)
(* This functor is invoked by the generated parser. *)
......
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