merge branch 4.02 from release 4.02.0 to release 4.02.1

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

6 files changed, 48 insertions, 33 deletions

diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml
index be884ded5f..e08a7c3e02 100644
--- a/bytecomp/bytegen.ml
+++ b/bytecomp/bytegen.ml
@@ -445,7 +445,6 @@ let rec comp_expr env exp sz cont =
         let ofs = Ident.find_same id env.ce_rec in
         Koffsetclosure(ofs) :: cont
       with Not_found ->
-        Format.eprintf "%a@." Ident.print id;
         fatal_error ("Bytegen.comp_expr: var " ^ Ident.unique_name id)
       end
   | Lconst cst ->
diff --git a/bytecomp/bytepackager.ml b/bytecomp/bytepackager.ml
index 3348f46dcd..05ebac9aad 100644
--- a/bytecomp/bytepackager.ml
+++ b/bytecomp/bytepackager.ml
@@ -222,9 +222,10 @@ let package_object_files ppf files targetfile targetname coercion =
                                           targetname Subst.identity members in
     build_global_target oc targetname members mapping ofs coercion;
     let pos_debug = pos_out oc in
-    if !Clflags.debug && !events <> [] then
+    if !Clflags.debug && !events <> [] then begin
       output_value oc (List.rev !events);
       output_value oc (StringSet.elements !debug_dirs);
+    end;
     let pos_final = pos_out oc in
     let imports =
       List.filter
diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml
index 77df46110e..e9a977656d 100644
--- a/bytecomp/emitcode.ml
+++ b/bytecomp/emitcode.ml
@@ -143,6 +143,7 @@ let record_event ev =
   let path = ev.ev_loc.Location.loc_start.Lexing.pos_fname in
   let abspath = Location.absolute_path path in
   debug_dirs := StringSet.add (Filename.dirname abspath) !debug_dirs;
+  if Filename.is_relative path then debug_dirs := StringSet.add (Sys.getcwd ()) !debug_dirs;
   ev.ev_pos <- !out_position;
   events := ev :: !events
 
diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml
index 4ad8e9b4e1..5d9fb593fa 100644
--- a/bytecomp/lambda.ml
+++ b/bytecomp/lambda.ml
@@ -537,9 +537,12 @@ let lam_of_loc kind loc =
           Const_base (Const_int enum);
         ]))
   | Loc_FILE -> Lconst (Const_immstring file)
-  | Loc_MODULE -> Lconst (Const_immstring
-                      (String.capitalize
-                         (Filename.chop_extension (Filename.basename file))))
+  | Loc_MODULE ->
+    let filename = Filename.basename file in
+    let module_name =
+      try String.capitalize (Filename.chop_extension filename)
+      with Invalid_argument _ -> "//"^filename^"//"
+    in Lconst (Const_immstring module_name)
   | Loc_LOC ->
     let loc = Printf.sprintf "File %S, line %d, characters %d-%d"
         file lnum cnum enum in
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index 14f8b0659f..5e07978305 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -669,7 +669,7 @@ and transl_exp0 e =
             transl_function e.exp_loc !Clflags.native_code repr partial pl)
       in
       Lfunction(kind, params, body)
