lablGL/raw.ml

   1 (* $Id: raw.ml,v 1.9 2007-04-13 02:48:43 garrigue Exp $ *)
   2
   3 type addr
   4 type kind =
   5     [`bitmap|`byte|`double|`float|`int|`long|`short
   6     |`ubyte|`uint|`ulong|`ushort]
   7 type fkind = [`double|`float]
   8 type ikind = [`bitmap|`byte|`int|`long|`short|`ubyte|`uint|`ulong|`ushort]
   9 type lkind = [`int|`long|`uint|`ulong]
  10 type 'a t =
  11     { kind: 'a; base: addr; offset: int; size: int; static: bool}
  12
  13 let kind raw = raw.kind
  14 let byte_size raw = raw.size
  15 let static raw = raw.static
  16 let cast raw ~kind =
  17   { kind = kind; size = raw.size; base = raw.base;
  18     offset = raw.offset; static = raw.static }
  19
  20 external sizeof : [< kind] -> int = "ml_raw_sizeof"
  21 let length raw = raw.size / sizeof raw.kind
  22 let sub raw ~pos ~len =
  23   let size = sizeof raw.kind in
  24   if pos < 0 or (pos+len) * size > raw.size then invalid_arg "Raw.sub";
  25   { raw with offset = raw.offset + pos * size; size = len * size }
  26
  27 external get : [< ikind] t -> pos:int -> int = "ml_raw_get"
  28 external set : [< ikind] t -> pos:int -> int -> unit = "ml_raw_set"
  29 external get_float : [< fkind] t -> pos:int -> float = "ml_raw_get_float"
  30 external set_float : [< fkind] t -> pos:int -> float -> unit
  31     = "ml_raw_set_float"
  32 external get_hi : [< lkind] t -> pos:int -> int = "ml_raw_get_hi"
  33 external set_hi : [< lkind] t -> pos:int -> int -> unit = "ml_raw_set_hi"
  34 external get_lo : [< lkind] t -> pos:int -> int = "ml_raw_get_lo"
  35 external set_lo : [< lkind] t -> pos:int -> int -> unit = "ml_raw_set_lo"
  36 external get_long : [< lkind] t -> pos:int -> nativeint = "ml_raw_get_long"
  37 external set_long : [< lkind] t -> pos:int -> nativeint -> unit
  38     = "ml_raw_set_long"
  39
  40 external gets : [< ikind] t -> pos:int -> len:int -> int array
  41     = "ml_raw_read"
  42 external gets_string : 'a t -> pos:int -> len:int -> string
  43     = "ml_raw_read_string"
  44 external gets_float : [< fkind] t -> pos:int -> len:int -> float array
  45     = "ml_raw_read_float"
  46 external sets : [< ikind] t -> pos:int -> int array -> unit = "ml_raw_write"
  47 external sets_string : 'a t -> pos:int -> string -> unit
  48     = "ml_raw_write_string"
  49 external sets_float : [< fkind] t -> pos:int -> float array -> unit
  50     = "ml_raw_write_float"
  51
  52 (*
  53 external fill : [< ikind] t -> pos:int -> len:int -> unit = "ml_raw_fill"
  54 external fill_float : [< fkind] t -> pos:int -> len:int -> unit
  55     = "ml_raw_fill_float"
  56 *)
  57
  58 external create : ([< kind] as 'a) -> len:int -> 'a t = "ml_raw_alloc"
  59 external create_static : ([< kind] as 'a) -> len:int -> 'a t
  60     = "ml_raw_alloc_static"
  61 external free_static : 'a t -> unit = "ml_raw_free_static"
  62
  63 let of_array arr ~kind =
  64   let raw = create kind ~len:(Array.length arr) in
  65   sets raw ~pos:0 arr;
  66   raw
  67 let of_float_array arr ~kind =
  68   let raw = create kind ~len:(Array.length arr) in
  69   sets_float raw ~pos:0 arr;
  70   raw
  71 let of_string s ~kind =
  72   let raw = create kind ~len:(String.length s) in
  73   sets_string raw ~pos:0 s;
  74   raw
  75 let of_matrix mat ~kind =
  76   let h = Array.length mat in
  77   if h = 0 then invalid_arg "Raw.of_matrix";
  78   let w = Array.length mat.(0) in
  79   let raw = create kind ~len:(h*w) in
  80   for i = 0 to h - 1 do
  81     if Array.length mat.(i) <> w then invalid_arg "Raw.of_matrix";
  82     sets_float raw ~pos:(i*w) mat.(i)
  83   done;
  84   raw