many additions

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@5332 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

1 files changed, 102 insertions, 0 deletions

diff --git a/testlabl/multimatch.ml b/testlabl/multimatch.ml
index b0f36e3f3..254a1b326 100644
--- a/testlabl/multimatch.ml
+++ b/testlabl/multimatch.ml
@@ -1,3 +1,4 @@
+(* Simple example *)
 let f x =
   (multimatch x with `A -> 1 | `B -> true),
   (multimatch x with `A -> 1. | `B -> "1");;
@@ -15,6 +16,7 @@ module M : sig
 end = struct let f = f end;;
 
 
+(* Two-level example *)
 let f = multifun
     `A -> (multifun `C -> 1 | `D -> 1.)
   | `B -> (multifun `C -> true | `D -> "1");;
@@ -32,3 +34,103 @@ module M : sig
     [< `A & 'b = [< `C & 'a = int | `D & 'a = bool] -> 'a
      | `B & 'b = [< `C & 'c = bool | `D & 'c = string] -> 'c] -> 'b
 end = struct let f = f end;;
+
+module M : sig
+  val f :
+    [< `A & 'b = [< `C & 'a = int | `D] -> 'a
+     | `B & 'b = [< `C & 'c = bool | `D & 'c = string] -> 'c] -> 'b
+end = struct let f = f end;;
+
+
+(* Examples with hidden sharing *)
+let r = ref []
+let f = multifun `A -> 1 | `B -> true
+let g x = r := [f x];;
+
+(* Bad! *)
+module M : sig
+  val g : [< `A & 'a = int | `B & 'a = bool] -> unit
+end = struct let g = g end;;
+
+let r = ref []
+let f = multifun `A -> r | `B -> ref [];;
+(* Bad *)
+module M : sig
+  val f : [< `A & 'b = int list ref | `B & 'b = 'c list ref] -> 'b
+end = struct let f = f end;;
+(* OK *)
+let l : int list = r;;
+module M : sig
+  val f : [< `A & 'b = int list ref | `B & 'b = 'c list ref] -> 'b
+end = struct let f = f end;;
+
+
+(* Examples that would need unification *)
+let f = multifun `A -> (1, []) | `B -> (true, [])
+let g x = fst (f x);;
+(* Should work, but doesn't... *)
+module M : sig
+  val g : [< `A & 'a * 'b = int * bool | `B & 'a * 'b = bool * int] -> 'a
+end = struct let g = g end;;
+let g = multifun (`A|`B) as x -> g x;;
+
+(* Other examples *)
+
+let f x =
+  let a = multimatch x with `A -> 1 | `B -> "1" in
+  (multifun `A -> print_int | `B -> print_string) x a
+;;
+
+let f = multifun (`A|`B) as x -> f x;;
+
+type unit_op = [`Set of int | `Move of int]
+type int_op = [`Get]
+
+let op r =
+  multifun
+    `Get     -> !r
+  | `Set x   -> r := x
+  | `Move dx -> r := !r + dx
+;;
+
+let rec trace r = function
+    [] -> []
+  | op1 :: ops ->
+      multimatch op1 with
+        #int_op as op1 ->
+          let x = op r op1 in
+          x :: trace r ops
+      | #unit_op as op1 ->
+          op r op1;
+          trace r ops
+;;
+
+class point x = object
+  val mutable x : int = x
+  method get = x
+  method set y = x <- y
+  method move dx = x <- x + dx
+end;;
+
+let poly sort coeffs x =
+  let add, mul, zero =
+    multimatch sort with
+      `Int -> (+), ( * ), 0
+    | `Float -> (+.), ( *. ), 0.
+  in
+  let rec compute = function
+      []     -> zero
+    | c :: cs -> add c (mul x (compute cs))
+  in
+  compute coeffs
+;;
+
+module M : sig
+  val poly : [< `Int & 'a = int | `Float & 'a = float] -> 'a list -> 'a -> 'a
+end = struct let poly = poly end;;
+
+type ('a,'b) num_sort =
+  'b constraint 'b = [< `Int & 'a = int | `Float & 'a = float]
+module M : sig
+  val poly : ('a,_) num_sort -> 'a list -> 'a -> 'a
+end = struct let poly = poly end;;