Module Printf, Format, and Scanf are printed in -w A warning mode. This found an old and subtle bug in Format; for other modules, the code is clearer and cleaner!

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@11100 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

4 files changed, 82 insertions, 72 deletions

diff --git a/stdlib/Compflags b/stdlib/Compflags
index 862a1c4e1..8578751c9 100755
--- a/stdlib/Compflags
+++ b/stdlib/Compflags
@@ -18,6 +18,7 @@ case $1 in
   pervasives.cm[iox]|pervasives.p.cmx) echo ' -nopervasives';;
   camlinternalOO.cmi) echo ' -nopervasives';;
   camlinternalOO.cmx|camlinternalOO.p.cmx) echo ' -inline 0';;
+  printf.cm[io]|format.cm[io]|scanf.cm[io]) echo ' -w A';;
   scanf.cmx|scanf.p.cmx) echo ' -inline 9';;
   arrayLabels.cm[ox]|arrayLabels.p.cmx) echo ' -nolabels';;
   listLabels.cm[ox]|listLabels.p.cmx) echo ' -nolabels';;
diff --git a/stdlib/format.ml b/stdlib/format.ml
index a8d6ec9e1..56648dd6a 100644
--- a/stdlib/format.ml
+++ b/stdlib/format.ml
@@ -60,7 +60,8 @@ and block_type =
                when it leads to a new indentation of the current line *)
 | Pp_fits   (* Internal usage: when a block fits on a single line *)
 
-and tblock = Pp_tbox of int list ref  (* Tabulation box *)
+and tblock =
+  | Pp_tbox of int list ref  (* Tabulation box *)
 ;;
 
 (* The Queue:
@@ -182,28 +183,30 @@ let clear_queue q = q.insert <- Nil; q.body <- Nil;;
 let add_queue x q =
   let c = Cons { head = x; tail = Nil; } in
   match q with
-  | { insert = Cons cell } ->
+  | { insert = Cons cell; body = _; } ->
     q.insert <- c; cell.tail <- c
   (* Invariant: when insert is Nil body should be Nil. *)
-  | _ -> q.insert <- c; q.body <- c;;
+  | { insert = Nil; body = _; } ->
+    q.insert <- c; q.body <- c
+;;
 
 exception Empty_queue;;
 
 let peek_queue = function
-  | { body = Cons { head = x; }; } -> x
-  | _ -> raise Empty_queue
+  | { body = Cons { head = x; tail = _; }; _ } -> x
+  | { body = Nil; insert = _; } -> raise Empty_queue
 ;;
 
 let take_queue = function
-  | { body = Cons { head = x; tail = tl; }; } as q ->
+  | { body = Cons { head = x; tail = tl; }; _ } as q ->
     q.body <- tl;
     if tl = Nil then q.insert <- Nil; (* Maintain the invariant. *)
     x
-  | _ -> raise Empty_queue
+  | { body = Nil; insert = _; } -> raise Empty_queue
 ;;
 
 (* Enter a token in the pretty-printer queue. *)
-let pp_enqueue state ({length = len} as token) =
+let pp_enqueue state ({ length = len; _} as token) =
   state.pp_right_total <- state.pp_right_total + len;
   add_queue token state.pp_queue
 ;;
@@ -272,15 +275,16 @@ let pp_force_break_line state =
     if width > state.pp_space_left then
       (match bl_ty with
        | Pp_fits -> () | Pp_hbox -> ()
-       | _ -> break_line state width)
-  | _ -> pp_output_newline state
+       | Pp_vbox | Pp_hvbox | Pp_hovbox | Pp_box ->
+         break_line state width)
+  | [] -> pp_output_newline state
 ;;
 
 (* To skip a token, if the previous line has been broken. *)
 let pp_skip_token state =
   (* When calling pp_skip_token the queue cannot be empty. *)
   match take_queue state.pp_queue with
-  | { elem_size = size; length = len; } ->
+  | { elem_size = size; length = len; token = _; } ->
     state.pp_left_total <- state.pp_left_total - len;
     state.pp_space_left <- state.pp_space_left + int_of_size size
 ;;
@@ -308,15 +312,16 @@ let format_pp_token state size = function
     let bl_type =
       begin match ty with
       | Pp_vbox -> Pp_vbox
-      | _ -> if size > state.pp_space_left then ty else Pp_fits
+      | Pp_hbox | Pp_hvbox | Pp_hovbox | Pp_box | Pp_fits ->
+        if size > state.pp_space_left then ty else Pp_fits
       end in
     state.pp_format_stack <-
       Format_elem (bl_type, offset) :: state.pp_format_stack
 
   | Pp_end ->
     begin match state.pp_format_stack with
-    | x :: (y :: l as ls) -> state.pp_format_stack <- ls
-    | _ -> () (* No more block to close. *)
+    | _ :: ls -> state.pp_format_stack <- ls
+    | [] -> () (* No more block to close. *)
     end
 
   | Pp_tbegin (Pp_tbox _ as tbox) ->
@@ -324,8 +329,8 @@ let format_pp_token state size = function
 
   | Pp_tend ->
     begin match state.pp_tbox_stack with
-    | x :: ls -> state.pp_tbox_stack <- ls
-    | _ -> () (* No more tabulation block to close. *)
+    | _ :: ls -> state.pp_tbox_stack <- ls
+    | [] -> () (* No more tabulation block to close. *)
     end
 
   | Pp_stab ->
@@ -335,7 +340,7 @@ let format_pp_token state size = function
         | [] -> [n]
         | x :: l as ls -> if n < x then n :: ls else x :: add_tab n l in
       tabs := add_tab (state.pp_margin - state.pp_space_left) !tabs
-    | _ -> () (* No opened tabulation block. *)
+    | [] -> () (* No opened tabulation block. *)
     end
 
   | Pp_tbreak (n, off) ->
@@ -347,7 +352,7 @@ let format_pp_token state size = function
         | [] -> raise Not_found in
       let tab =
         match !tabs with
-        | x :: l ->
+        | x :: _ ->
           begin
             try find insertion_point !tabs with
             | Not_found -> x
@@ -357,13 +362,13 @@ let format_pp_token state size = function
       if offset >= 0
       then break_same_line state (offset + n)
       else break_new_line state (tab + off) state.pp_margin
-    | _ -> () (* No opened tabulation block. *)
+    | [] -> () (* No opened tabulation block. *)
     end
 
   | Pp_newline ->
     begin match state.pp_format_stack with
     | Format_elem (_, width) :: _ -> break_line state width
-    | _ -> pp_output_newline state
+    | [] -> pp_output_newline state (* No opened block. *)
     end
 
   | Pp_if_newline ->
@@ -392,7 +397,7 @@ let format_pp_token state size = function
       | Pp_vbox -> break_new_line state off width
       | Pp_hbox -> break_same_line state n
       end
-    | _ -> () (* No opened block. *)
+    | [] -> () (* No opened block. *)
     end
 
    | Pp_open_tag tag_name ->
@@ -406,7 +411,7 @@ let format_pp_token state size = function
        let marker = state.pp_mark_close_tag tag_name in
        pp_output_string state marker;
        state.pp_mark_stack <- tags
-     | _ -> () (* No more tag to close. *)
+     | [] -> () (* No more tag to close. *)
      end
 ;;
 
@@ -474,7 +479,7 @@ let set_size state ty =
   match state.pp_scan_stack with
   | Scan_elem
       (left_tot,
-       ({elem_size = size; token = tok} as queue_elem)) :: t ->
+       ({ elem_size = size; token = tok; length = _; } as queue_elem)) :: t ->
     let size = int_of_size size in
     (* test if scan stack contains any data that is not obsolete. *)
     if left_tot < state.pp_left_total then clear_scan_stack state else
@@ -491,9 +496,12 @@ let set_size state ty =
           queue_elem.elem_size <- size_of_int (state.pp_right_total + size);
           state.pp_scan_stack <- t
         end
-      | _ -> () (* scan_push is only used for breaks and boxes. *)
+      | Pp_text _ | Pp_stab | Pp_tbegin _ | Pp_tend | Pp_end
+      | Pp_newline | Pp_if_newline
+      | Pp_open_tag _ | Pp_close_tag ->
+        () (* scan_push is only used for breaks and boxes. *)
       end
-  | _ -> () (* scan_stack is never empty. *)
+  | [] -> () (* scan_stack is never empty. *)
 ;;
 
 (* Push a token on scan stack. If b is true set_size is called. *)
@@ -847,7 +855,7 @@ let pp_set_formatter_out_channel state os =
 let default_pp_mark_open_tag s = "<" ^ s ^ ">";;
 let default_pp_mark_close_tag s = "</" ^ s ^ ">";;
 
-let default_pp_print_open_tag s = ();;
+let default_pp_print_open_tag _ = ();;
 let default_pp_print_close_tag = default_pp_print_open_tag;;
 
 let pp_make_formatter f g h i =
@@ -1011,11 +1019,12 @@ module Tformat = Printf.CamlinternalPr.Tformat;;
 
 (* Trailer: giving up at character number ... *)
 let giving_up mess fmt i =
-  "fprintf: " ^ mess ^ " ``" ^ Sformat.to_string fmt ^ "'', \
-   giving up at character number " ^ string_of_int i ^
-  (if i < Sformat.length fmt
-   then " (" ^ String.make 1 (Sformat.get fmt i) ^ ")."
-   else String.make 1 '.')
+  Printf.sprintf
+    "Format.fprintf: %s ``%s'', giving up at character number %d%s"
+    mess (Sformat.to_string fmt) i
+    (if i < Sformat.length fmt
+     then Printf.sprintf " (%c)." (Sformat.get fmt i)
+     else Printf.sprintf "%c" '.')
 ;;
 
 (* When an invalid format deserves a special error explanation. *)
@@ -1028,11 +1037,11 @@ let invalid_format fmt i = format_invalid_arg "bad format" fmt i;;
 let invalid_integer fmt i =
   invalid_arg (giving_up "bad integer specification" fmt i);;
 
-(* Finding an integer out of a sub-string of the format. *)
+(* Finding an integer size out of a sub-string of the format. *)
 let format_int_of_string fmt i s =
   let sz =
     try int_of_string s with
-    | Failure s -> invalid_integer fmt i in
+    | Failure _ -> invalid_integer fmt i in
   size_of_int sz
 ;;
 
@@ -1110,7 +1119,7 @@ let mkprintf to_s get_out =
           | '[' ->
             do_pp_open_box ppf n (succ i)
           | ']' ->
-             pp_close_box ppf ();
+            pp_close_box ppf ();
             doprn n (succ i)
           | '{' ->
             do_pp_open_tag ppf n (succ i)
@@ -1142,7 +1151,7 @@ let mkprintf to_s get_out =
           | '@' as c ->
             pp_print_as_char c;
             doprn n (succ i)
-          | c -> invalid_format fmt i
+          | _ -> invalid_format fmt i
           end
         | c ->
           pp_print_as_char c;
@@ -1173,10 +1182,10 @@ let mkprintf to_s get_out =
         | ' ' -> get_int n (succ i) c
         | '%' ->
           let cont_s n s i = c (format_int_of_string fmt i s) n i
-          and cont_a n printer arg i = invalid_integer fmt i
-          and cont_t n printer i = invalid_integer fmt i
-          and cont_f n i = invalid_integer fmt i
-          and cont_m n sfmt i = invalid_integer fmt i in
+          and cont_a _n _printer _arg i = invalid_integer fmt i
+          and cont_t _n _printer i = invalid_integer fmt i
+          and cont_f _n i = invalid_integer fmt i
+          and cont_m _n _sfmt i = invalid_integer fmt i in
           Tformat.scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m
         | _ ->
           let rec get j =
@@ -1185,7 +1194,7 @@ let mkprintf to_s get_out =
             | '0' .. '9' | '-' -> get (succ j)
             | _ ->
               let size =
-              if j = i then size_of_int 0 else
+                if j = i then size_of_int 0 else
                 let s = Sformat.sub fmt (Sformat.index_of_int i) (j - i) in
                 format_int_of_string fmt j s in
               c size n j in
@@ -1215,7 +1224,7 @@ let mkprintf to_s get_out =
                  ("bad box name ho" ^ String.make 1 c) fmt i
              end
            | 'v' -> Pp_hvbox, succ i
-           | c -> Pp_hbox, i
+           | _ -> Pp_hbox, i
            end
         | 'b' -> Pp_box, succ i
         | 'v' -> Pp_vbox, succ i
@@ -1249,12 +1258,12 @@ let mkprintf to_s get_out =
                 then (Obj.magic printer : unit -> string) ()
                 else exstring (fun ppf () -> printer ppf) () in
               get (s :: s0 :: accu) n i i
-            and cont_f n i =
+            and cont_f _n i =
               format_invalid_arg "bad tag name specification" fmt i
-            and cont_m n sfmt i =
+            and cont_m _n _sfmt i =
               format_invalid_arg "bad tag name specification" fmt i in
             Tformat.scan_format fmt v n j cont_s cont_a cont_t cont_f cont_m
-          | c -> get accu n i (succ j) in
+          | _ -> get accu n i (succ j) in
         get [] n i i
 
       and do_pp_break ppf n i =
@@ -1267,7 +1276,7 @@ let mkprintf to_s get_out =
             pp_print_break ppf (int_of_size nspaces) (int_of_size offset);
             doprn n (skip_gt i) in
           get_int n (succ i) got_nspaces
-        | c -> pp_print_space ppf (); doprn n i
+        | _c -> pp_print_space ppf (); doprn n i
 
       and do_pp_open_box ppf n i =
         if i >= len then begin pp_open_box_gen ppf 0 Pp_box; doprn n i end else
@@ -1278,7 +1287,7 @@ let mkprintf to_s get_out =
             pp_open_box_gen ppf (int_of_size size) kind;
             doprn n (skip_gt i) in
           get_int n i got_size
-        | c -> pp_open_box_gen ppf 0 Pp_box; doprn n i
+        | _c -> pp_open_box_gen ppf 0 Pp_box; doprn n i
 
       and do_pp_open_tag ppf n i =
         if i >= len then begin pp_open_tag ppf ""; doprn n i end else
@@ -1288,7 +1297,7 @@ let mkprintf to_s get_out =
             pp_open_tag ppf tag_name;
             doprn n (skip_gt i) in
           get_tag_name n (succ i) got_name
-        | c -> pp_open_tag ppf ""; doprn n i in
+        | _c -> pp_open_tag ppf ""; doprn n i in
 
       doprn (Sformat.index_of_int 0) 0 in
 
diff --git a/stdlib/printf.ml b/stdlib/printf.ml
index a16c9184a..11cf3cdf9 100644
--- a/stdlib/printf.ml
+++ b/stdlib/printf.ml
@@ -228,7 +228,7 @@ let iter_on_format_args fmt add_conv add_char =
         match Sformat.get fmt j with
         | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' ->
           add_char (add_conv skip i conv) 'i'
-        | c -> add_conv skip i 'i' end
+        | _ -> add_conv skip i 'i' end
     | '{' as conv ->
       (* Just get a regular argument, skipping the specification. *)
       let i = add_conv skip i conv in
@@ -299,7 +299,7 @@ let ac_of_format fmt =
     (* Just finishing a meta format: no additional argument to record. *)
     if c <> ')' && c <> '}' then incr_ac skip c;
     succ i
-  and add_char i c = succ i in
+  and add_char i _ = succ i in
 
   iter_on_format_args fmt add_conv add_char;
   ac
@@ -391,7 +391,7 @@ type positional_specification =
    case. Put it another way: this means type dependency, which is completely
    out of scope of the Caml type algebra. *)
 
