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

Diff of /types/types.ml

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

revision 656 by abate, Tue Jul 10 17:51:50 2007 UTC revision 672 by abate, Tue Jul 10 17:53:24 2007 UTC
# Line 15  Line 15 
15    | Integer of Intervals.V.t    | Integer of Intervals.V.t
16    | Atom of Atoms.V.t    | Atom of Atoms.V.t
17    | Char of Chars.V.t    | Char of Chars.V.t
18      | Pair of const * const
19      | Xml of const * const
20      | Record of const label_map
21      | String of U.uindex * U.uindex * U.t * const
22    
23  let compare_const c1 c2 =  
24    let rec compare_const c1 c2 =
25    match (c1,c2) with    match (c1,c2) with
26      | Integer x, Integer y -> Intervals.V.compare x y      | Integer x, Integer y -> Intervals.V.compare x y
27      | Integer _, _ -> -1      | Integer _, _ -> -1
# Line 25  Line 30 
30      | Atom _, _ -> -1      | Atom _, _ -> -1
31      | _, Atom _ -> 1      | _, Atom _ -> 1
32      | Char x, Char y -> Chars.V.compare x y      | Char x, Char y -> Chars.V.compare x y
33        | Char _, _ -> -1
34  let hash_const = function      | _, Char _ -> 1
35    | Integer x -> Intervals.V.hash x      | Pair (x1,x2), Pair (y1,y2) ->
36    | Atom x -> Atoms.V.hash x          let c = compare_const x1 y1 in
37    | Char x -> Chars.V.hash x          if c <> 0 then c else compare_const x2 y2
38        | Pair (_,_), _ -> -1
39        | _, Pair (_,_) -> 1
40        | Xml (x1,x2), Xml (y1,y2) ->
41            let c = compare_const x1 y1 in
42            if c <> 0 then c else compare_const x2 y2
43        | Xml (_,_), _ -> -1
44        | _, Xml (_,_) -> 1
45        | Record x, Record y ->
46            LabelMap.compare compare_const x y
47        | Record _, _ -> -1
48        | _, Record _ -> 1
49        | String (i1,j1,s1,r1), String (i2,j2,s2,r2) ->
50            let c = Pervasives.compare i1 i2 in if c <> 0 then c
51            else let c = Pervasives.compare j1 j2 in if c <> 0 then c
52            else let c = U.compare s1 s2 in if c <> 0 then c (* Should compare
53                                                                only the substring *)
54            else compare_const r1 r2
55    
56    let rec hash_const = function
57      | Integer x -> 1 + 17 * (Intervals.V.hash x)
58      | Atom x -> 2 + 17 * (Atoms.V.hash x)
59      | Char x -> 3 + 17 * (Chars.V.hash x)
60      | Pair (x,y) -> 4 + 17 * (hash_const x) + 257 * (hash_const y)
61      | Xml (x,y) -> 5 + 17 * (hash_const x) + 257 * (hash_const y)
62      | Record x -> 6 + 17 * (LabelMap.hash hash_const x)
63      | String (i,j,s,r) -> 7 + 17 * (U.hash s) + 257 * hash_const r
64          (* Note: improve hash for String *)
65    
66  let equal_const c1 c2 = compare_const c1 c2 = 0  let equal_const c1 c2 = compare_const c1 c2 = 0
67    
# Line 216  Line 248 
248    { empty with record = BoolRec.atom x }    { empty with record = BoolRec.atom x }
249  let atom a = { empty with atoms = a }  let atom a = { empty with atoms = a }
250  let char c = { empty with chars = c }  let char c = { empty with chars = c }
 let constant = function  
   | Integer i -> interval (Intervals.atom i)  
   | Atom a -> atom (Atoms.atom a)  
   | Char c -> char (Chars.atom c)  
251    
252  let cup x y =  let cup x y =
253    if x == y then x else {    if x == y then x else {
# Line 294  Line 322 
322  let id n = n.Node.id  let id n = n.Node.id
323    
324    
325    let rec constant = function
326      | Integer i -> interval (Intervals.atom i)
327      | Atom a -> atom (Atoms.atom a)
328      | Char c -> char (Chars.atom c)
329      | Pair (x,y) -> times (const_node x) (const_node y)
330      | Xml (x,y) -> times (const_node x) (const_node y)
331      | Record x -> record' (false ,LabelMap.map const_node x)
332      | String (i,j,s,c) ->
333          if U.equal_index i j then constant c
334          else
335            let (ch,i') = U.next s i in
336            constant (Pair (Char (Chars.V.mk_int ch), String (i',j,s,c)))
337    and const_node c = cons (constant c)
338    
339  let neg x = diff any x  let neg x = diff any x
340    
# Line 972  Line 1012 
1012    
1013  module Print =  module Print =
1014  struct  struct
1015    let print_const ppf = function    let rec print_const ppf = function
1016      | Integer i -> Intervals.V.print ppf i      | Integer i -> Intervals.V.print ppf i
1017      | Atom a -> Atoms.V.print_quote ppf a      | Atom a -> Atoms.V.print_quote ppf a
1018      | Char c -> Chars.V.print ppf c      | Char c -> Chars.V.print ppf c
1019        | Pair (x,y) -> Format.fprintf ppf "(%a,%a)" print_const x print_const y
1020        | Xml (x,y) -> Format.fprintf ppf "XML(%a,%a)" print_const x print_const y
1021        | Record r ->
1022            Format.fprintf ppf "Record{";
1023            List.iter
1024              (fun (l,c) ->
1025                 Format.fprintf ppf "%a : %a; "
1026                 Label.print (LabelPool.value l)
1027                 print_const c)
1028              (LabelMap.get r);
1029            Format.fprintf ppf "}"
1030        | String (i,j,s,c) ->
1031            Format.fprintf ppf "\"%a\" @ %a"
1032            U.print (U.mk (U.get_substr s i j))
1033            print_const c
1034    
1035    let nil_atom = Atoms.V.mk_ascii "nil"    let nil_atom = Atoms.V.mk_ascii "nil"
1036    let nil_type = atom (Atoms.atom nil_atom)    let nil_type = atom (Atoms.atom nil_atom)
Legend:
Removed from v.656  
changed lines
  Added in v.672
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5