← Back to branch summary

~ubuntu-branches/debian/sid/ocaml/sid

« back to all changes in this revision

Viewing changes to stdlib/camlinternalLazy.ml

  • Committer: Bazaar Package Importer
  • Author(s): Stefano Zacchiroli
  • Date: 2009-02-22 08:49:13 UTC
  • mfrom: (12.1.1 squeeze)
  • Revision ID: james.westby@ubuntu.com-20090222084913-3i0uw2bhd0lgw0ok
* Uploading to unstable
* debian/control: bump dh-ocaml to (>= 0.4) to avoid buggy ocamlinit.mk

Show diffs side-by-side

added added

removed removed

Lines of Context:
stdlib/camlinternalLazy.ml
 
1
(***********************************************************************)
 
2
(*                                                                     *)
 
3
(*                           Objective Caml                            *)
 
4
(*                                                                     *)
 
5
(*            Damien Doligez, projet Para, INRIA Rocquencourt          *)
 
6
(*                                                                     *)
 
7
(*  Copyright 1997 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: camlinternalLazy.ml,v 1.1 2008/08/01 16:57:10 mauny Exp $ *)
 
15
 
 
16
(* Internals of forcing lazy values. *)
 
17
 
 
18
exception Undefined;;
 
19
 
 
20
let raise_undefined = Obj.repr (fun () -> raise Undefined);;
 
21
 
 
22
(* Assume [blk] is a block with tag lazy *)
 
23
let force_lazy_block (blk : 'arg lazy_t) =
 
24
  let closure = (Obj.obj (Obj.field (Obj.repr blk) 0) : unit -> 'arg) in
 
25
  Obj.set_field (Obj.repr blk) 0 raise_undefined;
 
26
  try
 
27
    let result = closure () in
 
28
    Obj.set_field (Obj.repr blk) 0 (Obj.repr result);  (* do set_field BEFORE set_tag *)
 
29
    Obj.set_tag (Obj.repr blk) Obj.forward_tag;
 
30
    result
 
31
  with e ->
 
32
    Obj.set_field (Obj.repr blk) 0 (Obj.repr (fun () -> raise e));
 
33
    raise e
 
34
;;
 
35
 
 
36
(* Assume [blk] is a block with tag lazy *)
 
37
let force_val_lazy_block (blk : 'arg lazy_t) =
 
38
  let closure = (Obj.obj (Obj.field (Obj.repr blk) 0) : unit -> 'arg) in
 
39
  Obj.set_field (Obj.repr blk) 0 raise_undefined;
 
40
  let result = closure () in
 
41
  Obj.set_field (Obj.repr blk) 0 (Obj.repr result);  (* do set_field BEFORE set_tag *)
 
42
  Obj.set_tag (Obj.repr blk) (Obj.forward_tag);
 
43
  result
 
44
;;
 
45
 
 
46
(* [force] is not used, since [Lazy.force] is declared as a primitive
 
47
   whose code inlines the tag tests of its argument.  This function is
 
48
   here for the sake of completeness, and for debugging purpose. *)
 
49
 
 
50
let force (lzv : 'arg lazy_t) =
 
51
  let x = Obj.repr lzv in
 
52
  let t = Obj.tag x in
 
53
  if t = Obj.forward_tag then (Obj.obj (Obj.field x 0) : 'arg) else
 
54
  if t <> Obj.lazy_tag then (Obj.obj x : 'arg)
 
55
  else force_lazy_block lzv
 
56
;;
 
57
 
 
58
let force_val (lzv : 'arg lazy_t) =
 
59
  let x = Obj.repr lzv in
 
60
  let t = Obj.tag x in
 
61
  if t = Obj.forward_tag then (Obj.obj (Obj.field x 0) : 'arg) else
 
62
  if t <> Obj.lazy_tag then (Obj.obj x : 'arg)
 
63
  else force_val_lazy_block lzv
 
64
;;