/[svn]/types/types.ml
ViewVC logotype

Diff of /types/types.ml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 221 by abate, Tue Jul 10 17:15:42 2007 UTC revision 222 by abate, Tue Jul 10 17:15:58 2007 UTC
# Line 13  Line 13 
13  end  end
14    
15  module LabelPool = Pool.Make(HashedString)  module LabelPool = Pool.Make(HashedString)
 module AtomPool  = Pool.Make(HashedString)  
16    
17  type label = LabelPool.t  type label = LabelPool.t
 type atom  = AtomPool.t  
18    
19  type const = Integer of Big_int.big_int | Atom of atom | Char of Chars.Unichar.t  type const =
20      | Integer of Intervals.v
21      | Atom of Atoms.v
22      | Char of Chars.v
23    
24  type pair_kind = [ `Normal | `XML ]  type pair_kind = [ `Normal | `XML ]
25    
26  type descr = {  type descr = {
27    atoms : atom Atoms.t;    atoms : Atoms.t;
28    ints  : Intervals.t;    ints  : Intervals.t;
29    chars : Chars.t;    chars : Chars.t;
30    times : (node * node) Boolean.t;    times : (node * node) Boolean.t;
# Line 113  Line 114 
114  let internalize n = n  let internalize n = n
115  let id n = n.id  let id n = n.id
116    
117    let rec compare_rec r1 r2 =
118      if r1 == r2 then 0
119      else match (r1,r2) with
120        | (l1,(o1,x1))::r1,(l2,(o2,x2))::r2 ->
121            if ((l1:int) < l2) then -1
122            else if (l1 > l2) then 1
123            else if o2 && not o1 then -1
124            else if o1 && not o2 then 1
125            else if x1.id < x2.id then -1
126            else if x1.id > x2.id then 1
127            else compare_rec r1 r2
128        | ([],_) -> -1
129        | _ -> 1
130    
131    let rec compare_rec_list l1 l2  =
132      if l1 == l2 then 0
133      else match (l1,l2) with
134        | (o1,r1)::l1, (o2,r2)::l2 ->
135            if o2 && not o1 then -1
136            else if o1 && not o2 then 1
137            else let c = compare_rec r1 r2 in if c <> 0 then c
138            else compare_rec_list l1 l2
139        | ([],_) -> -1
140        | _ -> 1
141    
142    let rec compare_rec_bool l1 l2  =
143      if l1 == l2 then 0
144      else match (l1,l2) with
145        | (p1,n1)::l1, (p2,n2)::l2 ->
146            let c = compare_rec_list p1 p2 in if c <> 0 then c
147            else let c = compare_rec_list n1 n2 in if c <> 0 then c
148            else compare_rec_bool l1 l2
149        | ([],_) -> -1
150        | _ -> 1
151    
152    let rec compare_times_list l1 l2  =
153      if l1 == l2 then 0
154      else match (l1,l2) with
155        | (x1,y1)::l1, (x2,y2)::l2 ->
156            if (x1.id < x2.id) then -1
157            else if (x1.id > x2.id) then 1
158            else if (y1.id < y2.id) then -1
159            else if (y1.id > y2.id) then 1
160            else compare_times_list l1 l2
161        | ([],_) -> -1
162        | _ -> 1
163    
164    let rec compare_times_bool l1 l2  =
165      if l1 == l2 then 0
166      else match (l1,l2) with
167        | (p1,n1)::l1, (p2,n2)::l2 ->
168            let c = compare_times_list p1 p2 in if c <> 0 then c
169            else let c = compare_times_list n1 n2 in if c <> 0 then c
170            else compare_times_bool l1 l2
171        | ([],_) -> -1
172        | _ -> 1
173    
174  let rec equal_rec r1 r2 =  let rec equal_rec r1 r2 =
175    (r1 == r2) ||    (r1 == r2) ||
176    match (r1,r2) with    match (r1,r2) with
177      | (l1,(o1,x1))::r1,(l2,(o2,x2))::r2 ->      | (l1,(o1,x1))::r1,(l2,(o2,x2))::r2 ->
178          (l1 = l2) && (o1 = o2) && (x1.id = x2.id) && (equal_rec r1 r2)          (x1.id = x2.id) && (l1 == l2) && (o1 == o2) && (equal_rec r1 r2)
179      | _ -> false      | _ -> false
180    
181  let rec equal_rec_list l1 l2  =  let rec equal_rec_list l1 l2  =
182    (l1 == l2) ||    (l1 == l2) ||
183    match (l1,l2) with    match (l1,l2) with
184      | (o1,r1)::l1, (o2,r2)::l2 ->      | (o1,r1)::l1, (o2,r2)::l2 ->
185          (o1 = o2) &&          (o1 == o2) &&
186          (equal_rec r1 r2)          (equal_rec r1 r2) && (equal_rec_list l1 l2)
187      | _ -> false      | _ -> false
188    
189  let rec equal_rec_bool l1 l2 =  let rec equal_rec_bool l1 l2 =
# Line 156  Line 214 
214      | _ -> false      | _ -> false
215    
216  let equal_descr a b =  let equal_descr a b =
217    (a.atoms = b.atoms) &&    (Atoms.equal a.atoms b.atoms) &&
218    (a.chars = b.chars) &&    (Chars.equal a.chars b.chars) &&
219    (a.ints  = b.ints) &&    (Intervals.equal a.ints  b.ints) &&
220    (equal_times_bool a.times b.times) &&    (equal_times_bool a.times b.times) &&
221    (equal_times_bool a.xml b.xml) &&    (equal_times_bool a.xml b.xml) &&
222    (equal_times_bool a.arrow b.arrow) &&    (equal_times_bool a.arrow b.arrow) &&
223    (equal_rec_bool a.record b.record)    (equal_rec_bool a.record b.record)
224    
225    let compare_descr a b =
226      let c = compare a.atoms b.atoms in if c <> 0 then c
227      else let c = compare a.chars b.chars in if c <> 0 then c
228      else let c = compare a.ints b.ints in if c <> 0 then c
229      else let c = compare_times_bool a.times b.times in if c <> 0 then c
230      else let c = compare_times_bool a.xml b.xml in if c <> 0 then c
231      else let c = compare_times_bool a.arrow b.arrow in if c <> 0 then c
232      else let c = compare_rec_bool a.record b.record in if c <> 0 then c
233      else 0
234    
235    (*
236    let compare_descr a b =
237      let c = compare_descr a b in
238      assert (c = compare a b);
239      c
240    *)
241    
242    
243  let rec hash_times_list accu = function  let rec hash_times_list accu = function
244    | (x,y)::l ->    | (x,y)::l ->
245        hash_times_list (accu * 257 + x.id * 17 + y.id) l        hash_times_list (accu * 257 + x.id * 17 + y.id) l
# Line 176  Line 252 
252    
253  let rec hash_rec accu = function  let rec hash_rec accu = function
254    | (l,(o,x))::rem ->    | (l,(o,x))::rem ->
255          let accu = if o then accu else accu + 5 in
256        hash_rec (257 * accu + 17 * (LabelPool.hash l) + x.id) rem        hash_rec (257 * accu + 17 * (LabelPool.hash l) + x.id) rem
257    | [] -> accu + 5    | [] -> accu + 5
258    
259  let rec hash_rec_list accu = function  let rec hash_rec_list accu = function
260    | (o,r)::l ->    | (o,r)::l ->
261        hash_rec_list (hash_rec accu r) l        hash_rec_list (hash_rec (if o then accu*3 else accu) r) l
262    | [] -> accu + 17    | [] -> accu + 17
263    
264  let rec hash_rec_bool accu = function  let rec hash_rec_bool accu = function
# Line 191  Line 268 
268    
269    
270  let hash_descr a =  let hash_descr a =
271    let accu =    let accu = Chars.hash 1 a.chars in
272      (Hashtbl.hash a.ints) +  17 * (Hashtbl.hash a.atoms) +    let accu = Intervals.hash accu a.ints in
273      257 * (Hashtbl.hash a.chars) in    let accu = Atoms.hash accu a.atoms in
274    let accu = hash_times_bool accu a.times in    let accu = hash_times_bool accu a.times in
275    let accu = hash_times_bool accu a.xml in    let accu = hash_times_bool accu a.xml in
276    let accu = hash_times_bool accu a.arrow in    let accu = hash_times_bool accu a.arrow in
# Line 433  Line 510 
510    s.status = Empty    s.status = Empty
511    
512    
513  module Assumptions = Set.Make(struct type t = descr let compare = compare end)  module Assumptions = Set.Make(struct type t = descr let compare = compare_descr end)
514  let memo = ref Assumptions.empty  let memo = ref Assumptions.empty
515  let cache_false = DescrHash.create 33000  let cache_false = DescrHash.create 33000
516    
# Line 535  Line 612 
612  and empty_rec_record c =  and empty_rec_record c =
613    List.for_all empty_rec_record_aux (get_record c)    List.for_all empty_rec_record_aux (get_record c)
614    
615  (*let is_empty d =  (*
616    let is_empty d =
617    empty_rec d    empty_rec d
618  *)  *)
619    
# Line 686  Line 764 
764      | [h] -> h ppf      | [h] -> h ppf
765      | h::t -> Format.fprintf ppf "@[%t |@ %a@]" h print_union t      | h::t -> Format.fprintf ppf "@[%t |@ %a@]" h print_union t
766    
   let print_atom ppf a =  
     Format.fprintf ppf "`%s" (AtomPool.value a)  
   
767    let print_tag ppf a =    let print_tag ppf a =
768      match Atoms.is_atom a with      match Atoms.is_atom a with
769        | Some a -> Format.fprintf ppf "%s" (AtomPool.value a)        | Some a -> Format.fprintf ppf "%s" (Atoms.value a)
770        | None ->        | None -> Format.fprintf ppf "(%a)" print_union (Atoms.print a)
           Format.fprintf ppf "(%a)"  
             print_union  
                (Atoms.print "Atom" print_atom a)  
771    
772    let print_const ppf = function    let print_const ppf = function
773      | Integer i -> Format.fprintf ppf "%s" (Big_int.string_of_big_int i)      | Integer i -> Intervals.print_v ppf i
774      | Atom a -> print_atom ppf a      | Atom a -> Atoms.print_v ppf a
775      | Char c -> Chars.Unichar.print ppf c      | Char c -> Chars.print_v ppf c
776    
777    let named = State.ref "Types.Printf.named" DescrMap.empty    let named = State.ref "Types.Printf.named" DescrMap.empty
778    let register_global name d =    let register_global name d =
# Line 775  Line 847 
847        print_union ppf        print_union ppf
848          (Intervals.print d.ints @          (Intervals.print d.ints @
849           Chars.print d.chars @           Chars.print d.chars @
850           Atoms.print "Atom" print_atom d.atoms @           Atoms.print d.atoms @
851           Boolean.print "Pair" print_times d.times @           Boolean.print "Pair" print_times d.times @
852           Boolean.print "XML" print_xml d.xml @           Boolean.print "XML" print_xml d.xml @
853           Boolean.print "Arrow" print_arrow d.arrow @           Boolean.print "Arrow" print_arrow d.arrow @
# Line 906  Line 978 
978    | x::r -> try f x with Not_found -> find f r    | x::r -> try f x with Not_found -> find f r
979    
980  type t =  type t =
981    | Int of Big_int.big_int    | Int of Intervals.v
982    | Atom of atom    | Atom of Atoms.v
983    | Char of Chars.Unichar.t    | Char of Chars.v
984    | Pair of (t * t)    | Pair of (t * t)
985    | Xml of (t * t)    | Xml of (t * t)
986    | Record of (label * t) list    | Record of (label * t) list
# Line 920  Line 992 
992    if (Assumptions.mem d memo) || (is_empty d) then raise Not_found    if (Assumptions.mem d memo) || (is_empty d) then raise Not_found
993    else    else
994      try Int (Intervals.sample d.ints) with Not_found ->      try Int (Intervals.sample d.ints) with Not_found ->
995      try Atom (Atoms.sample (fun _ -> AtomPool.dummy_min) d.atoms) with      try Atom (Atoms.sample d.atoms) with
996          Not_found ->          Not_found ->
997  (* Here: could create a fresh atom ... *)  (* Here: could create a fresh atom ... *)
998      try Char (Chars.sample d.chars) with Not_found ->      try Char (Chars.sample d.chars) with Not_found ->
# Line 1025  Line 1097 
1097    
1098    
1099    let rec print ppf = function    let rec print ppf = function
1100      | Int i -> Format.fprintf ppf "%s" (Big_int.string_of_big_int i)      | Int i -> Intervals.print_v ppf i
1101      | Atom a ->      | Atom a -> Atoms.print_v ppf a
1102          if a = LabelPool.dummy_min then      | Char c -> Chars.print_v ppf c
           Format.fprintf ppf "(almost any atom)"  
         else  
           Format.fprintf ppf "`%s" (AtomPool.value a)  
     | Char c -> Chars.Unichar.print ppf c  
1103      | Pair (x1,x2) -> Format.fprintf ppf "(%a,%a)" print x1 print x2      | Pair (x1,x2) -> Format.fprintf ppf "(%a,%a)" print x1 print x2
1104      | Xml (x1,x2) -> Format.fprintf ppf "XML(%a,%a)" print x1 print x2      | Xml (x1,x2) -> Format.fprintf ppf "XML(%a,%a)" print x1 print x2
1105      | Record r ->      | Record r ->
Legend:
Removed from v.221  
changed lines
  Added in v.222
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5