Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
M
menhir
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
12
Issues
12
List
Boards
Labels
Service Desk
Milestones
Merge Requests
0
Merge Requests
0
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Operations
Operations
Incidents
Environments
Packages & Registries
Packages & Registries
Container Registry
Analytics
Analytics
CI / CD
Repository
Value Stream
Wiki
Wiki
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
POTTIER Francois
menhir
Commits
86639b79
Commit
86639b79
authored
Jul 23, 2018
by
Frédéric Bour
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
proof-of-concept
parent
d1026227
Changes
18
Hide whitespace changes
Inline
Side-by-side
Showing
18 changed files
with
231 additions
and
81 deletions
+231
-81
demos/calc-incremental/calc.ml
demos/calc-incremental/calc.ml
+8
-6
demos/calc-incremental/parser.mly
demos/calc-incremental/parser.mly
+9
-7
demos/calc/Makefile
demos/calc/Makefile
+1
-1
demos/calc/parser.mly
demos/calc/parser.mly
+1
-0
src/EngineTypes.ml
src/EngineTypes.ml
+15
-0
src/IL.mli
src/IL.mli
+2
-0
src/codeBits.ml
src/codeBits.ml
+9
-2
src/codeBits.mli
src/codeBits.mli
+2
-1
src/codePieces.ml
src/codePieces.ml
+3
-0
src/codePieces.mli
src/codePieces.mli
+1
-0
src/grammarFunctor.ml
src/grammarFunctor.ml
+6
-0
src/grammarFunctor.mli
src/grammarFunctor.mli
+5
-0
src/infer.ml
src/infer.ml
+11
-3
src/inliner.ml
src/inliner.ml
+2
-0
src/interface.ml
src/interface.ml
+17
-5
src/invariant.ml
src/invariant.ml
+22
-9
src/printer.ml
src/printer.ml
+4
-0
src/tableBackend.ml
src/tableBackend.ml
+113
-47
No files found.
demos/calc-incremental/calc.ml
View file @
86639b79
...
...
@@ -19,9 +19,9 @@ let rec loop lexbuf (checkpoint : int I.checkpoint) =
and offer it to the parser, which will produce a new
checkpoint. Then, repeat. *)
let
token
=
Lexer
.
token
lexbuf
in
let
startp
=
lexbuf
.
lex_start_p
and
endp
=
lexbuf
.
lex_curr_p
in
let
checkpoint
=
I
.
offer
checkpoint
(
token
,
startp
,
endp
)
in
let
startp
=
lexbuf
.
lex_start_p
os
and
endp
=
lexbuf
.
lex_curr_p
os
in
let
checkpoint
=
I
.
offer
checkpoint
(
token
,
(
startp
,
endp
)
)
in
loop
lexbuf
checkpoint
|
I
.
Shifting
_
|
I
.
AboutToReduce
_
->
...
...
@@ -57,7 +57,8 @@ let fail lexbuf (_ : int I.checkpoint) =
(
lexeme_start
lexbuf
)
let
loop
lexbuf
result
=
let
supplier
=
I
.
lexer_lexbuf_to_supplier
Lexer
.
token
lexbuf
in
let
get_location
l
=
(
l
.
Lexing
.
lex_start_pos
,
l
.
Lexing
.
lex_curr_pos
)
in
let
supplier
=
I
.
lexer_lexbuf_to_supplier
Lexer
.
token
get_location
lexbuf
in
I
.
loop_handle
succeed
(
fail
lexbuf
)
supplier
result
(* -------------------------------------------------------------------------- *)
...
...
@@ -66,8 +67,9 @@ let loop lexbuf result =
let
process
(
line
:
string
)
=
let
lexbuf
=
from_string
line
in
let
loc
=
(
lexbuf
.
lex_start_pos
,
lexbuf
.
lex_curr_pos
)
in
try
loop
lexbuf
(
Parser
.
Incremental
.
main
l
exbuf
.
lex_curr_p
)
loop
lexbuf
(
Parser
.
Incremental
.
main
l
oc
)
with
|
Lexer
.
Error
msg
->
Printf
.
fprintf
stderr
"%s%!"
msg
...
...
@@ -89,7 +91,7 @@ let rec repeat channel =
process
optional_line
;
if
continue
then
repeat
channel
let
()
=
repeat
(
from_channel
stdin
)
demos/calc-incremental/parser.mly
View file @
86639b79
%
location
<
MyLocation
>
%
token
<
int
>
INT
%
token
PLUS
MINUS
TIMES
DIV
%
token
LPAREN
RPAREN
...
...
@@ -17,17 +19,17 @@ main:
expr
:
|
i
=
INT
{
i
}
{
prerr_endline
(
MyLocation
.
trace
$
loc
);
i
}
|
LPAREN
e
=
expr
RPAREN
{
e
}
{
prerr_endline
(
MyLocation
.
trace
$
loc
);
e
}
|
e1
=
expr
PLUS
e2
=
expr
{
e1
+
e2
}
{
prerr_endline
(
MyLocation
.
trace
$
loc
);
e1
+
e2
}
|
e1
=
expr
MINUS
e2
=
expr
{
e1
-
e2
}
{
prerr_endline
(
MyLocation
.
trace
$
loc
);
e1
-
e2
}
|
e1
=
expr
TIMES
e2
=
expr
{
e1
*
e2
}
{
prerr_endline
(
MyLocation
.
trace
$
loc
);
e1
*
e2
}
|
e1
=
expr
DIV
e2
=
expr
{
e1
/
e2
}
{
prerr_endline
(
MyLocation
.
trace
$
loc
);
e1
/
e2
}
|
MINUS
e
=
expr
%
prec
UMINUS
{
-
e
}
{
prerr_endline
(
MyLocation
.
trace
$
loc
);
-
e
}
demos/calc/Makefile
View file @
86639b79
...
...
@@ -5,7 +5,7 @@ ifndef MENHIR
MENHIR
:=
$(
shell
../find-menhir.sh
)
endif
MENHIRFLAGS
:=
--infer
MENHIRFLAGS
:=
--infer
--table
OCAMLBUILD
:=
ocamlbuild
-use-ocamlfind
-use-menhir
-menhir
"
$(MENHIR)
$(MENHIRFLAGS)
"
...
...
demos/calc/parser.mly
View file @
86639b79
...
...
@@ -2,6 +2,7 @@
%
token
PLUS
MINUS
TIMES
DIV
%
token
LPAREN
RPAREN
%
token
EOL
%
location
<
MyLocation
>
%
left
PLUS
MINUS
/*
lowest
precedence
*/
%
left
TIMES
DIV
/*
medium
precedence
*/
...
...
src/EngineTypes.ml
View file @
86639b79
...
...
@@ -406,3 +406,18 @@ module type ENGINE = sig
and
type
location
:=
location
end
(* --------------------------------------------------------------------------- *)
(* This signature describes the signature of locations manipulated by Menhir. *)
module
type
LOCATION
=
sig
type
t
val
empty_after
:
t
->
t
val
join
:
t
array
->
t
val
trace
:
t
->
string
val
get
:
Lexing
.
lexbuf
->
t
end
module
As_location
(
M
:
LOCATION
)
:
LOCATION
with
type
t
=
M
.
t
=
M
src/IL.mli
View file @
86639b79
...
...
@@ -29,6 +29,7 @@ and interface_item =
|
IIInclude
of
module_type
(* Submodule. *)
|
IIModule
of
string
*
module_type
|
IIModuleAlias
of
string
*
Stretch
.
t
(* Comment. *)
|
IIComment
of
string
...
...
@@ -239,6 +240,7 @@ and modexpr =
|
MVar
of
string
|
MStruct
of
structure
|
MApp
of
modexpr
*
modexpr
|
MTextual
of
Stretch
.
t
(* Structures. *)
...
...
src/codeBits.ml
View file @
86639b79
...
...
@@ -75,8 +75,14 @@ let tposition =
(* A location is a pair of positions. This might change in the future. *)
let
tlocation
=
tpair
tposition
tposition
let
default_tlocation
=
tpair
tposition
tposition
let
tlocation
~
public
grammar
=
match
grammar
.
UnparameterizedSyntax
.
location
with
|
None
->
default_tlocation
|
Some
_path
->
let
path
=
if
public
then
"Location.t"
else
"Menhir__Location.t"
in
TypApp
(
path
,
[]
)
(* The type of lexer buffers. *)
...
...
@@ -252,6 +258,7 @@ let interface_item_to_structure_item = function
|
IIValDecls
_
|
IIInclude
_
|
IIModule
(
_
,
_
)
|
IIModuleAlias
(
_
,
_
)
|
IIComment
_
->
[]
...
...
src/codeBits.mli
View file @
86639b79
...
...
@@ -35,7 +35,8 @@ val tint: typ
val
tstring
:
typ
val
texn
:
typ
val
tposition
:
typ
val
tlocation
:
typ
val
default_tlocation
:
typ
val
tlocation
:
public
:
bool
->
UnparameterizedSyntax
.
grammar
->
typ
val
tlexbuf
:
typ
val
tobj
:
typ
...
...
src/codePieces.ml
View file @
86639b79
...
...
@@ -72,6 +72,9 @@ let startp =
let
endp
=
"_endpos"
let
loc
=
"_loc"
(* ------------------------------------------------------------------------ *)
(* Types for semantic values. *)
...
...
src/codePieces.mli
View file @
86639b79
...
...
@@ -53,6 +53,7 @@ val token: string
val
beforeendp
:
string
val
startp
:
string
val
endp
:
string
val
loc
:
string
(* ------------------------------------------------------------------------ *)
...
...
src/grammarFunctor.ml
View file @
86639b79
...
...
@@ -1581,6 +1581,12 @@ module OnErrorReduce = struct
end
(* ------------------------------------------------------------------------ *)
(* [%location] declaration. *)
let
location_module
=
G
.
grammar
.
location
(* ------------------------------------------------------------------------ *)
end
(* module Make *)
src/grammarFunctor.mli
View file @
86639b79
...
...
@@ -588,6 +588,11 @@ module OnErrorReduce : sig
end
(* ------------------------------------------------------------------------ *)
(* [%location] declaration. *)
val
location_module
:
Stretch
.
t
option
(* ------------------------------------------------------------------------ *)
(* Diagnostics. *)
...
...
src/infer.ml
View file @
86639b79
...
...
@@ -112,7 +112,7 @@ let actiondef grammar symbol branch =
PAnnot
(
PVar
endp
,
tposition
)
::
PAnnot
(
PVar
starto
,
tint
)
::
PAnnot
(
PVar
endo
,
tint
)
::
PAnnot
(
PVar
loc
,
tlocation
)
::
PAnnot
(
PVar
loc
,
tlocation
~
public
:
false
grammar
)
::
formals
)
[]
branch
.
producers
in
...
...
@@ -130,8 +130,8 @@ let actiondef grammar symbol branch =
PAnnot
(
PVar
"_endofs"
,
tint
)
::
PAnnot
(
PVar
"_endofs__0_"
,
tint
)
::
PAnnot
(
PVar
"_symbolstartofs"
,
tint
)
::
PAnnot
(
PVar
"_sloc"
,
tlocation
)
::
PAnnot
(
PVar
"_loc"
,
tlocation
)
::
PAnnot
(
PVar
"_sloc"
,
tlocation
~
public
:
false
grammar
)
::
PAnnot
(
PVar
"_loc"
,
tlocation
~
public
:
false
grammar
)
::
formals
in
...
...
@@ -151,6 +151,13 @@ let actiondef grammar symbol branch =
|
_
->
EFun
(
formals
,
body
)
let
location_module
grammar
=
match
grammar
.
UnparameterizedSyntax
.
location
with
|
None
->
[]
|
Some
path
->
let
md
=
MApp
(
MVar
"MenhirLib.EngineTypes.As_location"
,
MTextual
path
)
in
[
SIModuleDef
(
"Menhir__Location"
,
md
)]
(* [program] turns an entire grammar into a test program. *)
let
program
grammar
=
...
...
@@ -209,6 +216,7 @@ let program grammar =
[
SIFunctor
(
grammar
.
parameters
,
interface_to_structure
(
tokentypedef
grammar
)
@
location_module
grammar
@
SIStretch
grammar
.
preludes
::
SIValDefs
(
false
,
[
begindef
;
def
;
enddef
])
::
SIStretch
grammar
.
postludes
::
...
...
src/inliner.ml
View file @
86639b79
...
...
@@ -311,6 +311,8 @@ and inline_modexpr = function
MStruct
(
inline_structure
s
)
|
MApp
(
e1
,
e2
)
->
MApp
(
inline_modexpr
e1
,
inline_modexpr
e2
)
|
MTextual
stretch
->
MTextual
stretch
(* The external entry point. *)
...
...
src/interface.ml
View file @
86639b79
...
...
@@ -15,6 +15,11 @@ open UnparameterizedSyntax
open
IL
open
CodeBits
(* -------------------------------------------------------------------------- *)
(* The type of locations. *)
(* -------------------------------------------------------------------------- *)
(* The [Error] exception. *)
...
...
@@ -64,7 +69,7 @@ let incremental =
let
entrytypescheme_incremental
grammar
symbol
=
let
t
=
TypTextual
(
ocamltype_of_start_symbol
grammar
symbol
)
in
type2scheme
(
marrow
[
tlocation
]
(
checkpoint
t
))
type2scheme
(
marrow
[
tlocation
~
public
:
true
grammar
]
(
checkpoint
t
))
(* -------------------------------------------------------------------------- *)
...
...
@@ -128,7 +133,7 @@ let inspection_api grammar () =
(* The incremental API. *)
let
incremental_engine
()
:
module_type
=
let
incremental_engine
grammar
:
module_type
=
with_types
WKNonDestructive
"MenhirLib.IncrementalEngine.INCREMENTAL_ENGINE"
[
...
...
@@ -136,8 +141,7 @@ let incremental_engine () : module_type =
"token"
,
(* NOT [tctoken], which is qualified if [--external-tokens] is used *)
TokenType
.
ttoken
;
[]
,
"location"
,
CodeBits
.
tlocation
"location"
,
tlocation
~
public
:
true
grammar
]
let
incremental_entry_points
grammar
:
interface
=
...
...
@@ -159,7 +163,7 @@ let incremental_api grammar () : interface =
interpreter
,
MTSigEnd
(
IIComment
"The incremental API."
::
IIInclude
(
incremental_engine
()
)
::
IIInclude
(
incremental_engine
grammar
)
::
listiflazy
Settings
.
inspection
(
inspection_api
grammar
)
)
)
::
...
...
@@ -170,11 +174,19 @@ let incremental_api grammar () : interface =
(* -------------------------------------------------------------------------- *)
let
location_module
grammar
=
match
grammar
.
UnparameterizedSyntax
.
location
with
|
None
->
[]
|
Some
mpath
->
[
IIModuleAlias
(
"Location"
,
mpath
)]
(* -------------------------------------------------------------------------- *)
(* The complete interface of the generated parser. *)
let
interface
grammar
=
[
IIFunctor
(
grammar
.
parameters
,
monolithic_api
grammar
@
location_module
grammar
@
listiflazy
Settings
.
table
(
incremental_api
grammar
)
)
]
...
...
src/invariant.ml
View file @
86639b79
...
...
@@ -676,19 +676,32 @@ let () =
(* [$startpos] and [$endpos] have been expanded away. *)
assert
false
|
Position
(
_
,
_
,
FlavorLocation
)
->
(* [$loc] and [$sloc] have been expanded away. *)
assert
false
begin
match
Grammar
.
location_module
with
|
None
->
(* [$loc] and [$sloc] have been expanded away. *)
assert
false
|
Some
_
->
(* $loc has been kept for custom locations. *)
()
end
|
Position
(
RightNamed
_
,
WhereSymbolStart
,
_
)
->
(* [$symbolstartpos(x)] does not exist. *)
assert
false
|
Position
(
RightNamed
id
,
where
,
_
)
->
(* If the semantic action mentions [$startpos($i)], then the
[i]-th symbol in the right-hand side must keep track of
its start position. Similarly for end positions. *)
Array
.
iteri
(
fun
i
id'
->
if
id
=
id'
then
record_ConVar
true
(
rhs
.
(
i
)
,
where
)
)
ids
begin
match
Grammar
.
location_module
with
|
None
->
(* If the semantic action mentions [$startpos($i)], then the
[i]-th symbol in the right-hand side must keep track of
its start position. Similarly for end positions. *)
Array
.
iteri
(
fun
i
id'
->
if
id
=
id'
then
record_ConVar
true
(
rhs
.
(
i
)
,
where
)
)
ids
|
Some
_
->
(* $startpos when using custom locations should have been
rejected before. *)
()
end
)
(
Action
.
keywords
action
)
);
(* end of loop on productions *)
...
...
src/printer.ml
View file @
86639b79
...
...
@@ -696,6 +696,8 @@ and modexpr f = function
structend
f
s
|
MApp
(
e1
,
e2
)
->
fprintf
f
"%a (%a)"
modexpr
e1
modexpr
e2
|
MTextual
mpath
->
fprintf
f
"(%a)"
(
stretch
true
)
mpath
let
valdecl
f
(
x
,
ts
)
=
fprintf
f
"val %s: %a"
x
typ
ts
.
body
...
...
@@ -743,6 +745,8 @@ and interface_item f item =
fprintf
f
"include %a"
module_type
mt
|
IIModule
(
name
,
mt
)
->
fprintf
f
"module %s : %a"
name
module_type
mt
|
IIModuleAlias
(
name
,
mpath
)
->
fprintf
f
"module %s = %a"
name
(
stretch
true
)
mpath
|
IIComment
comment
->
fprintf
f
"(* %s *)"
comment
end
;
...
...
src/tableBackend.ml
View file @
86639b79
...
...
@@ -159,10 +159,14 @@ let reducecellparams prod i _symbol (next : pattern) : pattern =
let
ids
=
Production
.
identifiers
prod
in
let
loc
=
PTuple
[
PVar
(
Printf
.
sprintf
"_startpos_%s_"
ids
.
(
i
));
PVar
(
Printf
.
sprintf
"_endpos_%s_"
ids
.
(
i
));
]
match
Grammar
.
location_module
with
|
None
->
PTuple
[
PVar
(
Printf
.
sprintf
"_startpos_%s_"
ids
.
(
i
));
PVar
(
Printf
.
sprintf
"_endpos_%s_"
ids
.
(
i
));
]
|
Some
_
->
PVar
(
Printf
.
sprintf
"_loc_%s_"
ids
.
(
i
))
in
PRecord
[
...
...
@@ -199,8 +203,11 @@ let reducecellcasts prod i symbol casts =
(* 2015/11/04. The start and end positions of an epsilon production are obtained
by taking the end position stored in the top stack cell (whatever it is). *)
let
location_of_top_stack_cell
=
ERecordAccess
(
EVar
stack
,
flocation
)
let
endpos_of_top_stack_cell
=
EApp
(
EVar
"Pervasives.snd"
,
[
ERecordAccess
(
EVar
stack
,
flocation
)
])
EApp
(
EVar
"Pervasives.snd"
,
[
location_of_top_stack_cell
])
(* This is the body of the [reduce] function associated with
production [prod]. It assumes that the variables [env] and [stack]
...
...
@@ -236,21 +243,36 @@ let reducebody prod =
by the OCaml compiler. *)
let
posbindings
=
(
PVar
beforeendp
,
endpos_of_top_stack_cell
)
::
(
PVar
startp
,
if
length
>
0
then
EVar
(
Printf
.
sprintf
"_startpos_%s_"
ids
.
(
0
))
else
match
Grammar
.
location_module
with
|
None
->
[
PVar
beforeendp
,
endpos_of_top_stack_cell
)
::
(
PVar
endp
,
if
length
>
0
then
EVar
(
Printf
.
sprintf
"_endpos_%s_"
ids
.
(
length
-
1
))
else
EVar
startp
)
::
[]
;
PVar
startp
,
if
length
>
0
then
EVar
(
Printf
.
sprintf
"_startpos_%s_"
ids
.
(
0
))
else
endpos_of_top_stack_cell
;
PVar
endp
,
if
length
>
0
then
EVar
(
Printf
.
sprintf
"_endpos_%s_"
ids
.
(
length
-
1
))
else
EVar
startp
]
|
Some
_
->
[
PVar
loc
,
if
length
>
0
then
let
loc
id
=
EVar
(
Printf
.
sprintf
"_loc_%s_"
id
)
in
let
locs
=
EArray
(
Array
.
to_list
(
Array
.
map
loc
ids
))
in
EApp
(
EVar
"Menhir__Location.join"
,
[
locs
]
)
else
EApp
(
EVar
"Menhir__Location.empty_after"
,
[
location_of_top_stack_cell
]
)
]
in
(* This cannot be one of the start productions. *)
...
...
@@ -264,25 +286,26 @@ let reducebody prod =
let
act
=
EAnnot
(
Action
.
to_il_expr
action
,
type2scheme
(
semvtypent
nt
))
in
let
positions
=
[
EVar
startp
;
EVar
endp
]
let
elocation
=
match
Grammar
.
location_module
with
|
None
->
ETuple
[
EVar
startp
;
EVar
endp
]
|
Some
_
->
EVar
loc
in
EComment
(
Production
.
print
prod
,
blet
(
(
pat
,
EVar
stack
)
::
(* destructure the stack *)
casts
@
(* perform type casts *)
posbindings
@
(* bind [startp] and [endp] *)
[
PVar
semv
,
act
]
,
(* run the user's code and bind [semv] *)
(
pat
,
EVar
stack
)
::
(* destructure the stack *)
casts
@
(* perform type casts *)
posbindings
@
(* bind [startp] and [endp] *)
[
PVar
semv
,
act
]
,
(* run the user's code and bind [semv] *)
(* Return a new stack, onto which we have pushed a new stack cell. *)
ERecord
[
(* the new stack cell *)
fstate
,
EVar
state
;
(* the current state after popping; it will be updated by [goto] *)
fsemv
,
ERepr
(
EVar
semv
);
(* the newly computed semantic value *)
flocation
,
ETuple
positions
;
(* the newly computed start and end positions *)
fnext
,
EVar
stack
;
(* this is the stack after popping *)
ERecord
[
(* the new stack cell *)
fstate
,
EVar
state
;
(* the current state after popping; it will be updated by [goto] *)
fsemv
,
ERepr
(
EVar
semv
);
(* the newly computed semantic value *)
flocation
,
elocation
;
(* the newly computed start and end positions *)
fnext
,
EVar
stack
;
(* this is the stack after popping *)
]
)
...
...
@@ -301,7 +324,9 @@ let semantic_action prod =
ELet
(
[
PVar
stack
,
ERecordAccess
(
EVar
env
,
fstack
)
]
@
(
if
Production
.
length
prod
=
0
then
[
PVar
state
,
ERecordAccess
(
EVar
env
,
fcurrent
)
]
else
[]
)
,
(
if
Production
.
length
prod
=
0
then
[
PVar
state
,
ERecordAccess
(
EVar
env
,
fcurrent
)
]
else
[]
)
,
reducebody
prod
...
...
@@ -661,18 +686,53 @@ let trace =
(* ------------------------------------------------------------------------ *)
let
location_typ
=
{
typename
=
"location"
;
typeparams
=
[]
;
typerhs
=
TAbbrev
tlocation
;
typeconstraint
=
None
;
}
let
location_module
=
match
Grammar
.
location_module
with
|
None
->
[]
|
Some
path
->
[
SIModuleDef
(
"Menhir__Location"
,
MApp
(
MVar
"MenhirLib.EngineTypes.As_location"
,
MTextual
path
))]
let
post_location_module
=
match
Grammar
.
location_module
with
|
None
->
[]
|
Some
path
->
[
SIModuleDef
(
"Location"
,
MTextual
path
)]
let
location_typ
=
match
Grammar
.
location_module
with
|
None
->
{
typename
=
"location"
;
typeparams
=
[]
;
typerhs
=
TAbbrev
default_tlocation
;
typeconstraint
=
None
}
|
Some
_
->
{
typename
=
"location"
;
typeparams
=
[]
;
typerhs
=
TAbbrev
(
TypApp
(
"Menhir__Location.t"
,
[]
))
;
typeconstraint
=
None
}
let
trace_location
=
{
valpublic
=
false
;
valpat
=
PVar
"trace_location"
;
valval
=
EVar
"MenhirLib.General.trace_location"
;
}
let
trace_location
=
match
Grammar
.
location_module
with
|
None
->
{
valpublic
=
false
;
valpat
=
PVar
"trace_location"
;
valval
=
EVar
"MenhirLib.General.trace_location"
}
|
Some
_
->
{
valpublic
=
false
;
valpat
=
PVar
"trace_location"
;
valval
=
EVar
"Menhir__Location.trace"
}
let
get_location
=
match
Grammar
.
location_module
with
|
None
->
"MenhirLib.General.get_location"
|
Some
_
->
"Menhir__Location.get"
(* ------------------------------------------------------------------------ *)
...
...
@@ -722,7 +782,7 @@ let monolithic_entry_point state nt t =
EVar
entry
,
[
EIntConst
(
Lr1
.
number
state
);
EVar
lexer
;
EVar
"MenhirLib.General.get_location"
;
EVar
get_location
;
EVar
lexbuf
]
)
...
...
@@ -1022,6 +1082,8 @@ let program =
SIStretch
grammar
.
preludes
::
location_module
@
(* Define the tables. *)
SIModuleDef
(
tables
,
...
...
@@ -1030,8 +1092,6 @@ let program =
exception [Error] and of the type [token]. *)
SIInclude
(
MVar
basics
);
SITypeDefs
[
location_typ
];
(* This is a non-recursive definition, so none of the names
defined here are visible in the semantic actions. *)
SIValDefs
(
false
,
[
...
...
@@ -1047,7 +1107,11 @@ let program =
goto
;
semantic_action
;
trace
;
])
]);
(* Define location_typ last, to satisfy the functor interface without
making the type location visible from the semantic actions. *)
SITypeDefs
[
location_typ
];
]
)
::
...
...
@@ -1121,6 +1185,8 @@ let program =
SIValDefs
(
false
,
incremental_api
)
])
::
post_location_module
@