(* $Id: netshm_array.ml 996 2006-09-19 15:39:34Z gerd $ *) open Netshm open Netshm_data type 'a t = { table : shm_table; htbl : (int, 'a) Netshm_hashtbl.t; (* We use the hash table to store the normal elements. For the * length of the array, we use the index (-1) which is mapped * to an int instead of 'a. Implemented by bypassing htbl in this * case. *) idx_only_manager : int data_manager; idx_len_manager : (int * int) data_manager; default_val : 'a; } let shm_table t = t.table let with_length f t = let r = ref None in Netshm.read_blocks t.table (-1l) (fun frag_opt -> match frag_opt with | Some frag -> let length = Int32.to_int frag.{ 0 } in r := Some (f length); raise Break | None -> assert false ); match !r with | None -> assert false | Some x -> x let length t = with_length (fun l -> l) t let get t k = with_length (fun length -> if k < 0 || k >= length then invalid_arg "Netshm_array.get: index out of bounds"; try Netshm_hashtbl.find t.htbl k with | Not_found -> t.default_val ) t ;; let set t k x = with_length (fun length -> if k < 0 || k >= length then invalid_arg "Netshm_array.set: index out of bounds"; Netshm_hashtbl.replace t.htbl k x ) t let resize t n = if n < 0 then invalid_arg "Netshm_array.resize"; with_length (fun old_len -> (* First remove any element at indexes >= n *) if n < old_len then ( let l = ref [] in Netshm_hashtbl.iter_keys (fun idx -> if idx >= n then l := idx :: !l ) t.htbl; List.iter (fun idx -> Netshm_hashtbl.remove t.htbl idx ) !l ); (* Finally just set the new length field: *) Netshm.write_blocks t.table [] (-1l) (fun frag_opt -> match frag_opt with | Some frag -> frag.{ 0 } <- Int32.of_int n; raise Break | None -> assert false ) ) t let default_value t = t.default_val let shm_table t = t.table let manage ?pagesize ?init defval val_manager lm sd = let shm_init = match init with | Some n -> Some 1000 | None -> None in let idx_manager = Netshm_data.int_manager in let htbl = Netshm_hashtbl.manage ?pagesize ?init:shm_init idx_manager val_manager lm sd in let table = Netshm_hashtbl.shm_table htbl in let idx_only_manager = left_pair_manager idx_manager in let idx_len_manager = pair_manager idx_manager Netshm_data.int_manager in let t = { table = table; htbl = htbl; idx_only_manager = idx_only_manager; idx_len_manager = idx_len_manager; default_val = defval } in Netshm.group table (fun () -> if not (Netshm.mem table (-1l)) then let length_field = Bigarray.Array1.create Bigarray.int32 Bigarray.c_layout 1 in length_field.{ 0 } <- 0l; Netshm.add table (-1l) length_field ) (); ( match init with | None -> () | Some n -> resize t n ); t