merge trunkgadts-devel

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/gadts-devel@11283 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

8 files changed, 38 insertions, 26 deletions

diff --git a/parsing/lexer.mll b/parsing/lexer.mll
index 20af0fb313..87e2a8cbce 100644
--- a/parsing/lexer.mll
+++ b/parsing/lexer.mll
@@ -416,7 +416,7 @@ and comment = parse
   | "*)"
       { match !comment_start_loc with
         | [] -> assert false
-        | [x] -> comment_start_loc := [];
+        | [_] -> comment_start_loc := [];
         | _ :: l -> comment_start_loc := l;
                     comment lexbuf;
        }
diff --git a/parsing/location.ml b/parsing/location.ml
index e4c09aa3ae..dd6d08fb12 100644
--- a/parsing/location.ml
+++ b/parsing/location.ml
@@ -207,7 +207,7 @@ let get_pos_info pos =
   (pos.pos_fname, pos.pos_lnum, pos.pos_cnum - pos.pos_bol)
 ;;
 
-let print ppf loc =
+let print_loc ppf loc =
   let (file, line, startchar) = get_pos_info loc.loc_start in
   let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum + startchar in
   if file = "//toplevel//" then begin
@@ -217,11 +217,15 @@ let print ppf loc =
   end else begin
     fprintf ppf "%s%s%s%i" msg_file file msg_line line;
     if startchar >= 0 then
-      fprintf ppf "%s%i%s%i" msg_chars startchar msg_to endchar;
-    fprintf ppf "%s@.%s" msg_colon msg_head;
+      fprintf ppf "%s%i%s%i" msg_chars startchar msg_to endchar
   end
 ;;
 
+let print ppf loc =
+  if loc.loc_start.pos_fname = "//toplevel//"
+  && highlight_locations ppf loc none then ()
+  else fprintf ppf "%a%s@.%s" print_loc loc msg_colon msg_head
+
 let print_error ppf loc =
   print ppf loc;
   fprintf ppf "Error: ";
@@ -235,7 +239,7 @@ let print_warning loc ppf w =
       let n = Warnings.print ppf w in
       num_loc_lines := !num_loc_lines + n
     in
-    fprintf ppf "%a" print loc;
+    print ppf loc;
     fprintf ppf "Warning %a@." printw w;
     pp_print_flush ppf ();
     incr num_loc_lines;
diff --git a/parsing/location.mli b/parsing/location.mli
index 2215d98646..d984c8423f 100644
--- a/parsing/location.mli
+++ b/parsing/location.mli
@@ -46,7 +46,8 @@ val rhs_loc: int -> t
 val input_name: string ref
 val input_lexbuf: Lexing.lexbuf option ref
 
-val get_pos_info : Lexing.position -> string * int * int (* file, line, char *)
+val get_pos_info: Lexing.position -> string * int * int (* file, line, char *)
+val print_loc: formatter -> t -> unit
 val print_error: formatter -> t -> unit
 val print_error_cur_file: formatter -> unit
 val print_warning: t -> formatter -> Warnings.t -> unit
@@ -55,3 +56,5 @@ val echo_eof: unit -> unit
 val reset: unit -> unit
 
 val highlight_locations: formatter -> t -> t -> bool
+
+val print: formatter -> t -> unit
diff --git a/parsing/longident.ml b/parsing/longident.ml
index 1114a2ef55..612f9df197 100644
--- a/parsing/longident.ml
+++ b/parsing/longident.ml
@@ -20,14 +20,14 @@ type t =
 let rec flat accu = function
     Lident s -> s :: accu
   | Ldot(lid, s) -> flat (s :: accu) lid
-  | Lapply(l1, l2) -> Misc.fatal_error "Longident.flat"
+  | Lapply(_, _) -> Misc.fatal_error "Longident.flat"
 
 let flatten lid = flat [] lid
 
 let last = function
     Lident s -> s
-  | Ldot(lid, s) -> s
-  | Lapply(l1, l2) -> Misc.fatal_error "Longident.last"
+  | Ldot(_, s) -> s
+  | Lapply(_, _) -> Misc.fatal_error "Longident.last"
 
 let rec split_at_dots s pos =
   try
diff --git a/parsing/parser.mly b/parsing/parser.mly
index 2c0b3bddc3..e3b94667f3 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -70,8 +70,9 @@ let ghtyp d = { ptyp_desc = d; ptyp_loc = symbol_gloc () };;
 
 let mkassert e =
   match e with
-  | {pexp_desc = Pexp_construct (Lident "false", None, false) } ->
-         mkexp (Pexp_assertfalse)
+  | { pexp_desc = Pexp_construct (Lident "false", None, false);
+      pexp_loc = _ } ->
+      mkexp (Pexp_assertfalse)
   | _ -> mkexp (Pexp_assert (e))
 ;;
 
@@ -93,7 +94,7 @@ let mkuminus name arg =
       mkexp(Pexp_constant(Const_int64(Int64.neg n)))
   | "-", Pexp_constant(Const_nativeint n) ->
       mkexp(Pexp_constant(Const_nativeint(Nativeint.neg n)))
