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

Diff of /types/types.ml

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

revision 14 by abate, Tue Jul 10 16:57:42 2007 UTC revision 15 by abate, Tue Jul 10 16:57:55 2007 UTC
# Line 6  Line 6 
6  type label = int  type label = int
7  type atom  = int  type atom  = int
8    
9  type const = Integer of int | Atom of atom | String of string | Char of Chars.Unichar.t  type const = Integer of Big_int.big_int | Atom of atom | Char of Chars.Unichar.t
10    
11  module I = struct  module I = struct
12    type 'a t = {    type 'a t = {
# Line 16  Line 16 
16      arrow : ('a * 'a) Boolean.t;      arrow : ('a * 'a) Boolean.t;
17      record: (label * bool * 'a) Boolean.t;      record: (label * bool * 'a) Boolean.t;
18      chars : Chars.t;      chars : Chars.t;
     strs  : Strings.t;  
19    }    }
20    
21    let empty = {    let empty = {
# Line 26  Line 25 
25      ints  = Intervals.empty;      ints  = Intervals.empty;
26      atoms = Atoms.empty;      atoms = Atoms.empty;
27      chars = Chars.empty;      chars = Chars.empty;
     strs  = Strings.empty;  
28    }    }
29    
30    let any =  {    let any =  {
31      times = Boolean.full;      times = Boolean.full;
32      arrow = Boolean.full;      arrow = Boolean.full;
33      record= Boolean.full;      record= Boolean.full;
34      ints  = Intervals.full;      ints  = Intervals.any;
35      atoms = Atoms.full;      atoms = Atoms.full;
36      chars = Chars.full;      chars = Chars.full;
     strs  = Strings.any;  
37    }    }
38    
39    let interval i j = { empty with ints = Intervals.atom (i,j) }    let interval i j = { empty with ints = Intervals.atom i j }
40    let times x y = { empty with times = Boolean.atom (x,y) }    let times x y = { empty with times = Boolean.atom (x,y) }
41    let arrow x y = { empty with arrow = Boolean.atom (x,y) }    let arrow x y = { empty with arrow = Boolean.atom (x,y) }
42    let record label opt t = { empty with record = Boolean.atom (label,opt,t) }    let record label opt t = { empty with record = Boolean.atom (label,opt,t) }
43    let atom a = { empty with atoms = Atoms.atom a }    let atom a = { empty with atoms = Atoms.atom a }
   let string r = { empty with strs = Strings.Regexp.compile r }  
44    let char c = { empty with chars = Chars.atom c }    let char c = { empty with chars = Chars.atom c }
45    let char_class c1 c2 = { empty with chars = Chars.char_class c1 c2 }    let char_class c1 c2 = { empty with chars = Chars.char_class c1 c2 }
46    let constant = function    let constant = function
47      | Integer i -> interval i i      | Integer i -> interval i i
48      | Atom a -> atom a      | Atom a -> atom a
     | String s -> string (Strings.Regexp.str s)  
49      | Char c -> char c      | Char c -> char c
50    
51    
# Line 63  Line 59 
59        ints  = Intervals.cup x.ints  y.ints;        ints  = Intervals.cup x.ints  y.ints;
60        atoms = Atoms.cup x.atoms y.atoms;        atoms = Atoms.cup x.atoms y.atoms;
61        chars = Chars.cup x.chars y.chars;        chars = Chars.cup x.chars y.chars;
       strs  = Strings.cup x.strs y.strs;  
62      }      }
63    
64    let cap x y =    let cap x y =
# Line 74  Line 69 
69        ints  = Intervals.cap x.ints  y.ints;        ints  = Intervals.cap x.ints  y.ints;
70        atoms = Atoms.cap x.atoms y.atoms;        atoms = Atoms.cap x.atoms y.atoms;
71        chars = Chars.cap x.chars y.chars;        chars = Chars.cap x.chars y.chars;
       strs  = Strings.cap x.strs y.strs;  
72      }      }
73    
74    let diff x y =    let diff x y =
# Line 85  Line 79 
79        ints  = Intervals.diff x.ints  y.ints;        ints  = Intervals.diff x.ints  y.ints;
80        atoms = Atoms.diff x.atoms y.atoms;        atoms = Atoms.diff x.atoms y.atoms;
81        chars = Chars.diff x.chars y.chars;        chars = Chars.diff x.chars y.chars;
       strs  = Strings.diff x.strs y.strs;  
82      }      }
83    
84    let neg x = diff any x    let neg x = diff any x
85    
86    let equal e a b =    let equal e a b =
87      if a.ints <> b.ints then raise NotEqual;      if not (Intervals.equal a.ints b.ints) then raise NotEqual;
88      if a.atoms <> b.atoms then raise NotEqual;      if a.atoms <> b.atoms then raise NotEqual;
89      if a.chars <> b.chars then raise NotEqual;      if a.chars <> b.chars then raise NotEqual;
     if a.strs <> b.strs then raise NotEqual;  
