Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
7
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Open sidebar
POTTIER Francois
menhir
Commits
bb3ab865
Commit
bb3ab865
authored
Dec 04, 2014
by
POTTIER Francois
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Merge the stylistic patch from master branch.
parent
057781d0
Changes
29
Hide whitespace changes
Inline
Side-by-side
Showing
29 changed files
with
144 additions
and
275 deletions
+144
-275
TODO
TODO
+5
-0
src/_tags
src/_tags
+3
-0
src/action.ml
src/action.ml
+3
-3
src/codeBackend.ml
src/codeBackend.ml
+5
-30
src/codeBits.ml
src/codeBits.ml
+1
-1
src/codePieces.ml
src/codePieces.ml
+1
-1
src/compressedBitSet.ml
src/compressedBitSet.ml
+1
-1
src/conflict.ml
src/conflict.ml
+3
-3
src/coqBackend.ml
src/coqBackend.ml
+1
-1
src/derivation.ml
src/derivation.ml
+1
-1
src/dot.ml
src/dot.ml
+2
-0
src/fancy-parser.mly
src/fancy-parser.mly
+30
-25
src/infer.ml
src/infer.ml
+1
-1
src/inliner.ml
src/inliner.ml
+3
-3
src/invariant.ml
src/invariant.ml
+3
-3
src/item.ml
src/item.ml
+3
-7
src/lr1.ml
src/lr1.ml
+3
-3
src/misc.ml
src/misc.ml
+1
-1
src/myocamlbuild.ml
src/myocamlbuild.ml
+3
-1
src/packedIntArray.ml
src/packedIntArray.ml
+1
-1
src/parameterizedGrammar.ml
src/parameterizedGrammar.ml
+15
-6
src/partialGrammar.ml
src/partialGrammar.ml
+21
-15
src/patricia.ml
src/patricia.ml
+2
-136
src/printer.ml
src/printer.ml
+7
-6
src/slr.ml
src/slr.ml
+1
-1
src/tableBackend.ml
src/tableBackend.ml
+2
-2
src/tokenType.ml
src/tokenType.ml
+0
-1
src/traverse.ml
src/traverse.ml
+20
-20
src/unparameterizedPrinter.ml
src/unparameterizedPrinter.ml
+2
-2
No files found.
TODO
View file @
bb3ab865
* Changes that could be applied to the code back-end:
[action] could now be inlined into [run]
[initiate] and [bookkeeping] could be merged?
[env.shifted] could be removed; use [env.token] instead
* Clarifier si ocamlbuild doit recevoir -use-ocamlfind, -no-ocamlfind,
ou rien; tester en particulier sous Windows?
...
...
src/_tags
View file @
bb3ab865
# Enable Jonathan's "nazi warnings".
<*>: my_warnings
# Tag both parser source files with origin_parser.
<{yacc-parser,fancy-parser}.mly>:origin_parser
...
...
src/action.ml
View file @
bb3ab865
...
...
@@ -97,7 +97,7 @@ let rename_pkeywords (psym, first_prod, last_prod) phi l =
(* Similarly for $endpos. *)
|
Left
,
WhereEnd
->
last_prod
,
(
used1
,
true
)
(* $i cannot be combined with inlining. *)
|
RightDollar
i
,
w
->
assert
false
|
RightDollar
_
,
_
->
assert
false
|
RightNamed
s
,
w
->
(* In the host rule, $startpos(x) is changed to
to $startpos(first_prod) (same thing for $endpos). *)
...
...
@@ -118,7 +118,7 @@ let rename_pkeywords (psym, first_prod, last_prod) phi l =
(
from_pos
,
to_pos
)
::
phi
else
phi
)
,
(
used1
,
used2
))
|
x
->
pk
::
l
,
phi
,
(
used1
,
used2
))
|
_
->
pk
::
l
,
phi
,
(
used1
,
used2
))
([]
,
phi
,
(
false
,
false
))
l
...
...
@@ -159,7 +159,7 @@ let keywords action =
let
pkeywords
action
=
action
.
pkeywords
let
rec
print
f
action
=
let
print
f
action
=
let
module
P
=
Printer
.
Make
(
struct
let
f
=
f
let
locate_stretches
=
None
let
raw_stretch_action
=
true
...
...
src/codeBackend.ml
View file @
bb3ab865
...
...
@@ -230,25 +230,6 @@ let statecon s =
let
estatecon
s
=
EData
(
statecon
s
,
[]
)
let
rec
begins_with
s1
s2
i1
i2
n1
n2
=
if
i1
=
n1
then
true
else
if
i2
=
n2
then
false
else
if
String
.
unsafe_get
s1
i1
=
String
.
unsafe_get
s2
i2
then
begins_with
s1
s2
(
i1
+
1
)
(
i2
+
1
)
n1
n2
else
false
let
begins_with
s1
s2
=
begins_with
s1
s2
0
0
(
String
.
length
s1
)
(
String
.
length
s2
)
(* This predicate tells whether a data constructor represents a state.
It is based on the name, which is inelegant and inefficient. TEMPORARY *)
let
is_statecon
:
string
->
bool
=
begins_with
(
dataprefix
"State"
)
let
pstatecon
s
=
PData
(
statecon
s
,
[]
)
...
...
@@ -323,9 +304,6 @@ let insertif condition x =
let
var
x
:
expr
=
EVar
x
let
vars
xs
=
List
.
map
var
xs
let
pvar
x
:
pattern
=
PVar
x
...
...
@@ -770,7 +748,7 @@ let reducecellparams prod i holds_state symbol =
used in the semantic action, then it is dropped using a wildcard
pattern. *)
let
semvpat
t
=
let
semvpat
_
t
=
if
used
.
(
i
)
then
PVar
ids
.
(
i
)
else
...
...
@@ -1078,8 +1056,7 @@ let errorbookkeeping e =
))
(* This code is used to indicate that a new error has been detected in
state [s]. [covered] is the set of tokens that [s] knows how to
handle.
state [s].
If I am correct, the count of shifted tokens is never -1
here. Indeed, that would mean that we first found an error, and
...
...
@@ -1097,7 +1074,7 @@ let errorbookkeeping e =
resetting [env.shifted] to zero, to counter-act the effect of
[discard], which increments that counter. *)
let
initiate
covered
s
=
let
initiate
s
=
blet
(
[
assertshifted
]
,
...
...
@@ -1112,9 +1089,7 @@ let initiate covered s =
input stream. It does not set up exception handlers for dealing
with errors. *)
(* TEMPORARY I believe [action] could now be inlined into [run] *)
let
rec
runactiondef
s
:
valdef
list
=
let
runactiondef
s
:
valdef
list
=
match
Invariant
.
has_default_reduction
s
with
|
Some
(
prod
,
toks
)
as
defred
->
...
...
@@ -1180,7 +1155,7 @@ let rec runactiondef s : valdef list =
if
TerminalSet
.
subset
TerminalSet
.
universe
covered
then
branches
else
branches
@
[
{
branchpat
=
PWildcard
;
branchbody
=
initiate
covered
s
}
]
branches
@
[
{
branchpat
=
PWildcard
;
branchbody
=
initiate
s
}
]
in
(* Finally, construct the code for [run] and [action]. The
...
...
src/codeBits.ml
View file @
bb3ab865
...
...
@@ -79,7 +79,7 @@ let rec simplify = function
(* Building a [let] construct, with on-the-fly simplification. *)
let
rec
blet
(
bindings
,
body
)
=
let
blet
(
bindings
,
body
)
=
match
simplify
bindings
with
|
[]
->
body
...
...
src/codePieces.ml
View file @
bb3ab865
...
...
@@ -125,7 +125,7 @@ let symval symbol x =
match
semvtype
symbol
with
|
[]
->
[]
|
[
t
]
->
|
[
_
t
]
->
[
x
]
|
_
->
assert
false
...
...
src/compressedBitSet.ml
View file @
bb3ab865
...
...
@@ -192,7 +192,7 @@ let rec compare s1 s2 =
else
if
ss1
>
ss2
then
1
else
compare
qs1
qs2
let
rec
equal
s1
s2
=
let
equal
s1
s2
=
compare
s1
s2
=
0
let
rec
disjoint
s1
s2
=
...
...
src/conflict.ml
View file @
bb3ab865
...
...
@@ -287,7 +287,7 @@ let explain_reduce_item
(* Otherwise, explore the transitions out of this item. *)
let
prod
,
nt
,
rhs
,
pos
,
length
=
Item
.
def
item
in
let
prod
,
_
nt
,
rhs
,
pos
,
length
=
Item
.
def
item
in
(* Shift transition, followed only if the symbol matches
the symbol found in the input string. *)
...
...
@@ -363,7 +363,7 @@ let () =
|
Item
.
Shift
(
Symbol
.
T
tok
,
_
)
when
Terminal
.
equal
tok
P
.
token
->
shift
+
1
,
reduce
|
Item
.
Reduce
prod
|
Item
.
Reduce
_
when
TerminalSet
.
mem
P
.
token
toks
->
shift
,
reduce
+
1
|
_
->
...
...
@@ -413,7 +413,7 @@ let () =
let
derivation
=
explain_shift_item
P
.
source
P
.
path
item
in
Item
.
Map
.
add
item
derivation
derivations
|
Item
.
Reduce
prod
|
Item
.
Reduce
_
when
TerminalSet
.
mem
P
.
token
toks
->
still_looking_for_shift_item
,
...
...
src/coqBackend.ml
View file @
bb3ab865
...
...
@@ -253,7 +253,7 @@ module Run (T: sig end) = struct
let
write_init
f
=
write_inductive_alphabet
f
"initstate"
(
ProductionMap
.
fold
(
fun
prod
node
l
->
ProductionMap
.
fold
(
fun
_
prod
node
l
->
(
print_init
node
)
::
l
)
Lr1
.
entry
[]
);
fprintf
f
"Instance InitStateAlph : Alphabet initstate := _.
\n\n
"
...
...
src/derivation.ml
View file @
bb3ab865
...
...
@@ -270,7 +270,7 @@ and common_forest cforest1 forest2 : cforest * cforest * forest =
items, because this is convenient for the application that we have in mind,
but this assumption is really irrelevant. *)
let
rec
factor
forests
=
let
factor
forests
=
match
Item
.
Map
.
fold
(
fun
item
forest
accu
->
match
accu
with
...
...
src/dot.ml
View file @
bb3ab865
...
...
@@ -123,6 +123,8 @@ end) = struct
);
G
.
iter
(
fun
?
style
~
label
source
->
ignore
style
;
(* avoid unused variable warnings *)
ignore
label
;
G
.
successors
(
fun
?
style
~
label
destination
->
fprintf
f
"%s %s %s [ label=
\"
%s
\"
%s ] ;
\n
"
(
G
.
name
source
)
...
...
src/fancy-parser.mly
View file @
bb3ab865
...
...
@@ -83,11 +83,12 @@ declaration:
|
TOKEN
OCAMLTYPE
?
clist
(
terminal
)
error
|
TOKEN
OCAMLTYPE
?
error
{
Error
.
error
(
Positions
.
two
$
startpos
$
endpos
)
"\
Syntax error in a %token declaration.
Here are sample valid declarations:
%token DOT SEMICOLON
%token <string> LID UID"
{
Error
.
error
(
Positions
.
two
$
startpos
$
endpos
)
(
String
.
concat
"
\n
"
[
"Syntax error in a %token declaration."
;
"Here are sample valid declarations:"
;
" %token DOT SEMICOLON"
;
" %token <string> LID UID"
;
])
}
|
START
t
=
OCAMLTYPE
?
nts
=
clist
(
nonterminal
)
%
prec
decl
...
...
@@ -103,11 +104,12 @@ Here are sample valid declarations:
|
START
OCAMLTYPE
?
clist
(
nonterminal
)
error
|
START
OCAMLTYPE
?
error
{
Error
.
error
(
Positions
.
two
$
startpos
$
endpos
)
"\
Syntax error in a %start declaration.
Here are sample valid declarations:
%start expression phrase
%start <int> date time"
{
Error
.
error
(
Positions
.
two
$
startpos
$
endpos
)
(
String
.
concat
"
\n
"
[
"Syntax error in a %start declaration."
;
"Here are sample valid declarations:"
;
" %start expression phrase"
;
" %start <int> date time"
;
])
}
|
TYPE
t
=
OCAMLTYPE
ss
=
clist
(
actual_parameter
)
%
prec
decl
...
...
@@ -117,11 +119,12 @@ Here are sample valid declarations:
|
TYPE
OCAMLTYPE
clist
(
actual_parameter
)
error
|
TYPE
OCAMLTYPE
error
|
TYPE
error
{
Error
.
error
(
Positions
.
two
$
startpos
$
endpos
)
"\
Syntax error in a %type declaration.
Here are sample valid declarations:
%type <Syntax.expression> expression
%type <int> date time"
{
Error
.
error
(
Positions
.
two
$
startpos
$
endpos
)
(
String
.
concat
"
\n
"
[
"Syntax error in a %type declaration."
;
"Here are sample valid declarations:"
;
" %type <Syntax.expression> expression"
;
" %type <int> date time"
;
])
}
|
k
=
priority_keyword
ss
=
clist
(
symbol
)
%
prec
decl
...
...
@@ -130,22 +133,24 @@ Here are sample valid declarations:
|
priority_keyword
clist
(
symbol
)
error
|
priority_keyword
error
{
Error
.
error
(
Positions
.
two
$
startpos
$
endpos
)
"\
Syntax error in a precedence declaration.
Here are sample valid declarations:
%left PLUS TIMES
%nonassoc unary_minus
%right CONCAT"
{
Error
.
error
(
Positions
.
two
$
startpos
$
endpos
)
(
String
.
concat
"
\n
"
[
"Syntax error in a precedence declaration."
;
"Here are sample valid declarations:"
;
" %left PLUS TIMES"
;
" %nonassoc unary_minus"
;
" %right CONCAT"
;
])
}
|
PARAMETER
t
=
OCAMLTYPE
{
[
with_poss
$
startpos
$
endpos
(
DParameter
t
)
]
}
|
PARAMETER
error
{
Error
.
error
(
Positions
.
two
$
startpos
$
endpos
)
"\
Syntax error in a %parameter declaration.
Here is a sample valid declaration:
%parameter <X : sig type t end>"
{
Error
.
error
(
Positions
.
two
$
startpos
$
endpos
)
(
String
.
concat
"
\n
"
[
"Syntax error in a %parameter declaration."
;
"Here is a sample valid declaration:"
;
" %parameter <X : sig type t end>"
;
])
}
|
error
...
...
src/infer.ml
View file @
bb3ab865
...
...
@@ -304,7 +304,7 @@ let depend grammar =
)
dependencies
in
if
List
.
length
dependencies
>
0
then
begin
Printf
.
printf
"%s.ml %s.mli:"
base
base
;
List
.
iter
(
fun
(
basename
,
filename
)
->
List
.
iter
(
fun
(
_
basename
,
filename
)
->
Printf
.
printf
" %s"
filename
)
dependencies
;
Printf
.
printf
"
\n
%!"
...
...
src/inliner.ml
View file @
bb3ab865
...
...
@@ -9,7 +9,7 @@ open CodeBits
checking against it in this way is quite cheap, and lets me sleep
safely.) *)
class
locals
table
=
object
(
self
)
class
locals
table
=
object
method
pvar
(
locals
:
StringSet
.
t
)
(
id
:
string
)
=
if
Hashtbl
.
mem
table
id
then
StringSet
.
add
id
locals
else
locals
...
...
@@ -70,7 +70,7 @@ let inline ({ valdefs = defs } as p : program) =
object
inherit
[
StringSet
.
t
,
unit
]
Traverse
.
fold
inherit
locals
table
method
evar
locals
()
id
=
method
!
evar
locals
()
id
=
visit
locals
id
end
in
...
...
@@ -203,7 +203,7 @@ let inline ({ valdefs = defs } as p : program) =
object
(
self
)
inherit
[
StringSet
.
t
]
Traverse
.
map
as
super
inherit
locals
table
method
eapp
locals
e
actuals
=
method
!
eapp
locals
e
actuals
=
match
e
with
|
EVar
id
when
(
Hashtbl
.
mem
table
id
)
&&
(* a global identifier *)
...
...
src/invariant.ml
View file @
bb3ab865
...
...
@@ -33,7 +33,7 @@ let stack_symbols : Lr0.node -> Symbol.t array =
in
Misc
.
tabulate
Lr0
.
n
(
fun
node
->
Item
.
Set
.
fold
(
fun
item
accu
->
let
prod
,
nt
,
rhs
,
pos
,
length
=
Item
.
def
item
in
let
_
prod
,
_
nt
,
rhs
,
pos
,
_
length
=
Item
.
def
item
in
if
pos
>
Array
.
length
accu
then
Array
.
sub
rhs
0
pos
else
accu
)
(
Lr0
.
items
node
)
dummy
)
...
...
@@ -189,7 +189,7 @@ let stack_states : Lr1.node -> property =
empty
|
Some
symbol
->
|
Some
_
symbol
->
(* If [node] is not a start state, then include the contribution of
every incoming transition. We compute a join over all predecessors.
...
...
@@ -629,7 +629,7 @@ let rec require where symbol =
end
and
require_aux
where
prod
=
let
nt
,
rhs
=
Production
.
def
prod
in
let
_
nt
,
rhs
=
Production
.
def
prod
in
let
length
=
Array
.
length
rhs
in
if
length
>
0
then
match
where
with
...
...
src/item.ml
View file @
bb3ab865
...
...
@@ -44,10 +44,6 @@ let def t =
assert
((
pos
>=
0
)
&&
(
pos
<=
length
));
prod
,
nt
,
rhs
,
pos
,
length
let
nt
t
=
let
_
,
nt
,
_
,
_
,
_
=
def
t
in
nt
let
startnt
t
=
let
_
,
_
,
rhs
,
pos
,
length
=
def
t
in
assert
(
pos
=
0
&&
length
=
1
);
...
...
@@ -60,7 +56,7 @@ let startnt t =
(* Printing. *)
let
print
item
=
let
_
,
nt
,
rhs
,
pos
,
length
=
def
item
in
let
_
,
nt
,
rhs
,
pos
,
_
=
def
item
in
Printf
.
sprintf
"%s -> %s"
(
Nonterminal
.
print
false
nt
)
(
Symbol
.
printaod
0
pos
rhs
)
(* Classifying items. *)
...
...
@@ -154,7 +150,7 @@ module Closure (L : Lookahead.S) = struct
let
()
=
Production
.
iter
(
fun
prod
->
let
nt
,
rhs
=
Production
.
def
prod
in
let
_
nt
,
rhs
=
Production
.
def
prod
in
let
length
=
Array
.
length
rhs
in
mapping
.
(
Production
.
p2i
prod
)
<-
Array
.
init
(
length
+
1
)
(
fun
pos
->
...
...
@@ -194,7 +190,7 @@ module Closure (L : Lookahead.S) = struct
let
()
=
Production
.
iter
(
fun
prod
->
let
nt
,
rhs
=
Production
.
def
prod
in
let
_
nt
,
rhs
=
Production
.
def
prod
in
let
length
=
Array
.
length
rhs
in
Array
.
iteri
(
fun
pos
node
->
...
...
src/lr1.ml
View file @
bb3ab865
...
...
@@ -564,7 +564,7 @@ let () =
end
|
prod1
::
prod2
::
_
->
|
_
prod1
::
_
prod2
::
_
->
(* This is a shift/reduce/reduce conflict. If the priorities
are such that each individual shift/reduce conflict is solved
...
...
@@ -616,7 +616,7 @@ let () =
|
[]
|
[
_
]
->
()
|
prod1
::
prod2
::
_
->
|
_
prod1
::
_
prod2
::
_
->
(* There is no transition in addition to the reduction(s). We
have a pure reduce/reduce conflict. Do nothing about it at
...
...
@@ -1043,7 +1043,7 @@ let default_conflict_resolution () =
let
has_ambiguity
=
ref
false
in
let
toks
=
ref
TerminalSet
.
empty
in
TerminalMap
.
iter
(
fun
tok
prods
->
TerminalMap
.
iter
(
fun
tok
_
prods
->
node
.
reductions
<-
reductions
;
has_ambiguity
:=
true
;
toks
:=
TerminalSet
.
add
tok
!
toks
...
...
src/misc.ml
View file @
bb3ab865
...
...
@@ -264,7 +264,7 @@ let gcp s1 s2 =
(* [gcps] returns the greatest common prefix of a nonempty list of strings. *)
let
rec
gcps
=
function
let
gcps
=
function
|
[]
->
assert
false
|
s
::
ss
->
...
...
src/myocamlbuild.ml
View file @
bb3ab865
...
...
@@ -7,7 +7,9 @@ open Command
let
flags
()
=
(* -inline 1000 *)
flag
[
"ocaml"
;
"compile"
;
"native"
]
(
S
[
A
"-inline"
;
A
"1000"
])
flag
[
"ocaml"
;
"compile"
;
"native"
]
(
S
[
A
"-inline"
;
A
"1000"
]);
(* nazi warnings *)
flag
[
"ocaml"
;
"compile"
;
"my_warnings"
]
(
S
[
A
"-w"
;
A
"@1..49-4-9-33"
])
(* ---------------------------------------------------------------------------- *)
...
...
src/packedIntArray.ml
View file @
bb3ab865
...
...
@@ -95,7 +95,7 @@ let pack (a : int array) : t =
for
j
=
0
to
n
-
1
do
let
c
=
ref
0
in
for
x
=
1
to
w
do
for
_
x
=
1
to
w
do
c
:=
(
!
c
lsl
k
)
lor
next
()
done
;
s
.
[
j
]
<-
Char
.
chr
!
c
...
...
src/parameterizedGrammar.ml
View file @
bb3ab865
...
...
@@ -58,7 +58,8 @@ let string_of paren_fun ?paren ?colors t : string =
"("
^
s
^
")"
else
s
let
rec
paren_nt_type
((
white
,
black
)
as
colors
)
=
function
let
rec
paren_nt_type
colors
=
function
(* [colors] is a pair [white, black] *)
Arrow
[]
->
"*"
,
false
...
...
@@ -93,17 +94,23 @@ and paren_var (white, black) x =
(
s
,
p
)
end
let
string_of_nt_type
?
paren
?
colors
t
=
let
string_of_nt_type
?
colors
t
=
(* TEMPORARY note: always called without a [colors] argument! *)
string_of
?
colors
paren_nt_type
t
let
string_of_var
?
paren
?
colors
v
=
let
string_of_var
?
colors
v
=
(* TEMPORARY note: always called without a [colors] argument! *)
string_of
?
colors
paren_var
v
(* for debugging:
(* [print_env env] returns a string description of the typing environment. *)
let print_env =
List.iter (fun (k, (_, v)) ->
Printf.eprintf "%s: %s\n" k (string_of_var v))
*)
(* [occurs_check x y] checks that [x] does not occur within [y]. *)
let
dfs
action
x
=
...
...
@@ -154,8 +161,8 @@ let rec unify_var toplevel x y =
if
not
(
UnionFind
.
equivalent
x
y
)
then
let
reprx
,
repry
=
UnionFind
.
find
x
,
UnionFind
.
find
y
in
match
reprx
.
structure
,
repry
.
structure
with
None
,
Some
t
->
occurs_check
x
y
;
UnionFind
.
union
x
y
|
Some
t
,
None
->
occurs_check
y
x
;
UnionFind
.
union
y
x
None
,
Some
_
->
occurs_check
x
y
;
UnionFind
.
union
x
y
|
Some
_
,
None
->
occurs_check
y
x
;
UnionFind
.
union
y
x
|
None
,
None
->
UnionFind
.
union
x
y
|
Some
t
,
Some
t'
->
unify
toplevel
t
t'
;
UnionFind
.
union
x
y
...
...
@@ -254,7 +261,7 @@ let check_grammar p_grammar =
is implemented by [successors]. Non terminals are indexed using
[nt].
*)
let
nt
,
conv
,
iconv
=
index_map
p_grammar
.
p_rules
in
let
nt
,
conv
,
_
iconv
=
index_map
p_grammar
.
p_rules
in
let
parameters
,
name
,
branches
,
positions
=
(
fun
n
->
(
nt
n
)
.
pr_parameters
)
,
(
fun
n
->
(
nt
n
)
.
pr_nt
)
,
(
fun
n
->
(
nt
n
)
.
pr_branches
)
,
(
fun
n
->
(
nt
n
)
.
pr_positions
)
...
...
@@ -456,11 +463,13 @@ let rec subst_parameter subst = function
let
subst_parameters
subst
=
List
.
map
(
subst_parameter
subst
)
(* TEMPORARY why unused?
let names_of_p_grammar p_grammar =
StringMap.fold (fun tok _ acu -> StringSet.add tok acu)
p_grammar.p_tokens StringSet.empty
$$ (StringMap.fold (fun nt _ acu -> StringSet.add nt acu)
p_grammar.p_rules)
*)
let
expand
p_grammar
=
(* Check that it is safe to expand this parameterized grammar. *)
...
...
src/partialGrammar.ml
View file @
bb3ab865
...
...
@@ -260,9 +260,10 @@ let rename nonterminal filename =
(* A nonterminal is considered public if it is declared using %public
or %start. *)
(* TEMPORARY why unused?
let is_public grammar prule =
prule.pr_public_flag || StringMap.mem prule.pr_nt grammar.p_start_symbols
*)
(* ------------------------------------------------------------------------- *)
type
symbol_kind
=
...
...
@@ -275,29 +276,29 @@ type symbol_kind =
(* The symbol is a token. *)
|
Token
of
token_properties
(* We do not know yet what
does
the symbol means.
(* We do not know yet what the symbol means.
This is defined in the sequel or it is free in the partial grammar. *)
|
DontKnow
of
Positions
.
t
type
symbol_table
=
(
symbol
,
symbol_kind
)
Hashtbl
.
t
let
find_symbol
symbols
symbol
=
let
find_symbol
(
symbols
:
symbol_table
)
symbol
=
Hashtbl
.
find
symbols
symbol
let
add_in_symbol_table
symbols
symbol
kind
=
let
add_in_symbol_table
(
symbols
:
symbol_table
)
symbol
kind
=
use_name
symbol
;
Hashtbl
.
add
symbols
symbol
kind
;
symbols
let
replace_in_symbol_table
symbols
symbol
kind
=
let
replace_in_symbol_table
(
symbols
:
symbol_table
)
symbol
kind
=
Hashtbl
.
replace
symbols
symbol
kind
;
symbols
let
empty_symbol_table
()
=
let
empty_symbol_table
()
:
symbol_table
=
Hashtbl
.
create
13
let
store_symbol
symbols
symbol
kind
=
let
store_symbol
(
symbols
:
symbol_table
)
symbol
kind
=
try
let
sym_info
=
find_symbol
symbols
symbol
in
match
sym_info
,
kind
with
...
...
@@ -361,6 +362,8 @@ let store_private_nonterminal tokens symbols symbol positions =
non_terminal_is_not_a_token
tokens
symbol
positions
;
store_symbol
symbols
symbol
(
PrivateNonTerminal
(
List
.
hd
positions
))
(* for debugging, presumably:
let string_of_kind = function
| PublicNonTerminal p ->
Printf.sprintf "public (%s)" (Positions.string_of_pos p)
...
...
@@ -386,6 +389,7 @@ let string_of_symbol_table t =
(Printf.sprintf "%s: %s\n"
(fill_blank k) (string_of_kind v))) t;
Buffer.contents b
*)
let
is_private_symbol
t
x
=
try
...
...
@@ -398,6 +402,7 @@ let is_private_symbol t x =
with
Not_found
->
false
(* TEMPORARY why unused?
let is_public_symbol t x =
try
match Hashtbl.find t x with
...
...
@@ -408,6 +413,7 @@ let is_public_symbol t x =
false
with Not_found ->
false
*)
let
fold_on_private_symbols
f
init
t
=
Hashtbl
.
fold
...
...
@@ -466,7 +472,7 @@ let symbols_of grammar (pgrammar : ConcreteSyntax.grammar) =
in
List
.
fold_left
symbols_of_rule
(
empty_symbol_table
()
)
pgrammar
.
pg_rules
let
merge_rules
tokens
symbols
pgs
=
let
merge_rules
symbols
pgs
=
(* Retrieve all the public symbols. *)
let
public_symbols
=
...
...
@@ -495,7 +501,7 @@ let merge_rules tokens symbols pgs =
else
(
StringSet
.
add
symbol
defined
,
clashes
))
in
let
private_symbols
,
clashes
=
let
_
private_symbols
,
clashes
=
List
.
fold_left
detect_private_symbol_clashes
(
StringSet
.
empty
,
StringSet
.
empty
)
symbols
in
let
rpgs
=
List
.
map
...
...
@@ -579,7 +585,7 @@ let join grammar pgrammar =