Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
POTTIER Francois
menhir
Commits
01f4b77d
Commit
01f4b77d
authored
Oct 26, 2015
by
POTTIER Francois
Browse files
Cleanup: updated [signal], [warning] and [grammar_warning] to also take a format.
parent
1a570d12
Changes
10
Hide whitespace changes
Inline
Side-by-side
src/error.ml
View file @
01f4b77d
open
Printf
(* TEMPORARY Vrifier que les messages d'erreur sont standardiss au
maximum, localiss au maximum. Supprimer autant de fonctions que
possible dans ce module. *)
(* TEMPORARY reprendre compl`etement implementation et interface
de ce module *)
(* ---------------------------------------------------------------------------- *)
(* Global state. *)
...
...
@@ -72,46 +65,39 @@ let logC =
let
errors
=
ref
false
let
print_positions
positions
=
let
display
continuation
header
positions
format
=
List
.
iter
(
fun
position
->
fprintf
stderr
"%s:
\n
"
(
Positions
.
string_of_pos
position
)
)
positions
let
printN
positions
message
=
(* TEMPORARY *)
print_positions
positions
;
fprintf
stderr
"%s
\n
%!"
message
let
error_message
message
=
"Error: "
^
message
let
error
positions
format
=
print_positions
positions
;
)
positions
;
Printf
.
kfprintf
(
fun
_
->
exit
1
)
continuation
stderr
(
"Error: "
^^
format
^^
"
\n
%!"
)
(
header
^^
format
^^
"
\n
%!"
)
let
errorp
v
=
error
[
Positions
.
position
v
]
let
error
positions
format
=
display
(
fun
_
->
exit
1
)
"Error: "
positions
format
let
signal
positions
message
=
printN
positions
message
;
errors
:=
true
let
signal
positions
format
=
display
(
fun
_
->
errors
:=
true
)
"Error: "
positions
format
let
warning
positions
message
=
printN
positions
(
Printf
.
sprintf
"Warning: %s"
message
)
let
warning
positions
format
=
display
(
fun
_
->
()
)
"Warning: "
positions
format
let
errors
()
=
!
errors
(* Certain warnings about the grammar can optionally be treated as errors.
The following function emits a warning or error message, via [warning] or
[signal]. It does not stop the program; the client must at some point call
[errors] and stop the program if any errors have been reported. *)
let
errorp
v
=
error
[
Positions
.
position
v
]
let
grammar_warning
positions
message
=
if
Settings
.
strict
then
signal
positions
(
error_message
message
)
else
warning
positions
message
let
grammar_warning
=
if
Settings
.
strict
then
signal
else
warning
src/error.mli
View file @
01f4b77d
...
...
@@ -34,34 +34,32 @@ val logC: int -> (out_channel -> unit) -> unit
(* [error ps format ...] displays the list of positions [ps], followed with the
error message [format ...], and exits. The strings "Error: " and "\n" are
automatically added at the beginning and end of the error message. The
message should begin with a lowercase letter. *)
message should begin with a lowercase letter
and end with a dot
. *)
val
error
:
Positions
.
positions
->
(
'
a
,
out_channel
,
unit
,
'
b
)
format4
->
'
a
(* [errorp v msg] displays the error message [msg], referring to the
position range carried by [v], and exits. *)
(* [errorp] is like [error], but uses the position range carried by [v]. *)
val
errorp
:
_
Positions
.
located
->
(
'
a
,
out_channel
,
unit
,
'
b
)
format4
->
'
a
(* [
warning ps msg] displays the warning message [msg], referring to
the positions [p
s]. *)
(* [
signal] is like [error], except it does not exit immediately. It sets a
flag which can be tested using [error
s]. *)
val
warning
:
Positions
.
positions
->
string
->
unit
(* [signal ps msg] displays the error message [msg], referring to the
positions [ps], and does not exit immediately. *)
val
signal
:
Positions
.
positions
->
string
->
unit
val
signal
:
Positions
.
positions
->
(
'
a
,
out_channel
,
unit
,
unit
)
format4
->
'
a
(* [errors] returns [true] if [signal] was previously called. Together
[signal] and [errors] allow reporting multiple errors before aborting. *)
val
errors
:
unit
->
bool
(* [warning] is like [signal], except it does not set a flag. *)
val
warning
:
Positions
.
positions
->
(
'
a
,
out_channel
,
unit
,
unit
)
format4
->
'
a
(* Certain warnings about the grammar can optionally be treated as errors.
The following function emits a warning or error message, via [warning] or
[signal]. It does not stop the program; the client must at some point call
[errors] and stop the program if any errors have been reported. *)
val
grammar_warning
:
Positions
.
positions
->
string
->
unit
val
grammar_warning
:
Positions
.
positions
->
(
'
a
,
out_channel
,
unit
,
unit
)
format4
->
'
a
src/front.ml
View file @
01f4b77d
...
...
@@ -134,7 +134,7 @@ let grammar =
in
if
not
Settings
.
infer
&&
inlined
&&
not
skipping_parser_generation
then
Error
.
warning
[]
"you are using the standard library and/or the %inline keyword. We
\n
\
"you are using the standard library and/or the
%
%inline keyword. We
\n
\
recommend switching on --infer in order to avoid obscure type error messages."
;
Time
.
tick
"Inlining"
;
grammar
...
...
src/grammar.ml
View file @
01f4b77d
...
...
@@ -48,7 +48,7 @@ module TokPrecedence = struct
()
|
PrecedenceLevel
(
_
,
_
,
pos1
,
pos2
)
->
Error
.
grammar_warning
(
Positions
.
two
pos1
pos2
)
(
Printf
.
sprintf
"the precedence level assigned to %s is never useful."
id
)
"the precedence level assigned to %s is never useful."
id
)
Front
.
grammar
.
tokens
end
...
...
@@ -737,7 +737,7 @@ module Production = struct
(* Check whether this %prec declaration was useless. *)
let
pos
=
Positions
.
position
sym
in
if
not
(
Hashtbl
.
mem
ever_useful
pos
)
then
begin
Error
.
grammar_warning
[
pos
]
"this %prec declaration is never useful."
;
Error
.
grammar_warning
[
pos
]
"this
%
%prec declaration is never useful."
;
Hashtbl
.
add
ever_useful
pos
()
(* hack: avoid two warnings at the same position *)
end
)
osym
...
...
@@ -1116,7 +1116,7 @@ let () =
if
not
(
NONEMPTY
.
nonterminal
nt
)
then
Error
.
grammar_warning
(
Nonterminal
.
positions
nt
)
(
Printf
.
sprintf
"%s generates the empty language."
(
Nonterminal
.
print
false
nt
)
)
;
"%s generates the empty language."
(
Nonterminal
.
print
false
nt
);
done
(* ------------------------------------------------------------------------ *)
...
...
src/interpret.ml
View file @
01f4b77d
...
...
@@ -337,16 +337,18 @@ let interpret_error sentence =
an error, computes the state in which the error is obtained, and constructs
a targeted sentence. *)
let
target_sentence
signal
:
located_sentence
->
maybe_targeted_sentence
=
let
target_sentence
(
signal
:
Positions
.
positions
->
(
'
a
,
out_channel
,
unit
,
unit
)
format4
->
'
a
)
:
located_sentence
->
maybe_targeted_sentence
=
fun
(
poss
,
sentence
)
->
(
poss
,
sentence
)
,
interpret_error_aux
poss
sentence
(* failure: *)
(
fun
msg
->
signal
poss
(
Printf
.
sprintf
"
T
his sentence does not end with a syntax error, as it should.
\n
%s"
signal
poss
"
t
his sentence does not end with a syntax error, as it should.
\n
%s"
msg
)
;
;
None
)
(* success: *)
...
...
@@ -537,9 +539,8 @@ let message_table (detect_redundancy : bool) (runs : filtered_targeted_run list)
|
sentence1
,
_
->
if
detect_redundancy
then
Error
.
signal
(
fst
sentence1
@
fst
sentence2
)
(
Printf
.
sprintf
"Redundancy: these sentences both cause an error in state %d."
(
Lr1
.
number
s
));
"these sentences both cause an error in state %d."
(
Lr1
.
number
s
);
table
|
exception
Not_found
->
Lr1
.
NodeMap
.
add
s
(
sentence2
,
message
)
table
...
...
@@ -668,11 +669,10 @@ let () =
(* Check that the domain of [table1] is a subset of the domain of [table2]. *)
table1
|>
Lr1
.
NodeMap
.
iter
(
fun
s
((
poss1
,
_
)
,
_
)
->
if
not
(
Lr1
.
NodeMap
.
mem
s
table2
)
then
Error
.
signal
poss1
(
Printf
.
sprintf
"
T
his sentence leads to an error in state %d.
\n
\
Error
.
signal
poss1
"
t
his sentence leads to an error in state %d.
\n
\
No sentence that leads to this state exists in
\"
%s
\"
."
(
Lr1
.
number
s
)
filename2
)
);
(* Check that [table1] is a subset of [table2], that is, for every state
...
...
@@ -687,11 +687,10 @@ let () =
try
let
(
poss2
,
_
)
,
message2
=
Lr1
.
NodeMap
.
find
s
table2
in
if
message1
<>
message2
then
Error
.
warning
(
poss1
@
poss2
)
(
Printf
.
sprintf
"
T
hese sentences lead to an error in state %d.
\n
\
Error
.
warning
(
poss1
@
poss2
)
"
t
hese sentences lead to an error in state %d.
\n
\
The corresponding messages in
\"
%s
\"
and
\"
%s
\"
differ."
(
Lr1
.
number
s
)
filename1
filename2
)
with
Not_found
->
()
);
...
...
src/invariant.ml
View file @
01f4b77d
...
...
@@ -269,16 +269,16 @@ let () =
incr
count
;
Error
.
grammar_warning
(
Nonterminal
.
positions
nt
)
(
Printf
.
sprintf
"symbol %s is never accepted."
(
Nonterminal
.
print
false
nt
)
)
"symbol %s is never accepted."
(
Nonterminal
.
print
false
nt
)
|
None
->
incr
count
;
Error
.
grammar_warning
(
Production
.
positions
prod
)
(
Printf
.
sprintf
"production %sis never reduced."
(
Production
.
print
prod
)
)
"production %sis never reduced."
(
Production
.
print
prod
)
);
if
!
count
>
0
then
Error
.
grammar_warning
[]
(
Printf
.
sprintf
"in total, %d productions are never reduced."
!
count
)
"in total, %d productions are never reduced."
!
count
(* ------------------------------------------------------------------------ *)
(* From the above information, deduce, for each production, the states that
...
...
src/lr1.ml
View file @
01f4b77d
...
...
@@ -892,11 +892,11 @@ let () =
if
!
shift_reduce
=
1
then
Error
.
grammar_warning
[]
"one state has shift/reduce conflicts."
else
if
!
shift_reduce
>
1
then
Error
.
grammar_warning
[]
(
Printf
.
sprintf
"%d states have shift/reduce conflicts."
!
shift_reduce
)
;
Error
.
grammar_warning
[]
"%d states have shift/reduce conflicts."
!
shift_reduce
;
if
!
reduce_reduce
=
1
then
Error
.
grammar_warning
[]
"one state has reduce/reduce conflicts."
else
if
!
reduce_reduce
>
1
then
Error
.
grammar_warning
[]
(
Printf
.
sprintf
"%d states have reduce/reduce conflicts."
!
reduce_reduce
)
Error
.
grammar_warning
[]
"%d states have reduce/reduce conflicts."
!
reduce_reduce
(* There is a global check for errors at the end of [Invariant], so we do
not need to check & stop here. *)
...
...
@@ -922,11 +922,10 @@ let rec best choice = function
2- they are derived, via inlining, from the same production. *)
Error
.
signal
(
Production
.
positions
choice
@
Production
.
positions
prod
)
(
Printf
.
sprintf
"do not know how to resolve a reduce/reduce conflict
\n
\
between the following two productions:
\n
%s
\n
%s"
(
Production
.
print
choice
)
(
Production
.
print
prod
)
)
;
(
Production
.
print
prod
);
choice
(* dummy *)
(* Go ahead. *)
...
...
@@ -976,11 +975,11 @@ let default_conflict_resolution () =
if
!
shift_reduce
=
1
then
Error
.
warning
[]
"one shift/reduce conflict was arbitrarily resolved."
else
if
!
shift_reduce
>
1
then
Error
.
warning
[]
(
Printf
.
sprintf
"%d shift/reduce conflicts were arbitrarily resolved."
!
shift_reduce
)
;
Error
.
warning
[]
"%d shift/reduce conflicts were arbitrarily resolved."
!
shift_reduce
;
if
!
reduce_reduce
=
1
then
Error
.
warning
[]
"one reduce/reduce conflict was arbitrarily resolved."
else
if
!
reduce_reduce
>
1
then
Error
.
warning
[]
(
Printf
.
sprintf
"%d reduce/reduce conflicts were arbitrarily resolved."
!
reduce_reduce
)
;
Error
.
warning
[]
"%d reduce/reduce conflicts were arbitrarily resolved."
!
reduce_reduce
;
(* Now, ensure that states that have a reduce action at the
pseudo-token "#" have no other action. *)
...
...
@@ -1052,7 +1051,7 @@ let default_conflict_resolution () =
if
!
ambiguities
=
1
then
Error
.
grammar_warning
[]
"one state has an end-of-stream conflict."
else
if
!
ambiguities
>
1
then
Error
.
grammar_warning
[]
(
Printf
.
sprintf
"%d states have an end-of-stream conflict."
!
ambiguities
)
Error
.
grammar_warning
[]
"%d states have an end-of-stream conflict."
!
ambiguities
(* ------------------------------------------------------------------------ *)
(* Extra reductions. 2015/10/19 *)
...
...
@@ -1134,7 +1133,7 @@ let extra_reductions () =
StringSet
.
iter
(
fun
nt
->
if
not
(
StringSet
.
mem
nt
!
extra_nts
)
then
Error
.
grammar_warning
[]
(
Printf
.
sprintf
"the declaration %%on_error_reduce %s is never useful."
nt
)
"the declaration %%on_error_reduce %s is never useful."
nt
)
OnErrorReduce
.
declarations
(* ------------------------------------------------------------------------ *)
...
...
src/parserAux.ml
View file @
01f4b77d
...
...
@@ -64,7 +64,7 @@ let normalize_producers producers =
let
override
pos
o1
o2
=
match
o1
,
o2
with
|
Some
_
,
Some
_
->
Error
.
signal
[
pos
]
"
T
his production carries two %prec declarations."
;
Error
.
signal
[
pos
]
"
t
his production carries two
%
%prec declarations."
;
o2
|
None
,
Some
_
->
o2
...
...
src/partialGrammar.ml
View file @
01f4b77d
...
...
@@ -734,7 +734,7 @@ let check_parameterized_grammar_is_well_defined grammar =
if
not
(
StringSet
.
mem
token
!
used_tokens
||
StringSet
.
mem
token
Settings
.
ignored_unused_tokens
)
then
Error
.
warning
[
p
]
(
Printf
.
sprintf
"the token %s is unused."
token
)
"the token %s is unused."
token
)
grammar
.
p_tokens
end
;
...
...
src/reachability.ml
View file @
01f4b77d
...
...
@@ -32,9 +32,8 @@ let trim grammar =
if
not
(
StringSet
.
mem
symbol
reachable
)
then
Error
.
grammar_warning
rule
.
positions
(
Printf
.
sprintf
"symbol %s is unreachable from any of the start symbol(s)."
symbol
)
symbol
)
grammar
.
rules
;
{
grammar
with
rules
=
StringMap
.
restrict
reachable
grammar
.
rules
}
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment