← Back to branch summary

~ubuntu-branches/ubuntu/precise/ocaml-batteries/precise

« back to all changes in this revision

Viewing changes to src/batInnerWeaktbl.ml

  • Committer: Bazaar Package Importer
  • Author(s): Stefano Zacchiroli
  • Date: 2010-03-06 16:03:38 UTC
  • mfrom: (1.1.2 upstream)
  • Revision ID: james.westby@ubuntu.com-20100306160338-spvwiv3uc4jr28hw
Tags: 1.1.0-1
http://bugs.debian.org/569455
http://bugs.debian.org/514265
* New upstream release
  - major changes, "diet" version of the library
  - fix old FTBFS error, due to major code changes (Closes: #569455)
* Revamp packaging
  - adapt to new stuff shipped by upstream
  - switch from CDBS to dh
  - adapt dependencies (generally: reduce them)
* debian/patches/
  - remove old debian/patches/{debian-specific-installation-paths,
    debian-specific-info-on-doc-availability} as obsolete
  - new patch 0001-install-fix-for-bytecode-only-build: avoid
    installing *.a files with bytecode only compilation
* debian/libbatteries-ocaml-dev.links: remove file, shortend
  /usr/bin/ocaml-batteries to the top-level no longer exists
* remove debian/README.Debian (previous content is now obsolete)
* bump Standards-Version to 3.8.4 (no changes needed)
* debian/watch: update to match new upstream version convention
* debian/libbatteries-ocaml-{dev,doc}.{docs,examples}: ship only doc
  file from the root dir, other stuff is currently out of date
  (Closes: #514265)

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/batInnerWeaktbl.ml
 
1
(***********************************************************************)
 
2
(*                                                                     *)
 
3
(*                            Weaktbl                                  *)
 
4
(*                                                                     *)
 
5
(*             (C) 2007 by Zheng Li (li@pps.jussieu.fr)                *)
 
6
(*                                                                     *)
 
7
(*  This program is free software; you can redistribute it and/or      *)
 
8
(*  modify it under the terms of the GNU Lesser General Public         *)
 
9
(*  License version 2.1 as published by the Free Software Foundation,  *)
 
10
(*  with the special exception on linking described in file LICENSE.   *)
 
11
(*                                                                     *)
 
12
(*  This program is distributed in the hope that it will be useful,    *)
 
13
(*  but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
 
14
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
 
15
(*  GNU Library General Public License for more details.               *)
 
16
(*                                                                     *)
 
17
(***********************************************************************)
 
18
 
 
19
 
 
20
(* weak stack, for ordering purpose *)
 
21
module Stack = struct
 
22
  type 'a t = {mutable data:'a Weak.t; mutable length:int; mutable cursor:int}
 
23
  let create n = 
 
24
    let len = min n (Sys.max_array_length - 1) in
 
25
    {data = Weak.create len; length = len; cursor = 0}
 
26
  let iter f s = 
 
27
    for i = s.cursor -1 downto 0 do
 
28
      match Weak.get s.data i with Some x -> f x | _ -> ()
 
29
    done
 
30
  let length s = (* resize by the way, since it's invoked by push *)
 
31
    let flag = ref false and pt = ref 0 in
 
32
    for i = 0 to s.cursor -1 do
 
33
      match Weak.get s.data i with
 
34
      | Some x as d -> if !flag then Weak.set s.data !pt d; incr pt
 
35
      | None -> flag := true
 
36
    done;
 
37
    s.cursor <- !pt; s.cursor
 
38
  let copy s = 
 
39
    let s' = create s.length in 
 
40
    Weak.blit s.data 0 s'.data 0 s.cursor; s'.cursor <- s.cursor; s'
 
41
  let rec push x s = 
 
42
    if s.cursor < s.length then
 
43
      (Weak.set s.data s.cursor (Some x); s.cursor <- s.cursor + 1)
 
44
    else
 
45
      let len = length s in
 
46
      if len >= s.length / 3 && len < s.length * 2 / 3 then push x s else
 
47
        let len' = min (len * 3 / 2 + 2) (Sys.max_array_length -1) in
 
48
        if len' = len then failwith "Weaktbl.Stack.push: stack cannnot grow"
 
49
        else
 
50
          let data' = Weak.create len' in
 
51
          Weak.blit s.data 0 data' 0 s.cursor; 
 
52
          s.data <- data'; s.length <- len'; push x s
 
53
  let rec pop s =
 
54
    if s.cursor <= 0 then raise Not_found;
 
55
    s.cursor <- s.cursor -1;
 
56
    match Weak.get s.data s.cursor with Some x -> x | None -> pop s
 
57
  let rec top s =
 
58
    if s.cursor <= 0 then raise Not_found;
 
59
    match Weak.get s.data (s.cursor -1) with 
 
60
    | Some x -> x | None -> s.cursor <- s.cursor -1; top s
 
61
  let is_empty s = (* stop as earlier as we can *)
 
62
    try iter (fun _ -> raise Not_found) s; true with Not_found -> false
 
63
end
 
64
 
 
65
open Obj (* Recover polymorphism from standard monomorphic (Weak)Hashtbl *)
 
66
module Make (H: Hashtbl.HashedType) : Hashtbl.S with type key = H.t = struct
 
67
  type box = H.t Weak.t
 
68
  let enbox k = let w = Weak.create 1 in Weak.set w 0 (Some k); w
 
69
  let unbox bk = Weak.get bk 0 
 
70
  type bind = box * t
 
71
  let bind_new k v = enbox k, repr v
 
72
  type cls = bind Stack.t
 
73
  let cls_new bd = let cls = Stack.create 1 in Stack.push bd cls; cls
 
74
  let dummy k = cls_new (bind_new k ())
 
75
  let rec top_bind cls = 
 
76
    let (bk,v) as bind = Stack.top cls in 
 
77
    match unbox bk with 
 
78
    | Some k -> k, (obj v) | _ -> assert (bind == Stack.pop cls); top_bind cls
 
79
  let top_key cls = fst (top_bind cls) and top_value cls = snd (top_bind cls)
 
80
  let all_bind cls =
 
81
    let l = ref [] in
 
82
    let f (bk,v) = match unbox bk with 
 
83
      | Some k -> l := (k, obj v) :: !l | _ -> () in
 
84
    Stack.iter f cls; List.rev !l
 
85
  let all_key cls = List.map fst (all_bind cls) 
 
86
  and all_value cls = List.map snd (all_bind cls) 
 
87
  module HX = struct
 
88
    type t = cls
 
89
    let hash x = try H.hash (top_key x) with Not_found -> 0
 
90
    let equal x y = try H.equal (top_key x) (top_key y) with Not_found -> false
 
91
  end
 
92
  module W = Weak.Make(HX)
 
93
  type key = H.t and 'a t = W.t
 
94
  let create = W.create and clear = W.clear
 
95
  let find_all tbl key = 
 
96
    try all_value (W.find tbl (dummy key)) with Not_found-> []
 
97
  let rec find tbl key = top_value (W.find tbl (dummy key))
 
98
  let add tbl key data =
 
99
    let bd = bind_new key data in
 
100
    let cls = 
 
101
      try let c = W.find tbl (dummy key) in Stack.push bd c; c
 
102
      with Not_found -> let c = cls_new bd in W.add tbl c; c in
 
103
    let final _ = ignore bd; ignore cls in
 
104
    try Gc.finalise final key 
 
105
    with Invalid_argument _ -> Gc.finalise final bd; Gc.finalise final cls
 
106
  let remove tbl key = 
 
107
    try ignore (Stack.pop (W.find tbl (dummy key))) with Not_found -> ()
 
108
  let replace tbl key data = remove tbl key; add tbl key data
 
109
  let mem tbl key = try ignore (find tbl key); true with Not_found -> false
 
110
  let iter f tbl = 
 
111
    let f' (bk,v) = match unbox bk with Some k -> f k (obj v) | None -> () in
 
112
    W.iter (Stack.iter f') tbl
 
113
  let fold f tbl accu = 
 
114
    let r = ref accu in
 
115
    let f' k v = r := f k v !r in
 
116
    iter f' tbl; !r
 
117
  let length tbl = W.fold (fun cls -> (+) (Stack.length cls)) tbl 0
 
118
  let copy tbl = 
 
119
    let tbl'= W.create (W.count tbl * 3 / 2 + 2) in 
 
120
    W.iter (fun cls -> W.add tbl' (Stack.copy cls)) tbl; tbl'
 
121
end
 
122
 
 
123
module StdHash = Make
 
124
  (struct 
 
125
     type t = Obj.t let equal x y = (compare x y) = 0 let hash = Hashtbl.hash
 
126
  end)
 
127
open StdHash
 
128
type ('a,'b) t = 'b StdHash.t
 
129
let create = create and clear = clear and copy = copy and length = length
 
130
let add tbl k = add tbl (repr k)
 
131
let remove tbl k = remove tbl (repr k)
 
132
let find tbl k = find tbl (repr k)
 
133
let find_all tbl k = find_all tbl (repr k)
 
134
let replace tbl k = replace tbl (repr k)
 
135
let mem tbl k = mem tbl (repr k)
 
136
let iter f = iter (fun k d -> f (obj k) d)
 
137
let fold f = fold (fun k d a -> f (obj k) d a)
 
138