90      Boolean.equal (fun (x1,x2) (y1,y2) -> e x1 y1; e x2 y2) a.times b.times;      Boolean.equal (fun (x1,x2) (y1,y2) -> e x1 y1; e x2 y2) a.times b.times;
91      Boolean.equal (fun (x1,x2) (y1,y2) -> e x1 y1; e x2 y2) a.arrow b.arrow;      Boolean.equal (fun (x1,x2) (y1,y2) -> e x1 y1; e x2 y2) a.arrow b.arrow;
92      Boolean.equal (fun (l1,o1,x1) (l2,o2,x2) ->      Boolean.equal (fun (l1,o1,x1) (l2,o2,x2) ->
# Line 108  Line 100 
100        ints  = a.ints;        ints  = a.ints;
101        atoms = a.atoms;        atoms = a.atoms;
102        chars = a.chars;        chars = a.chars;
       strs  = a.strs;  
103      }      }
104    
105    let hash h a =    let hash h a =
106      Hashtbl.hash (map h a)      (Hashtbl.hash { map h a with ints = Intervals.empty })
107        + (Intervals.hash a.ints)
108    
109    let iter f a =    let iter f a =
110      ignore (map f a)      ignore (map f a)
# Line 232  Line 224 
224    else if not (Intervals.is_empty d.ints) then false    else if not (Intervals.is_empty d.ints) then false
225    else if not (Atoms.is_empty d.atoms) then false    else if not (Atoms.is_empty d.atoms) then false
226    else if not (Chars.is_empty d.chars) then false    else if not (Chars.is_empty d.chars) then false
   else if not (Strings.is_empty d.strs) then false  
