new warning for black holes

Jacques Garrigue · Jacques Garrigue · commit 0edba97cf601 · 2004-11-29T02:27:25.000Z
git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@6703 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
diff --git a/Makefile b/Makefile
@@ -19,7 +19,7 @@ include stdlib/StdlibModules
 
 CAMLC=boot/ocamlrun boot/ocamlc -nostdlib -I boot
 CAMLOPT=boot/ocamlrun ./ocamlopt -nostdlib -I stdlib
-COMPFLAGS=-warn-error Ay -w Y $(INCLUDES)
+COMPFLAGS=-warn-error Axy -w Y $(INCLUDES)
 LINKFLAGS=
 
 CAMLYACC=boot/ocamlyacc
diff --git a/debugger/loadprinter.ml b/debugger/loadprinter.ml
@@ -134,9 +134,9 @@ let install_printer ppf lid =
       raise(Error(Unavailable_module(s, lid))) in
   let print_function =
     if is_old_style then
-      (fun formatter repr -> (Obj.obj v) (Obj.obj repr))
+      (fun formatter repr -> Obj.obj v (Obj.obj repr))
     else
-      (fun formatter repr -> (Obj.obj v) formatter (Obj.obj repr)) in
+      (fun formatter repr -> Obj.obj v formatter (Obj.obj repr)) in
   Printval.install_printer path ty_arg ppf print_function
 
 let remove_printer lid =
diff --git a/ocamldoc/odoc_texi.ml b/ocamldoc/odoc_texi.ml
@@ -264,8 +264,8 @@ class text =
 
     (** this method is not used here but is virtual
         in a class we will inherit later *)
-    method label ?(no_ : bool option) (_ : string) = 
-      failwith "gni" ; ""
+    method label ?(no_ : bool option) (_ : string) : string = 
+      failwith "gni"
 
     (** Return the Texinfo code corresponding to the [text] parameter.*)
     method texi_of_text t =
diff --git a/otherlibs/dynlink/dynlink.ml b/otherlibs/dynlink/dynlink.ml
@@ -114,7 +114,7 @@ let digest_interface unit loadpath =
       close_in ic;
       raise(Error(Corrupted_interface filename))
     end;
-    input_value ic;
+    ignore (input_value ic);
     let crc =
       match input_value ic with
         (_, crc) :: _ -> crc
diff --git a/otherlibs/labltk/jpf/fileselect.ml b/otherlibs/labltk/jpf/fileselect.ml
@@ -56,8 +56,7 @@ let subshell cmd =
   let r,w = pipe () in
     match fork () with
       0 -> close r; dup2 ~src:w ~dst:stdout; 
-           execv ~prog:"/bin/sh" ~args:[| "/bin/sh"; "-c"; cmd |]; 
-           exit 127
+           execv ~prog:"/bin/sh" ~args:[| "/bin/sh"; "-c"; cmd |]
     | id -> 
         close w; 
         let rc = in_channel_of_descr r in
diff --git a/otherlibs/labltk/jpf/shell.ml b/otherlibs/labltk/jpf/shell.ml
@@ -22,7 +22,7 @@ let subshell cmd =
     match fork () with
       0 -> close r; dup2 w stdout; 
            close stderr;
-           execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |]; exit 127
+           execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |]
     | id -> 
         close w; 
         let rc = in_channel_of_descr r in
diff --git a/otherlibs/threads/Makefile b/otherlibs/threads/Makefile
@@ -19,7 +19,7 @@ CC=$(BYTECC)
 CFLAGS=-I../../byterun -O $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) -g
 CAMLC=../../ocamlcomp.sh -I ../unix
 MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib
-COMPFLAGS=-warn-error Ay -w Y
+COMPFLAGS=-warn-error Axy -w Y
 
 C_OBJS=scheduler.o
 
diff --git a/otherlibs/unix/Makefile b/otherlibs/unix/Makefile
@@ -23,7 +23,7 @@ CFLAGS=-I../../byterun -O $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS)
 CAMLC=../../ocamlcomp.sh
 CAMLOPT=../../ocamlcompopt.sh
 MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib
-COMPFLAGS=-warn-error Ay -w Y
+COMPFLAGS=-warn-error Axy -w Y
 
 OBJS=accept.o access.o addrofstr.o alarm.o bind.o chdir.o chmod.o \
   chown.o chroot.o close.o closedir.o connect.o cst2constr.o cstringv.o \