-  | Texp_apply({exp_desc = Texp_ident(path, _, {val_kind = Val_prim p})} as fn,
+  | Texp_apply({exp_desc = Texp_ident(path, _, {val_kind = Val_prim p})},
                oargs)
     when List.length oargs >= p.prim_arity
     && List.for_all (fun (_, arg,_) -> arg <> None) oargs ->
@@ -695,12 +695,6 @@ and transl_exp0 e =
           wrap (Lsend(Cached, meth, obj, [cache; pos], e.exp_loc))
         | _ -> assert false
       else begin
-        if p.prim_name = "%sequand" && Path.last path = "&" then
-          Location.prerr_warning fn.exp_loc
-            (Warnings.Deprecated "operator (&); you should use (&&) instead");
-        if p.prim_name = "%sequor" && Path.last path = "or" then
-          Location.prerr_warning fn.exp_loc
-            (Warnings.Deprecated "operator (or); you should use (||) instead");
         let prim = transl_prim e.exp_loc p args in
         match (prim, args) with
           (Praise k, [arg1]) ->
diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml
index 1f475565f9..89be6f5da1 100644
--- a/bytecomp/translmod.ml
+++ b/bytecomp/translmod.ml
@@ -83,21 +83,12 @@ let rec apply_coercion strict restr arg =
       arg
   | Tcoerce_structure(pos_cc_list, id_pos_list) ->
       name_lambda strict arg (fun id ->
+        let get_field pos = Lprim(Pfield pos,[Lvar id]) in
         let lam =
           Lprim(Pmakeblock(0, Immutable),
-                List.map (apply_coercion_field id) pos_cc_list) in
-        let fv = free_variables lam in
-        let (lam,s) =
-          List.fold_left (fun (lam,s) (id',pos,c) ->
-            if IdentSet.mem id' fv then
-              let id'' = Ident.create (Ident.name id') in
-              (Llet(Alias,id'',
-                    apply_coercion Alias c (Lprim(Pfield pos,[Lvar id])),lam),
-               Ident.add id' (Lvar id'') s)
-            else (lam,s))
-            (lam, Ident.empty) id_pos_list
+                List.map (apply_coercion_field get_field) pos_cc_list)
         in
-        if s == Ident.empty then lam else subst_lambda s lam)
+        wrap_id_pos_list id_pos_list get_field lam)
   | Tcoerce_functor(cc_arg, cc_res) ->
       let param = Ident.create "funarg" in
       name_lambda strict arg (fun id ->
@@ -111,8 +102,26 @@ let rec apply_coercion strict restr arg =
       name_lambda strict arg
         (fun id -> apply_coercion Alias cc (transl_normal_path path))
 
-and apply_coercion_field id (pos, cc) =
-  apply_coercion Alias cc (Lprim(Pfield pos, [Lvar id]))
+and apply_coercion_field get_field (pos, cc) =
+  apply_coercion Alias cc (get_field pos)
+
+and wrap_id_pos_list id_pos_list get_field lam =
+  let fv = free_variables lam in
+  (*Format.eprintf "%a@." Printlambda.lambda lam;
+  IdentSet.iter (fun id -> Format.eprintf "%a " Ident.print id) fv;
+  Format.eprintf "@.";*)
+  let (lam,s) =
+    List.fold_left (fun (lam,s) (id',pos,c) ->
+      if IdentSet.mem id' fv then
+        let id'' = Ident.create (Ident.name id') in
+        (Llet(Alias,id'',
+              apply_coercion Alias c (get_field pos),lam),
+         Ident.add id' (Lvar id'') s)
+      else (lam,s))
+      (lam, Ident.empty) id_pos_list
+  in
+  if s == Ident.empty then lam else subst_lambda s lam
+  
 
 (* Compose two coercions
    apply_coercion c1 (apply_coercion c2 e) behaves like
@@ -154,7 +163,7 @@ let compose_coercions c1 c2 =
   let c3 = compose_coercions c1 c2 in
   let open Includemod in
   Format.eprintf "@[<2>compose_coercions@ (%a)@ (%a) =@ %a@]@."
-    print_coercion c1 print_coercion c2 print_coercion c2;
+    print_coercion c1 print_coercion c2 print_coercion c3;
   c3
 *)
 
@@ -322,7 +331,7 @@ let rec transl_module cc rootpath mexp =
   | _ ->
   match mexp.mod_desc with
     Tmod_ident (path,_) ->
-      apply_coercion StrictOpt cc
+      apply_coercion Strict cc
         (transl_path ~loc:mexp.mod_loc mexp.mod_env path)
   | Tmod_structure str ->
       transl_struct [] cc rootpath str
@@ -362,18 +371,26 @@ and transl_structure fields cc rootpath = function
           Lprim(Pmakeblock(0, Immutable),
                 List.map (fun id -> Lvar id) (List.rev fields))
       | Tcoerce_structure(pos_cc_list, id_pos_list) ->
-              (* ignore id_pos_list as the ids are already bound *)
+              (* Do not ignore id_pos_list ! *)
+          (*Format.eprintf "%a@.@[" Includemod.print_coercion cc;
+          List.iter (fun l -> Format.eprintf "%a@ " Ident.print l)
+            fields;
+          Format.eprintf "@]@.";*)
           let v = Array.of_list (List.rev fields) in
-          (*List.fold_left
-            (fun lam (id, pos) -> Llet(Alias, id, Lvar v.(pos), lam))*)
+          let get_field pos = Lvar v.(pos)
+          and ids = List.fold_right IdentSet.add fields IdentSet.empty in
+          let lam =
             (Lprim(Pmakeblock(0, Immutable),
                 List.map
                   (fun (pos, cc) ->
                     match cc with
                       Tcoerce_primitive p -> transl_primitive Location.none p
-                    | _ -> apply_coercion Strict cc (Lvar v.(pos)))
+                    | _ -> apply_coercion Strict cc (get_field pos))
                   pos_cc_list))
-            (*id_pos_list*)
+          and id_pos_list =
+            List.filter (fun (id,_,_) -> not (IdentSet.mem id ids)) id_pos_list
+          in
+          wrap_id_pos_list id_pos_list get_field lam
       | _ ->
           fatal_error "Translmod.transl_structure"
       end