helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/gtkArgv.ml

   1 (* $Id$ *)
   2
   3 open Gaux
   4 open Gtk
   5
   6 type data =
   7   | NONE
   8   | CHAR of char
   9   | BOOL of bool
  10   | INT of int
  11   | FLOAT of float
  12   | STRING of string option
  13   | OBJECT of unit obj option
  14   | POINTER of Gpointer.boxed option
  15
  16 type 'a result =
  17   [ `NONE
  18   | `CHAR of char | `BOOL of bool | `INT of int
  19   | `UINT of int32 | `LONG of nativeint | `ULONG of nativeint
  20   | `FLOAT of float | `DOUBLE of float
  21   | `STRING of string option | `ENUM of int | `FLAGS of int32
  22   | `BOXED of Gpointer.boxed option
  23   | `POINTER of Gpointer.boxed option
  24   | `OBJECT of 'a obj option ]
  25
  26 module Arg = struct
  27   type t
  28   external shift : t -> pos:int -> t = "ml_gtk_arg_shift"
  29   external get_type : t -> gtk_type = "ml_gtk_arg_get_type"
  30   external get : t -> data = "ml_gtk_arg_get"
  31   external set_retloc : t -> 'a result -> unit = "ml_gtk_arg_set_retloc"
  32   external get_pointer : t -> Gpointer.boxed = "ml_gtk_arg_get_pointer"
  33   external get_nativeint : t -> nativeint = "ml_gtk_arg_get_nativeint"
  34
  35   (* Safely get an argument *)
  36   (*
  37   external get_char : t -> char = "ml_gtk_arg_get_char"
  38   external get_bool : t -> bool = "ml_gtk_arg_get_bool"
  39   external get_int : t -> int = "ml_gtk_arg_get_int"
  40   external get_float : t -> float = "ml_gtk_arg_get_float"
  41   external get_string : t -> string option = "ml_gtk_arg_get_string"
  42   external get_object : t -> unit obj option = "ml_gtk_arg_get_object"
  43   *)
  44   (* Safely set a result
  45      Beware: this is not the opposite of get, arguments and results
  46      are two different ways to use GtkArg. *)
  47   (*
  48   external set_char : t -> char -> unit = "ml_gtk_arg_set_char"
  49   external set_bool : t -> bool -> unit = "ml_gtk_arg_set_bool"
  50   external set_int : t -> int -> unit = "ml_gtk_arg_set_int"
  51   external set_nativeint : t -> nativeint -> unit = "ml_gtk_arg_set_nativeint"
  52   external set_float : t -> float -> unit = "ml_gtk_arg_set_float"
  53   external set_string : t -> string -> unit = "ml_gtk_arg_set_string"
  54   external set_pointer : t -> Gpointer.boxed -> unit = "ml_gtk_arg_set_pointer"
  55   external set_object : t -> 'a obj -> unit = "ml_gtk_arg_set_object"
  56   *)
  57 end
  58
  59 open Arg
  60 type raw_obj
  61 type t = { referent: raw_obj; nargs: int; args: Arg.t }
  62 let nth arg ~pos =
  63   if pos < 0 || pos >= arg.nargs then invalid_arg "GtkArg.Vect.nth";
  64   shift arg.args ~pos
  65 let result arg =
  66   if arg.nargs < 0 then invalid_arg "GtkArgv.result";
  67   shift arg.args ~pos:arg.nargs
  68 external wrap_object : raw_obj -> unit obj = "Val_GtkObject"
  69 let referent arg =
  70   if arg.referent == Obj.magic (-1) then invalid_arg "GtkArgv.referent";
  71   wrap_object arg.referent
  72 let get_result_type arg = get_type (result arg)
  73 let get_type arg ~pos = get_type (nth arg ~pos)
  74 let get arg ~pos = get (nth arg ~pos)
  75 let set_result arg = set_retloc (result arg)
  76
  77 let get_args arg =
  78   let rec loop args ~pos =
  79     if pos < 0 then args
  80     else loop (get arg ~pos :: args) ~pos:(pos-1)
  81   in loop [] ~pos:(arg.nargs - 1)
  82
  83 let get_pointer arg ~pos = get_pointer (nth arg ~pos)
  84 let get_nativeint arg ~pos = get_nativeint (nth arg ~pos)
  85
  86 (*
  87 let get_char arg ~pos = get_char (nth arg ~pos)
  88 let get_bool arg ~pos = get_bool (nth arg ~pos)
  89 let get_int arg ~pos = get_int (nth arg ~pos)
  90 let get_float arg ~pos = get_float (nth arg ~pos)
  91 let get_string arg ~pos = get_string (nth arg ~pos)
  92 let get_object arg ~pos = get_object (nth arg ~pos)
  93 let set_result_char arg = set_char (result arg)
  94 let set_result_bool arg = set_bool (result arg)
  95 let set_result_int arg = set_int (result arg)
  96 let set_result_nativeint arg = set_nativeint (result arg)
  97 let set_result_float arg = set_float (result arg)
  98 let set_result_string arg = set_string (result arg)
  99 let set_result_pointer arg = set_pointer (result arg)
 100 let set_result_object arg = set_object (result arg)
 101 *)
 102
 103 external string_at_pointer : ?pos:int -> ?len:int -> Gpointer.boxed -> string
 104     = "ml_string_at_pointer"
 105 external int_at_pointer : Gpointer.boxed -> int
 106     = "ml_int_at_pointer"