diff --git a/testlabl/poly.exp b/testlabl/poly.exp
@@ -1,4 +1,4 @@
-        Objective Caml version 3.09+dev4 (2004-10-13)
+        Objective Caml version 3.09+dev9 (2004-11-29)
 
 #   * * *       #   type 'a t = { t : 'a; }
 # type 'a fold = { fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b; }
@@ -263,23 +263,23 @@ type 'a u = A of 'a t
 # - : t * [< `A | `B ] -> int = <fun>
 # - : [< `A | `B ] * t -> int = <fun>
 # Characters 0-41:
-Warning: this pattern-matching is not exhaustive.
+Warning P: this pattern-matching is not exhaustive.
 Here is an example of a value that is not matched:
 (`AnyExtraTag, `AnyExtraTag)
 - : [> `A | `B ] * [> `A | `B ] -> int = <fun>
 # Characters 0-29:
-Warning: this pattern-matching is not exhaustive.
+Warning P: this pattern-matching is not exhaustive.
 Here is an example of a value that is not matched:
 (_, 0)
 Characters 21-24:
-Warning: this match case is unused.
+Warning U: this match case is unused.
 - : [ `B ] * int -> int = <fun>
 # Characters 0-29:
-Warning: this pattern-matching is not exhaustive.
+Warning P: this pattern-matching is not exhaustive.
 Here is an example of a value that is not matched:
 (0, _)
 Characters 21-24:
-Warning: this match case is unused.
+Warning U: this match case is unused.
 - : int * [ `B ] -> int = <fun>
 #       Characters 69-135:
 Constraints are not satisfied in this type.
@@ -318,8 +318,8 @@ type bt = 'a ca cb as 'a
 # val f : unit -> c = <fun>
 # val f : unit -> c = <fun>
 # Characters 11-60:
-Warning: the following private methods were made public implicitly:
-  n
+Warning X: the following private methods were made public implicitly:
+  n .
 val f : unit -> < m : int; n : int > = <fun>
 # Characters 11-56:
 This object is expected to have type c but has actually type
diff --git a/testlabl/poly.exp2 b/testlabl/poly.exp2
@@ -1,4 +1,4 @@
-        Objective Caml version 3.09+dev4 (2004-10-13)
+        Objective Caml version 3.09+dev9 (2004-11-29)
 
 #   * * *       #   type 'a t = { t : 'a; }
 # type 'a fold = { fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b; }
@@ -144,9 +144,9 @@ This method has type 'a -> 'a which is less general than 'b. 'b -> 'b
 #   Characters 24-28:
 This expression has type bool but is here used with type int
 #   Characters 27-31:
-Warning: This use of a polymorphic method is not principal
+Warning X: this use of a polymorphic method is not principal.
 Characters 35-39:
-Warning: This use of a polymorphic method is not principal
+Warning X: this use of a polymorphic method is not principal.
 val f4 : id -> int * bool = <fun>
 #           class c : object method m : #id -> int * bool end
 #             class id2 : object method id : 'a -> 'a method mono : int -> int end
@@ -270,23 +270,23 @@ type 'a u = A of 'a t
 # - : t * [< `A | `B ] -> int = <fun>
 # - : [< `A | `B ] * t -> int = <fun>
 # Characters 0-41:
-Warning: this pattern-matching is not exhaustive.
+Warning P: this pattern-matching is not exhaustive.
 Here is an example of a value that is not matched:
 (`AnyExtraTag, `AnyExtraTag)
 - : [> `A | `B ] * [> `A | `B ] -> int = <fun>
 # Characters 0-29:
-Warning: this pattern-matching is not exhaustive.
+Warning P: this pattern-matching is not exhaustive.
 Here is an example of a value that is not matched:
 (_, 0)
 Characters 21-24:
-Warning: this match case is unused.
+Warning U: this match case is unused.
 - : [ `B ] * int -> int = <fun>
 # Characters 0-29:
-Warning: this pattern-matching is not exhaustive.
+Warning P: this pattern-matching is not exhaustive.
 Here is an example of a value that is not matched:
 (0, _)
 Characters 21-24:
-Warning: this match case is unused.
+Warning U: this match case is unused.
 - : int * [ `B ] -> int = <fun>
 #       Characters 69-135:
 Constraints are not satisfied in this type.
@@ -325,8 +325,8 @@ type bt = 'a ca cb as 'a
 # val f : unit -> c = <fun>
 # val f : unit -> c = <fun>
 # Characters 11-60:
