viewcvs.cgi/misc/imap.ml

type 'a t = Obj.t array

let empty = Obj.magic ()
  (* [| |] does not ensure physical equality with ocamlopt (?) after deserialization.
     0 does not work either: the code generator considers registers set to empty as integer-only
     registers, which is not safe. *)

let get = Array.unsafe_get
let set = Array.unsafe_set

let get_len a : int = Obj.magic (get a 0)
let set_len a (i : int) = set a 0 (Obj.repr i)
let get_int a i : int = Obj.magic (get a i)
let set_int a (i : int) (x : int) = set a i (Obj.repr x)

let acreate n = Array.create n (Obj.repr n)

let elements (t : 'a t) : (int * 'a) list =
  if t == empty then [] else
  let rec aux accu i =
    if (i > 0) 
    then aux ((get_int t i, Obj.magic (get t (succ i)))::accu) (i - 2)
    else accu
  in
  aux [] (get_len t - 2)

let map_elements f t =
  if t == empty then [] else
  let rec aux accu i =
    if (i > 0) 
    then aux (f (get_int t i) (Obj.magic (get t (succ i)))::accu) (i - 2)
    else accu
  in
  aux [] (get_len t - 2)

let sort a = 
  Array.sort 
    (fun (i,_) (j,_) -> 
       assert (i != j); if (i:int) < j then (-1) else 1) a

let real_create a = 
  let n = Array.length a in
  let m = (n lsl 1) + 1 in
  let t = acreate m in
  for i = 1 to n do
    let j = i lsl 1 in
    let (idx,v) = a.(pred i) in
    set_int t (pred j) idx;
    set t j (Obj.repr v);
  done;
  t

let create a =
  if Array.length a = 0 then empty else (sort a; real_create a)

let create_default def a =
  sort a;
  let l = Array.to_list a in
  let rec aux i = function
    | [] ->
        if (i == max_int) then []
        else [(succ i, def)]
    | ((i1,_) as c)::rest ->
        if (succ i == i1) then c :: (aux i1 rest)
        else (succ i, def) :: c :: (aux i1 rest)
  in
  let l =  
    match l with
      | ((i1,_) as c)::rest ->
          if (i1 == min_int) then c :: (aux i1 rest)
          else (min_int,def) :: c :: (aux i1 rest)
      | [] -> [(min_int,def)] in
  let a = Array.of_list l in
  real_create a
  

let rec find_aux t (i : int) low high =
  if (low >= high) then low
  else
    let m = ((low + high) lsr 1) lor 1 in
    if i < get_int t m then find_aux t i low (m-2)
    else find_aux t i m high

