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

Diff of /types/types.ml

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

revision 6 by abate, Tue Jul 10 16:57:08 2007 UTC revision 11 by abate, Tue Jul 10 16:57:31 2007 UTC
# Line 49  Line 49 
49    
50    let any_record = { empty with record = any.record }    let any_record = { empty with record = any.record }
51    
52    let cup x y = {    let cup x y =
53        if x = y then x else {
54      times = Boolean.cup x.times y.times;      times = Boolean.cup x.times y.times;
55      arrow = Boolean.cup x.arrow y.arrow;      arrow = Boolean.cup x.arrow y.arrow;
56      record= Boolean.cup x.record y.record;      record= Boolean.cup x.record y.record;
# Line 57  Line 58 
58      atoms = Atoms.cup x.atoms y.atoms;      atoms = Atoms.cup x.atoms y.atoms;
59      strs  = Strings.cup x.strs y.strs;      strs  = Strings.cup x.strs y.strs;
60    }    }
61    let cap x y = {  
62      let cap x y =
63        if x = y then x else {
64      times = Boolean.cap x.times y.times;      times = Boolean.cap x.times y.times;
65      record= Boolean.cap x.record y.record;      record= Boolean.cap x.record y.record;
66      arrow = Boolean.cap x.arrow y.arrow;      arrow = Boolean.cap x.arrow y.arrow;
# Line 65  Line 68 
68      atoms = Atoms.cap x.atoms y.atoms;      atoms = Atoms.cap x.atoms y.atoms;
69      strs  = Strings.cap x.strs y.strs;      strs  = Strings.cap x.strs y.strs;
70    }    }
71    let diff x y = {  
72      let diff x y =
73        if x = y then empty else {
74      times = Boolean.diff x.times y.times;      times = Boolean.diff x.times y.times;
75      arrow = Boolean.diff x.arrow y.arrow;      arrow = Boolean.diff x.arrow y.arrow;
76      record= Boolean.diff x.record y.record;      record= Boolean.diff x.record y.record;
# Line 73  Line 78 
78      atoms = Atoms.diff x.atoms y.atoms;      atoms = Atoms.diff x.atoms y.atoms;
79      strs  = Strings.diff x.strs y.strs;      strs  = Strings.diff x.strs y.strs;
80    }    }
81    
82    let neg x = diff any x    let neg x = diff any x
83    
84    let equal e a b =    let equal e a b =
# Line 334  Line 340 
340  and sample_rec_arrow c =  and sample_rec_arrow c =
341    find sample_rec_arrow_aux c    find sample_rec_arrow_aux c
342    
343  and sample_rec_arrow_aux (left,right) =  and check_empty_simple_arrow_line left (s1,s2) =
   let single_right (s1,s2) =  
344      let rec aux accu1 accu2 = function      let rec aux accu1 accu2 = function
345        | (t1,t2)::left ->        | (t1,t2)::left ->
346            let accu1' = diff_t accu1 t1 in            let accu1' = diff_t accu1 t1 in
# Line 347  Line 352 
352      let accu1 = descr s1 in      let accu1 = descr s1 in
353      (is_empty accu1) ||      (is_empty accu1) ||
354      (try aux accu1 (diff any (descr s2)) left; true with NotEmpty -> false)      (try aux accu1 (diff any (descr s2)) left; true with NotEmpty -> false)
355    in  
356    if List.exists single_right right then raise Not_found  and check_empty_arrow_line left right =
357      List.exists (check_empty_simple_arrow_line left) right
358    
359    and sample_rec_arrow_aux (left,right) =
360      if (check_empty_arrow_line left right) then raise Not_found
361    else Fun left    else Fun left
362    
363    
# Line 360  Line 369 
369    List.fold_left aux [] fields    List.fold_left aux [] fields
370    
371  let get x = sample_rec Assumptions.empty x  let get x = sample_rec Assumptions.empty x
372    
373  end  end
374    
375    
# Line 541  Line 551 
551  let normalize n =  let normalize n =
552    internalize (rec_normalize (descr n))    internalize (rec_normalize (descr n))
553    
   
 let apply t1 t2 =  
   failwith "apply: not yet implemented"  
   
   
