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