-  | ("-" | "-."), Pexp_constant(Const_float f) ->
+  | _, Pexp_constant(Const_float f) ->
       mkexp(Pexp_constant(Const_float(neg_float_string f)))
   | _ ->
       mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, ["", arg]))
@@ -160,7 +161,7 @@ let bigarray_function str name =
   Ldot(Ldot(Lident "Bigarray", str), name)
 
 let bigarray_untuplify = function
-    { pexp_desc = Pexp_tuple explist} -> explist
+    { pexp_desc = Pexp_tuple explist; pexp_loc = _ } -> explist
   | exp -> [exp]
 
 let bigarray_get arr arg =
@@ -593,7 +594,7 @@ structure_tail:
 structure_item:
     LET rec_flag let_bindings
       { match $3 with
-          [{ppat_desc = Ppat_any}, exp] -> mkstr(Pstr_eval exp)
+          [{ ppat_desc = Ppat_any; ppat_loc = _ }, exp] -> mkstr(Pstr_eval exp)
         | _ -> mkstr(Pstr_value($2, List.rev $3)) }
   | EXTERNAL val_ident COLON core_type EQUAL primitive_declaration
       { mkstr(Pstr_primitive($2, {pval_type = $4; pval_prim = $6})) }
@@ -1379,7 +1380,7 @@ type_declaration:
               ptype_private = private_flag;
               ptype_manifest = manifest;
               ptype_variance = variance;
-              ptype_loc = symbol_rloc()}) }
+              ptype_loc = symbol_rloc() }) }
 ;
 constraints:
         constraints CONSTRAINT constrain        { $3 :: $1 }
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index 84ee659c01..b8d7da9fc0 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -189,12 +189,14 @@ and class_structure = pattern * class_field list
 and class_field =
     Pcf_inher of override_flag * class_expr * string option
   | Pcf_valvirt of (string * mutable_flag * core_type * Location.t)
-  | Pcf_val of (string * mutable_flag * override_flag * expression * Location.t)
-  | Pcf_virt  of (string * private_flag * core_type * Location.t)
-  | Pcf_meth of (string * private_flag *override_flag * expression * Location.t)
-  | Pcf_cstr  of (core_type * core_type * Location.t)
-  | Pcf_let   of rec_flag * (pattern * expression) list * Location.t
-  | Pcf_init  of expression
+  | Pcf_val of
+      (string * mutable_flag * override_flag * expression * Location.t)
+  | Pcf_virt of (string * private_flag * core_type * Location.t)
+  | Pcf_meth of
+      (string * private_flag * override_flag * expression * Location.t)
+  | Pcf_cstr of (core_type * core_type * Location.t)
+  | Pcf_let of rec_flag * (pattern * expression) list * Location.t
+  | Pcf_init of expression
 
 and class_declaration = class_expr class_infos
 
@@ -239,7 +241,7 @@ and with_constraint =
   | Pwith_typesubst of type_declaration
   | Pwith_modsubst of Longident.t
 
-(* value expressions for the module language *)
+(* Value expressions for the module language *)
 
 and module_expr =
   { pmod_desc: module_expr_desc;
diff --git a/parsing/printast.ml b/parsing/printast.ml
index 713295f6fa..6329f53020 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -96,7 +96,7 @@ let line i f s (*...*) =
 let list i f ppf l =
   match l with
   | [] -> line i ppf "[]\n";
-  | h::t ->
+  | _ :: _ ->
      line i ppf "[\n";
      List.iter (f (i+1) ppf) l;
      line i ppf "]\n";
@@ -152,7 +152,7 @@ let rec core_type i ppf x =
       core_type i ppf ct;
   | Ptyp_package (s, l) ->
       line i ppf "Ptyp_package %a\n" fmt_longident s;
-      list i package_with ppf l
+      list i package_with ppf l;
 
 and package_with i ppf (s, t) =
   line i ppf "with type %s\n" s;
@@ -524,7 +524,7 @@ and module_type i ppf x =
       list i longident_x_with_constraint ppf l;
   | Pmty_typeof m ->
       line i ppf "Pmty_typeof\n";
-      module_expr i ppf m
+      module_expr i ppf m;
 
 and signature i ppf x = list i signature_item ppf x
 
diff --git a/parsing/syntaxerr.ml b/parsing/syntaxerr.ml
index b0fda3695b..29f0deb3aa 100644
--- a/parsing/syntaxerr.ml
+++ b/parsing/syntaxerr.ml
@@ -37,7 +37,9 @@ let report_error ppf = function
           Location.print_error opening_loc opening
       end
   | Applicative_path loc ->
-      fprintf ppf "%aSyntax error: applicative paths of the form F(X).t are not supported when the option -no-app-func is set."
+      fprintf ppf
+        "%aSyntax error: applicative paths of the form F(X).t \
+         are not supported when the option -no-app-func is set."
         Location.print_error loc
   | Other loc ->
       fprintf ppf "%aSyntax error" Location.print_error loc