Skip to content

GitLab

Commit b508805d authored by POTTIER Francois's avatar POTTIER Francois
Browse files

Modified the table back-end to merge the sub-modules [MenhirInterpreter] 

and [Inspection].
parent a3ce6eee
Hide whitespace changes
Inline Side-by-side
Showing with 80 additions and 95 deletions
demos/calc-incremental/calc.ml
View file @ b508805d
......@@ -30,7 +30,7 @@ let height env =
(* Printing a symbol. *)
let print_symbol symbol =
let open Parser.Inspection in
let open I in
match symbol with
| X (T T_TIMES) ->
"*"
......@@ -56,10 +56,7 @@ let print_symbol symbol =
"error"
module P =
Printers.Make(struct
include Parser.MenhirInterpreter
include Parser.Inspection
end) (struct
Printers.Make(I) (struct
let arrow = " -> "
let dot = "."
let space = " "
......@@ -71,12 +68,12 @@ module P =
let print_element e =
match e with
| I.Element (s, v, _, _) ->
print_symbol (Parser.Inspection.X (Parser.Inspection.incoming_symbol s))
print_symbol (I.X (I.incoming_symbol s))
let print_element e : string =
match e with
| I.Element (s, v, _, _) ->
let open Parser.Inspection in
let open I in
match incoming_symbol s with
| T T_TIMES ->
"*"
......@@ -121,7 +118,7 @@ let dump env =
()
| I.Cons (I.Element (current, _, _, _), _) ->
Printf.fprintf stderr "Current state: %d\n%!" (Obj.magic current);
let items = Parser.Inspection.items current in
let items = I.items current in
Printf.fprintf stderr "#Items: %d\n%!" (List.length items);
List.iter (fun item ->
Printf.fprintf stderr "%s\n%!" (P.print_item item)
......
src/interface.ml
View file @ b508805d
......@@ -34,27 +34,12 @@ let interpreter =
let result t =
TypApp (interpreter ^ ".result", [ t ])
let raw_lr1state =
"lr1state"
let lr1state =
interpreter ^ "." ^ raw_lr1state
"lr1state"
let tlr1state a : typ =
TypApp (lr1state, [a])
(* This interface item is a re-definition of the type [lr1state] as
an abbreviation for [MenhirInterpreter.lr1state]. *)
let lr1state_redef =
let a = "a" in
IITypeDecls [{
typename = raw_lr1state;
typeparams = [ a ];
typerhs = TAbbrev (tlr1state (TypVar a));
typeconstraint = None
}]
(* -------------------------------------------------------------------------- *)
(* The name of the sub-module that contains the incremental entry points. *)
......@@ -98,6 +83,35 @@ let monolithic_api grammar =
(* -------------------------------------------------------------------------- *)
(* The inspection API. *)
let inspection_api grammar () =
let a = "a" in
(* Define the types [terminal] and [nonterminal]. *)
TokenType.tokengadtdef grammar @
NonterminalType.nonterminalgadtdef grammar @
(* Include the signature that lists the inspection functions, with
appropriate type instantiations. *)
IIComment "The inspection API." ::
IIInclude (
with_types WKDestructive
"MenhirLib.IncrementalEngine.INSPECTION" [
[ a ], "lr1state", tlr1state (TypVar a);
[], "production", TypApp ("production", []);
[ a ], TokenType.tctokengadt, TokenType.ttokengadt (TypVar a);
[ a ], NonterminalType.tcnonterminalgadt, NonterminalType.tnonterminalgadt (TypVar a)
]
) ::
[]
(* -------------------------------------------------------------------------- *)
(* The incremental API. *)
let incremental_engine () : module_type =
......@@ -129,56 +143,22 @@ let incremental_api grammar () : interface =
MTSigEnd (
IIComment "The incremental API." ::
IIInclude (incremental_engine()) ::
[]
listiflazy Settings.inspection (inspection_api grammar)
)
) ::
(* The entry points must come after the incremental API, because
their type refers to the type [result]. *)
incremental_entry_points grammar
(* -------------------------------------------------------------------------- *)
(* The inspection API. *)
let inspection_api grammar () =
let a = "a" in
IIComment "The inspection API." ::
IIModule (inspection, MTSigEnd (
(* Define the types [terminal] and [nonterminal]. *)
TokenType.tokengadtdef grammar @
NonterminalType.nonterminalgadtdef grammar @
(* Include the signature that lists the inspection functions, with
appropriate type instantiations. *)
IIComment "The inspection functions." ::
IIInclude (
with_types WKDestructive
"MenhirLib.IncrementalEngine.INSPECTION" [
[ a ], "lr1state", tlr1state (TypVar a);
[], "production", TypApp ("MenhirInterpreter.production", []);
[ a ], TokenType.tctokengadt, TokenType.ttokengadt (TypVar a);
[ a ], NonterminalType.tcnonterminalgadt, NonterminalType.tnonterminalgadt (TypVar a)
]
) ::
[]
)) ::
[]
(* -------------------------------------------------------------------------- *)
(* The complete interface of the generated parser. *)
let interface grammar = [
IIFunctor (grammar.parameters,
monolithic_api grammar @
listiflazy Settings.table (incremental_api grammar) @
listiflazy Settings.inspection (inspection_api grammar)
listiflazy Settings.table (incremental_api grammar)
)
]
......
src/interface.mli
View file @ b508805d
......@@ -18,12 +18,6 @@ val interpreter: string
val result: IL.typ -> IL.typ
(* The type ['a lr1state], defined by the interpreter sub-module. *)
val lr1state: string
val tlr1state: IL.typ -> IL.typ
val lr1state_redef: IL.interface_item
(* The name of the sub-module that contains the incremental entry points. *)
val incremental: string
......
src/tableBackend.ml
View file @ b508805d
......@@ -16,11 +16,8 @@ module Run (T : sig end) = struct
let menhirlib =
"MenhirLib"
let tableInterpreter =
menhirlib ^ ".TableInterpreter"
let make =
tableInterpreter ^ ".Make"
let make_engine =
menhirlib ^ ".TableInterpreter.Make"
let make_symbol =
menhirlib ^ ".InspectionTableInterpreter.Symbols"
......@@ -64,14 +61,22 @@ let entry =
let start =
interpreter ^ ".start"
(* The following are names of internal sub-modules. *)
let basics =
"Basics" (* name of an internal sub-module *)
"Basics"
let tables =
"Tables" (* name of an internal sub-module *)
"Tables"
let symbols =
"Symbols"
let shared =
"Shared"
let more =
"More" (* name of an internal sub-module *)
let ti =
"TI"
(* ------------------------------------------------------------------------ *)
......@@ -934,11 +939,23 @@ let program =
(* Define the tables. *)
SIModuleDef (shared,
MStruct [
SIValDefs (false, [
lhs;
])
]
) ::
SIModuleDef (tables,
MStruct [
(* The internal sub-module [basics] contains the definitions of the
exception [Error] and of the type [token]. *)
SIInclude (MVar basics);
(* The internal sub-module [shared] contains the tables that are
used both in normal mode and in [--inspection] mode. *)
SIInclude (MVar shared);
(* This is a non-recursive definition, so none of the names
defined here are visible in the semantic actions. *)
SIValDefs (false, [
......@@ -949,7 +966,7 @@ let program =
error;
start_def;
action;
lhs;
(* [lhs] is part of [shared] *)
goto;
semantic_action;
trace;
......@@ -957,43 +974,40 @@ let program =
]
) ::
(* Apply the functor [TableInterpreter.Make] to the tables. *)
SIModuleDef (interpreter, MStruct (
SIModuleDef (interpreter,
MApp (MVar make, MVar tables)
) ::
(* Apply the functor [TableInterpreter.Make] to the tables. *)
SIModuleDef (ti, MApp (MVar make_engine, MVar tables)) ::
SIInclude (MVar ti) ::
listiflazy Settings.inspection (fun () -> [
SIModuleDef (inspection, MStruct (
listiflazy Settings.inspection (fun () ->
(* Define the internal sub-module [more], which contains type
(* Define the internal sub-module [symbols], which contains type
definitions. Then, include this sub-module. This sub-module is used
again below, as part of the application of the functor
[TableInterpreter.MakeInspection]. *)
SIModuleDef (more, MStruct (
SIModuleDef (symbols, MStruct (
interface_to_structure (
tokengadtdef grammar @
nonterminalgadtdef grammar
)
)) ::
SIInclude (MVar more) ::
SIInclude (MVar symbols) ::
SIInclude (MApp (MVar make_inspection, MStruct (
(* This module must satisfy [InspectionTableFormat.TABLES]. *)
(* [lr1state] *)
interface_to_structure [
lr1state_redef;
] @
SIInclude (MVar ti) ::
(* [terminal], [nonterminal]. *)
SIInclude (MVar more) ::
SIInclude (MVar symbols) ::
(* This functor application builds the types [symbol] and [xsymbol]
in terms of the types [terminal] and [nonterminal]. This saves
us the trouble of generating these definitions. *)
SIInclude (MApp (MVar make_symbol, MVar more)) ::
SIInclude (MApp (MVar make_symbol, MVar symbols)) ::
(* [lhs] *)
SIInclude (MVar tables) ::
SIInclude (MVar shared) ::
SIValDefs (false,
terminal() ::
nonterminal() ::
......@@ -1008,9 +1022,9 @@ let program =
[]
))
)
]) @
)) ::
SIValDefs (false, monolithic_api) ::
......
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