New branch binary-annot by Fabrice Le Fessant from r10789

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/binary-annot@10790 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

1 files changed, 68 insertions, 0 deletions

diff --git a/ocaml-binary-annot/stdlib/camlinternalMod.ml b/ocaml-binary-annot/stdlib/camlinternalMod.ml
new file mode 100644
index 0000000000..12a77cc8fb
--- /dev/null
+++ b/ocaml-binary-annot/stdlib/camlinternalMod.ml
@@ -0,0 +1,68 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*         Xavier Leroy, projet Cristal, INRIA Rocquencourt            *)
+(*                                                                     *)
+(*  Copyright 2004 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+type shape =
+  | Function
+  | Lazy
+  | Class
+  | Module of shape array
+
+let rec init_mod loc shape =
+  match shape with
+  | Function ->
+      let pad1 = 1 and pad2 = 2 and pad3 = 3 and pad4 = 4
+      and pad5 = 5 and pad6 = 6 and pad7 = 7 and pad8 = 8 in
+      Obj.repr(fun _ ->
+        ignore pad1; ignore pad2; ignore pad3; ignore pad4;
+        ignore pad5; ignore pad6; ignore pad7; ignore pad8;
+        raise (Undefined_recursive_module loc))
+  | Lazy ->
+      Obj.repr (lazy (raise (Undefined_recursive_module loc)))
+  | Class ->
+      Obj.repr (CamlinternalOO.dummy_class loc)
+  | Module comps ->
+      Obj.repr (Array.map (init_mod loc) comps)
+
+let overwrite o n =
+  assert (Obj.size o >= Obj.size n);
+  for i = 0 to Obj.size n - 1 do
+    Obj.set_field o i (Obj.field n i)
+  done
+
+let rec update_mod shape o n =
+  match shape with
+  | Function ->
+      if Obj.tag n = Obj.closure_tag && Obj.size n <= Obj.size o
+      then begin overwrite o n; Obj.truncate o (Obj.size n) (* PR #4008 *) end
+      else overwrite o (Obj.repr (fun x -> (Obj.obj n : _ -> _) x))
+  | Lazy ->
+      if Obj.tag n = Obj.lazy_tag then
+        Obj.set_field o 0 (Obj.field n 0)
+      else if Obj.tag n = Obj.forward_tag then begin (* PR#4316 *)
+        Obj.set_tag o Obj.forward_tag;
+        Obj.set_field o 0 (Obj.field n 0)
+      end else begin
+        (* forwarding pointer was shortcut by GC *)
+        Obj.set_tag o Obj.forward_tag;
+        Obj.set_field o 0 n
+      end
+  | Class ->
+      assert (Obj.tag n = 0 && Obj.size n = 4);
+      overwrite o n
+  | Module comps ->
+      assert (Obj.tag n = 0 && Obj.size n >= Array.length comps);
+      for i = 0 to Array.length comps - 1 do
+        update_mod comps.(i) (Obj.field o i) (Obj.field n i)
+      done