Commit 5287555a authored by POTTIER Francois's avatar POTTIER Francois

CodeBits: replaced [filter_types] with [interface_to_structure], which is

more general and correct (the old code could change a set of nonrecursive
type definitions into a set of recursive type definitions).
parent d92bfe7f
* filter_typedefs
* simplify Printer.functorparams
* Introduce a submodule Incremental for the incremental entry
points. Clean up IL to make it more general.
......
......@@ -1631,18 +1631,19 @@ let grammar =
let program =
[ SIFunctor (grammar.parameters, [
[ SIFunctor (grammar.parameters,
SIExcDefs [ excdef ];
SIExcDefs [ excdef ] ::
SITypeDefs (
filter_typedefs (tokentypedefs grammar) @
[ envtypedef; statetypedef ]
);
interface_to_structure (
tokentypedefs grammar
) @
SIStretch grammar.preludes;
SITypeDefs [ envtypedef; statetypedef ] ::
SIValDefs (false, [ excvaldef ]);
SIStretch grammar.preludes ::
SIValDefs (false, [ excvaldef ]) ::
SIValDefs (true,
ProductionMap.fold (fun _ s defs ->
......@@ -1659,11 +1660,11 @@ let program =
else
defs
) [ discarddef; initenvdef; printtokendef; assertfalsedef; errorcasedef ])))
);
) ::
SIStretch grammar.postludes;
SIStretch grammar.postludes ::
])]
[])]
(* ------------------------------------------------------------------------ *)
(* We are done! *)
......
......@@ -153,14 +153,21 @@ let tvprefix name =
(* ------------------------------------------------------------------------ *)
let filter_typedefs (items : interface_item list) : typedef list =
(* TEMPORARY ideally, should not flatten, as this turns a nonrecursive
definition into a recursive one *)
List.flatten (List.map (fun item ->
match item with
| IITypeDecls defs ->
defs
| _ ->
[]
) items)
(* Converting an interface to a structure. Only exception and type definitions
go through. *)
let interface_item_to_structure_item = function
| IIExcDecls defs ->
[ SIExcDefs defs ]
| IITypeDecls defs ->
[ SITypeDefs defs ]
| IIFunctor (_, _)
| IIValDecls _
| IIInclude _
| IIModule (_, _)
| IIComment _ ->
[]
let interface_to_structure i =
List.flatten (List.map interface_item_to_structure_item i)
......@@ -54,7 +54,7 @@ val prefix: string -> string
val dataprefix: string -> string
val tvprefix: string -> string
(* Projecting interface items to typedefs. Any interface items other
than typedefs are lost. *)
val filter_typedefs: interface_item list -> typedef list
(* Converting an interface to a structure. Only exception and type definitions
go through. *)
val interface_to_structure: interface -> structure
......@@ -180,12 +180,12 @@ let program grammar =
tokens, because, in principle, the semantic actions may refer to
it or to its data constructors. *)
[ SIFunctor (grammar.parameters, [
SITypeDefs (filter_typedefs (tokentypedefs grammar));
SIStretch grammar.preludes;
SIValDefs (false, [ begindef; def; enddef ]);
SIStretch grammar.postludes;
])]
[ SIFunctor (grammar.parameters,
interface_to_structure (tokentypedefs grammar) @
SIStretch grammar.preludes ::
SIValDefs (false, [ begindef; def; enddef ]) ::
SIStretch grammar.postludes ::
[])]
(* ------------------------------------------------------------------------- *)
(* Writing the program associated with a grammar to a file. *)
......
......@@ -13,7 +13,7 @@ val tnonterminalgadt: IL.typ -> IL.typ
information, or because [--infer] has been set and inference has been
performed already. This definition is produced only in [--table] mode. *)
val nonterminalgadtdef: UnparameterizedSyntax.grammar -> IL.interface_item list
val nonterminalgadtdef: UnparameterizedSyntax.grammar -> IL.interface
(* When in [--(raw-)depend] mode, we are asked to produce a mock [.mli] file
before [--infer] has run, which means that we are usually not able to
......
......@@ -5,5 +5,5 @@ val tsymbolgadt: IL.typ -> IL.typ
(* The definition of the symbol GADT. This definition can be produced only if
we are successfully able to construct the nonterminal GADT first. *)
val symbolgadtdef: UnparameterizedSyntax.grammar -> IL.interface_item list
val symbolgadtdef: UnparameterizedSyntax.grammar -> IL.interface
......@@ -745,28 +745,29 @@ let grammar =
let program =
[ SIFunctor (grammar.parameters, [
[ SIFunctor (grammar.parameters,
SIExcDefs [ excdef ];
SIExcDefs [ excdef ] ::
SITypeDefs (
filter_typedefs (tokentypedefs grammar) @
filter_typedefs (nonterminalgadtdef grammar) @
filter_typedefs (symbolgadtdef grammar) @
[ tokendef1 ]
);
interface_to_structure (
tokentypedefs grammar @
nonterminalgadtdef grammar @
symbolgadtdef grammar
) @
SIStretch grammar.preludes;
SITypeDefs [ tokendef1 ] ::
SIValDefs (false, [ excvaldef ]);
SIStretch grammar.preludes ::
SIModuleDef (interpreter, application);
SIValDefs (false, [ excvaldef ]) ::
SIValDefs (false, api);
SIModuleDef (interpreter, application) ::
SIStretch grammar.postludes;
SIValDefs (false, api) ::
])]
SIStretch grammar.postludes ::
[])]
let () =
Time.tick "Producing abstract syntax"
......
......@@ -117,7 +117,7 @@ let produce_tokentypes grammar =
necessary by the fact that the two can be different
when there are functor parameters. *)
let items = typedefs grammar in
let i = typedefs grammar in
let module P =
Printer.Make (struct
......@@ -127,7 +127,7 @@ let produce_tokentypes grammar =
end)
in
P.interface [
IIFunctor (grammar.parameters, items)
IIFunctor (grammar.parameters, i)
];
let module P =
Printer.Make (struct
......@@ -137,9 +137,9 @@ let produce_tokentypes grammar =
end)
in
P.program [
SIFunctor (grammar.parameters, [
SITypeDefs (filter_typedefs items)
])
SIFunctor (grammar.parameters,
interface_to_structure i
)
];
exit 0
......
......@@ -38,7 +38,7 @@ val tokenprefix: string -> string
the type [token] when not in [--table] mode, and the types [token] and
[terminal] when in [--table] mode. *)
val tokentypedefs: UnparameterizedSyntax.grammar -> IL.interface_item list
val tokentypedefs: UnparameterizedSyntax.grammar -> IL.interface
(* If [--only-tokens] is set, then [produce_tokentypes] writes the type
definitions to the [.ml] and [.mli] files and stops Menhir. Otherwise,
......
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