Commit bb3ab865 authored by POTTIER Francois's avatar POTTIER Francois

Merge the stylistic patch from master branch.

parent 057781d0
* 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, * Clarifier si ocamlbuild doit recevoir -use-ocamlfind, -no-ocamlfind,
ou rien; tester en particulier sous Windows? ou rien; tester en particulier sous Windows?
......
# Enable Jonathan's "nazi warnings".
<*>: my_warnings
# Tag both parser source files with origin_parser. # Tag both parser source files with origin_parser.
<{yacc-parser,fancy-parser}.mly>:origin_parser <{yacc-parser,fancy-parser}.mly>:origin_parser
......
...@@ -97,7 +97,7 @@ let rename_pkeywords (psym, first_prod, last_prod) phi l = ...@@ -97,7 +97,7 @@ let rename_pkeywords (psym, first_prod, last_prod) phi l =
(* Similarly for $endpos. *) (* Similarly for $endpos. *)
| Left, WhereEnd -> last_prod, (used1, true) | Left, WhereEnd -> last_prod, (used1, true)
(* $i cannot be combined with inlining. *) (* $i cannot be combined with inlining. *)
| RightDollar i, w -> assert false | RightDollar _, _ -> assert false
| RightNamed s, w -> | RightNamed s, w ->
(* In the host rule, $startpos(x) is changed to (* In the host rule, $startpos(x) is changed to
to $startpos(first_prod) (same thing for $endpos). *) to $startpos(first_prod) (same thing for $endpos). *)
...@@ -118,7 +118,7 @@ let rename_pkeywords (psym, first_prod, last_prod) phi l = ...@@ -118,7 +118,7 @@ let rename_pkeywords (psym, first_prod, last_prod) phi l =
(from_pos, to_pos) :: phi else phi), (from_pos, to_pos) :: phi else phi),
(used1, used2)) (used1, used2))
| x -> pk :: l, phi, (used1, used2)) | _ -> pk :: l, phi, (used1, used2))
([], phi, (false, false)) l ([], phi, (false, false)) l
...@@ -159,7 +159,7 @@ let keywords action = ...@@ -159,7 +159,7 @@ let keywords action =
let pkeywords action = let pkeywords action =
action.pkeywords action.pkeywords
let rec print f action = let print f action =
let module P = Printer.Make (struct let f = f let module P = Printer.Make (struct let f = f
let locate_stretches = None let locate_stretches = None
let raw_stretch_action = true let raw_stretch_action = true
......
...@@ -230,25 +230,6 @@ let statecon s = ...@@ -230,25 +230,6 @@ let statecon s =
let estatecon s = let estatecon s =
EData (statecon 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 = let pstatecon s =
PData (statecon s, []) PData (statecon s, [])
...@@ -323,9 +304,6 @@ let insertif condition x = ...@@ -323,9 +304,6 @@ let insertif condition x =
let var x : expr = let var x : expr =
EVar x EVar x
let vars xs =
List.map var xs
let pvar x : pattern = let pvar x : pattern =
PVar x PVar x
...@@ -770,7 +748,7 @@ let reducecellparams prod i holds_state symbol = ...@@ -770,7 +748,7 @@ let reducecellparams prod i holds_state symbol =
used in the semantic action, then it is dropped using a wildcard used in the semantic action, then it is dropped using a wildcard
pattern. *) pattern. *)
let semvpat t = let semvpat _t =
if used.(i) then if used.(i) then
PVar ids.(i) PVar ids.(i)
else else
...@@ -1078,8 +1056,7 @@ let errorbookkeeping e = ...@@ -1078,8 +1056,7 @@ let errorbookkeeping e =
)) ))
(* This code is used to indicate that a new error has been detected in (* 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 state [s].
handle.
If I am correct, the count of shifted tokens is never -1 If I am correct, the count of shifted tokens is never -1
here. Indeed, that would mean that we first found an error, and here. Indeed, that would mean that we first found an error, and
...@@ -1097,7 +1074,7 @@ let errorbookkeeping e = ...@@ -1097,7 +1074,7 @@ let errorbookkeeping e =
resetting [env.shifted] to zero, to counter-act the effect of resetting [env.shifted] to zero, to counter-act the effect of
[discard], which increments that counter. *) [discard], which increments that counter. *)
let initiate covered s = let initiate s =
blet ( blet (
[ assertshifted ], [ assertshifted ],
...@@ -1112,9 +1089,7 @@ let initiate covered s = ...@@ -1112,9 +1089,7 @@ let initiate covered s =
input stream. It does not set up exception handlers for dealing input stream. It does not set up exception handlers for dealing
with errors. *) with errors. *)
(* TEMPORARY I believe [action] could now be inlined into [run] *) let runactiondef s : valdef list =
let rec runactiondef s : valdef list =
match Invariant.has_default_reduction s with match Invariant.has_default_reduction s with
| Some (prod, toks) as defred -> | Some (prod, toks) as defred ->
...@@ -1180,7 +1155,7 @@ let rec runactiondef s : valdef list = ...@@ -1180,7 +1155,7 @@ let rec runactiondef s : valdef list =
if TerminalSet.subset TerminalSet.universe covered then if TerminalSet.subset TerminalSet.universe covered then
branches branches
else else
branches @ [ { branchpat = PWildcard; branchbody = initiate covered s } ] branches @ [ { branchpat = PWildcard; branchbody = initiate s } ]
in in
(* Finally, construct the code for [run] and [action]. The (* Finally, construct the code for [run] and [action]. The
......
...@@ -79,7 +79,7 @@ let rec simplify = function ...@@ -79,7 +79,7 @@ let rec simplify = function
(* Building a [let] construct, with on-the-fly simplification. *) (* Building a [let] construct, with on-the-fly simplification. *)
let rec blet (bindings, body) = let blet (bindings, body) =
match simplify bindings with match simplify bindings with
| [] -> | [] ->
body body
......
...@@ -125,7 +125,7 @@ let symval symbol x = ...@@ -125,7 +125,7 @@ let symval symbol x =
match semvtype symbol with match semvtype symbol with
| [] -> | [] ->
[] []
| [ t ] -> | [ _t ] ->
[ x ] [ x ]
| _ -> | _ ->
assert false assert false
......
...@@ -192,7 +192,7 @@ let rec compare s1 s2 = ...@@ -192,7 +192,7 @@ let rec compare s1 s2 =
else if ss1 > ss2 then 1 else if ss1 > ss2 then 1
else compare qs1 qs2 else compare qs1 qs2
let rec equal s1 s2 = let equal s1 s2 =
compare s1 s2 = 0 compare s1 s2 = 0
let rec disjoint s1 s2 = let rec disjoint s1 s2 =
......
...@@ -287,7 +287,7 @@ let explain_reduce_item ...@@ -287,7 +287,7 @@ let explain_reduce_item
(* Otherwise, explore the transitions out of this 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 (* Shift transition, followed only if the symbol matches
the symbol found in the input string. *) the symbol found in the input string. *)
...@@ -363,7 +363,7 @@ let () = ...@@ -363,7 +363,7 @@ let () =
| Item.Shift (Symbol.T tok, _) | Item.Shift (Symbol.T tok, _)
when Terminal.equal tok P.token -> when Terminal.equal tok P.token ->
shift + 1, reduce shift + 1, reduce
| Item.Reduce prod | Item.Reduce _
when TerminalSet.mem P.token toks -> when TerminalSet.mem P.token toks ->
shift, reduce + 1 shift, reduce + 1
| _ -> | _ ->
...@@ -413,7 +413,7 @@ let () = ...@@ -413,7 +413,7 @@ let () =
let derivation = explain_shift_item P.source P.path item in let derivation = explain_shift_item P.source P.path item in
Item.Map.add item derivation derivations Item.Map.add item derivation derivations
| Item.Reduce prod | Item.Reduce _
when TerminalSet.mem P.token toks -> when TerminalSet.mem P.token toks ->
still_looking_for_shift_item, still_looking_for_shift_item,
......
...@@ -253,7 +253,7 @@ module Run (T: sig end) = struct ...@@ -253,7 +253,7 @@ module Run (T: sig end) = struct
let write_init f = let write_init f =
write_inductive_alphabet f "initstate" ( write_inductive_alphabet f "initstate" (
ProductionMap.fold (fun prod node l -> ProductionMap.fold (fun _prod node l ->
(print_init node)::l) Lr1.entry []); (print_init node)::l) Lr1.entry []);
fprintf f "Instance InitStateAlph : Alphabet initstate := _.\n\n" fprintf f "Instance InitStateAlph : Alphabet initstate := _.\n\n"
......
...@@ -270,7 +270,7 @@ and common_forest cforest1 forest2 : cforest * cforest * forest = ...@@ -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, items, because this is convenient for the application that we have in mind,
but this assumption is really irrelevant. *) but this assumption is really irrelevant. *)
let rec factor forests = let factor forests =
match match
Item.Map.fold (fun item forest accu -> Item.Map.fold (fun item forest accu ->
match accu with match accu with
......
...@@ -123,6 +123,8 @@ end) = struct ...@@ -123,6 +123,8 @@ end) = struct
); );
G.iter (fun ?style ~label source -> G.iter (fun ?style ~label source ->
ignore style; (* avoid unused variable warnings *)
ignore label;
G.successors (fun ?style ~label destination -> G.successors (fun ?style ~label destination ->
fprintf f "%s %s %s [ label=\"%s\"%s ] ;\n" fprintf f "%s %s %s [ label=\"%s\"%s ] ;\n"
(G.name source) (G.name source)
......
...@@ -83,11 +83,12 @@ declaration: ...@@ -83,11 +83,12 @@ declaration:
| TOKEN OCAMLTYPE? clist(terminal) error | TOKEN OCAMLTYPE? clist(terminal) error
| TOKEN OCAMLTYPE? error | TOKEN OCAMLTYPE? error
{ Error.error (Positions.two $startpos $endpos) "\ { Error.error (Positions.two $startpos $endpos) (String.concat "\n" [
Syntax error in a %token declaration. "Syntax error in a %token declaration.";
Here are sample valid declarations: "Here are sample valid declarations:";
%token DOT SEMICOLON " %token DOT SEMICOLON";
%token <string> LID UID" " %token <string> LID UID";
])
} }
| START t = OCAMLTYPE? nts = clist(nonterminal) %prec decl | START t = OCAMLTYPE? nts = clist(nonterminal) %prec decl
...@@ -103,11 +104,12 @@ Here are sample valid declarations: ...@@ -103,11 +104,12 @@ Here are sample valid declarations:
| START OCAMLTYPE? clist(nonterminal) error | START OCAMLTYPE? clist(nonterminal) error
| START OCAMLTYPE? error | START OCAMLTYPE? error
{ Error.error (Positions.two $startpos $endpos) "\ { Error.error (Positions.two $startpos $endpos) (String.concat "\n" [
Syntax error in a %start declaration. "Syntax error in a %start declaration.";
Here are sample valid declarations: "Here are sample valid declarations:";
%start expression phrase " %start expression phrase";
%start <int> date time" " %start <int> date time";
])
} }
| TYPE t = OCAMLTYPE ss = clist(actual_parameter) %prec decl | TYPE t = OCAMLTYPE ss = clist(actual_parameter) %prec decl
...@@ -117,11 +119,12 @@ Here are sample valid declarations: ...@@ -117,11 +119,12 @@ Here are sample valid declarations:
| TYPE OCAMLTYPE clist(actual_parameter) error | TYPE OCAMLTYPE clist(actual_parameter) error
| TYPE OCAMLTYPE error | TYPE OCAMLTYPE error
| TYPE error | TYPE error
{ Error.error (Positions.two $startpos $endpos) "\ { Error.error (Positions.two $startpos $endpos) (String.concat "\n" [
Syntax error in a %type declaration. "Syntax error in a %type declaration.";
Here are sample valid declarations: "Here are sample valid declarations:";
%type <Syntax.expression> expression " %type <Syntax.expression> expression";
%type <int> date time" " %type <int> date time";
])
} }
| k = priority_keyword ss = clist(symbol) %prec decl | k = priority_keyword ss = clist(symbol) %prec decl
...@@ -130,22 +133,24 @@ Here are sample valid declarations: ...@@ -130,22 +133,24 @@ Here are sample valid declarations:
| priority_keyword clist(symbol) error | priority_keyword clist(symbol) error
| priority_keyword error | priority_keyword error
{ Error.error (Positions.two $startpos $endpos) "\ { Error.error (Positions.two $startpos $endpos) (String.concat "\n" [
Syntax error in a precedence declaration. "Syntax error in a precedence declaration.";
Here are sample valid declarations: "Here are sample valid declarations:";
%left PLUS TIMES " %left PLUS TIMES";
%nonassoc unary_minus " %nonassoc unary_minus";
%right CONCAT" " %right CONCAT";
])
} }
| PARAMETER t = OCAMLTYPE | PARAMETER t = OCAMLTYPE
{ [ with_poss $startpos $endpos (DParameter t) ] } { [ with_poss $startpos $endpos (DParameter t) ] }
| PARAMETER error | PARAMETER error
{ Error.error (Positions.two $startpos $endpos) "\ { Error.error (Positions.two $startpos $endpos) (String.concat "\n" [
Syntax error in a %parameter declaration. "Syntax error in a %parameter declaration.";
Here is a sample valid declaration: "Here is a sample valid declaration:";
%parameter <X : sig type t end>" " %parameter <X : sig type t end>";
])
} }
| error | error
......
...@@ -304,7 +304,7 @@ let depend grammar = ...@@ -304,7 +304,7 @@ let depend grammar =
) dependencies in ) dependencies in
if List.length dependencies > 0 then begin if List.length dependencies > 0 then begin
Printf.printf "%s.ml %s.mli:" base base; Printf.printf "%s.ml %s.mli:" base base;
List.iter (fun (basename, filename) -> List.iter (fun (_basename, filename) ->
Printf.printf " %s" filename Printf.printf " %s" filename
) dependencies; ) dependencies;
Printf.printf "\n%!" Printf.printf "\n%!"
......
...@@ -9,7 +9,7 @@ open CodeBits ...@@ -9,7 +9,7 @@ open CodeBits
checking against it in this way is quite cheap, and lets me sleep checking against it in this way is quite cheap, and lets me sleep
safely.) *) safely.) *)
class locals table = object(self) class locals table = object
method pvar (locals : StringSet.t) (id : string) = method pvar (locals : StringSet.t) (id : string) =
if Hashtbl.mem table id then StringSet.add id locals else locals if Hashtbl.mem table id then StringSet.add id locals else locals
...@@ -70,7 +70,7 @@ let inline ({ valdefs = defs } as p : program) = ...@@ -70,7 +70,7 @@ let inline ({ valdefs = defs } as p : program) =
object object
inherit [ StringSet.t, unit ] Traverse.fold inherit [ StringSet.t, unit ] Traverse.fold
inherit locals table inherit locals table
method evar locals () id = method! evar locals () id =
visit locals id visit locals id
end end
in in
...@@ -203,7 +203,7 @@ let inline ({ valdefs = defs } as p : program) = ...@@ -203,7 +203,7 @@ let inline ({ valdefs = defs } as p : program) =
object (self) object (self)
inherit [ StringSet.t ] Traverse.map as super inherit [ StringSet.t ] Traverse.map as super
inherit locals table inherit locals table
method eapp locals e actuals = method! eapp locals e actuals =
match e with match e with
| EVar id when | EVar id when
(Hashtbl.mem table id) && (* a global identifier *) (Hashtbl.mem table id) && (* a global identifier *)
......
...@@ -33,7 +33,7 @@ let stack_symbols : Lr0.node -> Symbol.t array = ...@@ -33,7 +33,7 @@ let stack_symbols : Lr0.node -> Symbol.t array =
in in
Misc.tabulate Lr0.n (fun node -> Misc.tabulate Lr0.n (fun node ->
Item.Set.fold (fun item accu -> 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 if pos > Array.length accu then Array.sub rhs 0 pos else accu
) (Lr0.items node) dummy ) (Lr0.items node) dummy
) )
...@@ -189,7 +189,7 @@ let stack_states : Lr1.node -> property = ...@@ -189,7 +189,7 @@ let stack_states : Lr1.node -> property =
empty empty
| Some symbol -> | Some _symbol ->
(* If [node] is not a start state, then include the contribution of (* If [node] is not a start state, then include the contribution of
every incoming transition. We compute a join over all predecessors. every incoming transition. We compute a join over all predecessors.
...@@ -629,7 +629,7 @@ let rec require where symbol = ...@@ -629,7 +629,7 @@ let rec require where symbol =
end end
and require_aux where prod = 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 let length = Array.length rhs in
if length > 0 then if length > 0 then
match where with match where with
......
...@@ -44,10 +44,6 @@ let def t = ...@@ -44,10 +44,6 @@ let def t =
assert ((pos >= 0) && (pos <= length)); assert ((pos >= 0) && (pos <= length));
prod, nt, rhs, pos, length prod, nt, rhs, pos, length
let nt t =
let _, nt, _, _, _ = def t in
nt
let startnt t = let startnt t =
let _, _, rhs, pos, length = def t in let _, _, rhs, pos, length = def t in
assert (pos = 0 && length = 1); assert (pos = 0 && length = 1);
...@@ -60,7 +56,7 @@ let startnt t = ...@@ -60,7 +56,7 @@ let startnt t =
(* Printing. *) (* Printing. *)
let print item = 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) Printf.sprintf "%s -> %s" (Nonterminal.print false nt) (Symbol.printaod 0 pos rhs)
(* Classifying items. *) (* Classifying items. *)
...@@ -154,7 +150,7 @@ module Closure (L : Lookahead.S) = struct ...@@ -154,7 +150,7 @@ module Closure (L : Lookahead.S) = struct
let () = let () =
Production.iter (fun prod -> Production.iter (fun prod ->
let nt, rhs = Production.def prod in let _nt, rhs = Production.def prod in
let length = Array.length rhs in let length = Array.length rhs in
mapping.(Production.p2i prod) <- Array.init (length+1) (fun pos -> mapping.(Production.p2i prod) <- Array.init (length+1) (fun pos ->
...@@ -194,7 +190,7 @@ module Closure (L : Lookahead.S) = struct ...@@ -194,7 +190,7 @@ module Closure (L : Lookahead.S) = struct
let () = let () =
Production.iter (fun prod -> Production.iter (fun prod ->
let nt, rhs = Production.def prod in let _nt, rhs = Production.def prod in
let length = Array.length rhs in let length = Array.length rhs in
Array.iteri (fun pos node -> Array.iteri (fun pos node ->
......
...@@ -564,7 +564,7 @@ let () = ...@@ -564,7 +564,7 @@ let () =
end end
| prod1 :: prod2 :: _ -> | _prod1 :: _prod2 :: _ ->
(* This is a shift/reduce/reduce conflict. If the priorities (* This is a shift/reduce/reduce conflict. If the priorities
are such that each individual shift/reduce conflict is solved are such that each individual shift/reduce conflict is solved
...@@ -616,7 +616,7 @@ let () = ...@@ -616,7 +616,7 @@ let () =
| [] | []
| [ _ ] -> | [ _ ] ->
() ()
| prod1 :: prod2 :: _ -> | _prod1 :: _prod2 :: _ ->
(* There is no transition in addition to the reduction(s). We (* There is no transition in addition to the reduction(s). We
have a pure reduce/reduce conflict. Do nothing about it at have a pure reduce/reduce conflict. Do nothing about it at
...@@ -1043,7 +1043,7 @@ let default_conflict_resolution () = ...@@ -1043,7 +1043,7 @@ let default_conflict_resolution () =
let has_ambiguity = ref false in let has_ambiguity = ref false in
let toks = ref TerminalSet.empty in let toks = ref TerminalSet.empty in
TerminalMap.iter (fun tok prods -> TerminalMap.iter (fun tok _prods ->
node.reductions <- reductions; node.reductions <- reductions;
has_ambiguity := true; has_ambiguity := true;
toks := TerminalSet.add tok !toks toks := TerminalSet.add tok !toks
......
...@@ -264,7 +264,7 @@ let gcp s1 s2 = ...@@ -264,7 +264,7 @@ let gcp s1 s2 =
(* [gcps] returns the greatest common prefix of a nonempty list of strings. *) (* [gcps] returns the greatest common prefix of a nonempty list of strings. *)
let rec gcps = function let gcps = function
| [] -> | [] ->
assert false assert false
| s :: ss -> | s :: ss ->
......
...@@ -7,7 +7,9 @@ open Command ...@@ -7,7 +7,9 @@ open Command
let flags () = let flags () =
(* -inline 1000 *) (* -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"])
(* ---------------------------------------------------------------------------- *) (* ---------------------------------------------------------------------------- *)
......
...@@ -95,7 +95,7 @@ let pack (a : int array) : t = ...@@ -95,7 +95,7 @@ let pack (a : int array) : t =
for j = 0 to n - 1 do for j = 0 to n - 1 do
let c = ref 0 in let c = ref 0 in
for x = 1 to w do for _x = 1 to w do