let find (t : 'a t) i : 'a =
  if t == empty then raise Not_found;
  let j = find_aux t i 1 (get_len t - 2) in
  if (get_int t j == i) then Obj.magic (get t (succ j))
  else raise Not_found

let find_default t def i =
  if t == empty then def
  else
    let j = find_aux t i 1 (get_len t - 2) in
    if (get_int t j == i) then Obj.magic (get t (succ j))
    else def

let find_lower (t : 'a t) i : 'a =
  Obj.magic (get t (succ (find_aux t i 1 (get_len t - 2))))

let merge (t1 : 'a t) (t2 : 'a t) =
  if t1 == empty then t2 else if t2 == empty then t1
  else
    let n1 = get_len t1 and n2 = get_len t2 in
    let m = pred (n1 + n2) in
    let t = acreate m in
    let rec aux i i1 (l1:int) i2 l2 =
      if l1 == l2 then
        (set_int t i l1;
         set t (succ i) (get t2 (pred i2));
         let i = i + 2 in
         if (i1 = n1) then (
           let l = n2 - i2 in
           let i2 = i2 - 2 in
           Array.blit t2 i2 t i l;
           i + l
         ) else if (i2 = n2) then (
           let l = n1 - i1 in
           let i1 = i1 - 2 in
           Array.blit t1 i1 t i l;
           i + l
         ) else 
           let l1 = get_int t1 i1 and l2 = get_int t2 i2 in
           let i1 = i1 + 2 and i2 = i2 + 2 in
           aux i i1 l1 i2 l2)
      else if l1 < l2 then
        (set_int t i l1;
         set t (succ i) (get t1 (pred i1));
         let i = i + 2 in
         if (i1 = n1) then (
           let i2 = i2 - 2 in
           let l = n2 - i2 in
           Array.blit t2 i2 t i l;
           i + l
         ) else
           let l1 = get_int t1 i1 in 
           let i1 = i1 + 2 in
           aux i i1 l1 i2 l2)
      else 
        (set_int t i l2;
         set t (succ i) (get t2 (pred i2));
         let i = i + 2 in
         if (i2 = n2) then (
           let l = n1 - i1 in
           let i1 = i1 - 2 in
           Array.blit t1 i1 t i l;
           i + l
         ) else
           let l2 = get_int t2 i2 in 
           let i2 = i2 + 2 in
           aux i i1 l1 i2 l2)
    in
    set_len t (aux 1 3 (get_int t1 1) 3 (get_int t2 1));
    t

let cardinal t =
  if t == empty then 0
  else (pred (get_len t)) lsr 1

let map f t =
  if t == empty then empty
  else 
    let n = get_len t in
    let t' = acreate n in
    Array.blit t 0 t' 0 n;
    let rec aux i =
      if (i = 0) then t'
      else (set t' i (Obj.magic (f (Obj.magic (get t i)))); aux (i - 2))
    in
    aux (pred n)

let compare f t1 t2 =
  if (t1 == t2) then 0
  else if t1 == empty then (-1)
  else if t2 == empty then 1
  else
    let n1 = get_len t1 and n2 = get_len t2 in
    if (n1 < n2) then (-1) else if (n1 > n2) then 1
    else
      let rec aux i =
        if (i < 0) then 0
        else
          let l1 = get t1 i and l2 = get t2 i in
          if (l1 < l2) then (-1) else if (l1 > l2) then 1
          else let x1 = Obj.magic (get t1 (succ i)) 
               and x2 = Obj.magic (get t2 (succ i)) 
          in let c = f x1 x2 in
          if c != 0 then c else aux (i - 2)
      in
      aux (n1 - 2)

let hash f t =
  if t == empty then 1
  else
    let rec aux accu i =
      if (i < 0) then accu
      else aux (accu * 65537 
                + 257 * (f (Obj.magic (get t (succ i))))
                + (get_int t i)) (i - 2) in
    aux 1 (get_len t - 2)

let remove t i =
  if t == empty then t
  else
    let j = find_aux t i 1 (get_len t - 2) in
    if (get_int t j != i) then t
    else
      let n = get_len t - 2 in
      if (n = 1) then empty
      else
        let t' = acreate n in
        Array.blit t 1 t' 1 (j - 1);
        Array.blit t (j + 2) t' j (n - j);
        t'

let iter f t =
  if t == empty then ()
  else
    let rec aux i =
      if (i < 0) then ()
      else f (get_int t i) (Obj.magic (get t (succ i))) in
    aux (get_len t - 2)

(*
type 'a t = (int * 'a) list

let empty = []

let create a =
  Array.sort (fun (i,_) (j,_) -> assert (i != j); if i < j then (-1) else 1) a;
  Array.to_list a

let create_default def a =
  let l = create a in
  let rec aux i = function
    | [] ->
        if (i == max_int) then []
        else [(succ i, def)]
    | ((i1,_) as c)::rest ->
        if (succ i == i1) then c :: (aux i1 rest)
        else (succ i, def) :: c :: (aux i1 rest)
  in
  let l =  
    match l with
      | ((i1,_) as c)::rest ->
          if (i1 == min_int) then c :: (aux i1 rest)
          else (min_int,def) :: c :: (aux i1 rest)
      | [] -> [(min_int,def)] in
  l

let merge l1 l2 = assert false

let find l x = List.assoc x l

let rec find_lower l x = match l with
  | (_,v)::(y,_)::_ when x < y -> v
  | _::l -> find_lower l x
  | [] -> assert false

let find_default l def x = try find l x with Not_found -> def

let cardinal = List.length

let elements l = l

let map f l = List.map (fun (x,v) -> (x, f v)) l

let map_elements f l = List.map (fun (x,v) -> f x v) l

let compare _ _ = assert false
let hash _ = assert false
let remove _ _ = assert false
let iter _ _ = assert false
*)
1	type 'a t = Obj.t array
2
3	let empty = Obj.magic ()
4	(* [\| \|] does not ensure physical equality with ocamlopt (?) after deserialization.
5	0 does not work either: the code generator considers registers set to empty as integer-only
6	registers, which is not safe. *)
7
8	let get = Array.unsafe_get
9	let set = Array.unsafe_set
10
11	let get_len a : int = Obj.magic (get a 0)
12	let set_len a (i : int) = set a 0 (Obj.repr i)
13	let get_int a i : int = Obj.magic (get a i)
14	let set_int a (i : int) (x : int) = set a i (Obj.repr x)
15
16	let acreate n = Array.create n (Obj.repr n)
17
18	let elements (t : 'a t) : (int * 'a) list =
19	if t == empty then [] else
20	let rec aux accu i =
21	if (i > 0)
22	then aux ((get_int t i, Obj.magic (get t (succ i)))::accu) (i - 2)
23	else accu
24	in
25	aux [] (get_len t - 2)
26
27	let map_elements f t =
28	if t == empty then [] else
29	let rec aux accu i =
30	if (i > 0)
31	then aux (f (get_int t i) (Obj.magic (get t (succ i)))::accu) (i - 2)
32	else accu
33	in
34	aux [] (get_len t - 2)
35
36	let sort a =
37	Array.sort
38	(fun (i,_) (j,_) ->
39	assert (i != j); if (i:int) < j then (-1) else 1) a
40
41	let real_create a =
42	let n = Array.length a in
43	let m = (n lsl 1) + 1 in
44	let t = acreate m in
45	for i = 1 to n do
46	let j = i lsl 1 in
47	let (idx,v) = a.(pred i) in
48	set_int t (pred j) idx;
49	set t j (Obj.repr v);
50	done;
51	t
52
53	let create a =
54	if Array.length a = 0 then empty else (sort a; real_create a)
55
56	let create_default def a =
57	sort a;
58	let l = Array.to_list a in
59	let rec aux i = function
60	\| [] ->
61	if (i == max_int) then []
62	else [(succ i, def)]
63	\| ((i1,_) as c)::rest ->
64	if (succ i == i1) then c :: (aux i1 rest)
65	else (succ i, def) :: c :: (aux i1 rest)
66	in
67	let l =
68	match l with
69	\| ((i1,_) as c)::rest ->
70	if (i1 == min_int) then c :: (aux i1 rest)
71	else (min_int,def) :: c :: (aux i1 rest)
72	\| [] -> [(min_int,def)] in
73	let a = Array.of_list l in
74	real_create a
75
76
77	let rec find_aux t (i : int) low high =
78	if (low >= high) then low
79	else
80	let m = ((low + high) lsr 1) lor 1 in
81	if i < get_int t m then find_aux t i low (m-2)
82	else find_aux t i m high
83
84	let find (t : 'a t) i : 'a =
85	if t == empty then raise Not_found;
86	let j = find_aux t i 1 (get_len t - 2) in
87	if (get_int t j == i) then Obj.magic (get t (succ j))
88	else raise Not_found
89
90	let find_default t def i =
91	if t == empty then def
92	else
93	let j = find_aux t i 1 (get_len t - 2) in
94	if (get_int t j == i) then Obj.magic (get t (succ j))
95	else def
96
97	let find_lower (t : 'a t) i : 'a =
98	Obj.magic (get t (succ (find_aux t i 1 (get_len t - 2))))
99
100	let merge (t1 : 'a t) (t2 : 'a t) =
101	if t1 == empty then t2 else if t2 == empty then t1
102	else
103	let n1 = get_len t1 and n2 = get_len t2 in
104	let m = pred (n1 + n2) in
105	let t = acreate m in
106	let rec aux i i1 (l1:int) i2 l2 =
107	if l1 == l2 then
108	(set_int t i l1;
109	set t (succ i) (get t2 (pred i2));
110	let i = i + 2 in
111	if (i1 = n1) then (
112	let l = n2 - i2 in
113	let i2 = i2 - 2 in
114	Array.blit t2 i2 t i l;
115	i + l
116	) else if (i2 = n2) then (
117	let l = n1 - i1 in
118	let i1 = i1 - 2 in
119	Array.blit t1 i1 t i l;
120	i + l
121	) else
122	let l1 = get_int t1 i1 and l2 = get_int t2 i2 in
123	let i1 = i1 + 2 and i2 = i2 + 2 in
124	aux i i1 l1 i2 l2)
125	else if l1 < l2 then
126	(set_int t i l1;
127	set t (succ i) (get t1 (pred i1));
128	let i = i + 2 in
129	if (i1 = n1) then (
130	let i2 = i2 - 2 in
131	let l = n2 - i2 in
132	Array.blit t2 i2 t i l;
133	i + l
134	) else
135	let l1 = get_int t1 i1 in
136	let i1 = i1 + 2 in
137	aux i i1 l1 i2 l2)
138	else
139	(set_int t i l2;
140	set t (succ i) (get t2 (pred i2));
141	let i = i + 2 in
142	if (i2 = n2) then (
143	let l = n1 - i1 in
144	let i1 = i1 - 2 in
145	Array.blit t1 i1 t i l;
146	i + l
147	) else
148	let l2 = get_int t2 i2 in
149	let i2 = i2 + 2 in
150	aux i i1 l1 i2 l2)
151	in
152	set_len t (aux 1 3 (get_int t1 1) 3 (get_int t2 1));
153	t
154
155	let cardinal t =
156	if t == empty then 0
157	else (pred (get_len t)) lsr 1
158
159	let map f t =
160	if t == empty then empty
161	else
162	let n = get_len t in
163	let t' = acreate n in
164	Array.blit t 0 t' 0 n;
165	let rec aux i =
166	if (i = 0) then t'
167	else (set t' i (Obj.magic (f (Obj.magic (get t i)))); aux (i - 2))
168	in
169	aux (pred n)
170
171	let compare f t1 t2 =
172	if (t1 == t2) then 0
173	else if t1 == empty then (-1)
174	else if t2 == empty then 1
175	else
176	let n1 = get_len t1 and n2 = get_len t2 in
177	if (n1 < n2) then (-1) else if (n1 > n2) then 1
178	else
179	let rec aux i =
180	if (i < 0) then 0
181	else
182	let l1 = get t1 i and l2 = get t2 i in
183	if (l1 < l2) then (-1) else if (l1 > l2) then 1
184	else let x1 = Obj.magic (get t1 (succ i))
185	and x2 = Obj.magic (get t2 (succ i))
186	in let c = f x1 x2 in
187	if c != 0 then c else aux (i - 2)
188	in
189	aux (n1 - 2)
190
191	let hash f t =
192	if t == empty then 1
193	else
194	let rec aux accu i =
195	if (i < 0) then accu
196	else aux (accu * 65537
197	+ 257 * (f (Obj.magic (get t (succ i))))
198	+ (get_int t i)) (i - 2) in
199	aux 1 (get_len t - 2)
200
201	let remove t i =
202	if t == empty then t
203	else
204	let j = find_aux t i 1 (get_len t - 2) in
205	if (get_int t j != i) then t
206	else
207	let n = get_len t - 2 in
208	if (n = 1) then empty
209	else
210	let t' = acreate n in
211	Array.blit t 1 t' 1 (j - 1);
212	Array.blit t (j + 2) t' j (n - j);
213	t'
214
215	let iter f t =
216	if t == empty then ()
217	else
218	let rec aux i =
219	if (i < 0) then ()
220	else f (get_int t i) (Obj.magic (get t (succ i))) in
221	aux (get_len t - 2)
222
223	(*
224	type 'a t = (int * 'a) list
225
226	let empty = []
227
228	let create a =
229	Array.sort (fun (i,_) (j,_) -> assert (i != j); if i < j then (-1) else 1) a;
230	Array.to_list a
231
232	let create_default def a =
233	let l = create a in
234	let rec aux i = function
235	\| [] ->
236	if (i == max_int) then []
237	else [(succ i, def)]
238	\| ((i1,_) as c)::rest ->
239	if (succ i == i1) then c :: (aux i1 rest)
240	else (succ i, def) :: c :: (aux i1 rest)
241	in
242	let l =
243	match l with
244	\| ((i1,_) as c)::rest ->
245	if (i1 == min_int) then c :: (aux i1 rest)
246	else (min_int,def) :: c :: (aux i1 rest)
247	\| [] -> [(min_int,def)] in
248	l
249
250	let merge l1 l2 = assert false
251
252	let find l x = List.assoc x l
253
254	let rec find_lower l x = match l with
255	\| (_,v)::(y,_)::_ when x < y -> v
256	\| _::l -> find_lower l x
257	\| [] -> assert false
258
259	let find_default l def x = try find l x with Not_found -> def
260
261	let cardinal = List.length
262
263	let elements l = l
264
265	let map f l = List.map (fun (x,v) -> (x, f v)) l
266
267	let map_elements f l = List.map (fun (x,v) -> f x v) l
268
269	let compare _ _ = assert false
270	let hash _ = assert false
271	let remove _ _ = assert false
272	let iter _ _ = assert false
273	*)