-let scan_positional_spec fmt got_spec n i =
+let scan_positional_spec fmt got_spec i =
   match Sformat.unsafe_get fmt i with
   | '0'..'9' as d ->
     let rec get_int_literal accu j =
@@ -488,7 +488,7 @@ let scan_format fmt args n pos cont_s cont_a cont_t cont_f cont_m =
 
   let rec scan_positional n widths i =
     let got_spec spec i = scan_flags spec n widths i in
-    scan_positional_spec fmt got_spec n i
+    scan_positional_spec fmt got_spec i
 
   and scan_flags spec n widths i =
     match Sformat.unsafe_get fmt i with
@@ -496,7 +496,7 @@ let scan_format fmt args n pos cont_s cont_a cont_t cont_f cont_m =
       let got_spec wspec i =
         let (width : int) = get_arg wspec n in
         scan_flags spec (next_index wspec n) (width :: widths) i in
-      scan_positional_spec fmt got_spec n (succ i)
+      scan_positional_spec fmt got_spec (succ i)
     | '0'..'9'
     | '.' | '#' | '-' | ' ' | '+' -> scan_flags spec n widths (succ i)
     | _ -> scan_conv spec n widths i
@@ -635,7 +635,7 @@ let mkprintf to_s get_out outc outs flush k fmt =
 let kfprintf k oc =
   mkprintf false (fun _ -> oc) output_char output_string flush k
 ;;
-let ifprintf oc = kapr (fun _ -> Obj.magic ignore);;
+let ifprintf _ = kapr (fun _ -> Obj.magic ignore);;
 
 let fprintf oc = kfprintf ignore oc;;
 let printf fmt = fprintf stdout fmt;;
diff --git a/stdlib/scanf.ml b/stdlib/scanf.ml
index b6498a85e..aa6e65621 100644
--- a/stdlib/scanf.ml
+++ b/stdlib/scanf.ml
@@ -675,7 +675,7 @@ let scan_sign max ib =
   match c with
   | '+' -> Scanning.store_char max ib c
   | '-' -> Scanning.store_char max ib c
-  | c -> max
+  | _ -> max
 ;;
 
 let scan_optionally_signed_decimal_int max ib =
@@ -698,8 +698,8 @@ let scan_unsigned_int max ib =
     | 'x' | 'X' -> scan_hexadecimal_int (Scanning.store_char max ib c) ib
     | 'o' -> scan_octal_int (Scanning.store_char max ib c) ib
     | 'b' -> scan_binary_int (Scanning.store_char max ib c) ib
-    | c -> scan_decimal_digits max ib end
-  | c -> scan_unsigned_decimal_int max ib
+    | _ -> scan_decimal_digits max ib end
+  | _ -> scan_unsigned_decimal_int max ib
 ;;
 
 let scan_optionally_signed_int max ib =
@@ -715,7 +715,7 @@ let scan_int_conv conv max _min ib =
   | 'o' -> scan_octal_int max ib
   | 'u' -> scan_unsigned_decimal_int max ib
   | 'x' | 'X' -> scan_hexadecimal_int max ib
-  | c -> assert false
+  | _ -> assert false
 ;;
 
 (* Scanning floating point numbers. *)
@@ -790,7 +790,7 @@ let scan_float max max_frac_part ib =
     let max_precision = min max max_frac_part in
     let max = max - (max_precision - scan_frac_part max_precision ib) in
     scan_exp_part max ib, max_frac_part
-  | c ->
+  | _ ->
     scan_exp_part max ib, max_frac_part
 ;;
 
@@ -808,7 +808,7 @@ let scan_Float max max_frac_part ib =
     scan_exp_part max ib
   | 'e' | 'E' ->
     scan_exp_part max ib
