| 551 |
let normalize n = |
let normalize n = |
| 552 |
internalize (rec_normalize (descr n)) |
internalize (rec_normalize (descr n)) |
| 553 |
|
|
|
let apply_simple result left t = |
|
|
let ok = ref false in |
|
|
let rec aux result accu1 accu2 = function |
|
|
| (t1,s1)::left -> |
|
|
let result = |
|
|
let accu1 = diff_t accu1 t1 in |
|
|
if non_empty accu1 then aux result accu1 accu2 left |
|
|
else (ok := true; result) in |
|
|
let result = |
|
|
let accu2 = cap_t accu2 s1 in |
|
|
aux result accu1 accu2 left in |
|
|
result |
|
|
| [] -> |
|
|
if subtype accu2 result |
|
|
then result |
|
|
else cup result accu2 |
|
|
in |
|
|
let result = aux result t any left in |
|
|
if !ok then result else raise Not_found |
|
|
|
|
|
let apply t1 t2 = |
|
|
if is_empty t2 |
|
|
then empty |
|
|
else |
|
|
if non_empty {t1 with arrow = []} |
|
|
then raise Not_found |
|
|
else |
|
|
List.fold_left |
|
|
(fun accu (left,right) -> |
|
|
if Sample.check_empty_arrow_line left right |
|
|
then accu |
|
|
else |
|
|
apply_simple accu left t2 |
|
|
) |
|
|
empty |
|
|
t1.arrow |
|
|
|
|
|
|
|
| 554 |
module Print = |
module Print = |
| 555 |
struct |
struct |
| 556 |
let marks = Hashtbl.create 63 |
let marks = Hashtbl.create 63 |
| 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 |
| 679 |
) iface |
) iface |
| 680 |
end |
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 |
| 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" |
Parent Directory
| 
Revision Log
| 
Patch