554  module Print =  module Print =
555  struct  struct
556    let marks = Hashtbl.create 63    let marks = Hashtbl.create 63
# Line 553  Line 558 
558    let count_name = ref 0    let count_name = ref 0
559    let name () =    let name () =
560      incr count_name;      incr count_name;
561      "'a" ^ (string_of_int !count_name)      "X" ^ (string_of_int !count_name)
562    (* TODO:
563       check that these generated names does not conflict with declared types *)
564    
565    let bool_iter f b =    let bool_iter f b =
566      List.iter (fun (p,n) -> List.iter f p; List.iter f n) b      List.iter (fun (p,n) -> List.iter f p; List.iter f n) b
# Line 637  Line 644 
644      Format.fprintf ppf "@[%a" print_descr d;      Format.fprintf ppf "@[%a" print_descr d;
645      end_print ppf      end_print ppf
646    
647      let rec print_sep f sep ppf = function
648        | [] -> ()
649        | [x] -> f ppf x
650        | x::rem -> f ppf x; Format.fprintf ppf "%s" sep; print_sep f sep ppf rem
651    
652    
653      let rec print_sample ppf = function
654        | Sample.Int i -> Format.fprintf ppf "%i" i
655        | Sample.Atom a -> Format.fprintf ppf "`%s" (atom_name a)
656        | Sample.String s -> Format.fprintf ppf "%S" s
657        | Sample.Pair (x1,x2) ->
658            Format.fprintf ppf "(%a,%a)"
659            print_sample x1
660            print_sample x2
661        | Sample.Record r ->
662            Format.fprintf ppf "{ %a }"
663              (print_sep
664                 (fun ppf (l,x) ->
665                    Format.fprintf ppf "%s = %a"
666                    (label_name l)
667                    print_sample x
668                 )
669                 " ; "
670              ) r
671        | Sample.Fun iface ->
672            Format.fprintf ppf "(fun ( %a ) x -> ...)"
673              (print_sep
674                 (fun ppf (t1,t2) ->
675                    Format.fprintf ppf "%a -> %a; "
676                    print t1 print t2
677                 )
678                 " ; "
679              ) iface
680    end
681    
682    module Arrow =
683    struct
684      type t = descr * (descr * descr) list list
685    
686      let get t =
687        List.fold_left
688          (fun ((dom,arr) as accu) (left,right) ->
689             if Sample.check_empty_arrow_line left right
690             then accu
691             else (
692               let left =
693                 List.map
694                   (fun (t,s) -> (descr t, descr s)) left in
695               let d = List.fold_left (fun d (t,_) -> cup d t) empty left in
696               (cap dom d, left :: arr)
697             )
698          )
699          (any, [])
700          t.arrow
701    
702      let domain (dom,_) = dom
703    
704      let apply_simple t result left =
705        let rec aux result accu1 accu2 = function
706          | (t1,s1)::left ->
707              let result =
708                let accu1 = diff accu1 t1 in
709                if non_empty accu1 then aux result accu1 accu2 left
710                else result in
711              let result =
712                let accu2 = cap accu2 s1 in
713                aux result accu1 accu2 left in
714              result
715          | [] ->
716              if subtype accu2 result
717              then result
718              else cup result accu2
719        in
720        aux result t any left
721    
722      let apply (_,arr) t =
723        List.fold_left (apply_simple t) empty arr
724    
725      let any = { empty with arrow = any.arrow }
726  end  end
727    
728    
729    
730  (*  (*
731  let rec print_normal_record ppf = function  let rec print_normal_record ppf = function
732    | Success -> Format.fprintf ppf "Yes"    | Success -> Format.fprintf ppf "Yes"
Legend:
Removed from v.6  
changed lines
  Added in v.11
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5