Commit 1ffe2cf1 authored by POTTIER Francois's avatar POTTIER Francois

Abandon the use of the type [Mark.t] to represent input files.

Use a new type [input_file] instead, which records the file's name and index
on the command line.
This allows fixing a bug in [UnparameterizedPrinter] where [List.sort] was
used with a non-transitive "ordering".
parent 0a12cb81
* UnparameterizedPrinter drops %on_error_reduce declarations!
* see if ErrorReports could be part of MenhirLib.
* see if --only-preprocess-for-ocamlyacc could be implemented.
......
......@@ -11,12 +11,6 @@ let get_initialized_ref ref =
| Some contents ->
contents
let filename =
ref (None : string option)
let filemark =
ref Mark.none
(* 2011/10/19: do not use [Filename.basename]. The [#] annotations that
we insert in the [.ml] file must retain their full path. This does
mean that the [#] annotations depend on how menhir is invoked -- e.g.
......@@ -25,15 +19,54 @@ let filemark =
(* This also influences the type error messages produced by [--infer]. *)
let set_filename name =
filename := Some name;
filemark := Mark.fresh()
let get_filename () =
get_initialized_ref filename
let get_filemark () =
!filemark
(* 2016/08/25: in principle, the order in which file names appear on the
command line (when there are several of them) does not matter. It is
however used in [UnparameterizedPrinter] (see the problem description
there). For this reason, we define a type [input_file] which includes
the file's name as well as its index on the command line. *)
type input_file = {
input_file_name: string;
input_file_index: int
}
let builtin_input_file = {
input_file_name = "<builtin>";
input_file_index = -1
}
let dummy_input_file = {
input_file_name = "<dummy>";
input_file_index = 0
}
let same_input_file file1 file2 =
file1.input_file_index = file2.input_file_index
(* could also use physical equality [file1 == file2] *)
let compare_input_files file1 file2 =
Pervasives.compare file1.input_file_index file2.input_file_index
(* Ideally, this function should NOT be used, as it reflects the
order of the input files on the command line. As of 2016/08/25,
it is used by [UnparameterizedPrinter], for lack of a better
solution. *)
let current_input_file =
ref dummy_input_file
(* This declares that a new file is being processed. *)
let new_input_file name : unit =
current_input_file := {
input_file_name = name;
input_file_index = !current_input_file.input_file_index + 1
}
let get_input_file () : input_file =
assert (!current_input_file != dummy_input_file);
!current_input_file
let get_input_file_name () : string =
(get_input_file()).input_file_name
let file_contents =
ref (None : string option)
......@@ -100,4 +133,3 @@ let errorp v =
let grammar_warning =
if Settings.strict then signal else warning
......@@ -9,11 +9,15 @@
(* TEMPORARY limiter ou supprimer ou commenter cette interface stateful *)
val set_filename: string -> unit
val new_input_file: string -> unit
val get_filename: unit -> string
val get_input_file_name: unit -> string
val get_filemark: unit -> Mark.t
type input_file
val builtin_input_file: input_file
val same_input_file: input_file -> input_file -> bool
val compare_input_files: input_file -> input_file -> int
val get_input_file: unit -> input_file
val file_contents: string option ref
......@@ -62,4 +66,3 @@ val warning: Positions.positions -> ('a, out_channel, unit, unit) format4 -> 'a
[errors] and stop the program if any errors have been reported. *)
val grammar_warning: Positions.positions -> ('a, out_channel, unit, unit) format4 -> 'a
......@@ -10,7 +10,7 @@ let load_partial_grammar filename =
Error.error []
"argument file names should end in %s. \"%s\" is not accepted."
validExt filename;
Error.set_filename filename;
Error.new_input_file filename;
try
let contents = IO.read_whole_file filename in
......
......@@ -579,10 +579,10 @@ module Production = struct
Array.make n None
let production_level : branch_production_level array =
(* The start productions should receive this dummy level, I suppose.
We use a fresh mark, so a reduce/reduce conflict that involves a
start production will not be solved. *)
let dummy = ProductionLevel (Mark.fresh(), 0) in
(* The start productions receive a level that pretends that they
originate in a fictitious "builtin" file. So, a reduce/reduce
conflict that involves a start production will not be solved. *)
let dummy = ProductionLevel (Error.builtin_input_file, 0) in
Array.make n dummy
let (_ : int) = StringMap.fold (fun nonterminal { branches = branches } k ->
......@@ -1369,7 +1369,7 @@ module Precedence = struct
| _, UndefinedPrecedence ->
Ic
| PrecedenceLevel (m1, l1, _, _), PrecedenceLevel (m2, l2, _, _) ->
if not (Mark.same m1 m2) then
if not (Error.same_input_file m1 m2) then
Ic
else
if l1 > l2 then
......@@ -1382,7 +1382,7 @@ module Precedence = struct
let production_order p1 p2 =
match p1, p2 with
| ProductionLevel (m1, l1), ProductionLevel (m2, l2) ->
if not (Mark.same m1 m2) then
if not (Error.same_input_file m1 m2) then
Ic
else
if l1 > l2 then
......
......@@ -243,7 +243,7 @@ let mk_stretch pos1 pos2 parenthesize monsters =
(String.make (pos1.pos_cnum - pos1.pos_bol) ' ') ^ content
in
Stretch.({
stretch_filename = Error.get_filename();
stretch_filename = Error.get_input_file_name();
stretch_linenum = pos1.pos_lnum;
stretch_linecount = pos2.pos_lnum - pos1.pos_lnum;
stretch_content = content;
......
......@@ -5,13 +5,13 @@ let new_precedence_level =
let c = ref 0 in
fun pos1 pos2 ->
incr c;
PrecedenceLevel (Error.get_filemark (), !c, pos1, pos2)
PrecedenceLevel (Error.get_input_file (), !c, pos1, pos2)
let new_production_level =
let c = ref 0 in
fun () ->
incr c;
ProductionLevel (Error.get_filemark (), !c)
ProductionLevel (Error.get_input_file (), !c)
let new_on_error_reduce_level =
new_production_level
......
......@@ -55,10 +55,10 @@ type precedence_level =
UndefinedPrecedence
(* Items are incomparable when they originate in different files. A
brand of type [Mark.t] is used to record an item's origin. The
value of type [input_file] is used to record an item's origin. The
positions allow locating certain warnings. *)
| PrecedenceLevel of Mark.t * int * Lexing.position * Lexing.position
| PrecedenceLevel of Error.input_file * int * Lexing.position * Lexing.position
type token_properties =
{
......@@ -84,7 +84,7 @@ type branch_prec_annotation =
which production appears first in the grammar. See [ParserAux]. *)
type branch_production_level =
| ProductionLevel of Mark.t * int
| ProductionLevel of Error.input_file * int
(* ------------------------------------------------------------------------ *)
......
......@@ -24,7 +24,7 @@ let rec insert_in_partitions item m = function
| [] ->
[ (m, [ item ]) ]
| (m', items) :: partitions when Mark.same m m' ->
| (m', items) :: partitions when Error.same_input_file m m' ->
(m', item :: items) :: partitions
| t :: partitions ->
......@@ -156,19 +156,26 @@ let print_postludes b g =
(* Because the resolution of reduce/reduce conflicts is implicitly dictated by
the order in which productions appear in the grammar, the printer should be
careful to preserve this order. *)
(* 2016/08/25: As noted above, when two productions originate in different files,
we have a problem. We MUST print them in some order, even though they should
be incomparable. In that case, we use the order in which the source files are
specified on the command line. However, this behavior is undocumented, and
should not be exploited. (In previous versions of Menhir, the function passed
to [List.sort] was not transitive, so it did not make any sense!) *)
let compare_pairs compare1 compare2 (x1, x2) (y1, y2) =
let c = compare1 x1 y1 in
if c <> 0 then c
else compare2 x2 y2
let branches_order r r' =
let branch_order b b' =
match b.branch_production_level, b'.branch_production_level with
| ProductionLevel (m, l), ProductionLevel (m', l') ->
if Mark.same m m' then
if l < l' then
-1
else if l > l' then
1
else
0
else 0
| ProductionLevel (m, l), ProductionLevel (m', l') ->
compare_pairs Error.compare_input_files Pervasives.compare (m, l) (m', l')
in
(* TEMPORARY I don't think we need a lexicographic ordering here *)
let rec lexical_order bs bs' =
match bs, bs' with
| [], [] ->
......
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