-Warning: the following private methods were made public implicitly:
-  n
+Warning X: the following private methods were made public implicitly:
+  n .
 val f : unit -> < m : int; n : int > = <fun>
 # Characters 11-56:
 This object is expected to have type c but has actually type
diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml
@@ -179,9 +179,9 @@ let dir_install_printer ppf lid =
     let v = eval_path path in
     let print_function =
       if is_old_style then
-        (fun formatter repr -> (Obj.obj v) (Obj.obj repr))
+        (fun formatter repr -> Obj.obj v (Obj.obj repr))
       else
-        (fun formatter repr -> (Obj.obj v) formatter (Obj.obj repr)) in
+        (fun formatter repr -> Obj.obj v formatter (Obj.obj repr)) in
     install_printer path ty_arg print_function
   with Exit -> ()
 
diff --git a/typing/typecore.ml b/typing/typecore.ml
@@ -869,14 +869,27 @@ let rec type_exp env sexp =
   | Pexp_function _ ->     (* defined in type_expect *)
       type_expect env sexp (newvar())
   | Pexp_apply(sfunct, sargs) ->
+      begin_def (); (* one more level for non-returning functions *)
       if !Clflags.principal then begin_def ();
       let funct = type_exp env sfunct in
       if !Clflags.principal then begin
         end_def ();
         generalize_structure funct.exp_type
       end;
+      let rec lower_args ty_fun =
+        match (expand_head env ty_fun).desc with
+          Tarrow (l, ty, ty_fun, com) ->
+            unify_var env (newvar()) ty;
+            lower_args ty_fun
+        | _ -> ()
+      in
+      let ty = instance funct.exp_type in
+      end_def ();
+      lower_args ty;
+      begin_def ();
       let (args, ty_res) = type_application env funct sargs in
-      let funct = {funct with exp_type = instance funct.exp_type} in
+      end_def ();
+      unify_var env (newvar()) funct.exp_type;
       re {
         exp_desc = Texp_apply(funct, args);
         exp_loc = sexp.pexp_loc;
@@ -1462,9 +1475,20 @@ and type_application env funct sargs =
          instance (result_type omitted ty_fun))
     | (l1, sarg1) :: sargl ->
         let (ty1, ty2) =
-          match (expand_head env ty_fun).desc with
+          let ty_fun = expand_head env ty_fun in
+          match ty_fun.desc with
             Tvar ->
               let t1 = newvar () and t2 = newvar () in
+              let not_identity = function
+                  Texp_ident(_,{val_kind=Val_prim
+                                  {Primitive.prim_name="%identity"}}) ->
+                    false
+                | _ -> true
+              in
+              if ty_fun.level >= t1.level && not_identity funct.exp_desc then
+                Location.prerr_warning sarg1.pexp_loc
+                  (Warnings.Other
+                     "this argument will not be received by the function.");
               unify env ty_fun (newty (Tarrow(l1,t1,t2,Clink(ref Cunknown))));
               (t1, t2)
           | Tarrow (l,t1,t2,_) when l = l1
@@ -1771,18 +1795,24 @@ and type_expect ?in_function env sexp ty_expected =
 (* Typing of statements (expressions whose values are discarded) *)
 
 and type_statement env sexp =
-    let exp = type_exp env sexp in
-    match (expand_head env exp.exp_type).desc with
-    | Tarrow _ ->
-        Location.prerr_warning sexp.pexp_loc Warnings.Partial_application;
-        exp
-    | Tconstr (p, _, _) when Path.same p Predef.path_unit -> exp
-    | Tvar ->
-        add_delayed_check (fun () -> check_partial_application env exp);
-        exp
-    | _ ->
-        Location.prerr_warning sexp.pexp_loc Warnings.Statement_type;
-        exp
+  begin_def();
+  let exp = type_exp env sexp in
+  end_def();
+  let ty = expand_head env exp.exp_type and tv = newvar() in
+  begin match ty.desc with
+  | Tarrow _ ->
+      Location.prerr_warning sexp.pexp_loc Warnings.Partial_application
+  | Tconstr (p, _, _) when Path.same p Predef.path_unit -> ()
+  | Tvar when ty.level > tv.level ->
+      Location.prerr_warning sexp.pexp_loc
+        (Warnings.Other "this statement never returns.")
+  | Tvar ->
+      add_delayed_check (fun () -> check_partial_application env exp)
+  | _ ->
+      Location.prerr_warning sexp.pexp_loc Warnings.Statement_type
+  end;
+  unify_var env tv ty;
+  exp
 
 (* Typing of match cases *)
 
