]> matita.cs.unibo.it Git - helm.git/blob - helm/DEVEL/lablgtk/lablgtk_20001129-0.1.0/gpointer.ml
implemented and exported heal_header_name and heal_header_value
[helm.git] / helm / DEVEL / lablgtk / lablgtk_20001129-0.1.0 / gpointer.ml
1 (* $Id$ *)
2
3 (* marked pointers *)
4 type 'a optaddr
5
6 let optaddr : 'a option -> 'a optaddr =
7   function
8       None -> Obj.magic 0
9     | Some x -> Obj.magic x
10
11 (* naked pointers *)
12 type optstring
13
14 external get_null : unit -> optstring = "ml_get_null"
15 let raw_null = get_null ()
16
17 let optstring : string option -> optstring =
18   function
19       None -> raw_null
20     | Some x -> Obj.magic x
21
22 (* boxed pointers *)
23 type boxed
24 let boxed_null : boxed = Obj.magic (0, raw_null)
25
26 type 'a optboxed
27
28 let optboxed : 'a option -> 'a optboxed =
29   function
30       None -> Obj.magic boxed_null
31     | Some obj -> Obj.magic obj
32
33 let may_box ~f obj : 'a optboxed =
34   match obj with
35     None -> Obj.magic boxed_null
36   | Some obj -> Obj.magic (f obj : 'a)
37
38 (* Exceptions *)
39
40 exception Null
41 let _ =  Callback.register_exception "null_pointer" Null