Commit 57e8832b authored by POTTIER Francois's avatar POTTIER Francois

Separated [tokentypedef] and [tokengadtdef] because these types must be

  defined at different places in the generated file (in order to avoid
  name clashes, and for clarity).
parent 8cb43224
...@@ -1636,7 +1636,7 @@ let program = ...@@ -1636,7 +1636,7 @@ let program =
SIExcDefs [ excdef ] :: SIExcDefs [ excdef ] ::
interface_to_structure ( interface_to_structure (
tokentypedefs grammar tokentypedef grammar
) @ ) @
SITypeDefs [ envtypedef; statetypedef ] :: SITypeDefs [ envtypedef; statetypedef ] ::
......
...@@ -181,7 +181,7 @@ let program grammar = ...@@ -181,7 +181,7 @@ let program grammar =
it or to its data constructors. *) it or to its data constructors. *)
[ SIFunctor (grammar.parameters, [ SIFunctor (grammar.parameters,
interface_to_structure (tokentypedefs grammar) @ interface_to_structure (tokentypedef grammar) @
SIStretch grammar.preludes :: SIStretch grammar.preludes ::
SIValDefs (false, [ begindef; def; enddef ]) :: SIValDefs (false, [ begindef; def; enddef ]) ::
SIStretch grammar.postludes :: SIStretch grammar.postludes ::
......
...@@ -82,9 +82,7 @@ let table_interface grammar = ...@@ -82,9 +82,7 @@ let table_interface grammar =
let interface grammar = [ let interface grammar = [
IIFunctor (grammar.parameters, IIFunctor (grammar.parameters,
TokenType.tokentypedefs grammar @ TokenType.tokentypedef grammar @ [
NonterminalType.nonterminalgadtdef grammar @
SymbolType.symbolgadtdef grammar @ [
IIComment "This exception is raised by the monolithic API functions."; IIComment "This exception is raised by the monolithic API functions.";
IIExcDecls [ excdef ]; IIExcDecls [ excdef ];
IIComment "The monolithic API."; IIComment "The monolithic API.";
...@@ -93,7 +91,12 @@ let interface grammar = [ ...@@ -93,7 +91,12 @@ let interface grammar = [
(Misc.normalize symbol, entrytypescheme grammar symbol) :: decls (Misc.normalize symbol, entrytypescheme grammar symbol) :: decls
) grammar.start_symbols [] ) grammar.start_symbols []
) )
] @ table_interface grammar) ] @
TokenType.tokengadtdef grammar @
NonterminalType.nonterminalgadtdef grammar @
SymbolType.symbolgadtdef grammar @
table_interface grammar
)
] ]
(* Writing the interface to a file. *) (* Writing the interface to a file. *)
......
...@@ -668,6 +668,8 @@ let application = ...@@ -668,6 +668,8 @@ let application =
MStruct [ MStruct [
SIExcDefs [ excredef ]; SIExcDefs [ excredef ];
SITypeDefs [ tokendef2 ]; SITypeDefs [ tokendef2 ];
(* This is a non-recursive definition, so none of the names
defined here are visible in the semantic actions. *)
SIValDefs (false, [ SIValDefs (false, [
token2terminal; token2terminal;
define ("error_terminal", EIntConst (Terminal.t2i Terminal.error)); define ("error_terminal", EIntConst (Terminal.t2i Terminal.error));
...@@ -839,13 +841,15 @@ let program = ...@@ -839,13 +841,15 @@ let program =
SIExcDefs [ excdef ] :: SIExcDefs [ excdef ] ::
interface_to_structure ( interface_to_structure (
tokentypedefs grammar @ tokentypedef grammar
nonterminalgadtdef grammar @
symbolgadtdef grammar
) @ ) @
SITypeDefs [ tokendef1 ] :: SITypeDefs [ tokendef1 ] ::
(* In order to avoid hiding user-defined identifiers, only the
exception [Error] and the type [token] should be defined (at
top level, with non-mangled names) above this line. *)
SIStretch grammar.preludes :: SIStretch grammar.preludes ::
SIValDefs (false, [ excvaldef ]) :: SIValDefs (false, [ excvaldef ]) ::
...@@ -854,6 +858,12 @@ let program = ...@@ -854,6 +858,12 @@ let program =
SIValDefs (false, api) :: SIValDefs (false, api) ::
interface_to_structure (
tokengadtdef grammar @
nonterminalgadtdef grammar @
symbolgadtdef grammar
) @
SIValDefs (false, [incoming_symbol_def]) :: SIValDefs (false, [incoming_symbol_def]) ::
SIStretch grammar.postludes :: SIStretch grammar.postludes ::
......
...@@ -66,45 +66,42 @@ let tokentypedef grammar = ...@@ -66,45 +66,42 @@ let tokentypedef grammar =
(* This is the definition of the token GADT. Here, the data (* This is the definition of the token GADT. Here, the data
constructors have no value argument, but have a type index. *) constructors have no value argument, but have a type index. *)
let tokengadtdef grammar = (* The token GADT is produced only in [--table] mode. This ensures that, when
let datadefs = [--table] is off, we remain compatible with old versions of OCaml, without
StringMap.fold (fun token properties defs -> GADTs. *)
if properties.tk_is_declared then
let index =
match properties.tk_ocamltype with
| None ->
tunit
| Some t ->
TypTextual t
in
{
dataname = ttokengadtdata token;
datavalparams = [];
datatypeparams = Some [ index ]
} :: defs
else
defs
) grammar.tokens []
in
[
IIComment "The indexed type of terminal symbols.";
IITypeDecls [{
typename = tctokengadt;
typeparams = [ "_" ];
typerhs = TDefSum datadefs;
typeconstraint = None
}]
]
(* The token type is always needed. The token GADT is needed only in let tokengadtdef grammar =
[--table] mode. This ensures that, when [--table] is off, we remain
compatible with old versions of OCaml, without GADTs. *)
let typedefs grammar =
if Settings.table then if Settings.table then
tokentypedef grammar @ tokengadtdef grammar let datadefs =
StringMap.fold (fun token properties defs ->
if properties.tk_is_declared then
let index =
match properties.tk_ocamltype with
| None ->
tunit
| Some t ->
TypTextual t
in
{
dataname = ttokengadtdata token;
datavalparams = [];
datatypeparams = Some [ index ]
} :: defs
else
defs
) grammar.tokens []
in
[
IIComment "The indexed type of terminal symbols.";
IITypeDecls [{
typename = tctokengadt;
typeparams = [ "_" ];
typerhs = TDefSum datadefs;
typeconstraint = None
}]
]
else else
tokentypedef grammar []
(* If we were asked to only produce a type definition, then (* If we were asked to only produce a type definition, then
do so and stop. *) do so and stop. *)
...@@ -117,7 +114,10 @@ let produce_tokentypes grammar = ...@@ -117,7 +114,10 @@ let produce_tokentypes grammar =
necessary by the fact that the two can be different necessary by the fact that the two can be different
when there are functor parameters. *) when there are functor parameters. *)
let i = typedefs grammar in let i =
tokentypedef grammar @
tokengadtdef grammar
in
let module P = let module P =
Printer.Make (struct Printer.Make (struct
...@@ -147,16 +147,25 @@ let produce_tokentypes grammar = ...@@ -147,16 +147,25 @@ let produce_tokentypes grammar =
| Settings.TokenTypeAndCode -> | Settings.TokenTypeAndCode ->
() ()
(* Define [tokentypedefs], and define [tokenprefix], so as to tell the code (* Define [tokentypedef] and [tokengadtdef], [tokenprefix]. *)
generator whether it should include a definition of the token types in the
code and how the token types are called. *)
let tokentypedefs grammar = let tokentypedef grammar =
match Settings.token_type_mode with
| Settings.CodeOnly _ ->
[]
| Settings.TokenTypeAndCode ->
tokentypedef grammar
| Settings.TokenTypeOnly ->
(* This should not happen, as [produce_tokentype] should
have been called first. *)
assert false
let tokengadtdef grammar =
match Settings.token_type_mode with match Settings.token_type_mode with
| Settings.CodeOnly _ -> | Settings.CodeOnly _ ->
[] []
| Settings.TokenTypeAndCode -> | Settings.TokenTypeAndCode ->
typedefs grammar tokengadtdef grammar
| Settings.TokenTypeOnly -> | Settings.TokenTypeOnly ->
(* This should not happen, as [produce_tokentype] should (* This should not happen, as [produce_tokentype] should
have been called first. *) have been called first. *)
......
...@@ -15,7 +15,7 @@ ...@@ -15,7 +15,7 @@
then the list [tokentypedefs] is empty, and [tokenprefix] produces a then the list [tokentypedefs] is empty, and [tokenprefix] produces a
nontrivial prefix. *) nontrivial prefix. *)
(* This is the conventional name of the [token] type, for use by the code (* The conventional name of the [token] type, for use by the code
generators. If [--external-tokens] is set, this type is qualified. *) generators. If [--external-tokens] is set, this type is qualified. *)
val ttoken: IL.typ val ttoken: IL.typ
...@@ -26,10 +26,10 @@ val ttoken: IL.typ ...@@ -26,10 +26,10 @@ val ttoken: IL.typ
val tokendata: string -> string val tokendata: string -> string
(* This is the conventional name of the [terminal] type, a.k.a. the token (* The conventional name of the [terminal] type, a.k.a. the token GADT. This
GADT. This is an indexed type (i.e., it has one type parameter). Its data is an indexed type (i.e., it has one type parameter). Its data constructors
constructors carry zero value arguments. If [--external-tokens] is set, carry zero value arguments. If [--external-tokens] is set, this type is
this type is qualified. *) qualified. *)
val ttokengadt: IL.typ -> IL.typ val ttokengadt: IL.typ -> IL.typ
...@@ -38,13 +38,14 @@ val ttokengadt: IL.typ -> IL.typ ...@@ -38,13 +38,14 @@ val ttokengadt: IL.typ -> IL.typ
val tokengadtdata: string -> string val tokengadtdata: string -> string
(* These are the definitions of the types of tokens, for use by the code (* The definitions of the token type and of the token GADT, for use by the
generators. This can be a list of zero, one, or two types. Indeed, this code generators. Each of these lists may define zero or one type. Indeed,
list is empty when [--external-tokens] is set. Otherwise, it contains just both lists are empty when [--external-tokens] is set. Otherwise, only the
the type [token] when not in [--table] mode, and the types [token] and type [token] is defined when not in [--table] mode, and both [token] and
[terminal] when in [--table] mode. *) [terminal] are defined when in [--table] mode. *)
val tokentypedefs: UnparameterizedSyntax.grammar -> IL.interface val tokentypedef: UnparameterizedSyntax.grammar -> IL.interface
val tokengadtdef: UnparameterizedSyntax.grammar -> IL.interface
(* If [--only-tokens] is set, then [produce_tokentypes] writes the type (* If [--only-tokens] is set, then [produce_tokentypes] writes the type
definitions to the [.ml] and [.mli] files and stops Menhir. Otherwise, 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