227    else (    else (
228      let backup = !memo in      let backup = !memo in
229      memo := Assumptions.add d backup;      memo := Assumptions.add d backup;
# Line 308  Line 299 
299    | x::r -> try f x with Not_found -> find f r    | x::r -> try f x with Not_found -> find f r
300    
301  type t =  type t =
302    | Int of int    | Int of Big_int.big_int
303    | Atom of atom    | Atom of atom
304    | Char of Chars.Unichar.t    | Char of Chars.Unichar.t
   | String of string  
305    | Pair of t * t    | Pair of t * t
306    | Record of (label * t) list    | Record of (label * t) list
307    | Fun of (node * node) list    | Fun of (node * node) list
# Line 325  Line 315 
315      try Int (Intervals.sample d.ints) with Not_found ->      try Int (Intervals.sample d.ints) with Not_found ->
316      try Atom (Atoms.sample (gen_atom 0) d.atoms) with Not_found ->      try Atom (Atoms.sample (gen_atom 0) d.atoms) with Not_found ->
317      try Char (Chars.sample d.chars) with Not_found ->      try Char (Chars.sample d.chars) with Not_found ->
     try String (Strings.sample d.strs) with Not_found ->  
318      try sample_rec_arrow d.arrow with Not_found ->      try sample_rec_arrow d.arrow with Not_found ->
319    
320      let memo = Assumptions.add d memo in      let memo = Assumptions.add d memo in
# Line 567  Line 556 
556    
557  module Print =  module Print =
558  struct  struct
559    let marks = Hashtbl.create 63    module DescrHash =
560        Hashtbl.Make(
561          struct
562            type t = descr
563            let hash = hash_descr
564            let equal = (=)
565          end
566        )
567    
568      let named = DescrHash.create 10
569      let register_global name d = DescrHash.add named d name
570    
571      let marks = DescrHash.create 63
572    let wh = ref []    let wh = ref []
573    let count_name = ref 0    let count_name = ref 0
574    let name () =    let name () =
# Line 584  Line 585 
585    let worth_abbrev d =    let worth_abbrev d =
586      not (trivial d.times && trivial d.arrow && trivial d.record)      not (trivial d.times && trivial d.arrow && trivial d.record)
587    
588    let rec mark n =    let rec mark n = mark_descr (descr n)
589      let i = id n and d = descr n in    and mark_descr d =
590        if not (DescrHash.mem named d) then
591      try      try
592        let r = Hashtbl.find marks i in          let r = DescrHash.find marks d in
593        if (!r = None) && (worth_abbrev d) then        if (!r = None) && (worth_abbrev d) then
594          (let na = name () in            let na = name () in
595           r := Some na;           r := Some na;
596           wh := (na,d) :: !wh           wh := (na,d) :: !wh
         )  
597      with Not_found ->      with Not_found ->
598        Hashtbl.add marks i (ref None);          DescrHash.add marks d (ref None);
       mark_descr d  
   and mark_descr d =  
599      bool_iter (fun (n1,n2) -> mark n1; mark n2) d.times;      bool_iter (fun (n1,n2) -> mark n1; mark n2) d.times;
600      bool_iter (fun (n1,n2) -> mark n1; mark n2) d.arrow;      bool_iter (fun (n1,n2) -> mark n1; mark n2) d.arrow;
601      bool_iter (fun (l,o,n) -> mark n) d.record      bool_iter (fun (l,o,n) -> mark n) d.record
# Line 609  Line 608 
608    
609    let print_atom ppf a = Format.fprintf ppf "`%s" (atom_name a)    let print_atom ppf a = Format.fprintf ppf "`%s" (atom_name a)
610    
611    let rec print ppf n =    let rec print ppf n = print_descr ppf (descr n)
 (*    Format.fprintf ppf "[%i]" (id n); *)  
     match !(Hashtbl.find marks (id n)) with  
       | Some n -> Format.fprintf ppf "%s" n  
       | None -> print_descr ppf (descr n)  
612    and print_descr ppf d =    and print_descr ppf d =
613        try
614          let name = DescrHash.find named d in
615          Format.fprintf ppf "%s" name
616        with Not_found ->
617          match !(DescrHash.find marks d) with
618            | Some n -> Format.fprintf ppf "%s" n
619            | None -> real_print_descr ppf d
620      and real_print_descr ppf d =
621      if d = any then Format.fprintf ppf "Any" else      if d = any then Format.fprintf ppf "Any" else
622      print_union ppf      print_union ppf
623        (Intervals.print d.ints @        (Intervals.print d.ints @
624         Chars.print d.chars @         Chars.print d.chars @
        Strings.print d.strs @  
625         Atoms.print "AnyAtom" print_atom d.atoms @         Atoms.print "AnyAtom" print_atom d.atoms @
626         Boolean.print "(Any,Any)" print_times d.times @         Boolean.print "(Any,Any)" print_times d.times @
627         Boolean.print "(Empty -> Any)" print_arrow d.arrow @         Boolean.print "(Empty -> Any)" print_arrow d.arrow @
# Line 638  Line 640 
640      (match List.rev !wh with      (match List.rev !wh with
641         | [] -> ()         | [] -> ()
642         | (na,d)::t ->         | (na,d)::t ->
643             Format.fprintf ppf " where@ @[%s = %a" na print_descr d;             Format.fprintf ppf " where@ @[%s = %a" na real_print_descr d;
644             List.iter             List.iter
645               (fun (na,d) -> Format.fprintf ppf " and@ %s = %a" na print_descr d)               (fun (na,d) ->
646                    Format.fprintf ppf " and@ %s = %a" na real_print_descr d)
647               t;               t;
648             Format.fprintf ppf "@]"             Format.fprintf ppf "@]"
649      );      );
650      Format.fprintf ppf "@]";      Format.fprintf ppf "@]";
651      count_name := 0;      count_name := 0;
652      wh := [];      wh := [];
653      Hashtbl.clear marks      DescrHash.clear marks
   
   let print ppf n =  
     mark n;  
     Format.fprintf ppf "@[%a" print n;  
     end_print ppf  
654    
655    let print_descr ppf d =    let print_descr ppf d =
656      mark_descr d;      mark_descr d;
657      Format.fprintf ppf "@[%a" print_descr d;      Format.fprintf ppf "@[%a" print_descr d;
658      end_print ppf      end_print ppf
659    
660       let print ppf n = print_descr ppf (descr n)
661    
662    let rec print_sep f sep ppf = function    let rec print_sep f sep ppf = function
663      | [] -> ()      | [] -> ()
664      | [x] -> f ppf x      | [x] -> f ppf x
# Line 666  Line 666 
666    
667    
668    let rec print_sample ppf = function    let rec print_sample ppf = function
669      | Sample.Int i -> Format.fprintf ppf "%i" i      | Sample.Int i -> Format.fprintf ppf "%s" (Big_int.string_of_big_int i)
670      | Sample.Atom a -> Format.fprintf ppf "`%s" (atom_name a)      | Sample.Atom a -> Format.fprintf ppf "`%s" (atom_name a)
671      | Sample.Char c -> Chars.Unichar.print ppf c      | Sample.Char c -> Chars.Unichar.print ppf c
     | Sample.String s -> Format.fprintf ppf "%S" s  
672      | Sample.Pair (x1,x2) ->      | Sample.Pair (x1,x2) ->
673          Format.fprintf ppf "(%a,%a)"          Format.fprintf ppf "(%a,%a)"
674          print_sample x1          print_sample x1
Legend:
Removed from v.14  
changed lines
  Added in v.15
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5