Commit dd0ba5fa authored by POTTIER Francois's avatar POTTIER Francois

Added the generation of the function [symbol], which has type

['a lr1state -> 'a symbol] and maps a state (an abstract datum)
to (a code for) its incoming symbol. This allows inspecting the
semantic values stored in the stack.
Updated the demo [calc-incremental] to display the contents of
the stack at every token. It seems to work!
parent b6469a4b
* maybe merge signature_item and structure_item?
that would allow getting rid of interface_item_to_structure_item
and of some duplication in the printer
* Introduce a submodule Incremental for the incremental entry
points. Move also the types terminal, nonterminal, symbol
to a sub-module, to avoid any name clashes.
* Clean up Interface and tableBackend. Decide whether we need
a new switch (--inspect) for the inspection API. Condition
[terminal], [nonterminal], etc. to this new switch.
* IncrementalEngine: document [lr1state], [element], [view].
* Define MenhirLib.Stream?
......
......@@ -12,12 +12,60 @@ let rec length xs =
| I.Cons (_, xs) ->
1 + length xs
(* Folding over a stream. *)
let rec foldr f xs accu =
match Lazy.force xs with
| I.Nil ->
accu
| I.Cons (x, xs) ->
f x (foldr f xs accu)
(* A measure of the stack height. Used as a primitive way of
testing the [view] function. *)
let height env =
length (I.view env)
(* Printing an element. *)
let print_element e : string =
match e with
| I.Element (s, v, _, _) ->
let sy = Parser.symbol s in
let open Parser in
match sy with
| T T_TIMES ->
"*"
| T T_RPAREN ->
")"
| T T_PLUS ->
"+"
| T T_MINUS ->
"-"
| T T_LPAREN ->
"("
| T T_INT ->
string_of_int v
| N N_expr ->
string_of_int v
| N N_main ->
string_of_int v
| T T_EOL ->
""
| T T_DIV ->
"/"
(* Printing a stack. *)
let print env : string =
let b = Buffer.create 80 in
foldr (fun e () ->
Buffer.add_string b (print_element e);
Buffer.add_char b ' ';
) (I.view env) ();
Buffer.contents b
(* Define the loop which drives the parser. At each iteration,
we analyze a result produced by the parser, and act in an
appropriate manner. *)
......@@ -26,8 +74,10 @@ let rec loop linebuf (result : int I.result) =
match result with
| I.InputNeeded env ->
(* TEMPORARY *)
if false then
Printf.fprintf stderr "Stack height: %d\n%!" (height env);
if true then begin
Printf.fprintf stderr "Stack height: %d\n%!" (height env);
Printf.fprintf stderr "Stack view:\n%s\n%!" (print env)
end;
(* The parser needs a token. Request one from the lexer,
and offer it to the parser, which will produce a new
result. Then, repeat. *)
......
......@@ -897,7 +897,7 @@ let shiftbranch s tok s' =
assert (not (Terminal.pseudo tok));
{
branchpat =
PData (tokenprefix (Terminal.print tok), tokval tok (PVar semv));
PData (tokendata (Terminal.print tok), tokval tok (PVar semv));
branchbody =
shiftbranchbody s tok s'
}
......
......@@ -143,13 +143,13 @@ let tokval tok x =
its semantic value. *)
let tokpat tok =
PData (TokenType.tokenprefix (Terminal.print tok), tokval tok PWildcard)
PData (TokenType.tokendata (Terminal.print tok), tokval tok PWildcard)
(* [tokpatv tok] is a pattern that matches the token [tok], and binds
its semantic value, if it has one, to the variable [semv]. *)
let tokpatv tok =
PData (TokenType.tokenprefix (Terminal.print tok), tokval tok (PVar semv))
PData (TokenType.tokendata (Terminal.print tok), tokval tok (PVar semv))
(* [tokspat toks] is a pattern that matches any token in the set [toks],
without binding its semantic value. *)
......
......@@ -349,6 +349,7 @@ module type ENGINE = sig
include IncrementalEngine.INCREMENTAL_ENGINE
with type token := token
and type 'a lr1state = state (* useful for us; hidden from the end user *)
include INCREMENTAL_ENGINE_START
with type state := state
......
......@@ -66,7 +66,16 @@ let table_interface grammar =
StringSet.fold (fun symbol decls ->
(incremental symbol, entrytypescheme_incremental grammar symbol) :: decls
) grammar.start_symbols []
)
);
(* TEMPORARY comment *)
IIValDecls [
let ty =
arrow (TypApp (interpreter ^ ".lr1state", [ TypVar "a" ]))
(TypApp ("symbol", [ TypVar "a" ]))
in
(* TEMPORARY code sharing with tableBackend *)
"symbol", type2scheme ty
]
] else []
(* This is the interface of the generated parser. *)
......
......@@ -7,6 +7,11 @@
val tnonterminalgadt: IL.typ -> IL.typ
(* [tnonterminalgadtdata nt] is the conventional name of the data constructor
associated with the non-terminal symbol [nt]. *)
val tnonterminalgadtdata: string -> string
(* This is the definition of the [nonterminal] GADT, for use by the code
generators. This definition can be constructed only if the type of every
nonterminal symbol is known, either because the user has provided this
......
......@@ -10,7 +10,7 @@ let tcsymbolgadt =
let tsymbolgadt a =
TypApp (tcsymbolgadt, [ a ])
(* The conventional name of the data constructors. *)
(* The conventional names of the data constructors. *)
let dataT =
"T"
......
......@@ -2,6 +2,11 @@
val tsymbolgadt: IL.typ -> IL.typ
(* The conventional names of the data constructors. *)
val dataT: string
val dataN: string
(* The definition of the symbol GADT. This definition can be produced only if
we are successfully able to construct the nonterminal GADT first. *)
......
......@@ -62,6 +62,9 @@ let entry =
let start =
interpreter ^ ".start"
let lr1state =
interpreter ^ ".lr1state"
(* ------------------------------------------------------------------------ *)
(* Code generation for semantic actions. *)
......@@ -736,6 +739,92 @@ let api : IL.valdef list =
(* ------------------------------------------------------------------------ *)
(* Constructing representations of symbols. *)
(* [eterminal t] is a value of type ['a terminal] (for some ['a]) that
encodes the terminal symbol [t]. It is just a data constructor of
the terminal GADT. *)
let eterminal (t : Terminal.t) : expr =
EData (tokengadtdata (Terminal.print t), [])
(* [enonterminal nt] is a value of type ['a nonterminal] (for some
['a]) that encodes the nonterminal symbol [nt]. It is just a data
constructor of the nonterminal GADT. *)
let enonterminal (nt : Nonterminal.t) : expr =
EData (tnonterminalgadtdata (Nonterminal.print false nt), [])
(* [esymbol symbol] is a value of type ['a symbol] (for some ['a])
that encodes the symbol [symbol]. It is built by applying the
injection [T] or [N] to the terminal or nonterminal encoding. *)
let esymbol (symbol : Symbol.t) : expr =
match symbol with
| Symbol.T t ->
EData (dataT, [ eterminal t ])
| Symbol.N nt ->
EData (dataN, [ enonterminal nt ])
(* The type [MenhirInterpreter.lr1state] is known (to us) to be an
alias for [int], so we can pattern match on it. To the user,
though, it will be an abstract type. *)
let tlr1state a : typ =
TypApp (lr1state, [a])
(* Produce a function [symbol] that maps a state of type ['a lr1state]
(represented as an integer value) to a value of type ['a symbol]. *)
(* TEMPORARY maybe subject to a switch, so as to reduce table size *)
let incoming_symbol_def = {
valpublic = true;
valpat = PVar "symbol";
valval =
EAnnot (
EFun ([ PVar state ],
EMatch (EVar state,
(* A default branch is used to ensure exhaustiveness. *)
let default =
{ branchpat =
PWildcard;
branchbody =
EComment ("This state does not exist.",
EApp (EVar "assert", [ efalse ])
)
}
in
(* One branch per LR(1) state. *)
Lr1.fold (fun branches node ->
let branchpat =
pint (Lr1.number node)
in
let branchbody =
match Lr1.incoming_symbol node with
| None ->
(* This function must not be applied to an initial state.
We will be careful not to expose the initial states
as inhabitants of the type ['a lr1state]. *)
EComment ("This is an initial state.",
EApp (EVar "assert", [ efalse ])
)
| Some symbol ->
(* To a non-initial state, we associate a representation
of its incoming symbol. *)
EMagic (esymbol symbol)
in
{ branchpat; branchbody } :: branches
) [default]
)
),
let a = TypVar "a" in
type2scheme (arrow (tlr1state a) (tsymbolgadt a))
)
}
(* ------------------------------------------------------------------------ *)
(* Let's put everything together. *)
open UnparameterizedSyntax
......@@ -765,6 +854,8 @@ let program =
SIValDefs (false, api) ::
SIValDefs (false, [incoming_symbol_def]) ::
SIStretch grammar.postludes ::
[])]
......
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