/[svn]/types/types.ml

Diff of /types/types.ml

Parent Directory | Revision Log | View Patch Patch

-revision 9 by abate,
Tue Jul 10 16:57:14 2007 UTC
+revision 10 by abate,
Tue Jul 10 16:57:27 2007 UTC
 Line 340
  and sample_rec_arrow c =
    find sample_rec_arrow_aux c
- and sample_rec_arrow_aux (left,right) =
+ and check_empty_simple_arrow_line left (s1,s2) =
-   let single_right (s1,s2) =
      let rec aux accu1 accu2 = function
        | (t1,t2)::left ->
            let accu1' = diff_t accu1 t1 in
-Line 353
+Line 352
      let accu1 = descr s1 in
      (is_empty accu1) ||
      (try aux accu1 (diff any (descr s2)) left; true with NotEmpty -> false)
-   in
-   if List.exists single_right right then raise Not_found
+ and check_empty_arrow_line left right =
+   List.exists (check_empty_simple_arrow_line left) right
+ and sample_rec_arrow_aux (left,right) =
+   if (check_empty_arrow_line left right) then raise Not_found
    else Fun left
-Line 366
+Line 369
    List.fold_left aux [] fields
  let get x = sample_rec Assumptions.empty x
  end
-Line 547
+Line 551
  let normalize n =
    internalize (rec_normalize (descr n))
+ 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 =
-   failwith "apply: not yet implemented"
+   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
  module Print =
-Line 643
+Line 680
      Format.fprintf ppf "@[%a" print_descr d;
      end_print ppf
+   let rec print_sep f sep ppf = function
+     | [] -> ()
+     | [x] -> f ppf x
+     | x::rem -> f ppf x; Format.fprintf ppf "%s" sep; print_sep f sep ppf rem
+   let rec print_sample ppf = function
+     | Sample.Int i -> Format.fprintf ppf "%i" i
+     | Sample.Atom a -> Format.fprintf ppf "`%s" (atom_name a)
+     | Sample.String s -> Format.fprintf ppf "%S" s
+     | Sample.Pair (x1,x2) ->
+         Format.fprintf ppf "(%a,%a)"
+         print_sample x1
+         print_sample x2
+     | Sample.Record r ->
+         Format.fprintf ppf "{ %a }"
+           (print_sep
+              (fun ppf (l,x) ->
+                 Format.fprintf ppf "%s = %a"
+                 (label_name l)
+                 print_sample x
+              )
+              " ; "
+           ) r
+     | Sample.Fun iface ->
+         Format.fprintf ppf "(fun ( %a ) x -> ...)"
+           (print_sep
+              (fun ppf (t1,t2) ->
+                 Format.fprintf ppf "%a -> %a; "
+                 print t1 print t2
+              )
+              " ; "
+           ) iface
  end
  (*

 Legend:



Removed from v.9
 


changed lines


 
Added in v.10
 Legend:



Removed from v.9
 


changed lines


 
Added in v.10
-Removed from v.9
+Added in v.10

CVS Admin">CVS Admin	ViewVC Help
Powered by ViewVC 1.1.5