-  | c -> bad_float ()
+  | _ -> bad_float ()
 ;;
 
 (* Scan a regular string:
@@ -967,7 +967,7 @@ let scan_String max ib =
     match check_next_char_for_string max ib with
     | '\r' -> skip_newline (Scanning.ignore_char max ib)
     | '\n' -> skip_spaces (Scanning.ignore_char max ib)
-    | c -> find_stop (scan_backslash_char max ib)
+    | _ -> find_stop (scan_backslash_char max ib)
 
   and skip_newline max =
     match check_next_char_for_string max ib with
@@ -1010,13 +1010,13 @@ let read_char_set fmt i =
     if j > lim then incomplete_format fmt else
     match Sformat.get fmt j with
     | ']' -> j
-    | c -> find_in_set (succ j)
+    | _ -> find_in_set (succ j)
 
   and find_set i =
     if i > lim then incomplete_format fmt else
     match Sformat.get fmt i with
     | ']' -> find_in_set (succ i)
-    | c -> find_in_set i in
+    | _ -> find_in_set i in
 
   if i > lim then incomplete_format fmt else
   match Sformat.get fmt i with
@@ -1086,7 +1086,7 @@ let make_char_bit_vect bit set =
       for j = int_of_char c1 to int_of_char c2 do
         set_bit_of_range r j bit done;
       loop bit false (succ i)
-    | c ->
+    | _ ->
       set_bit_of_range r (int_of_char set.[i]) bit;
       loop bit true (succ i) in
   loop bit false 0;
@@ -1105,7 +1105,7 @@ let make_setp stp char_set =
   match char_set with
   | Pos_set set ->
     begin match String.length set with
-    | 0 -> (fun c -> 0)
+    | 0 -> (fun _ -> 0)
     | 1 ->
       let p = set.[0] in
       (fun c -> if c == p then 1 else 0)
@@ -1116,11 +1116,11 @@ let make_setp stp char_set =
       let p1 = set.[0] and p2 = set.[1] and p3 = set.[2] in
       if p2 = '-' then make_pred 1 set stp else
       (fun c -> if c == p1 || c == p2 || c == p3 then 1 else 0)
-    | n -> make_pred 1 set stp
+    | _ -> make_pred 1 set stp
     end
   | Neg_set set ->
     begin match String.length set with
-    | 0 -> (fun c -> 1)
+    | 0 -> (fun _ -> 1)
     | 1 ->
       let p = set.[0] in
       (fun c -> if c != p then 1 else 0)
@@ -1131,7 +1131,7 @@ let make_setp stp char_set =
       let p1 = set.[0] and p2 = set.[1] and p3 = set.[2] in
       if p2 = '-' then make_pred 0 set stp else
       (fun c -> if c != p1 && c != p2 && c != p3 then 1 else 0)
-    | n -> make_pred 0 set stp
+    | _ -> make_pred 0 set stp
     end
 ;;
 
@@ -1210,18 +1210,18 @@ let scan_chars_in_char_set stp char_set max ib =
     match char_set with
     | Pos_set set ->
       begin match String.length set with
-      | 0 -> loop (fun c -> 0) max
+      | 0 -> loop (fun _ -> 0) max
       | 1 -> loop_pos1 set.[0] max
       | 2 -> loop_pos2 set.[0] set.[1] max
       | 3 when set.[1] != '-' -> loop_pos3 set.[0] set.[1] set.[2] max
-      | n -> loop (find_setp stp char_set) max end
+      | _ -> loop (find_setp stp char_set) max end
     | Neg_set set ->
       begin match String.length set with
-      | 0 -> loop (fun c -> 1) max
+      | 0 -> loop (fun _ -> 1) max
       | 1 -> loop_neg1 set.[0] max
       | 2 -> loop_neg2 set.[0] set.[1] max
       | 3 when set.[1] != '-' -> loop_neg3 set.[0] set.[1] set.[2] max
-      | n -> loop (find_setp stp char_set) max end in
+      | _ -> loop (find_setp stp char_set) max end in
   ignore_stoppers stp ib;
   max
 ;;
@@ -1309,7 +1309,7 @@ let scan_format ib ef fmt rv f =
   let return v = Obj.magic v () in
   let delay f x () = f x in
   let stack f = delay (return f) in
-  let no_stack f x = f in
+  let no_stack f _x = f in
 
   let rec scan fmt =