l4/pkg/ocaml/contrib/stdlib/camlinternalMod.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*         Xavier Leroy, projet Cristal, INRIA Rocquencourt            *)
   6 (*                                                                     *)
   7 (*  Copyright 2004 Institut National de Recherche en Informatique et   *)
   8 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   9 (*  under the terms of the GNU Library General Public License, with    *)
  10 (*  the special exception on linking described in file ../LICENSE.     *)
  11 (*                                                                     *)
  12 (***********************************************************************)
  13
  14 (* $Id: camlinternalMod.ml 8768 2008-01-11 16:13:18Z doligez $ *)
  15
  16 type shape =
  17   | Function
  18   | Lazy
  19   | Class
  20   | Module of shape array
  21
  22 let rec init_mod loc shape =
  23   match shape with
  24   | Function ->
  25       let pad1 = 1 and pad2 = 2 and pad3 = 3 and pad4 = 4
  26       and pad5 = 5 and pad6 = 6 and pad7 = 7 and pad8 = 8 in
  27       Obj.repr(fun _ ->
  28         ignore pad1; ignore pad2; ignore pad3; ignore pad4;
  29         ignore pad5; ignore pad6; ignore pad7; ignore pad8;
  30         raise (Undefined_recursive_module loc))
  31   | Lazy ->
  32       Obj.repr (lazy (raise (Undefined_recursive_module loc)))
  33   | Class ->
  34       Obj.repr (CamlinternalOO.dummy_class loc)
  35   | Module comps ->
  36       Obj.repr (Array.map (init_mod loc) comps)
  37
  38 let overwrite o n =
  39   assert (Obj.size o >= Obj.size n);
  40   for i = 0 to Obj.size n - 1 do
  41     Obj.set_field o i (Obj.field n i)
  42   done
  43
  44 let rec update_mod shape o n =
  45   match shape with
  46   | Function ->
  47       if Obj.tag n = Obj.closure_tag && Obj.size n <= Obj.size o
  48       then begin overwrite o n; Obj.truncate o (Obj.size n) (* PR #4008 *) end
  49       else overwrite o (Obj.repr (fun x -> (Obj.obj n : _ -> _) x))
  50   | Lazy ->
  51       if Obj.tag n = Obj.lazy_tag then
  52         Obj.set_field o 0 (Obj.field n 0)
  53       else if Obj.tag n = Obj.forward_tag then begin (* PR#4316 *)
  54         Obj.set_tag o Obj.forward_tag;
  55         Obj.set_field o 0 (Obj.field n 0)
  56       end else begin
  57         (* forwarding pointer was shortcut by GC *)
  58         Obj.set_tag o Obj.forward_tag;
  59         Obj.set_field o 0 n
  60       end
  61   | Class ->
  62       assert (Obj.tag n = 0 && Obj.size n = 4);
  63       overwrite o n
  64   | Module comps ->
  65       assert (Obj.tag n = 0 && Obj.size n >= Array.length comps);
  66       for i = 0 to Array.length comps - 1 do
  67         update_mod comps.(i) (Obj.field o i) (Obj.field n i)
  68       done