summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorXavier Clerc <xavier.clerc@inria.fr>2011-07-21 07:53:50 +0000
committerXavier Clerc <xavier.clerc@inria.fr>2011-07-21 07:53:50 +0000
commitefb3949fef3374ac03996143143ee2a36643e5b7 (patch)
treebf71414741cc5e16938b8f93268799c36bb97dc0
parent920096846e70d56ca04507a9354482c8a1c254d0 (diff)
'testlabl' renamed to 'experimental/garrigue'.
git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@11140 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
Diffstat
-rw-r--r--experimental/garrigue/.cvsignore1
-rw-r--r--experimental/garrigue/coerce.diffs93
-rw-r--r--experimental/garrigue/dirs_multimatch1
-rw-r--r--experimental/garrigue/dirs_poly1
-rw-r--r--experimental/garrigue/fixedtypes.ml77
-rw-r--r--experimental/garrigue/marshal_objects.diffs800
-rw-r--r--experimental/garrigue/multimatch.diffs1418
-rw-r--r--experimental/garrigue/multimatch.ml158
-rw-r--r--experimental/garrigue/newlabels.ps1458
-rw-r--r--experimental/garrigue/objvariant.diffs354
-rw-r--r--experimental/garrigue/objvariant.ml42
-rw-r--r--experimental/garrigue/printers.ml11
-rw-r--r--experimental/garrigue/tests.ml22
-rw-r--r--experimental/garrigue/valvirt.diffs2349
-rw-r--r--experimental/garrigue/varunion.ml435
15 files changed, 7220 insertions, 0 deletions
diff --git a/experimental/garrigue/.cvsignore b/experimental/garrigue/.cvsignore
new file mode 100644
index 000000000..4c57147b3
--- /dev/null
+++ b/experimental/garrigue/.cvsignore
@@ -0,0 +1 @@
+*.out *.out2 \ No newline at end of file
diff --git a/experimental/garrigue/coerce.diffs b/experimental/garrigue/coerce.diffs
new file mode 100644
index 000000000..e90e1fc93
--- /dev/null
+++ b/experimental/garrigue/coerce.diffs
@@ -0,0 +1,93 @@
+Index: typing/ctype.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.ml,v
+retrieving revision 1.201
+diff -u -r1.201 ctype.ml
+--- typing/ctype.ml 5 Apr 2006 02:28:13 -0000 1.201
++++ typing/ctype.ml 17 May 2006 23:48:22 -0000
+@@ -490,6 +490,31 @@
+ unmark_class_signature sign;
+ Some reason
+
++(* Variant for checking principality *)
++
++let rec free_nodes_rec ty =
++ let ty = repr ty in
++ if ty.level >= lowest_level then begin
++ if ty.level <= !current_level then raise Exit;
++ ty.level <- pivot_level - ty.level;
++ begin match ty.desc with
++ Tvar ->
++ raise Exit
++ | Tobject (ty, _) ->
++ free_nodes_rec ty
++ | Tfield (_, _, ty1, ty2) ->
++ free_nodes_rec ty1; free_nodes_rec ty2
++ | Tvariant row ->
++ let row = row_repr row in
++ iter_row free_nodes_rec {row with row_bound = []};
++ if not (static_row row) then free_nodes_rec row.row_more
++ | _ ->
++ iter_type_expr free_nodes_rec ty
++ end;
++ end
++
++let has_free_nodes ty =
++ try free_nodes_rec ty; false with Exit -> true
+
+ (**********************)
+ (* Type duplication *)
+Index: typing/ctype.mli
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.mli,v
+retrieving revision 1.54
+diff -u -r1.54 ctype.mli
+--- typing/ctype.mli 5 Apr 2006 02:28:13 -0000 1.54
++++ typing/ctype.mli 17 May 2006 23:48:22 -0000
+@@ -228,6 +228,9 @@
+ val closed_class:
+ type_expr list -> class_signature -> closed_class_failure option
+ (* Check whether all type variables are bound *)
++val has_free_nodes: type_expr -> bool
++ (* Check whether there are free type variables, or nodes with
++ level lower or equal to !current_level *)
+
+ val unalias: type_expr -> type_expr
+ val signature_of_class_type: class_type -> class_signature
+Index: typing/typecore.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/typecore.ml,v
+retrieving revision 1.181
+diff -u -r1.181 typecore.ml
+--- typing/typecore.ml 16 Apr 2006 23:28:22 -0000 1.181
++++ typing/typecore.ml 17 May 2006 23:48:22 -0000
+@@ -1183,12 +1183,29 @@
+ let (ty', force) =
+ Typetexp.transl_simple_type_delayed env sty'
+ in
++ if !Clflags.principal then begin_def ();
+ let arg = type_exp env sarg in
++ let has_fv =
++ if !Clflags.principal then begin
++ end_def ();
++ let b = has_free_nodes arg.exp_type in
++ Ctype.unify env arg.exp_type (newvar ());
++ b
++ end else
++ free_variables arg.exp_type <> []
++ in
+ begin match arg.exp_desc, !self_coercion, (repr ty').desc with
+ Texp_ident(_, {val_kind=Val_self _}), (path,r) :: _,
+ Tconstr(path',_,_) when Path.same path path' ->
+ r := sexp.pexp_loc :: !r;
+ force ()
++ | _ when not has_fv ->
++ begin try
++ let force' = subtype env arg.exp_type ty' in
++ force (); force' ()
++ with Subtype (tr1, tr2) ->
++ raise(Error(sexp.pexp_loc, Not_subtype(tr1, tr2)))
++ end
+ | _ ->
+ let ty, b = enlarge_type env ty' in
+ force ();
diff --git a/experimental/garrigue/dirs_multimatch b/experimental/garrigue/dirs_multimatch
new file mode 100644
index 000000000..b44951464
--- /dev/null
+++ b/experimental/garrigue/dirs_multimatch
@@ -0,0 +1 @@
+parsing typing bytecomp driver toplevel \ No newline at end of file
diff --git a/experimental/garrigue/dirs_poly b/experimental/garrigue/dirs_poly
new file mode 100644
index 000000000..3aec606ed
--- /dev/null
+++ b/experimental/garrigue/dirs_poly
@@ -0,0 +1 @@
+bytecomp byterun driver parsing stdlib tools toplevel typing utils otherlibs/labltk/browser/searchpos.ml
diff --git a/experimental/garrigue/fixedtypes.ml b/experimental/garrigue/fixedtypes.ml
new file mode 100644
index 000000000..a7d7ca4ae
--- /dev/null
+++ b/experimental/garrigue/fixedtypes.ml
@@ -0,0 +1,77 @@
+(* cvs update -r fixedtypes parsing typing *)
+
+(* recursive types *)
+class c = object (self) method m = 1 method s = self end
+module type S = sig type t = private #c end;;
+
+module M : S = struct type t = c end
+module type S' = S with type t = c;;
+
+class d = object inherit c method n = 2 end
+module type S2 = S with type t = private #d;;
+module M2 : S = struct type t = d end;;
+module M3 : S = struct type t = private #d end;;
+
+module T1 = struct
+ type ('a,'b) a = [`A of 'a | `B of 'b]
+ type ('a,'b) b = [`Z | ('a,'b) a]
+end
+module type T2 = sig
+ type a and b
+ val evala : a -> int
+ val evalb : b -> int
+end
+module type T3 = sig
+ type a0 = private [> (a0,b0) T1.a]
+ and b0 = private [> (a0,b0) T1.b]
+end
+module type T4 = sig
+ include T3
+ include T2 with type a = a0 and type b = b0
+end
+module F(X:T4) = struct
+ type a = X.a and b = X.b
+ let a = X.evala (`B `Z)
+ let b = X.evalb (`A(`B `Z))
+ let a2b (x : a) : b = `A x
+ let b2a (x : b) : a = `B x
+end
+module M4 = struct
+ type a = [`A of a | `B of b | `ZA]
+ and b = [`A of a | `B of b | `Z]
+ type a0 = a
+ type b0 = b
+ let rec eval0 = function
+ `A a -> evala a
+ | `B b -> evalb b
+ and evala : a -> int = function
+ #T1.a as x -> 1 + eval0 x
+ | `ZA -> 3
+ and evalb : b -> int = function
+ #T1.a as x -> 1 + eval0 x
+ | `Z -> 7
+end
+module M5 = F(M4)
+
+module M6 : sig
+ class ci : int ->
+ object
+ val x : int
+ method x : int
+ method move : int -> unit
+ end
+ type c = private #ci
+ val create : int -> c
+end = struct
+ class ci x = object
+ val mutable x : int = x
+ method x = x
+ method move d = x <- x+d
+ end
+ type c = ci
+ let create = new ci
+end
+let f (x : M6.c) = x#move 3; x#x;;
+
+module M : sig type t = private [> `A of bool] end =
+ struct type t = [`A of int] end
diff --git a/experimental/garrigue/marshal_objects.diffs b/experimental/garrigue/marshal_objects.diffs
new file mode 100644
index 000000000..bb9b4dd71
--- /dev/null
+++ b/experimental/garrigue/marshal_objects.diffs
@@ -0,0 +1,800 @@
+? bytecomp/alpha_eq.ml
+Index: bytecomp/lambda.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/lambda.ml,v
+retrieving revision 1.44
+diff -u -r1.44 lambda.ml
+--- bytecomp/lambda.ml 25 Aug 2005 15:35:16 -0000 1.44
++++ bytecomp/lambda.ml 2 Feb 2006 05:08:56 -0000
+@@ -287,9 +287,10 @@
+ let compare = compare
+ end)
+
+-let free_ids get l =
++let free_ids get used l =
+ let fv = ref IdentSet.empty in
+ let rec free l =
++ let old = !fv in
+ iter free l;
+ fv := List.fold_right IdentSet.add (get l) !fv;
+ match l with
+@@ -307,17 +308,20 @@
+ fv := IdentSet.remove v !fv
+ | Lassign(id, e) ->
+ fv := IdentSet.add id !fv
++ | Lifused(id, e) ->
++ if used && not (IdentSet.mem id old) then fv := IdentSet.remove id !fv
+ | Lvar _ | Lconst _ | Lapply _
+ | Lprim _ | Lswitch _ | Lstaticraise _
+ | Lifthenelse _ | Lsequence _ | Lwhile _
+- | Lsend _ | Levent _ | Lifused _ -> ()
++ | Lsend _ | Levent _ -> ()
+ in free l; !fv
+
+-let free_variables l =
+- free_ids (function Lvar id -> [id] | _ -> []) l
++let free_variables ?(ifused=false) l =
++ free_ids (function Lvar id -> [id] | _ -> []) ifused l
+
+ let free_methods l =
+- free_ids (function Lsend(Self, Lvar meth, obj, _) -> [meth] | _ -> []) l
++ free_ids (function Lsend(Self, Lvar meth, obj, _) -> [meth] | _ -> [])
++ false l
+
+ (* Check if an action has a "when" guard *)
+ let raise_count = ref 0
+Index: bytecomp/lambda.mli
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/lambda.mli,v
+retrieving revision 1.42
+diff -u -r1.42 lambda.mli
+--- bytecomp/lambda.mli 25 Aug 2005 15:35:16 -0000 1.42
++++ bytecomp/lambda.mli 2 Feb 2006 05:08:56 -0000
+@@ -177,7 +177,7 @@
+
+ val iter: (lambda -> unit) -> lambda -> unit
+ module IdentSet: Set.S with type elt = Ident.t
+-val free_variables: lambda -> IdentSet.t
++val free_variables: ?ifused:bool -> lambda -> IdentSet.t
+ val free_methods: lambda -> IdentSet.t
+
+ val transl_path: Path.t -> lambda
+Index: bytecomp/translclass.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translclass.ml,v
+retrieving revision 1.38
+diff -u -r1.38 translclass.ml
+--- bytecomp/translclass.ml 13 Aug 2005 20:59:37 -0000 1.38
++++ bytecomp/translclass.ml 2 Feb 2006 05:08:56 -0000
+@@ -46,6 +46,10 @@
+
+ let lfield v i = Lprim(Pfield i, [Lvar v])
+
++let ltuple l = Lprim(Pmakeblock(0,Immutable), l)
++
++let lprim name args = Lapply(oo_prim name, args)
++
+ let transl_label l = share (Const_immstring l)
+
+ let rec transl_meth_list lst =
+@@ -68,8 +72,8 @@
+ Lvar offset])])]))
+
+ let transl_val tbl create name =
+- Lapply (oo_prim (if create then "new_variable" else "get_variable"),
+- [Lvar tbl; transl_label name])
++ lprim (if create then "new_variable" else "get_variable")
++ [Lvar tbl; transl_label name]
+
+ let transl_vals tbl create vals rem =
+ List.fold_right
+@@ -82,7 +86,7 @@
+ (fun (nm, id) rem ->
+ try
+ (nm, id,
+- Lapply(oo_prim "get_method", [Lvar tbl; Lvar (Meths.find nm meths)]))
++ lprim "get_method" [Lvar tbl; Lvar (Meths.find nm meths)])
+ :: rem
+ with Not_found -> rem)
+ inh_meths []
+@@ -97,17 +101,15 @@
+ let (inh_init, obj_init, has_init) = init obj' in
+ if obj_init = lambda_unit then
+ (inh_init,
+- Lapply (oo_prim (if has_init then "create_object_and_run_initializers"
+- else"create_object_opt"),
+- [obj; Lvar cl]))
++ lprim (if has_init then "create_object_and_run_initializers"
++ else"create_object_opt")
++ [obj; Lvar cl])
+ else begin
+ (inh_init,
+- Llet(Strict, obj',
+- Lapply (oo_prim "create_object_opt", [obj; Lvar cl]),
++ Llet(Strict, obj', lprim "create_object_opt" [obj; Lvar cl],
+ Lsequence(obj_init,
+ if not has_init then Lvar obj' else
+- Lapply (oo_prim "run_initializers_opt",
+- [obj; Lvar obj'; Lvar cl]))))
++ lprim "run_initializers_opt" [obj; Lvar obj'; Lvar cl])))
+ end
+
+ let rec build_object_init cl_table obj params inh_init obj_init cl =
+@@ -203,14 +205,13 @@
+
+
+ let bind_method tbl lab id cl_init =
+- Llet(StrictOpt, id, Lapply (oo_prim "get_method_label",
+- [Lvar tbl; transl_label lab]),
++ Llet(StrictOpt, id, lprim "get_method_label" [Lvar tbl; transl_label lab],
+ cl_init)
+
+-let bind_methods tbl meths vals cl_init =
+- let methl = Meths.fold (fun lab id tl -> (lab,id) :: tl) meths [] in
++let bind_methods tbl methl vals cl_init =
+ let len = List.length methl and nvals = List.length vals in
+- if len < 2 && nvals = 0 then Meths.fold (bind_method tbl) meths cl_init else
++ if len < 2 && nvals = 0 then
++ List.fold_right (fun (n,i) -> bind_method tbl n i) methl cl_init else
+ if len = 0 && nvals < 2 then transl_vals tbl true vals cl_init else
+ let ids = Ident.create "ids" in
+ let i = ref len in
+@@ -229,21 +230,19 @@
+ vals' cl_init)
+ in
+ Llet(StrictOpt, ids,
+- Lapply (oo_prim getter,
+- [Lvar tbl; transl_meth_list (List.map fst methl)] @ names),
++ lprim getter
++ ([Lvar tbl; transl_meth_list (List.map fst methl)] @ names),
+ List.fold_right
+- (fun (lab,id) lam -> decr i; Llet(StrictOpt, id, lfield ids !i, lam))
++ (fun (lab,id) lam -> decr i; Llet(Alias, id, lfield ids !i, lam))
+ methl cl_init)
+
+ let output_methods tbl methods lam =
+ match methods with
+ [] -> lam
+ | [lab; code] ->
+- lsequence (Lapply(oo_prim "set_method", [Lvar tbl; lab; code])) lam
++ lsequence (lprim "set_method" [Lvar tbl; lab; code]) lam
+ | _ ->
+- lsequence (Lapply(oo_prim "set_methods",
+- [Lvar tbl; Lprim(Pmakeblock(0,Immutable), methods)]))
+- lam
++ lsequence (lprim "set_methods" [Lvar tbl; ltuple methods]) lam
+
+ let rec ignore_cstrs cl =
+ match cl.cl_desc with
+@@ -266,7 +265,8 @@
+ Llet (Strict, obj_init,
+ Lapply(Lprim(Pfield 1, [lpath]), Lvar cla ::
+ if top then [Lprim(Pfield 3, [lpath])] else []),
+- bind_super cla super cl_init))
++ bind_super cla super cl_init),
++ [], [])
+ | _ ->
+ assert false
+ end
+@@ -278,10 +278,11 @@
+ match field with
+ Cf_inher (cl, vals, meths) ->
+ let cl_init = output_methods cla methods cl_init in
+- let inh_init, cl_init =
++ let (inh_init, cl_init, meths', vals') =
+ build_class_init cla false
+ (vals, meths_super cla str.cl_meths meths)
+ inh_init cl_init msubst top cl in
++ let cl_init = bind_methods cla meths' vals' cl_init in
+ (inh_init, cl_init, [], values)
+ | Cf_val (name, id, exp) ->
+ (inh_init, cl_init, methods, (name, id)::values)
+@@ -304,29 +305,37 @@
+ (inh_init, cl_init, methods, vals @ values)
+ | Cf_init exp ->
+ (inh_init,
+- Lsequence(Lapply (oo_prim "add_initializer",
+- Lvar cla :: msubst false (transl_exp exp)),
++ Lsequence(lprim "add_initializer"
++ (Lvar cla :: msubst false (transl_exp exp)),
+ cl_init),
+ methods, values))
+ str.cl_field
+ (inh_init, cl_init, [], [])
+ in
+ let cl_init = output_methods cla methods cl_init in
+- (inh_init, bind_methods cla str.cl_meths values cl_init)
++ (* inh_init, bind_methods cla str.cl_meths values cl_init *)
++ let methods = Meths.fold (fun n i l -> (n,i)::l) str.cl_meths [] in
++ (inh_init, cl_init, methods, values)
+ | Tclass_fun (pat, vals, cl, _) ->
+- let (inh_init, cl_init) =
++ let (inh_init, cl_init, methods, values) =
+ build_class_init cla cstr super inh_init cl_init msubst top cl
+ in
++ let fv = free_variables ~ifused:true cl_init in
++ let vals = List.filter (fun (id,_) -> IdentSet.mem id fv) vals in
+ let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in
+- (inh_init, transl_vals cla true vals cl_init)
++ (* inh_init, transl_vals cla true vals cl_init *)
++ (inh_init, cl_init, methods, vals @ values)
+ | Tclass_apply (cl, exprs) ->
+ build_class_init cla cstr super inh_init cl_init msubst top cl
+ | Tclass_let (rec_flag, defs, vals, cl) ->
+- let (inh_init, cl_init) =
++ let (inh_init, cl_init, methods, values) =
+ build_class_init cla cstr super inh_init cl_init msubst top cl
+ in
++ let fv = free_variables ~ifused:true cl_init in
++ let vals = List.filter (fun (id,_) -> IdentSet.mem id fv) vals in
+ let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in
+- (inh_init, transl_vals cla true vals cl_init)
++ (* inh_init, transl_vals cla true vals cl_init *)
++ (inh_init, cl_init, methods, vals @ values)
+ | Tclass_constraint (cl, vals, meths, concr_meths) ->
+ let virt_meths =
+ List.filter (fun lab -> not (Concr.mem lab concr_meths)) meths in
+@@ -358,23 +367,34 @@
+ cl_init valids in
+ (inh_init,
+ Llet (Strict, inh,
+- Lapply(oo_prim "inherits", narrow_args @
+- [lpath; Lconst(Const_pointer(if top then 1 else 0))]),
++ lprim "inherits"
++ (narrow_args @
++ [lpath; Lconst(Const_pointer(if top then 1 else 0))]),
+ Llet(StrictOpt, obj_init, lfield inh 0,
+ Llet(Alias, inh_vals, lfield inh 1,
+- Llet(Alias, inh_meths, lfield inh 2, cl_init)))))
++ Llet(Alias, inh_meths, lfield inh 2, cl_init)))),
++ [], [])
+ | _ ->
+ let core cl_init =
+ build_class_init cla true super inh_init cl_init msubst top cl
+ in
+ if cstr then core cl_init else
+- let (inh_init, cl_init) =
+- core (Lsequence (Lapply (oo_prim "widen", [Lvar cla]), cl_init))
++ let (inh_init, cl_init, methods, values) =
++ core (Lsequence (lprim "widen" [Lvar cla], cl_init))
+ in
+- (inh_init,
+- Lsequence(Lapply (oo_prim "narrow", narrow_args), cl_init))
++ let cl_init = bind_methods cla methods values cl_init in
++ (inh_init, Lsequence(lprim "narrow" narrow_args, cl_init), [], [])
+ end
+
++let build_class_init cla env inh_init obj_init msubst top cl =
++ let inh_init = List.rev inh_init in
++ let (inh_init, cl_init, methods, values) =
++ build_class_init cla true ([],[]) inh_init obj_init msubst top cl in
++ assert (inh_init = []);
++ if IdentSet.mem env (free_variables ~ifused:true cl_init)
++ then bind_methods cla methods (("", env) :: values) cl_init
++ else Llet(Alias, env, lambda_unit, bind_methods cla methods values cl_init)
++
+ let rec build_class_lets cl =
+ match cl.cl_desc with
+ Tclass_let (rec_flag, defs, vals, cl) ->
+@@ -459,16 +479,16 @@
+ Strict, new_init, lfunction [obj_init] obj_init',
+ Llet(
+ Alias, cla, transl_path path,
+- Lprim(Pmakeblock(0, Immutable),
+- [Lapply(Lvar new_init, [lfield cla 0]);
+- lfunction [table]
+- (Llet(Strict, env_init,
+- Lapply(lfield cla 1, [Lvar table]),
+- lfunction [envs]
+- (Lapply(Lvar new_init,
+- [Lapply(Lvar env_init, [Lvar envs])]))));
+- lfield cla 2;
+- lfield cla 3])))
++ ltuple
++ [Lapply(Lvar new_init, [lfield cla 0]);
++ lfunction [table]
++ (Llet(Strict, env_init,
++ Lapply(lfield cla 1, [Lvar table]),
++ lfunction [envs]
++ (Lapply(Lvar new_init,
++ [Lapply(Lvar env_init, [Lvar envs])]))));
++ lfield cla 2;
++ lfield cla 3]))
+ with Exit ->
+ lambda_unit
+
+@@ -541,7 +561,7 @@
+ open CamlinternalOO
+ let builtin_meths arr self env env2 body =
+ let builtin, args = builtin_meths self env env2 body in
+- if not arr then [Lapply(oo_prim builtin, args)] else
++ if not arr then [lprim builtin args] else
+ let tag = match builtin with
+ "get_const" -> GetConst
+ | "get_var" -> GetVar
+@@ -599,7 +619,8 @@
+
+ (* Prepare for heavy environment handling *)
+ let tables = Ident.create (Ident.name cl_id ^ "_tables") in
+- let (top_env, req) = oo_add_class tables in
++ let table_init = ref None in
++ let (top_env, req) = oo_add_class tables table_init in
+ let top = not req in
+ let cl_env, llets = build_class_lets cl in
+ let new_ids = if top then [] else Env.diff top_env cl_env in
+@@ -633,6 +654,7 @@
+ begin try
+ (* Doesn't seem to improve size for bytecode *)
+ (* if not !Clflags.native_code then raise Not_found; *)
++ if !Clflags.debug then raise Not_found;
+ builtin_meths arr [self] env env2 (lfunction args body')
+ with Not_found ->
+ [lfunction (self :: args)
+@@ -665,15 +687,8 @@
+ build_object_init_0 cla [] cl copy_env subst_env top ids in
+ if not (Translcore.check_recursive_lambda ids obj_init) then
+ raise(Error(cl.cl_loc, Illegal_class_expr));
+- let inh_init' = List.rev inh_init in
+- let (inh_init', cl_init) =
+- build_class_init cla true ([],[]) inh_init' obj_init msubst top cl
+- in
+- assert (inh_init' = []);
+- let table = Ident.create "table"
+- and class_init = Ident.create (Ident.name cl_id ^ "_init")
+- and env_init = Ident.create "env_init"
+- and obj_init = Ident.create "obj_init" in
++ let cl_init = build_class_init cla env2 inh_init obj_init msubst top cl in
++ let obj_init = Ident.create "obj_init" in
+ let pub_meths =
+ List.sort
+ (fun s s' -> compare (Btype.hash_variant s) (Btype.hash_variant s'))
+@@ -685,42 +700,44 @@
+ let name' = List.assoc tag rev_map in
+ if name' <> name then raise(Error(cl.cl_loc, Tags(name, name'))))
+ tags pub_meths;
++ let pos = cl.cl_loc.Location.loc_end in
++ let filepos = [transl_label pos.Lexing.pos_fname;
++ Lconst(Const_base(Const_int pos.Lexing.pos_cnum))] in
+ let ltable table lam =
+- Llet(Strict, table,
+- Lapply (oo_prim "create_table", [transl_meth_list pub_meths]), lam)
++ Llet(Strict, table, lprim "create_table" [transl_meth_list pub_meths], lam)
+ and ldirect obj_init =
+ Llet(Strict, obj_init, cl_init,
+- Lsequence(Lapply (oo_prim "init_class", [Lvar cla]),
++ Lsequence(lprim "init_class_shared" (Lvar cla :: filepos),
+ Lapply(Lvar obj_init, [lambda_unit])))
+ in
+ (* Simplest case: an object defined at toplevel (ids=[]) *)
+ if top && ids = [] then llets (ltable cla (ldirect obj_init)) else
+
++ let table = Ident.create "table"
++ and class_init = Ident.create (Ident.name cl_id ^ "_init")
++ and env_init = Ident.create (Ident.name cl_id ^ "_env_init") in
++ let cl_init_fun = Lfunction(Curried, [cla], cl_init) in
+ let concrete =
+ ids = [] ||
+ Typeclass.virtual_methods (Ctype.signature_of_class_type cl.cl_type) = []
+- and lclass lam =
+- let cl_init = llets (Lfunction(Curried, [cla], cl_init)) in
++ and lclass cl_init lam =
+ Llet(Strict, class_init, cl_init, lam (free_variables cl_init))
+ and lbody fv =
+ if List.for_all (fun id -> not (IdentSet.mem id fv)) ids then
+- Lapply (oo_prim "make_class",[transl_meth_list pub_meths;
+- Lvar class_init])
++ lprim "make_class"
++ (transl_meth_list pub_meths :: Lvar class_init :: filepos)
+ else
+ ltable table (
+ Llet(
+ Strict, env_init, Lapply(Lvar class_init, [Lvar table]),
+- Lsequence(
+- Lapply (oo_prim "init_class", [Lvar table]),
+- Lprim(Pmakeblock(0, Immutable),
+- [Lapply(Lvar env_init, [lambda_unit]);
+- Lvar class_init; Lvar env_init; lambda_unit]))))
++ Lsequence(lprim "init_class_shared" (Lvar table :: filepos),
++ ltuple [Lapply(Lvar env_init, [lambda_unit]);
++ Lvar class_init; Lvar env_init; lambda_unit])))
+ and lbody_virt lenvs =
+- Lprim(Pmakeblock(0, Immutable),
+- [lambda_unit; Lfunction(Curried,[cla], cl_init); lambda_unit; lenvs])
++ ltuple [lambda_unit; cl_init_fun; lambda_unit; lenvs]
+ in
+ (* Still easy: a class defined at toplevel *)
+- if top && concrete then lclass lbody else
++ if top && concrete then lclass (llets cl_init_fun) lbody else
+ if top then llets (lbody_virt lambda_unit) else
+
+ (* Now for the hard stuff: prepare for table cacheing *)
+@@ -733,23 +750,16 @@
+ let lenv =
+ let menv =
+ if !new_ids_meths = [] then lambda_unit else
+- Lprim(Pmakeblock(0, Immutable),
+- List.map (fun id -> Lvar id) !new_ids_meths) in
++ ltuple (List.map (fun id -> Lvar id) !new_ids_meths) in
+ if !new_ids_init = [] then menv else
+- Lprim(Pmakeblock(0, Immutable),
+- menv :: List.map (fun id -> Lvar id) !new_ids_init)
++ ltuple (menv :: List.map (fun id -> Lvar id) !new_ids_init)
+ and linh_envs =
+ List.map (fun (_, p) -> Lprim(Pfield 3, [transl_path p]))
+ (List.rev inh_init)
+ in
+ let make_envs lam =
+ Llet(StrictOpt, envs,
+- (if linh_envs = [] then lenv else
+- Lprim(Pmakeblock(0, Immutable), lenv :: linh_envs)),
+- lam)
+- and def_ids cla lam =
+- Llet(StrictOpt, env2,
+- Lapply (oo_prim "new_variable", [Lvar cla; transl_label ""]),
++ (if linh_envs = [] then lenv else ltuple (lenv :: linh_envs)),
+ lam)
+ in
+ let inh_paths =
+@@ -757,46 +767,53 @@
+ (fun (_,path) -> List.mem (Path.head path) new_ids) inh_init in
+ let inh_keys =
+ List.map (fun (_,p) -> Lprim(Pfield 1, [transl_path p])) inh_paths in
+- let lclass lam =
+- Llet(Strict, class_init,
+- Lfunction(Curried, [cla], def_ids cla cl_init), lam)
++ let lclass_init lam =
++ Llet(Strict, class_init, cl_init_fun, lam)
+ and lcache lam =
+ if inh_keys = [] then Llet(Alias, cached, Lvar tables, lam) else
+- Llet(Strict, cached,
+- Lapply(oo_prim "lookup_tables",
+- [Lvar tables; Lprim(Pmakeblock(0, Immutable), inh_keys)]),
++ Llet(Strict, cached, lprim "lookup_tables" [Lvar tables; ltuple inh_keys],
+ lam)
+ and lset cached i lam =
+ Lprim(Psetfield(i, true), [Lvar cached; lam])
+ in
+- let ldirect () =
+- ltable cla
+- (Llet(Strict, env_init, def_ids cla cl_init,
+- Lsequence(Lapply (oo_prim "init_class", [Lvar cla]),
+- lset cached 0 (Lvar env_init))))
+- and lclass_virt () =
+- lset cached 0 (Lfunction(Curried, [cla], def_ids cla cl_init))
++ let ldirect prim pos =
++ ltable cla (
++ Llet(Strict, env_init, cl_init,
++ Lsequence(lprim prim (Lvar cla :: pos), Lvar env_init)))
++ and lclass_concrete cached =
++ ltuple [Lapply (lfield cached 0, [lenvs]);
++ lfield cached 1; lfield cached 0; lenvs]
+ in
++
+ llets (
+- lcache (
+- Lsequence(
+- Lifthenelse(lfield cached 0, lambda_unit,
+- if ids = [] then ldirect () else
+- if not concrete then lclass_virt () else
+- lclass (
+- Lapply (oo_prim "make_class_store",
+- [transl_meth_list pub_meths;
+- Lvar class_init; Lvar cached]))),
+ make_envs (
+- if ids = [] then Lapply(lfield cached 0, [lenvs]) else
+- Lprim(Pmakeblock(0, Immutable),
+- if concrete then
+- [Lapply(lfield cached 0, [lenvs]);
+- lfield cached 1;
+- lfield cached 0;
+- lenvs]
+- else [lambda_unit; lfield cached 0; lambda_unit; lenvs]
+- )))))
++ if inh_paths = [] && concrete then
++ if ids = [] then begin
++ table_init := Some (ldirect "init_class_shared" filepos);
++ Lapply (Lvar tables, [lenvs])
++ end else begin
++ let init =
++ lclass cl_init_fun (fun _ ->
++ lprim "make_class_env"
++ (transl_meth_list pub_meths :: Lvar class_init :: filepos))
++ in table_init := Some init;
++ lclass_concrete tables
++ end
++ else begin
++ lcache (
++ Lsequence(
++ Lifthenelse(lfield cached 0, lambda_unit,
++ if ids = [] then lset cached 0 (ldirect "init_class" []) else
++ if not concrete then lset cached 0 cl_init_fun else
++ lclass_init (
++ lprim "make_class_store"
++ [transl_meth_list pub_meths; Lvar class_init; Lvar cached])),
++ llets (
++ make_envs (
++ if ids = [] then Lapply(lfield cached 0, [lenvs]) else
++ if concrete then lclass_concrete cached else
++ ltuple [lambda_unit; lfield cached 0; lambda_unit; lenvs]))))
++ end))
+
+ (* Wrapper for class compilation *)
+
+Index: bytecomp/translobj.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translobj.ml,v
+retrieving revision 1.9
+diff -u -r1.9 translobj.ml
+--- bytecomp/translobj.ml 26 May 2004 11:10:51 -0000 1.9
++++ bytecomp/translobj.ml 2 Feb 2006 05:08:56 -0000
+@@ -88,7 +88,6 @@
+
+ (* Insert labels *)
+
+-let string s = Lconst (Const_base (Const_string s))
+ let int n = Lconst (Const_base (Const_int n))
+
+ let prim_makearray =
+@@ -124,8 +123,8 @@
+ let top_env = ref Env.empty
+ let classes = ref []
+
+-let oo_add_class id =
+- classes := id :: !classes;
++let oo_add_class id init =
++ classes := (id, init) :: !classes;
+ (!top_env, !cache_required)
+
+ let oo_wrap env req f x =
+@@ -141,10 +140,12 @@
+ let lambda = f x in
+ let lambda =
+ List.fold_left
+- (fun lambda id ->
++ (fun lambda (id, init) ->
+ Llet(StrictOpt, id,
+- Lprim(Pmakeblock(0, Mutable),
+- [lambda_unit; lambda_unit; lambda_unit]),
++ (match !init with
++ Some lam -> lam
++ | None -> Lprim(Pmakeblock(0, Mutable),
++ [lambda_unit; lambda_unit; lambda_unit])),
+ lambda))
+ lambda !classes
+ in
+Index: bytecomp/translobj.mli
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translobj.mli,v
+retrieving revision 1.6
+diff -u -r1.6 translobj.mli
+--- bytecomp/translobj.mli 26 May 2004 11:10:51 -0000 1.6
++++ bytecomp/translobj.mli 2 Feb 2006 05:08:56 -0000
+@@ -25,4 +25,4 @@
+ Ident.t -> int -> ('a -> lambda) -> 'a -> int * lambda
+
+ val oo_wrap: Env.t -> bool -> ('a -> lambda) -> 'a -> lambda
+-val oo_add_class: Ident.t -> Env.t * bool
++val oo_add_class: Ident.t -> Lambda.lambda option ref -> Env.t * bool
+Index: byterun/compare.h
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/byterun/compare.h,v
+retrieving revision 1.2
+diff -u -r1.2 compare.h
+--- byterun/compare.h 31 Dec 2003 14:20:35 -0000 1.2
++++ byterun/compare.h 2 Feb 2006 05:08:56 -0000
+@@ -17,5 +17,6 @@
+ #define CAML_COMPARE_H
+
+ CAMLextern int caml_compare_unordered;
++CAMLextern value caml_compare(value, value);
+
+ #endif /* CAML_COMPARE_H */
+Index: byterun/extern.c
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/byterun/extern.c,v
+retrieving revision 1.59
+diff -u -r1.59 extern.c
+--- byterun/extern.c 4 Jan 2006 16:55:49 -0000 1.59
++++ byterun/extern.c 2 Feb 2006 05:08:56 -0000
+@@ -411,6 +411,22 @@
+ extern_record_location(v);
+ break;
+ }
++ case Object_tag: {
++ value field0;
++ mlsize_t i;
++ i = Wosize_val(Field(v, 0)) - 1;
++ field0 = Field(Field(v, 0),i);
++ if (Wosize_val(field0) > 0) {
++ writecode32(CODE_OBJECT, Wosize_hd (hd));
++ extern_record_location(v);
++ extern_rec(field0);
++ for (i = 1; i < sz - 1; i++) extern_rec(Field(v, i));
++ v = Field(v, i);
++ goto tailcall;
++ }
++ if (!extern_closures)
++ extern_invalid_argument("output_value: dynamic class");
++ } /* may fall through */
+ default: {
+ value field0;
+ mlsize_t i;
+Index: byterun/intern.c
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/byterun/intern.c,v
+retrieving revision 1.60
+diff -u -r1.60 intern.c
+--- byterun/intern.c 22 Sep 2005 14:21:50 -0000 1.60
++++ byterun/intern.c 2 Feb 2006 05:08:56 -0000
+@@ -28,6 +28,8 @@
+ #include "mlvalues.h"
+ #include "misc.h"
+ #include "reverse.h"
++#include "callback.h"
++#include "compare.h"
+
+ static unsigned char * intern_src;
+ /* Reading pointer in block holding input data. */
+@@ -98,6 +100,25 @@
+ #define readblock(dest,len) \
+ (memmove((dest), intern_src, (len)), intern_src += (len))
+
++static value get_method_table (value key)
++{
++ static value *classes = NULL;
++ value current;
++ if (classes == NULL) {
++ classes = caml_named_value("caml_oo_classes");
++ if (classes == NULL) return 0;
++ caml_register_global_root(classes);
++ }
++ for (current = Field(*classes, 0); Is_block(current);
++ current = Field(current, 1))
++ {
++ value head = Field(current, 0);
++ if (caml_compare(key, Field(head, 0)) == Val_int(0))
++ return Field(head, 1);
++ }
++ return 0;
++}
++
+ static void intern_cleanup(void)
+ {
+ if (intern_input_malloced) caml_stat_free(intern_input);
+@@ -315,6 +336,24 @@
+ Custom_ops_val(v) = ops;
+ intern_dest += 1 + size;
+ break;
++ case CODE_OBJECT:
++ size = read32u();
++ v = Val_hp(intern_dest);
++ *dest = v;
++ if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v;
++ dest = (value *) (intern_dest + 1);
++ *intern_dest = Make_header(size, Object_tag, intern_color);
++ intern_dest += 1 + size;
++ intern_rec(dest);
++ *dest = get_method_table(*dest);
++ if (*dest == 0) {
++ intern_cleanup();
++ caml_failwith("input_value: unknown class");
++ }
++ for(size--, dest++; size > 1; size--, dest++)
++ intern_rec(dest);
++ goto tailcall;
++
+ default:
+ intern_cleanup();
+ caml_failwith("input_value: ill-formed message");
+Index: byterun/intext.h
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/byterun/intext.h,v
+retrieving revision 1.32
+diff -u -r1.32 intext.h
+--- byterun/intext.h 22 Sep 2005 14:21:50 -0000 1.32
++++ byterun/intext.h 2 Feb 2006 05:08:56 -0000
+@@ -56,6 +56,7 @@
+ #define CODE_CODEPOINTER 0x10
+ #define CODE_INFIXPOINTER 0x11
+ #define CODE_CUSTOM 0x12
++#define CODE_OBJECT 0x14
+
+ #if ARCH_FLOAT_ENDIANNESS == 0x76543210
+ #define CODE_DOUBLE_NATIVE CODE_DOUBLE_BIG
+Index: stdlib/camlinternalOO.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/stdlib/camlinternalOO.ml,v
+retrieving revision 1.14
+diff -u -r1.14 camlinternalOO.ml
+--- stdlib/camlinternalOO.ml 25 Oct 2005 18:34:07 -0000 1.14
++++ stdlib/camlinternalOO.ml 2 Feb 2006 05:08:56 -0000
+@@ -305,10 +305,38 @@
+ public_methods;
+ table
+
++(*
++let create_table_variables pub_meths priv_meths vars =
++ let tbl = create_table pub_meths in
++ let pub_meths = to_array pub_meths
++ and priv_meths = to_array priv_meths
++ and vars = to_array vars in
++ let len = 2 + Array.length pub_meths + Array.length priv_meths in
++ let res = Array.create len tbl in
++ let mv = new_methods_variables tbl pub_meths vars in
++ Array.blit mv 0 res 1;
++ res
++*)
++
+ let init_class table =
+ inst_var_count := !inst_var_count + table.size - 1;
+ table.initializers <- List.rev table.initializers;
+- resize table (3 + magic table.methods.(1) * 16 / Sys.word_size)
++ let len = 3 + magic table.methods.(1) * 16 / Sys.word_size in
++ (* keep 1 more for extra info *)
++ let len = if len > Array.length table.methods then len else len+1 in
++ resize table len
++
++let classes = ref []
++let () = Callback.register "caml_oo_classes" classes
++
++let init_class_shared table (file : string) (pos : int) =
++ init_class table;
++ let rec unique_pos pos =
++ if List.mem_assoc (file, pos) !classes then unique_pos (pos + 0x100000)
++ else pos in
++ let pos = unique_pos pos in
++ table.methods.(Array.length table.methods - 1) <- Obj.magic (file, pos);
++ classes := ((file, pos), table.methods) :: !classes
+
+ let inherits cla vals virt_meths concr_meths (_, super, _, env) top =
+ narrow cla vals virt_meths concr_meths;
+@@ -319,12 +347,18 @@
+ Array.map (fun nm -> get_method cla (get_method_label cla nm))
+ (to_array concr_meths))
+
+-let make_class pub_meths class_init =
++let make_class pub_meths class_init file pos =
+ let table = create_table pub_meths in
+ let env_init = class_init table in
+- init_class table;
++ init_class_shared table file pos;
+ (env_init (Obj.repr 0), class_init, env_init, Obj.repr 0)
+
++let make_class_env pub_meths class_init file pos =
++ let table = create_table pub_meths in
++ let env_init = class_init table in
++ init_class_shared table file pos;
++ (env_init, class_init)
++
+ type init_table = { mutable env_init: t; mutable class_init: table -> t }
+
+ let make_class_store pub_meths class_init init_table =
+Index: stdlib/camlinternalOO.mli
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/stdlib/camlinternalOO.mli,v
+retrieving revision 1.9
+diff -u -r1.9 camlinternalOO.mli
+--- stdlib/camlinternalOO.mli 25 Oct 2005 18:34:07 -0000 1.9
++++ stdlib/camlinternalOO.mli 2 Feb 2006 05:08:56 -0000
+@@ -43,14 +43,20 @@
+ val add_initializer : table -> (obj -> unit) -> unit
+ val dummy_table : table
+ val create_table : string array -> table
++(* val create_table_variables :
++ string array -> string array -> string array -> table *)
+ val init_class : table -> unit
++val init_class_shared : table -> string -> int -> unit
+ val inherits :
+ table -> string array -> string array -> string array ->
+ (t * (table -> obj -> Obj.t) * t * obj) -> bool ->
+ (Obj.t * int array * closure array)
+ val make_class :
+- string array -> (table -> Obj.t -> t) ->
++ string array -> (table -> Obj.t -> t) -> string -> int ->
+ (t * (table -> Obj.t -> t) * (Obj.t -> t) * Obj.t)
++val make_class_env :
++ string array -> (table -> Obj.t -> t) -> string -> int ->
++ (Obj.t -> t) * (table -> Obj.t -> t)
+ type init_table
+ val make_class_store :
+ string array -> (table -> t) -> init_table -> unit
diff --git a/experimental/garrigue/multimatch.diffs b/experimental/garrigue/multimatch.diffs
new file mode 100644
index 000000000..6eb34b72e
--- /dev/null
+++ b/experimental/garrigue/multimatch.diffs
@@ -0,0 +1,1418 @@
+Index: parsing/lexer.mll
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/parsing/lexer.mll,v
+retrieving revision 1.73
+diff -u -r1.73 lexer.mll
+--- parsing/lexer.mll 11 Apr 2005 16:44:26 -0000 1.73
++++ parsing/lexer.mll 2 Feb 2006 06:28:32 -0000
+@@ -63,6 +63,8 @@
+ "match", MATCH;
+ "method", METHOD;
+ "module", MODULE;
++ "multifun", MULTIFUN;
++ "multimatch", MULTIMATCH;
+ "mutable", MUTABLE;
+ "new", NEW;
+ "object", OBJECT;
+Index: parsing/parser.mly
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/parsing/parser.mly,v
+retrieving revision 1.123
+diff -u -r1.123 parser.mly
+--- parsing/parser.mly 23 Mar 2005 03:08:37 -0000 1.123
++++ parsing/parser.mly 2 Feb 2006 06:28:32 -0000
+@@ -257,6 +257,8 @@
+ %token MINUSDOT
+ %token MINUSGREATER
+ %token MODULE
++%token MULTIFUN
++%token MULTIMATCH
+ %token MUTABLE
+ %token <nativeint> NATIVEINT
+ %token NEW
+@@ -325,7 +327,7 @@
+ %nonassoc SEMI /* below EQUAL ({lbl=...; lbl=...}) */
+ %nonassoc LET /* above SEMI ( ...; let ... in ...) */
+ %nonassoc below_WITH
+-%nonassoc FUNCTION WITH /* below BAR (match ... with ...) */
++%nonassoc FUNCTION WITH MULTIFUN /* below BAR (match ... with ...) */
+ %nonassoc AND /* above WITH (module rec A: SIG with ... and ...) */
+ %nonassoc THEN /* below ELSE (if ... then ...) */
+ %nonassoc ELSE /* (if ... then ... else ...) */
+@@ -804,8 +806,12 @@
+ { mkexp(Pexp_function("", None, List.rev $3)) }
+ | FUN labeled_simple_pattern fun_def
+ { let (l,o,p) = $2 in mkexp(Pexp_function(l, o, [p, $3])) }
++ | MULTIFUN opt_bar match_cases
++ { mkexp(Pexp_multifun(List.rev $3)) }
+ | MATCH seq_expr WITH opt_bar match_cases
+- { mkexp(Pexp_match($2, List.rev $5)) }
++ { mkexp(Pexp_match($2, List.rev $5, false)) }
++ | MULTIMATCH seq_expr WITH opt_bar match_cases
++ { mkexp(Pexp_match($2, List.rev $5, true)) }
+ | TRY seq_expr WITH opt_bar match_cases
+ { mkexp(Pexp_try($2, List.rev $5)) }
+ | TRY seq_expr WITH error
+@@ -1318,10 +1324,10 @@
+ | simple_core_type2 { Rinherit $1 }
+ ;
+ tag_field:
+- name_tag OF opt_ampersand amper_type_list
+- { Rtag ($1, $3, List.rev $4) }
+- | name_tag
+- { Rtag ($1, true, []) }
++ name_tag OF opt_ampersand amper_type_list amper_type_pair_list
++ { Rtag ($1, $3, List.rev $4, $5) }
++ | name_tag amper_type_pair_list
++ { Rtag ($1, true, [], $2) }
+ ;
+ opt_ampersand:
+ AMPERSAND { true }
+@@ -1331,6 +1337,11 @@
+ core_type { [$1] }
+ | amper_type_list AMPERSAND core_type { $3 :: $1 }
+ ;
++amper_type_pair_list:
++ AMPERSAND core_type EQUAL core_type amper_type_pair_list
++ { ($2, $4) :: $5 }
++ | /* empty */
++ { [] }
+ opt_present:
+ LBRACKETGREATER name_tag_list RBRACKET { List.rev $2 }
+ | /* empty */ { [] }
+Index: parsing/parsetree.mli
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/parsing/parsetree.mli,v
+retrieving revision 1.42
+diff -u -r1.42 parsetree.mli
+--- parsing/parsetree.mli 23 Mar 2005 03:08:37 -0000 1.42
++++ parsing/parsetree.mli 2 Feb 2006 06:28:32 -0000
+@@ -43,7 +43,7 @@
+ | Pfield_var
+
+ and row_field =
+- Rtag of label * bool * core_type list
++ Rtag of label * bool * core_type list * (core_type * core_type) list
+ | Rinherit of core_type
+
+ (* XXX Type expressions for the class language *)
+@@ -86,7 +86,7 @@
+ | Pexp_let of rec_flag * (pattern * expression) list * expression
+ | Pexp_function of label * expression option * (pattern * expression) list
+ | Pexp_apply of expression * (label * expression) list
+- | Pexp_match of expression * (pattern * expression) list
++ | Pexp_match of expression * (pattern * expression) list * bool
+ | Pexp_try of expression * (pattern * expression) list
+ | Pexp_tuple of expression list
+ | Pexp_construct of Longident.t * expression option * bool
+@@ -111,6 +111,7 @@
+ | Pexp_lazy of expression
+ | Pexp_poly of expression * core_type option
+ | Pexp_object of class_structure
++ | Pexp_multifun of (pattern * expression) list
+
+ (* Value descriptions *)
+
+Index: parsing/printast.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/parsing/printast.ml,v
+retrieving revision 1.29
+diff -u -r1.29 printast.ml
+--- parsing/printast.ml 4 Jan 2006 16:55:50 -0000 1.29
++++ parsing/printast.ml 2 Feb 2006 06:28:32 -0000
+@@ -205,10 +205,14 @@
+ line i ppf "Pexp_apply\n";
+ expression i ppf e;
+ list i label_x_expression ppf l;
+- | Pexp_match (e, l) ->
++ | Pexp_match (e, l, b) ->
+ line i ppf "Pexp_match\n";
+ expression i ppf e;
+ list i pattern_x_expression_case ppf l;
++ bool i ppf b
++ | Pexp_multifun l ->
++ line i ppf "Pexp_multifun\n";
++ list i pattern_x_expression_case ppf l;
+ | Pexp_try (e, l) ->
+ line i ppf "Pexp_try\n";
+ expression i ppf e;
+@@ -653,7 +657,7 @@
+
+ and label_x_bool_x_core_type_list i ppf x =
+ match x with
+- Rtag (l, b, ctl) ->
++ Rtag (l, b, ctl, cstr) ->
+ line i ppf "Rtag \"%s\" %s\n" l (string_of_bool b);
+ list (i+1) core_type ppf ctl
+ | Rinherit (ct) ->
+Index: typing/btype.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/btype.ml,v
+retrieving revision 1.38
+diff -u -r1.38 btype.ml
+--- typing/btype.ml 4 Jan 2006 16:55:50 -0000 1.38
++++ typing/btype.ml 2 Feb 2006 06:28:32 -0000
+@@ -66,16 +66,16 @@
+ Clink r when !r <> Cunknown -> commu_repr !r
+ | c -> c
+
+-let rec row_field_repr_aux tl = function
+- Reither(_, tl', _, {contents = Some fi}) ->
+- row_field_repr_aux (tl@tl') fi
+- | Reither(c, tl', m, r) ->
+- Reither(c, tl@tl', m, r)
++let rec row_field_repr_aux tl tl2 = function
++ Reither(_, tl', _, tl2', {contents = Some fi}) ->
++ row_field_repr_aux (tl@tl') (tl2@tl2') fi
++ | Reither(c, tl', m, tl2', r) ->
++ Reither(c, tl@tl', m, tl2@tl2', r)
+ | Rpresent (Some _) when tl <> [] ->
+ Rpresent (Some (List.hd tl))
+ | fi -> fi
+
+-let row_field_repr fi = row_field_repr_aux [] fi
++let row_field_repr fi = row_field_repr_aux [] [] fi
+
+ let rec rev_concat l ll =
+ match ll with
+@@ -170,7 +170,8 @@
+ (fun (_, fi) ->
+ match row_field_repr fi with
+ | Rpresent(Some ty) -> f ty
+- | Reither(_, tl, _, _) -> List.iter f tl
++ | Reither(_, tl, _, tl2, _) ->
++ List.iter f tl; List.iter (fun (t1,t2) -> f t1; f t2) tl2
+ | _ -> ())
+ row.row_fields;
+ match (repr row.row_more).desc with
+@@ -208,15 +209,17 @@
+ (fun (l, fi) -> l,
+ match row_field_repr fi with
+ | Rpresent(Some ty) -> Rpresent(Some(f ty))
+- | Reither(c, tl, m, e) ->
++ | Reither(c, tl, m, tpl, e) ->
+ let e = if keep then e else ref None in
+ let m = if row.row_fixed then fixed else m in
+ let tl = List.map f tl in
++ let tl1 = List.map (fun (t1,_) -> repr (f t1)) tpl
++ and tl2 = List.map (fun (_,t2) -> repr (f t2)) tpl in
+ bound := List.filter
+ (function {desc=Tconstr(_,[],_)} -> false | _ -> true)
+- (List.map repr tl)
++ (List.map repr tl @ tl1 @ tl2)
+ @ !bound;
+- Reither(c, tl, m, e)
++ Reither(c, tl, m, List.combine tl1 tl2, e)
+ | _ -> fi)
+ row.row_fields in
+ let name =
+Index: typing/ctype.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.ml,v
+retrieving revision 1.200
+diff -u -r1.200 ctype.ml
+--- typing/ctype.ml 6 Jan 2006 02:16:24 -0000 1.200
++++ typing/ctype.ml 2 Feb 2006 06:28:32 -0000
+@@ -340,7 +340,7 @@
+ let fi = filter_row_fields erase fi in
+ match row_field_repr f with
+ Rabsent -> fi
+- | Reither(_,_,false,e) when erase -> set_row_field e Rabsent; fi
++ | Reither(_,_,false,_,e) when erase -> set_row_field e Rabsent; fi
+ | _ -> p :: fi
+
+ (**************************************)
+@@ -1286,6 +1286,10 @@
+
+ module TypeMap = Map.Make (TypeOps)
+
++
++(* A list of univars which may appear free in a type, but only if generic *)
++let allowed_univars = ref TypeSet.empty
++
+ (* Test the occurence of free univars in a type *)
+ (* that's way too expansive. Must do some kind of cacheing *)
+ let occur_univar env ty =
+@@ -1307,7 +1311,12 @@
+ then
+ match ty.desc with
+ Tunivar ->
+- if not (TypeSet.mem ty bound) then raise (Unify [ty, newgenvar()])
++ if TypeSet.mem ty bound then () else
++ if TypeSet.mem ty !allowed_univars &&
++ (ty.level = generic_level ||
++ ty.level = pivot_level - generic_level)
++ then ()
++ else raise (Unify [ty, newgenvar()])
+ | Tpoly (ty, tyl) ->
+ let bound = List.fold_right TypeSet.add (List.map repr tyl) bound in
+ occur_rec bound ty
+@@ -1393,6 +1402,7 @@
+ with exn -> univar_pairs := old_univars; raise exn
+
+ let univar_pairs = ref []
++let delayed_conditionals = ref []
+
+
+ (*****************)
+@@ -1691,9 +1701,11 @@
+ with Not_found -> (h,l)::hl)
+ (List.map (fun (l,_) -> (hash_variant l, l)) row1.row_fields)
+ (List.map fst r2));
++ let fixed1 = row1.row_fixed || rm1.desc <> Tvar
++ and fixed2 = row2.row_fixed || rm2.desc <> Tvar in
+ let more =
+- if row1.row_fixed then rm1 else
+- if row2.row_fixed then rm2 else
++ if fixed1 then rm1 else
++ if fixed2 then rm2 else
+ newgenvar ()
+ in update_level env (min rm1.level rm2.level) more;
+ let fixed = row1.row_fixed || row2.row_fixed
+@@ -1726,18 +1738,18 @@
+ let bound = row1.row_bound @ row2.row_bound in
+ let row0 = {row_fields = []; row_more = more; row_bound = bound;
+ row_closed = closed; row_fixed = fixed; row_name = name} in
+- let set_more row rest =
++ let set_more row row_fixed rest =
+ let rest =
+ if closed then
+ filter_row_fields row.row_closed rest
+ else rest in
+- if rest <> [] && (row.row_closed || row.row_fixed)
+- || closed && row.row_fixed && not row.row_closed then begin
++ if rest <> [] && (row.row_closed || row_fixed)
++ || closed && row_fixed && not row.row_closed then begin
+ let t1 = mkvariant [] true and t2 = mkvariant rest false in
+ raise (Unify [if row == row1 then (t1,t2) else (t2,t1)])
+ end;
+ let rm = row_more row in
+- if row.row_fixed then
++ if row_fixed then
+ if row0.row_more == rm then () else
+ if rm.desc = Tvar then link_type rm row0.row_more else
+ unify env rm row0.row_more
+@@ -1748,11 +1760,11 @@
+ in
+ let md1 = rm1.desc and md2 = rm2.desc in
+ begin try
+- set_more row1 r2;
+- set_more row2 r1;
++ set_more row1 fixed1 r2;
++ set_more row2 fixed2 r1;
+ List.iter
+ (fun (l,f1,f2) ->
+- try unify_row_field env row1.row_fixed row2.row_fixed l f1 f2
++ try unify_row_field env fixed1 fixed2 row1 row2 l f1 f2
+ with Unify trace ->
+ raise (Unify ((mkvariant [l,f1] true,
+ mkvariant [l,f2] true) :: trace)))
+@@ -1761,13 +1773,13 @@
+ log_type rm1; rm1.desc <- md1; log_type rm2; rm2.desc <- md2; raise exn
+ end
+
+-and unify_row_field env fixed1 fixed2 l f1 f2 =
++and unify_row_field env fixed1 fixed2 row1 row2 l f1 f2 =
+ let f1 = row_field_repr f1 and f2 = row_field_repr f2 in
+ if f1 == f2 then () else
+ match f1, f2 with
+ Rpresent(Some t1), Rpresent(Some t2) -> unify env t1 t2
+ | Rpresent None, Rpresent None -> ()
+- | Reither(c1, tl1, m1, e1), Reither(c2, tl2, m2, e2) ->
++ | Reither(c1, tl1, m1, tp1, e1), Reither(c2, tl2, m2, tp2, e2) ->
+ if e1 == e2 then () else
+ let redo =
+ (m1 || m2) &&
+@@ -1777,32 +1789,70 @@
+ List.iter (unify env t1) tl;
+ !e1 <> None || !e2 <> None
+ end in
+- if redo then unify_row_field env fixed1 fixed2 l f1 f2 else
++ let redo =
++ redo || begin
++ if tp1 = [] && fixed1 then unify_pairs env tp2;
++ if tp2 = [] && fixed2 then unify_pairs env tp1;
++ !e1 <> None || !e2 <> None
++ end
++ in
++ if redo then unify_row_field env fixed1 fixed2 row1 row2 l f1 f2 else
+ let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in
+ let rec remq tl = function [] -> []
+ | ty :: tl' ->
+ if List.memq ty tl then remq tl tl' else ty :: remq tl tl'
+ in
+ let tl2' = remq tl2 tl1 and tl1' = remq tl1 tl2 in
++ let repr_pairs = List.map (fun (t1,t2) -> repr t1, repr t2) in
++ let tp1 = repr_pairs tp1 and tp2 = repr_pairs tp2 in
++ let rec rempq tp = function [] -> []
++ | (t1,t2 as p) :: tp' ->
++ if List.exists (fun (t1',t2') -> t1==t1' && t2==t2') (tp@tp') then
++ rempq tp tp'
++ else p :: rempq tp tp'
++ in
++ let tp1' =
++ if fixed2 then begin
++ delayed_conditionals :=
++ (!univar_pairs, tp1, l, row2) :: !delayed_conditionals;
++ []
++ end else rempq tp2 tp1
++ and tp2' =
++ if fixed1 then begin
++ delayed_conditionals :=
++ (!univar_pairs, tp2, l, row1) :: !delayed_conditionals;
++ []
++ end else rempq tp1 tp2
++ in
+ let e = ref None in
+- let f1' = Reither(c1 || c2, tl1', m1 || m2, e)
+- and f2' = Reither(c1 || c2, tl2', m1 || m2, e) in
+- set_row_field e1 f1'; set_row_field e2 f2';
+- | Reither(_, _, false, e1), Rabsent -> set_row_field e1 f2
+- | Rabsent, Reither(_, _, false, e2) -> set_row_field e2 f1
++ let f1' = Reither(c1 || c2, tl1', m1 || m2, tp2', e)
++ and f2' = Reither(c1 || c2, tl2', m1 || m2, tp1', e) in
++ set_row_field e1 f1'; set_row_field e2 f2'
++ | Reither(_, _, false, _, e1), Rabsent -> set_row_field e1 f2
++ | Rabsent, Reither(_, _, false, _, e2) -> set_row_field e2 f1
+ | Rabsent, Rabsent -> ()
+- | Reither(false, tl, _, e1), Rpresent(Some t2) when not fixed1 ->
++ | Reither(false, tl, _, tp, e1), Rpresent(Some t2) when not fixed1 ->
+ set_row_field e1 f2;
+- (try List.iter (fun t1 -> unify env t1 t2) tl
++ begin try
++ List.iter (fun t1 -> unify env t1 t2) tl;
++ List.iter (fun (t1,t2) -> unify env t1 t2) tp
++ with exn -> e1 := None; raise exn
++ end
++ | Rpresent(Some t1), Reither(false, tl, _, tp, e2) when not fixed2 ->
++ set_row_field e2 f1;
++ begin try
++ List.iter (unify env t1) tl;
++ List.iter (fun (t1,t2) -> unify env t1 t2) tp
++ with exn -> e2 := None; raise exn
++ end
++ | Reither(true, [], _, tpl, e1), Rpresent None when not fixed1 ->
++ set_row_field e1 f2;
++ (try List.iter (fun (t1,t2) -> unify env t1 t2) tpl
+ with exn -> e1 := None; raise exn)
+- | Rpresent(Some t1), Reither(false, tl, _, e2) when not fixed2 ->
++ | Rpresent None, Reither(true, [], _, tpl, e2) when not fixed2 ->
+ set_row_field e2 f1;
+- (try List.iter (unify env t1) tl
++ (try List.iter (fun (t1,t2) -> unify env t1 t2) tpl
+ with exn -> e2 := None; raise exn)
+- | Reither(true, [], _, e1), Rpresent None when not fixed1 ->
+- set_row_field e1 f2
+- | Rpresent None, Reither(true, [], _, e2) when not fixed2 ->
+- set_row_field e2 f1
+ | _ -> raise (Unify [])
+
+
+@@ -1920,6 +1970,166 @@
+ (* Matching between type schemes *)
+ (***********************************)
+
++(* Forward declaration (order should be reversed...) *)
++let equal' = ref (fun _ -> failwith "Ctype.equal'")
++
++let make_generics_univars tyl =
++ let polyvars = ref TypeSet.empty in
++ let rec make_rec ty =
++ let ty = repr ty in
++ if ty.level = generic_level then begin
++ if ty.desc = Tvar then begin
++ log_type ty;
++ ty.desc <- Tunivar;
++ polyvars := TypeSet.add ty !polyvars
++ end
++ else if ty.desc = Tunivar then set_level ty (generic_level - 1);
++ ty.level <- pivot_level - generic_level;
++ iter_type_expr make_rec ty
++ end
++ in
++ List.iter make_rec tyl;
++ List.iter unmark_type tyl;
++ !polyvars
++
++(* New version of moregeneral, using unification *)
++
++let copy_cond (p,tpl,l,row) =
++ let row =
++ match repr (copy (newgenty (Tvariant row))) with
++ {desc=Tvariant row} -> row
++ | _ -> assert false
++ and pairs =
++ List.map (fun (t1,t2) -> copy t1, copy t2) tpl in
++ (p, pairs, l, row)
++
++let get_row_field l row =
++ try row_field_repr (List.assoc l (row_repr row).row_fields)
++ with Not_found -> Rabsent
++
++let rec check_conditional_list env cdtls pattvars tpls =
++ match cdtls with
++ [] ->
++ let finished =
++ List.for_all (fun (_,t1,t2) -> !equal' env false [t1] [t2]) tpls in
++ if not finished then begin
++ let polyvars = make_generics_univars pattvars in
++ delayed_conditionals := [];
++ allowed_univars := polyvars;
++ List.iter (fun (pairs, ty1, ty2) -> unify_pairs env ty1 ty2 pairs)
++ tpls;
++ check_conditionals env polyvars !delayed_conditionals
++ end
++ | (pairs, tpl1, l, row2 as cond) :: cdtls ->
++ let cont = check_conditional_list env cdtls pattvars in
++ let tpl1 =
++ List.filter (fun (t1,t2) -> not (!equal' env false [t1] [t2])) tpl1 in
++ let included =
++ List.for_all
++ (fun (t1,t2) ->
++ List.exists
++ (fun (_,t1',t2') -> !equal' env false [t1;t2] [t1';t2'])
++ tpls)
++ tpl1 in
++ if included then cont tpls else
++ match get_row_field l row2 with
++ Rpresent _ ->
++ cont (List.map (fun (t1,t2) -> (pairs,t1,t2)) tpl1 @ tpls)
++ | Rabsent -> cont tpls
++ | Reither (c, tl2, _, _, _) ->
++ cont tpls;
++ if c && tl2 <> [] then () (* cannot succeed *) else
++ let (pairs, tpl1, l, row2) = copy_cond cond
++ and tpls = List.map (fun (p,t1,t2) -> p, copy t1, copy t2) tpls
++ and pattvars = List.map copy pattvars
++ and cdtls = List.map copy_cond cdtls in
++ cleanup_types ();
++ let tl2, tpl2, e2 =
++ match get_row_field l row2 with
++ Reither (c, tl2, _, tpl2, e2) -> tl2, tpl2, e2
++ | _ -> assert false
++ in
++ let snap = Btype.snapshot () in
++ let ok =
++ try
++ begin match tl2 with
++ [] ->
++ set_row_field e2 (Rpresent None)
++ | t::tl ->
++ set_row_field e2 (Rpresent (Some t));
++ List.iter (unify env t) tl
++ end;
++ List.iter (fun (t1,t2) -> unify_pairs env t1 t2 pairs) tpl2;
++ true
++ with exn ->
++ Btype.backtrack snap;
++ false
++ in
++ (* This is not [cont] : types have been copied *)
++ if ok then
++ check_conditional_list env cdtls pattvars
++ (List.map (fun (t1,t2) -> (pairs,t1,t2)) tpl1 @ tpls)
++
++and check_conditionals env polyvars cdtls =
++ let cdtls = List.map copy_cond cdtls in
++ let pattvars = ref [] in
++ TypeSet.iter
++ (fun ty ->
++ let ty = repr ty in
++ match ty.desc with
++ Tsubst ty ->
++ let ty = repr ty in
++ begin match ty.desc with
++ Tunivar ->
++ log_type ty;
++ ty.desc <- Tvar;
++ pattvars := ty :: !pattvars
++ | Ttuple [tv;_] ->
++ if tv.desc = Tunivar then
++ (log_type tv; tv.desc <- Tvar; pattvars := ty :: !pattvars)
++ else if tv.desc <> Tvar then assert false
++ | Tvar -> ()
++ | _ -> assert false
++ end
++ | _ -> ())
++ polyvars;
++ cleanup_types ();
++ check_conditional_list env cdtls !pattvars []
++
++
++(* Must empty univar_pairs first *)
++let unify_poly env polyvars subj patt =
++ let old_level = !current_level in
++ current_level := generic_level;
++ delayed_conditionals := [];
++ allowed_univars := polyvars;
++ try
++ unify env subj patt;
++ check_conditionals env polyvars !delayed_conditionals;
++ current_level := old_level;
++ allowed_univars := TypeSet.empty;
++ delayed_conditionals := []
++ with exn ->
++ current_level := old_level;
++ allowed_univars := TypeSet.empty;
++ delayed_conditionals := [];
++ raise exn
++
++let moregeneral env _ subj patt =
++ let old_level = !current_level in
++ current_level := generic_level;
++ let subj = instance subj
++ and patt = instance patt in
++ let polyvars = make_generics_univars [patt] in
++ current_level := old_level;
++ let snap = Btype.snapshot () in
++ try
++ unify_poly env polyvars subj patt;
++ true
++ with Unify _ ->
++ Btype.backtrack snap;
++ false
++
+ (*
+ Update the level of [ty]. First check that the levels of generic
+ variables from the subject are not lowered.
+@@ -2072,35 +2282,101 @@
+ Rpresent(Some t1), Rpresent(Some t2) ->
+ moregen inst_nongen type_pairs env t1 t2
+ | Rpresent None, Rpresent None -> ()
+- | Reither(false, tl1, _, e1), Rpresent(Some t2) when not univ ->
++ | Reither(false, tl1, _, [], e1), Rpresent(Some t2) when not univ ->
+ set_row_field e1 f2;
+ List.iter (fun t1 -> moregen inst_nongen type_pairs env t1 t2) tl1
+- | Reither(c1, tl1, _, e1), Reither(c2, tl2, m2, e2) ->
++ | Reither(c1, tl1, _, tpl1, e1), Reither(c2, tl2, m2, tpl2, e2) ->
+ if e1 != e2 then begin
+ if c1 && not c2 then raise(Unify []);
+- set_row_field e1 (Reither (c2, [], m2, e2));
+- if List.length tl1 = List.length tl2 then
+- List.iter2 (moregen inst_nongen type_pairs env) tl1 tl2
+- else match tl2 with
+- t2 :: _ ->
++ let tpl' = if tpl1 = [] then tpl2 else [] in
++ set_row_field e1 (Reither (c2, [], m2, tpl', e2));
++ begin match tl2 with
++ [t2] ->
+ List.iter (fun t1 -> moregen inst_nongen type_pairs env t1 t2)
+ tl1
+- | [] ->
+- if tl1 <> [] then raise (Unify [])
++ | _ ->
++ if List.length tl1 <> List.length tl2 then raise (Unify []);
++ List.iter2 (moregen inst_nongen type_pairs env) tl1 tl2
++ end;
++ if tpl1 <> [] then
++ delayed_conditionals :=
++ (!univar_pairs, tpl1, l, row2) :: !delayed_conditionals
+ end
+- | Reither(true, [], _, e1), Rpresent None when not univ ->
++ | Reither(true, [], _, [], e1), Rpresent None when not univ ->
+ set_row_field e1 f2
+- | Reither(_, _, _, e1), Rabsent when not univ ->
++ | Reither(_, _, _, [], e1), Rabsent when not univ ->
+ set_row_field e1 f2
+ | Rabsent, Rabsent -> ()
+ | _ -> raise (Unify []))
+ pairs
+
++let check_conditional env (pairs, tpl1, l, row2) tpls cont =
++ let tpl1 =
++ List.filter (fun (t1,t2) -> not (!equal' env false [t1] [t2])) tpl1 in
++ let included =
++ List.for_all
++ (fun (t1,t2) ->
++ List.exists (fun (t1',t2') -> !equal' env false [t1;t2] [t1';t2'])
++ tpls)
++ tpl1 in
++ if tpl1 = [] || included then cont tpls else
++ match get_row_field l row2 with
++ Rpresent _ -> cont (tpl1 @ tpls)
++ | Rabsent -> cont tpls
++ | Reither (c, tl2, _, tpl2, e2) ->
++ if not c || tl2 = [] then begin
++ let snap = Btype.snapshot () in
++ let ok =
++ try
++ begin match tl2 with
++ [] ->
++ set_row_field e2 (Rpresent None)
++ | t::tl ->
++ set_row_field e2 (Rpresent (Some t));
++ List.iter (unify env t) tl
++ end;
++ List.iter (fun (t1,t2) -> unify_pairs env t1 t2 pairs) tpl2;
++ true
++ with Unify _ -> false
++ in
++ if ok then cont (tpl1 @ tpls);
++ Btype.backtrack snap
++ end;
++ cont tpls
++
++let rec check_conditionals inst_nongen env cdtls tpls =
++ match cdtls with
++ [] ->
++ let tpls =
++ List.filter (fun (t1,t2) -> not (!equal' env false [t1] [t2])) tpls in
++ if tpls = [] then () else begin
++ delayed_conditionals := [];
++ let tl1, tl2 = List.split tpls in
++ let type_pairs = TypePairs.create 13 in
++ List.iter2 (moregen false type_pairs env) tl2 tl1;
++ check_conditionals inst_nongen env !delayed_conditionals []
++ end
++ | cdtl :: cdtls ->
++ check_conditional env cdtl tpls
++ (check_conditionals inst_nongen env cdtls)
++
++
+ (* Must empty univar_pairs first *)
+ let moregen inst_nongen type_pairs env patt subj =
+ univar_pairs := [];
+- moregen inst_nongen type_pairs env patt subj
++ delayed_conditionals := [];
++ try
++ moregen inst_nongen type_pairs env patt subj;
++ check_conditionals inst_nongen env !delayed_conditionals [];
++ univar_pairs := [];
++ delayed_conditionals := []
++ with exn ->
++ univar_pairs := [];
++ delayed_conditionals := [];
++ raise exn
++
+
++(* old implementation
+ (*
+ Non-generic variable can be instanciated only if [inst_nongen] is
+ true. So, [inst_nongen] should be set to false if the subject might
+@@ -2128,6 +2404,7 @@
+ in
+ current_level := old_level;
+ res
++*)
+
+
+ (* Alternative approach: "rigidify" a type scheme,
+@@ -2296,30 +2573,36 @@
+ {desc=Tvariant row2} -> eqtype_row rename type_pairs subst env row1 row2
+ | _ -> raise Cannot_expand
+ with Cannot_expand ->
++ let eqtype_rec = eqtype rename type_pairs subst env in
+ let row1 = row_repr row1 and row2 = row_repr row2 in
+ let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
+ if row1.row_closed <> row2.row_closed
+ || not row1.row_closed && (r1 <> [] || r2 <> [])
+ || filter_row_fields false (r1 @ r2) <> []
+ then raise (Unify []);
+- if not (static_row row1) then
+- eqtype rename type_pairs subst env row1.row_more row2.row_more;
++ if not (static_row row1) then eqtype_rec row1.row_more row2.row_more;
+ List.iter
+ (fun (_,f1,f2) ->
+ match row_field_repr f1, row_field_repr f2 with
+ Rpresent(Some t1), Rpresent(Some t2) ->
+- eqtype rename type_pairs subst env t1 t2
+- | Reither(true, [], _, _), Reither(true, [], _, _) ->
+- ()
+- | Reither(false, t1::tl1, _, _), Reither(false, t2::tl2, _, _) ->
+- eqtype rename type_pairs subst env t1 t2;
++ eqtype_rec t1 t2
++ | Reither(true, [], _, tp1, _), Reither(true, [], _, tp2, _) ->
++ List.iter2
++ (fun (t1,t1') (t2,t2') -> eqtype_rec t1 t2; eqtype_rec t1' t2')
++ tp1 tp2
++ | Reither(false, t1::tl1, _, tpl1, _),
++ Reither(false, t2::tl2, _, tpl2, _) ->
++ eqtype_rec t1 t2;
++ List.iter2
++ (fun (t1,t1') (t2,t2') -> eqtype_rec t1 t2; eqtype_rec t1' t2')
++ tpl1 tpl2;
+ if List.length tl1 = List.length tl2 then
+ (* if same length allow different types (meaning?) *)
+- List.iter2 (eqtype rename type_pairs subst env) tl1 tl2
++ List.iter2 eqtype_rec tl1 tl2
+ else begin
+ (* otherwise everything must be equal *)
+- List.iter (eqtype rename type_pairs subst env t1) tl2;
+- List.iter (fun t1 -> eqtype rename type_pairs subst env t1 t2) tl1
++ List.iter (eqtype_rec t1) tl2;
++ List.iter (fun t1 -> eqtype_rec t1 t2) tl1
+ end
+ | Rpresent None, Rpresent None -> ()
+ | Rabsent, Rabsent -> ()
+@@ -2334,6 +2617,8 @@
+ with
+ Unify _ -> false
+
++let () = equal' := equal
++
+ (* Must empty univar_pairs first *)
+ let eqtype rename type_pairs subst env t1 t2 =
+ univar_pairs := [];
+@@ -2770,14 +3055,14 @@
+ (fun (l,f as orig) -> match row_field_repr f with
+ Rpresent None ->
+ if posi then
+- (l, Reither(true, [], false, ref None)), Unchanged
++ (l, Reither(true, [], false, [], ref None)), Unchanged
+ else
+ orig, Unchanged
+ | Rpresent(Some t) ->
+ let (t', c) = build_subtype env visited loops posi level' t in
+ if posi && level > 0 then begin
+ bound := t' :: !bound;
+- (l, Reither(false, [t'], false, ref None)), c
++ (l, Reither(false, [t'], false, [], ref None)), c
+ end else
+ (l, Rpresent(Some t')), c
+ | _ -> assert false)
+@@ -2960,11 +3245,11 @@
+ List.fold_left
+ (fun cstrs (_,f1,f2) ->
+ match row_field_repr f1, row_field_repr f2 with
+- (Rpresent None|Reither(true,_,_,_)), Rpresent None ->
++ (Rpresent None|Reither(true,_,_,[],_)), Rpresent None ->
+ cstrs
+ | Rpresent(Some t1), Rpresent(Some t2) ->
+ subtype_rec env ((t1, t2)::trace) t1 t2 cstrs
+- | Reither(false, t1::_, _, _), Rpresent(Some t2) ->
++ | Reither(false, t1::_, _, [], _), Rpresent(Some t2) ->
+ subtype_rec env ((t1, t2)::trace) t1 t2 cstrs
+ | Rabsent, _ -> cstrs
+ | _ -> raise Exit)
+@@ -2977,11 +3262,11 @@
+ (fun cstrs (_,f1,f2) ->
+ match row_field_repr f1, row_field_repr f2 with
+ Rpresent None, Rpresent None
+- | Reither(true,[],_,_), Reither(true,[],_,_)
++ | Reither(true,[],_,[],_), Reither(true,[],_,[],_)
+ | Rabsent, Rabsent ->
+ cstrs
+ | Rpresent(Some t1), Rpresent(Some t2)
+- | Reither(false,[t1],_,_), Reither(false,[t2],_,_) ->
++ | Reither(false,[t1],_,[],_), Reither(false,[t2],_,[],_) ->
+ subtype_rec env ((t1, t2)::trace) t1 t2 cstrs
+ | _ -> raise Exit)
+ cstrs pairs
+@@ -3079,16 +3364,26 @@
+ let fields = List.map
+ (fun (l,f) ->
+ let f = row_field_repr f in l,
+- match f with Reither(b, ty::(_::_ as tyl), m, e) ->
+- let tyl' =
+- List.fold_left
+- (fun tyl ty ->
+- if List.exists (fun ty' -> equal env false [ty] [ty']) tyl
+- then tyl else ty::tyl)
+- [ty] tyl
++ match f with Reither(b, tyl, m, tp, e) ->
++ let rem_dbl eq l =
++ List.rev
++ (List.fold_left
++ (fun xs x -> if List.exists (eq x) xs then xs else x::xs)
++ [] l)
++ in
++ let tyl' = rem_dbl (fun t1 t2 -> equal env false [t1] [t2]) tyl
++ and tp' =
++ List.filter
++ (fun (ty1,ty2) -> not (equal env false [ty1] [ty2])) tp
++ in
++ let tp' =
++ rem_dbl
++ (fun (t1,t2) (t1',t2') -> equal env false [t1;t2] [t1';t2'])
++ tp'
+ in
+- if List.length tyl' <= List.length tyl then
+- let f = Reither(b, List.rev tyl', m, ref None) in
++ if List.length tyl' < List.length tyl
++ || List.length tp' < List.length tp then
++ let f = Reither(b, tyl', m, tp', ref None) in
+ set_row_field e f;
+ f
+ else f
+@@ -3344,9 +3639,9 @@
+ List.iter
+ (fun (l,fi) ->
+ match row_field_repr fi with
+- Reither (c, t1::(_::_ as tl), m, e) ->
++ Reither (c, t1::(_::_ as tl), m, tp, e) ->
+ List.iter (unify env t1) tl;
+- set_row_field e (Reither (c, [t1], m, ref None))
++ set_row_field e (Reither (c, [t1], m, tp, ref None))
+ | _ ->
+ ())
+ row.row_fields;
+Index: typing/includecore.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/includecore.ml,v
+retrieving revision 1.32
+diff -u -r1.32 includecore.ml
+--- typing/includecore.ml 8 Aug 2005 05:40:52 -0000 1.32
++++ typing/includecore.ml 2 Feb 2006 06:28:32 -0000
+@@ -71,10 +71,10 @@
+ (fun (_, f1, f2) ->
+ match Btype.row_field_repr f1, Btype.row_field_repr f2 with
+ Rpresent(Some t1),
+- (Rpresent(Some t2) | Reither(false, [t2], _, _)) ->
++ (Rpresent(Some t2) | Reither(false,[t2],_,[],_)) ->
+ to_equal := (t1,t2) :: !to_equal; true
+- | Rpresent None, (Rpresent None | Reither(true, [], _, _)) -> true
+- | Reither(c1,tl1,_,_), Reither(c2,tl2,_,_)
++ | Rpresent None, (Rpresent None | Reither(true,[],_,[],_)) -> true
++ | Reither(c1,tl1,_,[],_), Reither(c2,tl2,_,[],_)
+ when List.length tl1 = List.length tl2 && c1 = c2 ->
+ to_equal := List.combine tl1 tl2 @ !to_equal; true
+ | Rabsent, (Reither _ | Rabsent) -> true
+Index: typing/oprint.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/oprint.ml,v
+retrieving revision 1.22
+diff -u -r1.22 oprint.ml
+--- typing/oprint.ml 23 Mar 2005 03:08:37 -0000 1.22
++++ typing/oprint.ml 2 Feb 2006 06:28:33 -0000
+@@ -223,14 +223,18 @@
+ print_fields rest ppf []
+ | (s, t) :: l ->
+ fprintf ppf "%s : %a;@ %a" s print_out_type t (print_fields rest) l
+-and print_row_field ppf (l, opt_amp, tyl) =
++and print_row_field ppf (l, opt_amp, tyl, tpl) =
+ let pr_of ppf =
+ if opt_amp then fprintf ppf " of@ &@ "
+ else if tyl <> [] then fprintf ppf " of@ "
+- else fprintf ppf ""
+- in
+- fprintf ppf "@[<hv 2>`%s%t%a@]" l pr_of (print_typlist print_out_type " &")
+- tyl
++ and pr_tp ppf (t1,t2) =
++ fprintf ppf "@[<hv 2>%a =@ %a@]"
++ print_out_type t1
++ print_out_type t2
++ in
++ fprintf ppf "@[<hv 2>`%s%t%a%a@]" l pr_of
++ (print_typlist print_out_type " &") tyl
++ (print_list_init pr_tp (fun ppf -> fprintf ppf " &@ ")) tpl
+ and print_typlist print_elem sep ppf =
+ function
+ [] -> ()
+Index: typing/outcometree.mli
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/outcometree.mli,v
+retrieving revision 1.14
+diff -u -r1.14 outcometree.mli
+--- typing/outcometree.mli 23 Mar 2005 03:08:37 -0000 1.14
++++ typing/outcometree.mli 2 Feb 2006 06:28:33 -0000
+@@ -61,7 +61,8 @@
+ bool * out_variant * bool * (string list) option
+ | Otyp_poly of string list * out_type
+ and out_variant =
+- | Ovar_fields of (string * bool * out_type list) list
++ | Ovar_fields of
++ (string * bool * out_type list * (out_type * out_type) list ) list
+ | Ovar_name of out_ident * out_type list
+
+ type out_class_type =
+Index: typing/parmatch.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/parmatch.ml,v
+retrieving revision 1.70
+diff -u -r1.70 parmatch.ml
+--- typing/parmatch.ml 24 Mar 2005 17:20:54 -0000 1.70
++++ typing/parmatch.ml 2 Feb 2006 06:28:33 -0000
+@@ -568,11 +568,11 @@
+ List.fold_left
+ (fun nm (tag,f) ->
+ match Btype.row_field_repr f with
+- | Reither(_, _, false, e) ->
++ | Reither(_, _, false, _, e) ->
+ (* m=false means that this tag is not explicitly matched *)
+ Btype.set_row_field e Rabsent;
+ None
+- | Rabsent | Reither (_, _, true, _) | Rpresent _ -> nm)
++ | Rabsent | Reither (_, _, true, _, _) | Rpresent _ -> nm)
+ row.row_name row.row_fields in
+ if not row.row_closed || nm != row.row_name then begin
+ (* this unification cannot fail *)
+@@ -605,8 +605,8 @@
+ List.for_all
+ (fun (tag,f) ->
+ match Btype.row_field_repr f with
+- Rabsent | Reither(_, _, false, _) -> true
+- | Reither (_, _, true, _)
++ Rabsent | Reither(_, _, false, _, _) -> true
++ | Reither (_, _, true, _, _)
+ (* m=true, do not discard matched tags, rather warn *)
+ | Rpresent _ -> List.mem tag fields)
+ row.row_fields
+@@ -739,7 +739,7 @@
+ match Btype.row_field_repr f with
+ Rabsent (* | Reither _ *) -> others
+ (* This one is called after erasing pattern info *)
+- | Reither (c, _, _, _) -> make_other_pat tag c :: others
++ | Reither (c, _, _, _, _) -> make_other_pat tag c :: others
+ | Rpresent arg -> make_other_pat tag (arg = None) :: others)
+ [] row.row_fields
+ with
+Index: typing/printtyp.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/printtyp.ml,v
+retrieving revision 1.140
+diff -u -r1.140 printtyp.ml
+--- typing/printtyp.ml 4 Jan 2006 16:55:50 -0000 1.140
++++ typing/printtyp.ml 2 Feb 2006 06:28:33 -0000
+@@ -157,9 +157,12 @@
+ and raw_field ppf = function
+ Rpresent None -> fprintf ppf "Rpresent None"
+ | Rpresent (Some t) -> fprintf ppf "@[<1>Rpresent(Some@,%a)@]" raw_type t
+- | Reither (c,tl,m,e) ->
+- fprintf ppf "@[<hov1>Reither(%b,@,%a,@,%b,@,@[<1>ref%t@])@]" c
+- raw_type_list tl m
++ | Reither (c,tl,m,tpl,e) ->
++ fprintf ppf "@[<hov1>Reither(%b,@,%a,@,%b,@,%a,@,@[<1>ref%t@])@]"
++ c raw_type_list tl m
++ (raw_list
++ (fun ppf (t1,t2) ->
++ fprintf ppf "@[%a,@,%a@]" raw_type t1 raw_type t2)) tpl
+ (fun ppf ->
+ match !e with None -> fprintf ppf " None"
+ | Some f -> fprintf ppf "@,@[<1>(%a)@]" raw_field f)
+@@ -219,8 +222,9 @@
+ List.for_all
+ (fun (_, f) ->
+ match row_field_repr f with
+- | Reither(c, l, _, _) ->
+- row.row_closed && if c then l = [] else List.length l = 1
++ | Reither(c, l, _, pl, _) ->
++ row.row_closed && pl = [] &&
++ if c then l = [] else List.length l = 1
+ | _ -> true)
+ row.row_fields
+
+@@ -392,13 +396,16 @@
+
+ and tree_of_row_field sch (l, f) =
+ match row_field_repr f with
+- | Rpresent None | Reither(true, [], _, _) -> (l, false, [])
+- | Rpresent(Some ty) -> (l, false, [tree_of_typexp sch ty])
+- | Reither(c, tyl, _, _) ->
+- if c (* contradiction: un constructeur constant qui a un argument *)
+- then (l, true, tree_of_typlist sch tyl)
+- else (l, false, tree_of_typlist sch tyl)
+- | Rabsent -> (l, false, [] (* une erreur, en fait *))
++ | Rpresent None | Reither(true, [], _, [], _) -> (l, false, [], [])
++ | Rpresent(Some ty) -> (l, false, [tree_of_typexp sch ty], [])
++ | Reither(c, tyl, _, tpl, _) ->
++ let ttpl =
++ List.map
++ (fun (t1,t2) -> tree_of_typexp sch t1, tree_of_typexp sch t2)
++ tpl
++ in
++ (l, c && tpl = [], tree_of_typlist sch tyl, ttpl)
++ | Rabsent -> (l, false, [], [] (* une erreur, en fait *))
+
+ and tree_of_typlist sch tyl =
+ List.map (tree_of_typexp sch) tyl
+Index: typing/typeclass.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/typeclass.ml,v
+retrieving revision 1.85
+diff -u -r1.85 typeclass.ml
+--- typing/typeclass.ml 22 Jul 2005 06:42:36 -0000 1.85
++++ typing/typeclass.ml 2 Feb 2006 06:28:33 -0000
+@@ -727,7 +727,7 @@
+ {pexp_loc = loc; pexp_desc =
+ Pexp_match({pexp_loc = loc; pexp_desc =
+ Pexp_ident(Longident.Lident"*opt*")},
+- scases)} in
++ scases, false)} in
+ let sfun =
+ {pcl_loc = scl.pcl_loc; pcl_desc =
+ Pcl_fun(l, None, {ppat_loc = loc; ppat_desc = Ppat_var"*opt*"},
+Index: typing/typecore.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/typecore.ml,v
+retrieving revision 1.178
+diff -u -r1.178 typecore.ml
+--- typing/typecore.ml 6 Jan 2006 02:25:37 -0000 1.178
++++ typing/typecore.ml 2 Feb 2006 06:28:33 -0000
+@@ -156,15 +156,21 @@
+ let field = row_field tag row in
+ begin match field with
+ | Rabsent -> assert false
+- | Reither (true, [], _, e) when not row.row_closed ->
+- set_row_field e (Rpresent None)
+- | Reither (false, ty::tl, _, e) when not row.row_closed ->
++ | Reither (true, [], _, tpl, e) when not row.row_closed ->
++ set_row_field e (Rpresent None);
++ List.iter
++ (fun (t1,t2) -> unify_pat pat.pat_env {pat with pat_type=t1} t2)
++ tpl
++ | Reither (false, ty::tl, _, tpl, e) when not row.row_closed ->
+ set_row_field e (Rpresent (Some ty));
++ List.iter
++ (fun (t1,t2) -> unify_pat pat.pat_env {pat with pat_type=t1} t2)
++ tpl;
+ begin match opat with None -> assert false
+ | Some pat -> List.iter (unify_pat pat.pat_env pat) (ty::tl)
+ end
+- | Reither (c, l, true, e) when not row.row_fixed ->
+- set_row_field e (Reither (c, [], false, ref None))
++ | Reither (c, l, true, tpl, e) when not row.row_fixed ->
++ set_row_field e (Reither (c, [], false, [], ref None))
+ | _ -> ()
+ end;
+ (* Force check of well-formedness *)
+@@ -307,13 +313,13 @@
+ match row_field_repr f with
+ Rpresent None ->
+ (l,None) :: pats,
+- (l, Reither(true,[], true, ref None)) :: fields
++ (l, Reither(true,[], true, [], ref None)) :: fields
+ | Rpresent (Some ty) ->
+ bound := ty :: !bound;
+ (l, Some {pat_desc=Tpat_any; pat_loc=Location.none; pat_env=env;
+ pat_type=ty})
+ :: pats,
+- (l, Reither(false, [ty], true, ref None)) :: fields
++ (l, Reither(false, [ty], true, [], ref None)) :: fields
+ | _ -> pats, fields)
+ ([],[]) fields in
+ let row =
+@@ -337,6 +343,18 @@
+ pat pats in
+ rp { r with pat_loc = loc }
+
++let rec flatten_or_pat pat =
++ match pat.pat_desc with
++ Tpat_or (p1, p2, _) ->
++ flatten_or_pat p1 @ flatten_or_pat p2
++ | _ ->
++ [pat]
++
++let all_variants pat =
++ List.for_all
++ (function {pat_desc=Tpat_variant _} -> true | _ -> false)
++ (flatten_or_pat pat)
++
+ let rec find_record_qual = function
+ | [] -> None
+ | (Longident.Ldot (modname, _), _) :: _ -> Some modname
+@@ -423,7 +441,7 @@
+ let arg = may_map (type_pat env) sarg in
+ let arg_type = match arg with None -> [] | Some arg -> [arg.pat_type] in
+ let row = { row_fields =
+- [l, Reither(arg = None, arg_type, true, ref None)];
++ [l, Reither(arg = None, arg_type, true, [], ref None)];
+ row_bound = arg_type;
+ row_closed = false;
+ row_more = newvar ();
+@@ -788,7 +806,7 @@
+ newty (Tarrow(p, type_option (newvar ()), type_approx env e, Cok))
+ | Pexp_function (p,_,(_,e)::_) ->
+ newty (Tarrow(p, newvar (), type_approx env e, Cok))
+- | Pexp_match (_, (_,e)::_) -> type_approx env e
++ | Pexp_match (_, (_,e)::_, false) -> type_approx env e
+ | Pexp_try (e, _) -> type_approx env e
+ | Pexp_tuple l -> newty (Ttuple(List.map (type_approx env) l))
+ | Pexp_ifthenelse (_,e,_) -> type_approx env e
+@@ -939,17 +957,26 @@
+ exp_loc = sexp.pexp_loc;
+ exp_type = ty_res;
+ exp_env = env }
+- | Pexp_match(sarg, caselist) ->
++ | Pexp_match(sarg, caselist, multi) ->
+ let arg = type_exp env sarg in
+ let ty_res = newvar() in
+ let cases, partial =
+- type_cases env arg.exp_type ty_res (Some sexp.pexp_loc) caselist
++ type_cases env arg.exp_type ty_res (Some sexp.pexp_loc) caselist ~multi
+ in
+ re {
+ exp_desc = Texp_match(arg, cases, partial);
+ exp_loc = sexp.pexp_loc;
+ exp_type = ty_res;
+ exp_env = env }
++ | Pexp_multifun caselist ->
++ let ty_arg = newvar() and ty_res = newvar() in
++ let cases, partial =
++ type_cases env ty_arg ty_res (Some sexp.pexp_loc) caselist ~multi:true
++ in
++ { exp_desc = Texp_function (cases, partial);
++ exp_loc = sexp.pexp_loc;
++ exp_type = newty (Tarrow ("", ty_arg, ty_res, Cok));
++ exp_env = env }
+ | Pexp_try(sbody, caselist) ->
+ let body = type_exp env sbody in
+ let cases, _ =
+@@ -1758,7 +1785,7 @@
+ {pexp_loc = loc; pexp_desc =
+ Pexp_match({pexp_loc = loc; pexp_desc =
+ Pexp_ident(Longident.Lident"*opt*")},
+- scases)} in
++ scases, false)} in
+ let sfun =
+ {pexp_loc = sexp.pexp_loc; pexp_desc =
+ Pexp_function(l, None,[{ppat_loc = loc; ppat_desc = Ppat_var"*opt*"},
+@@ -1864,7 +1891,8 @@
+
+ (* Typing of match cases *)
+
+-and type_cases ?in_function env ty_arg ty_res partial_loc caselist =
++and type_cases ?in_function ?(multi=false)
++ env ty_arg ty_res partial_loc caselist =
+ let ty_arg' = newvar () in
+ let pattern_force = ref [] in
+ let pat_env_list =
+@@ -1898,10 +1926,64 @@
+ let cases =
+ List.map2
+ (fun (pat, ext_env) (spat, sexp) ->
+- let exp = type_expect ?in_function ext_env sexp ty_res in
+- (pat, exp))
+- pat_env_list caselist
+- in
++ let add_variant_case lab row ty_res ty_res' =
++ let fi = List.assoc lab (row_repr row).row_fields in
++ begin match row_field_repr fi with
++ Reither (c, _, m, _, e) ->
++ let row' =
++ { row_fields =
++ [lab, Reither(c,[],false,[ty_res,ty_res'], ref None)];
++ row_more = newvar (); row_bound = [ty_res; ty_res'];
++ row_closed = false; row_fixed = false; row_name = None }
++ in
++ unify_pat ext_env {pat with pat_type= newty (Tvariant row)}
++ (newty (Tvariant row'))
++ | _ ->
++ unify_exp ext_env
++ { exp_desc = Texp_tuple []; exp_type = ty_res;
++ exp_env = ext_env; exp_loc = sexp.pexp_loc }
++ ty_res'
++ end
++ in
++ pat,
++ match pat.pat_desc with
++ _ when multi && all_variants pat ->
++ let ty_res' = newvar () in
++ List.iter
++ (function {pat_desc=Tpat_variant(lab,_,row)} ->
++ add_variant_case lab row ty_res ty_res'
++ | _ -> assert false)
++ (flatten_or_pat pat);
++ type_expect ?in_function ext_env sexp ty_res'
++ | Tpat_alias (p, id) when multi && all_variants p ->
++ let vd = Env.find_value (Path.Pident id) ext_env in
++ let row' =
++ match repr vd.val_type with
++ {desc=Tvariant row'} -> row'
++ | _ -> assert false
++ in
++ begin_def ();
++ let tv = newvar () in
++ let env = Env.add_value id {vd with val_type=tv} ext_env in
++ let exp = type_exp env sexp in
++ end_def ();
++ generalize exp.exp_type;
++ generalize tv;
++ List.iter
++ (function {pat_desc=Tpat_variant(lab,_,row)}, [tv'; ty'] ->
++ let fi' = List.assoc lab (row_repr row').row_fields in
++ let row' =
++ {row' with row_fields=[lab,fi']; row_more=newvar()} in
++ unify_pat ext_env {pat with pat_type=tv'}
++ (newty (Tvariant row'));
++ add_variant_case lab row ty_res ty'
++ | _ -> assert false)
++ (List.map (fun p -> p, instance_list [tv; exp.exp_type])
++ (flatten_or_pat p));
++ {exp with exp_type = instance exp.exp_type}
++ | _ ->
++ type_expect ?in_function ext_env sexp ty_res)
++ pat_env_list caselist in
+ let partial =
+ match partial_loc with None -> Partial
+ | Some loc -> Parmatch.check_partial loc cases
+Index: typing/typedecl.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/typedecl.ml,v
+retrieving revision 1.75
+diff -u -r1.75 typedecl.ml
+--- typing/typedecl.ml 16 Aug 2005 00:48:56 -0000 1.75
++++ typing/typedecl.ml 2 Feb 2006 06:28:33 -0000
+@@ -432,8 +432,10 @@
+ match Btype.row_field_repr f with
+ Rpresent (Some ty) ->
+ compute_same ty
+- | Reither (_, tyl, _, _) ->
+- List.iter compute_same tyl
++ | Reither (_, tyl, _, tpl, _) ->
++ List.iter compute_same tyl;
++ List.iter (compute_variance_rec true true true)
++ (List.map fst tpl @ List.map snd tpl)
+ | _ -> ())
+ row.row_fields;
+ compute_same row.row_more
+@@ -856,8 +858,8 @@
+ explain row.row_fields
+ (fun (l,f) -> match Btype.row_field_repr f with
+ Rpresent (Some t) -> t
+- | Reither (_,[t],_,_) -> t
+- | Reither (_,tl,_,_) -> Btype.newgenty (Ttuple tl)
++ | Reither (_,[t],_,_,_) -> t
++ | Reither (_,tl,_,_,_) -> Btype.newgenty (Ttuple tl)
+ | _ -> Btype.newgenty (Ttuple[]))
+ "case" (fun (lab,_) -> "`" ^ lab ^ " of ")
+ | _ -> trivial ty'
+Index: typing/types.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/types.ml,v
+retrieving revision 1.25
+diff -u -r1.25 types.ml
+--- typing/types.ml 9 Dec 2004 12:40:53 -0000 1.25
++++ typing/types.ml 2 Feb 2006 06:28:33 -0000
+@@ -48,7 +48,9 @@
+
+ and row_field =
+ Rpresent of type_expr option
+- | Reither of bool * type_expr list * bool * row_field option ref
++ | Reither of
++ bool * type_expr list * bool *
++ (type_expr * type_expr) list * row_field option ref
+ | Rabsent
+
+ and abbrev_memo =
+Index: typing/types.mli
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/types.mli,v
+retrieving revision 1.25
+diff -u -r1.25 types.mli
+--- typing/types.mli 9 Dec 2004 12:40:53 -0000 1.25
++++ typing/types.mli 2 Feb 2006 06:28:33 -0000
+@@ -47,7 +47,9 @@
+
+ and row_field =
+ Rpresent of type_expr option
+- | Reither of bool * type_expr list * bool * row_field option ref
++ | Reither of
++ bool * type_expr list * bool *
++ (type_expr * type_expr) list * row_field option ref
+ (* 1st true denotes a constant constructor *)
+ (* 2nd true denotes a tag in a pattern matching, and
+ is erased later *)
+Index: typing/typetexp.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/typetexp.ml,v
+retrieving revision 1.54
+diff -u -r1.54 typetexp.ml
+--- typing/typetexp.ml 22 Jul 2005 06:42:36 -0000 1.54
++++ typing/typetexp.ml 2 Feb 2006 06:28:33 -0000
+@@ -207,9 +207,9 @@
+ match Btype.row_field_repr f with
+ | Rpresent (Some ty) ->
+ bound := ty :: !bound;
+- Reither(false, [ty], false, ref None)
++ Reither(false, [ty], false, [], ref None)
+ | Rpresent None ->
+- Reither (true, [], false, ref None)
++ Reither (true, [], false, [], ref None)
+ | _ -> f)
+ row.row_fields
+ in
+@@ -273,13 +273,16 @@
+ (l, f) :: fields
+ in
+ let rec add_field fields = function
+- Rtag (l, c, stl) ->
++ Rtag (l, c, stl, stpl) ->
+ name := None;
+ let f = match present with
+ Some present when not (List.mem l present) ->
+- let tl = List.map (transl_type env policy) stl in
+- bound := tl @ !bound;
+- Reither(c, tl, false, ref None)
++ let transl_list = List.map (transl_type env policy) in
++ let tl = transl_list stl in
++ let stpl1, stpl2 = List.split stpl in
++ let tpl1 = transl_list stpl1 and tpl2 = transl_list stpl2 in
++ bound := tl @ tpl1 @ tpl2 @ !bound;
++ Reither(c, tl, false, List.combine tpl1 tpl2, ref None)
+ | _ ->
+ if List.length stl > 1 || c && stl <> [] then
+ raise(Error(styp.ptyp_loc, Present_has_conjunction l));
+@@ -311,9 +314,9 @@
+ begin match f with
+ Rpresent(Some ty) ->
+ bound := ty :: !bound;
+- Reither(false, [ty], false, ref None)
++ Reither(false, [ty], false, [], ref None)
+ | Rpresent None ->
+- Reither(true, [], false, ref None)
++ Reither(true, [], false, [], ref None)
+ | _ ->
+ assert false
+ end
+@@ -406,7 +409,8 @@
+ {row with row_fixed=true;
+ row_fields = List.map
+ (fun (s,f as p) -> match Btype.row_field_repr f with
+- Reither (c, tl, m, r) -> s, Reither (c, tl, true, r)
++ Reither (c, tl, m, tpl, r) ->
++ s, Reither (c, tl, true, tpl, r)
+ | _ -> p)
+ row.row_fields};
+ Btype.iter_row make_fixed_univars row
+Index: typing/unused_var.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/unused_var.ml,v
+retrieving revision 1.5
+diff -u -r1.5 unused_var.ml
+--- typing/unused_var.ml 4 Jan 2006 16:55:50 -0000 1.5
++++ typing/unused_var.ml 2 Feb 2006 06:28:33 -0000
+@@ -122,9 +122,11 @@
+ | Pexp_apply (e, lel) ->
+ expression ppf tbl e;
+ List.iter (fun (_, e) -> expression ppf tbl e) lel;
+- | Pexp_match (e, pel) ->
++ | Pexp_match (e, pel, _) ->
+ expression ppf tbl e;
+ match_pel ppf tbl pel;
++ | Pexp_multifun pel ->
++ match_pel ppf tbl pel;
+ | Pexp_try (e, pel) ->
+ expression ppf tbl e;
+ match_pel ppf tbl pel;
+Index: bytecomp/matching.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/matching.ml,v
+retrieving revision 1.67
+diff -u -r1.67 matching.ml
+--- bytecomp/matching.ml 7 Sep 2005 16:07:48 -0000 1.67
++++ bytecomp/matching.ml 2 Feb 2006 06:28:33 -0000
+@@ -1991,7 +1991,7 @@
+ List.iter
+ (fun (_, f) ->
+ match Btype.row_field_repr f with
+- Rabsent | Reither(true, _::_, _, _) -> ()
++ Rabsent | Reither(true, _::_, _, _, _) -> ()
+ | _ -> incr num_constr)
+ row.row_fields
+ else
+Index: toplevel/genprintval.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/toplevel/genprintval.ml,v
+retrieving revision 1.38
+diff -u -r1.38 genprintval.ml
+--- toplevel/genprintval.ml 13 Jun 2005 04:55:53 -0000 1.38
++++ toplevel/genprintval.ml 2 Feb 2006 06:28:33 -0000
+@@ -293,7 +293,7 @@
+ | (l, f) :: fields ->
+ if Btype.hash_variant l = tag then
+ match Btype.row_field_repr f with
+- | Rpresent(Some ty) | Reither(_,[ty],_,_) ->
++ | Rpresent(Some ty) | Reither(_,[ty],_,_,_) ->
+ let args =
+ tree_of_val (depth - 1) (O.field obj 1) ty in
+ Oval_variant (l, Some args)
diff --git a/experimental/garrigue/multimatch.ml b/experimental/garrigue/multimatch.ml
new file mode 100644
index 000000000..7c9aa73f9
--- /dev/null
+++ b/experimental/garrigue/multimatch.ml
@@ -0,0 +1,158 @@
+(* Simple example *)
+let f x =
+ (multimatch x with `A -> 1 | `B -> true),
+ (multimatch x with `A -> 1. | `B -> "1");;
+
+(* OK *)
+module M : sig
+ val f :
+ [< `A & 'a = int & 'b = float | `B & 'b =string & 'a = bool] -> 'a * 'b
+end = struct let f = f end;;
+
+(* Bad *)
+module M : sig
+ val f :
+ [< `A & 'a = int & 'b = float | `B & 'b =string & 'a = int] -> 'a * 'b
+end = struct let f = f end;;
+
+(* Should be good! *)
+module M : sig
+ val f :
+ [< `A & 'a = int * float | `B & 'a = bool * string] -> 'a
+end = struct let f = f end;;
+
+let f = multifun `A|`B as x -> f x;;
+
+(* Two-level example *)
+let f = multifun
+ `A -> (multifun `C -> 1 | `D -> 1.)
+ | `B -> (multifun `C -> true | `D -> "1");;
+
+(* OK *)
+module M : sig
+ val f :
+ [< `A & 'b = [< `C & 'a = int | `D & 'a = float & 'c = bool] -> 'a
+ | `B & 'b = [< `C & 'c = bool | `D & 'c = string] -> 'c] -> 'b
+end = struct let f = f end;;
+
+(* Bad *)
+module M : sig
+ val f :
+ [< `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 [];;
+(* Now OK *)
+module M : sig
+ val f : [< `A & 'b = int list ref | `B & 'b = 'c list ref] -> 'b
+end = struct let f = f end;;
+(* Still OK *)
+let l : int list ref = 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);;
+(* Didn't work, now Ok *)
+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;;
+
+
+(* type dispatch *)
+
+type num = [ `Int | `Float ]
+let print0 = multifun
+ `Int -> print_int
+ | `Float -> print_float
+;;
+let print1 = multifun
+ #num as x -> print0 x
+ | `List t -> List.iter (print0 t)
+ | `Pair(t1,t2) -> (fun (x,y) -> print0 t1 x; print0 t2 y)
+;;
+print1 (`Pair(`Int,`Float)) (1,1.0);;
diff --git a/experimental/garrigue/newlabels.ps b/experimental/garrigue/newlabels.ps
new file mode 100644
index 000000000..01eac1945
--- /dev/null
+++ b/experimental/garrigue/newlabels.ps
@@ -0,0 +1,1458 @@
+%!PS-Adobe-2.0
+%%Creator: dvipsk 5.78 p1.4 Copyright 1996-98 ASCII Corp.(www-ptex@ascii.co.jp)
+%%dvipsk 5.78 Copyright 1998 Radical Eye Software (www.radicaleye.com)
+%%Title: newlabels.dvi
+%%Pages: 2 0
+%%PageOrder: Ascend
+%%BoundingBox: 0 0 596 842
+%%EndComments
+%%BeginProcSet: PStoPS 1 15
+userdict begin
+[/showpage/erasepage/copypage]{dup where{pop dup load
+ type/operatortype eq{1 array cvx dup 0 3 index cvx put
+ bind def}{pop}ifelse}{pop}ifelse}forall
+[/letter/legal/executivepage/a4/a4small/b5/com10envelope
+ /monarchenvelope/c5envelope/dlenvelope/lettersmall/note
+ /folio/quarto/a5]{dup where{dup wcheck{exch{}put}
+ {pop{}def}ifelse}{pop}ifelse}forall
+/setpagedevice {pop}bind 1 index where{dup wcheck{3 1 roll put}
+ {pop def}ifelse}{def}ifelse
+/PStoPSmatrix matrix currentmatrix def
+/PStoPSxform matrix def/PStoPSclip{clippath}def
+/defaultmatrix{PStoPSmatrix exch PStoPSxform exch concatmatrix}bind def
+/initmatrix{matrix defaultmatrix setmatrix}bind def
+/initclip[{matrix currentmatrix PStoPSmatrix setmatrix
+ [{currentpoint}stopped{$error/newerror false put{newpath}}
+ {/newpath cvx 3 1 roll/moveto cvx 4 array astore cvx}ifelse]
+ {[/newpath cvx{/moveto cvx}{/lineto cvx}
+ {/curveto cvx}{/closepath cvx}pathforall]cvx exch pop}
+ stopped{$error/errorname get/invalidaccess eq{cleartomark
+ $error/newerror false put cvx exec}{stop}ifelse}if}bind aload pop
+ /initclip dup load dup type dup/operatortype eq{pop exch pop}
+ {dup/arraytype eq exch/packedarraytype eq or
+ {dup xcheck{exch pop aload pop}{pop cvx}ifelse}
+ {pop cvx}ifelse}ifelse
+ {newpath PStoPSclip clip newpath exec setmatrix} bind aload pop]cvx def
+/initgraphics{initmatrix newpath initclip 1 setlinewidth
+ 0 setlinecap 0 setlinejoin []0 setdash 0 setgray
+ 10 setmiterlimit}bind def
+end
+%%EndProcSet
+%DVIPSCommandLine: dvips -f newlabels
+%DVIPSParameters: dpi=300
+%DVIPSSource: TeX output 1999.10.26:1616
+%%BeginProcSet: tex.pro
+%!
+/TeXDict 300 dict def TeXDict begin /N{def}def /B{bind def}N /S{exch}N
+/X{S N}B /TR{translate}N /isls false N /vsize 11 72 mul N /hsize 8.5 72
+mul N /landplus90{false}def /@rigin{isls{[0 landplus90{1 -1}{-1 1}
+ifelse 0 0 0]concat}if 72 Resolution div 72 VResolution div neg scale
+isls{landplus90{VResolution 72 div vsize mul 0 exch}{Resolution -72 div
+hsize mul 0}ifelse TR}if Resolution VResolution vsize -72 div 1 add mul
+TR[matrix currentmatrix{dup dup round sub abs 0.00001 lt{round}if}
+forall round exch round exch]setmatrix}N /@landscape{/isls true N}B
+/@manualfeed{statusdict /manualfeed true put}B /@copies{/#copies X}B
+/FMat[1 0 0 -1 0 0]N /FBB[0 0 0 0]N /nn 0 N /IE 0 N /ctr 0 N /df-tail{
+/nn 8 dict N nn begin /FontType 3 N /FontMatrix fntrx N /FontBBox FBB N
+string /base X array /BitMaps X /BuildChar{CharBuilder}N /Encoding IE N
+end dup{/foo setfont}2 array copy cvx N load 0 nn put /ctr 0 N[}B /df{
+/sf 1 N /fntrx FMat N df-tail}B /dfs{div /sf X /fntrx[sf 0 0 sf neg 0 0]
+N df-tail}B /E{pop nn dup definefont setfont}B /ch-width{ch-data dup
+length 5 sub get}B /ch-height{ch-data dup length 4 sub get}B /ch-xoff{
+128 ch-data dup length 3 sub get sub}B /ch-yoff{ch-data dup length 2 sub
+get 127 sub}B /ch-dx{ch-data dup length 1 sub get}B /ch-image{ch-data
+dup type /stringtype ne{ctr get /ctr ctr 1 add N}if}B /id 0 N /rw 0 N
+/rc 0 N /gp 0 N /cp 0 N /G 0 N /sf 0 N /CharBuilder{save 3 1 roll S dup
+/base get 2 index get S /BitMaps get S get /ch-data X pop /ctr 0 N ch-dx
+0 ch-xoff ch-yoff ch-height sub ch-xoff ch-width add ch-yoff
+setcachedevice ch-width ch-height true[1 0 0 -1 -.1 ch-xoff sub ch-yoff
+.1 sub]{ch-image}imagemask restore}B /D{/cc X dup type /stringtype ne{]}
+if nn /base get cc ctr put nn /BitMaps get S ctr S sf 1 ne{dup dup
+length 1 sub dup 2 index S get sf div put}if put /ctr ctr 1 add N}B /I{
+cc 1 add D}B /bop{userdict /bop-hook known{bop-hook}if /SI save N @rigin
+0 0 moveto /V matrix currentmatrix dup 1 get dup mul exch 0 get dup mul
+add .99 lt{/QV}{/RV}ifelse load def pop pop}N /eop{SI restore userdict
+/eop-hook known{eop-hook}if showpage}N /@start{userdict /start-hook
+known{start-hook}if pop /VResolution X /Resolution X 1000 div /DVImag X
+/IE 256 array N 2 string 0 1 255{IE S dup 360 add 36 4 index cvrs cvn
+put}for pop 65781.76 div /vsize X 65781.76 div /hsize X}N /p{show}N
+/RMat[1 0 0 -1 0 0]N /BDot 260 string N /rulex 0 N /ruley 0 N /v{/ruley
+X /rulex X V}B /V{}B /RV statusdict begin /product where{pop false[
+(Display)(NeXT)(LaserWriter 16/600)]{dup length product length le{dup
+length product exch 0 exch getinterval eq{pop true exit}if}{pop}ifelse}
+forall}{false}ifelse end{{gsave TR -.1 .1 TR 1 1 scale rulex ruley false
+RMat{BDot}imagemask grestore}}{{gsave TR -.1 .1 TR rulex ruley scale 1 1
+false RMat{BDot}imagemask grestore}}ifelse B /QV{gsave newpath transform
+round exch round exch itransform moveto rulex 0 rlineto 0 ruley neg
+rlineto rulex neg 0 rlineto fill grestore}B /a{moveto}B /delta 0 N /tail
+{dup /delta X 0 rmoveto}B /M{S p delta add tail}B /b{S p tail}B /c{-4 M}
+B /d{-3 M}B /e{-2 M}B /f{-1 M}B /g{0 M}B /h{1 M}B /i{2 M}B /j{3 M}B /k{
+4 M}B /w{0 rmoveto}B /l{p -4 w}B /m{p -3 w}B /n{p -2 w}B /o{p -1 w}B /q{
+p 1 w}B /r{p 2 w}B /s{p 3 w}B /t{p 4 w}B /x{0 S rmoveto}B /y{3 2 roll p
+a}B /bos{/SS save N}B /eos{SS restore}B end
+
+%%EndProcSet
+TeXDict begin 39158280 55380996 1000 300 300 (newlabels.dvi)
+@start
+%DVIPSBitmapFont: Fa cmr6 6 2
+/Fa 2 51 df<187898181818181818181818181818FF08107D8F0F> 49
+D<1F00618040C08060C0600060006000C00180030006000C00102020207FC0FFC00B107F
+8F0F> I E
+%EndDVIPSBitmapFont
+%DVIPSBitmapFont: Fb cmmi8 8 4
+/Fb 4 111 df<FFC0FF1C00181C00101C00101C00103800203800203800203800207000
+40700040700040700040E00080E00080E00080E00080E00100E00200E004006008003830
+000FC00018177E9618> 85 D<0300038003000000000000000000000000001C00240046
+0046008C000C0018001800180031003100320032001C0009177F960C> 105
+D<383C1E0044C6630047028100460301008E0703000C0603000C0603000C060300180C06
+00180C0620180C0C20180C0C40301804C0301807001B0E7F8D1F> 109
+D<383C0044C6004702004602008E06000C06000C06000C0600180C00180C401818401818
+80300980300E00120E7F8D15> I E
+%EndDVIPSBitmapFont
+%DVIPSBitmapFont: Fc cmbx8 8 4
+/Fc 4 111 df<01800780FF80FF80078007800780078007800780078007800780078007
+800780078007800780FFF8FFF80D157D9414> 49 D<387C7C7C3800000000FCFC3C3C3C
+3C3C3C3C3C3C3C3CFFFF08187F970B> 105 D<FC7E0FC0FD8730E03E07C0F03E07C0F03C
+0780F03C0780F03C0780F03C0780F03C0780F03C0780F03C0780F03C0780F03C0780F0FF
+1FE3FCFF1FE3FC1E0F7E8E23> 109 D<FC7C00FD8E003E0F003E0F003C0F003C0F003C0F
+003C0F003C0F003C0F003C0F003C0F003C0F00FF3FC0FF3FC0120F7E8E17> I
+E
+%EndDVIPSBitmapFont
+%DVIPSBitmapFont: Fd cmsy8 8 3
+/Fd 3 93 df<FFFFF0FFFFF014027D881B> 0 D<020002000200C218F2783AE00F800F80
+3AE0F278C2180200020002000D0E7E8E12> 3 D<03F8001FFF003C07806000C0C00060C0
+0060C00060C00060C00060C00060C00060C00060C00060C00060C00060C00060C00060C0
+006040002013137E9218> 92 D E
+%EndDVIPSBitmapFont
+%DVIPSBitmapFont: Fe cmtt12 12 43
+/Fe 43 125 df<01818003C3C003C3C003C3C003C3C003C3C003C3C07FFFF0FFFFF8FFFF
+F87FFFF00787800787800787800F8F800F0F000F0F000F0F000F0F007FFFF0FFFFF8FFFF
+F87FFFF01E1E001E1E001E1E001E1E001E1E001E1E000C0C00151E7E9D1A> 35
+D<00E00003F00007F8000738000E1C000E1C000E1C000E1C000E38000E39FC0E71FC07F1
+FC07E1C007C1C00781C00783800F83801FC3803DC70078E70070EE00E07E00E07E00E03C
+08E03C1CE07E1C70FF1C7FE7F83FC3F80F00E0161E7F9D1A> 38
+D<0038007800F001E003C007800F000E001C001C0038003800700070007000E000E000E0
+00E000E000E000E000E000E000E000700070007000380038001C001C000E000F00078003
+C001E000F8007800380D2878A21A> 40 D<6000F00078003C001E000F000780038001C0
+01C000E000E0007000700070003800380038003800380038003800380038003800700070
+007000E000E001C001C0038007800F001E003C007800F00060000D287CA21A> I<7FFFC0
+FFFFE0FFFFE07FFFC013047D901A> 45 D<00C001C001C003C007C00FC07FC0FDC071C0
+01C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C0
+7FFF7FFF7FFF101E7B9D1A> 49 D<03F8000FFE001FFF803C07C07801E07000E0E00070
+F00070F000706000700000700000700000E00000E00001C00003C0000780000F00001E00
+003C0000780000F00003E00007C0000F00001E00703C00707FFFF0FFFFF07FFFF0141E7D
+9D1A> I<03FC000FFF003FFFC03C03E07800E07800707800700000700000700000E00001
+E00007C003FF8003FF0003FFC00003E00000E0000070000078000038000038600038F000
+38F00078E000707000E07E03E03FFFC00FFF0001FC00151E7E9D1A> I<01FC0007FF001F
+FFC01F07C03C01E07800F07000707000707000707800F03800E01E03C00FFF8003FE0007
+FF001F8FC03C01E07800F0700070E00038E00038E00038E00038F000787000707800F03E
+03E01FFFC007FF0001FC00151E7E9D1A> 56 D<01F00007FC001FFE003E0F0038078070
+03807001C0E001C0E001C0E001E0E000E0E000E0E001E07001E07803E03C0FE01FFFE00F
+FCE003F0E00001C00001C00001C0000380600380F00700F00F00F03E007FFC003FF0000F
+C000131E7D9D1A> I<3078FCFC78300000000000000000003078FCFC7830061576941A>
+I<183C7E7E3C18000000000000000000183C7E7E3E1E0E0E1C3CF8F060071C77941A> I<
+0000C00003E00007E0000FC0003F80007E0000FC0003F80007E0000FC0003F80007E0000
+FC0000FC00007E00003F80000FC00007E00003F80000FC00007E00003F80000FC00007E0
+0003E00000C0131A7D9B1A> I<7FFFF0FFFFF8FFFFF87FFFF00000000000000000000000
+007FFFF0FFFFF8FFFFF87FFFF0150C7E941A> I<600000F80000FC00007E00003F80000F
+C00007E00003F80000FC00007E00003F80000FC00007E00007E0000FC0003F80007E0000
+FC0003F80007E0000FC0003F80007E0000FC0000F80000600000131A7D9B1A> I<007C38
+01FF3807FFF80F83F81E00F81C0078380078380038700038700038700000E00000E00000
+E00000E00000E00000E00000E00000E000007000007000387000383800383800381C0070
+1E00F00F83E007FFC001FF80007C00151E7E9D1A> 67 D<FE03FEFF03FEFF03FE1D8070
+1D80701DC0701CC0701CC0701CE0701CE0701C60701C70701C70701C30701C38701C3870
+1C18701C1C701C1C701C0C701C0E701C0E701C06701C06701C07701C03701C0370FF81F0
+FF81F0FF80F0171E7F9D1A> 78 D<03F8E00FFEE01FFFE03C07E07801E0F001E0E000E0
+E000E0E000E0E000007000007800003F80001FF80007FF00007FC00007E00000F0000070
+000038000038600038E00038E00038E00070F000F0FE01E0FFFFC0EFFF80E1FE00151E7E
+9D1A> 83 D<7FFFFEFFFFFEFFFFFEE0380EE0380EE0380EE0380E003800003800003800
+003800003800003800003800003800003800003800003800003800003800003800003800
+00380000380000380000380000380003FF8003FF8003FF80171E7F9D1A> I<FFFCFFFCFF
+FCE000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E0
+00E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000FFFCFFFCFF
+FC0E2776A21A> 91 D<FFFCFFFCFFFC001C001C001C001C001C001C001C001C001C001C
+001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C
+001C001C001C001C001CFFFCFFFCFFFC0E277FA21A> 93 D<1FF0003FFC007FFE00780F
+00300700000380000380007F8007FF801FFF803F8380780380700380E00380E00380E003
+80700780780F803FFFFC1FFDFC07F0FC16157D941A> 97 D<7E0000FE00007E00000E00
+000E00000E00000E00000E00000E00000E3E000EFF800FFFE00FC1F00F80700F00380E00
+380E001C0E001C0E001C0E001C0E001C0E001C0E001C0F00380F00780F80F00FC1E00FFF
+C00EFF80063E00161E7F9D1A> I<00FF8003FFC00FFFE01F01E03C00C078000070000070
+0000E00000E00000E00000E00000E000007000007000007800703C00701F01F00FFFE003
+FFC000FE0014157D941A> I<000FC0001FC0000FC00001C00001C00001C00001C00001C0
+0001C001F1C007FDC00FFFC01E0FC03C07C07803C07001C0E001C0E001C0E001C0E001C0
+E001C0E001C0E001C07003C07003C03807C03E0FC01FFFF807FDFC01F1F8161E7E9D1A>
+I<01F80007FF000FFF801E07C03C01C07800E07000E0E00070E00070FFFFF0FFFFF0FFFF
+F0E000007000007000007800703C00701F01F00FFFE003FF8000FE0014157D941A> I<00
+07E0001FF0003FF800787800F03000E00000E00000E00000E0007FFFF0FFFFF0FFFFF000
+E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000
+E00000E00000E0003FFF807FFFC03FFF80151E7F9D1A> I<7E0000FE00007E00000E0000
+0E00000E00000E00000E00000E00000E3E000EFF800FFFC00FC1C00F80E00F00E00E00E0
+0E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E07FC3FC
+FFE7FE7FC3FC171E7F9D1A> 104 D<00C00001E00001E00000C000000000000000000000
+0000000000000000007FE0007FE0007FE00000E00000E00000E00000E00000E00000E000
+00E00000E00000E00000E00000E00000E00000E00000E00000E0007FFF80FFFFC07FFF80
+121F7C9E1A> I<7FE000FFE0007FE00000E00000E00000E00000E00000E00000E00000E0
+0000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E0
+0000E00000E00000E00000E00000E0007FFFC0FFFFE07FFFC0131E7D9D1A> 108
+D<7CE0E000FFFBF8007FFFF8001F1F1C001E1E1C001E1E1C001C1C1C001C1C1C001C1C1C
+001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C
+007F1F1F00FFBFBF807F1F1F00191580941A> I<7E3E00FEFF807FFFC00FC1C00F80E00F
+00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E
+00E07FC3FCFFE7FE7FC3FC17157F941A> I<01F00007FC001FFF003E0F803C07807803C0
+7001C0E000E0E000E0E000E0E000E0E000E0E000E0F001E07001C07803C03C07803E0F80
+1FFF0007FC0001F00013157D941A> I<7E3E00FEFF807FFFE00FC1F00F80700F00380E00
+380E001C0E001C0E001C0E001C0E001C0E001C0E001C0F00380F00780F80F00FC1E00FFF
+C00EFF800E3E000E00000E00000E00000E00000E00000E00000E00000E00007FC000FFE0
+007FC00016207F941A> I<7F81F8FF8FFC7F9FFE03FE1E03F80C03E00003E00003C00003
+80000380000380000380000380000380000380000380000380000380007FFF00FFFF007F
+FF0017157F941A> 114 D<07FB801FFF807FFF80780780E00380E00380E003807800007F
+C0001FFC0007FE00003F800007806001C0E001C0E001C0F003C0FC0780FFFF00EFFE00E3
+F80012157C941A> I<0180000380000380000380000380000380000380007FFFE0FFFFE0
+FFFFE0038000038000038000038000038000038000038000038000038000038000038070
+03807003807003807001C1E001FFE000FF80003F00141C7F9B1A> I<7E07E0FE0FE07E07
+E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00
+E00E00E00E01E00F03E007FFFC03FFFE00FCFC17157F941A> I<7F83FCFFC7FE7F83FC0E
+00E00E00E00E00E00701C00701C00701C003838003838003838001C70001C70001C70000
+EE0000EE0000EE00007C00007C0000380017157F941A> I<FF83FEFF83FEFF83FE380038
+3800381C00701C00701C00701C38701C7C701C7C700C6C600EEEE00EEEE00EEEE00EEEE0
+0EC6E006C6C007C7C00783C00783C017157F941A> I<7FC7F87FCFFC7FC7F80703C00383
+8003C70001EF0000FE00007C00007800003800007C0000EE0001EE0001C7000383800783
+C00F01C07FC7FCFFC7FE7FC7FC17157F941A> I<7F83FCFFC7FE7F83FC0E00E00E00E007
+00E00701C00701C00381C003838003C38001C38001C70000E70000E70000E60000660000
+6E00003C00003C00003C0000380000380000380000700000700030F00078E00071E0007F
+C0003F80001E000017207F941A> I<60F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0
+F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F060042775A21A> 124 D
+E
+%EndDVIPSBitmapFont
+%DVIPSBitmapFont: Ff cmr8 8 3
+/Ff 3 51 df<003000003000003000003000003000003000003000003000003000003000
+003000FFFFFCFFFFFC003000003000003000003000003000003000003000003000003000
+00300000300016187E931B> 43 D<06000E00FE000E000E000E000E000E000E000E000E
+000E000E000E000E000E000E000E000E000E00FFE00B157D9412> 49
+D<0F8030E040708030C038E0384038003800700070006000C00180030006000C08080810
+183FF07FF0FFF00D157E9412> I E
+%EndDVIPSBitmapFont
+%DVIPSBitmapFont: Fg cmmi12 12 13
+/Fg 13 121 df<0FFFF81FFFFC3FFFF870200040200080200080600000600000600000C0
+0000C00000C00000C00001C0000180000180000380000380000380000700000300001615
+7E9415> 28 D<0000100000002000000020000000200000002000000040000000400000
+004000000040000000800000008000000080000000800000010000000FE00000711C0001
+C10600030203000E0203801C020180180201C0380401C0700401C0700401C0700401C0E0
+080380E0080380E00807006008070070100E0030101C00301038001C10E0000623800001
+FE0000002000000020000000400000004000000040000000400000008000000080000000
+800000008000001A2D7EA21D> 30 D<70F8F8F87005057C840E> 58
+D<70F8FCFC7404040404080810102040060F7C840E> I<00008000018000018000030000
+0300000300000600000600000600000C00000C00000C0000180000180000180000300000
+300000300000600000600000600000C00000C00000C00001800001800001800001800003
+00000300000300000600000600000600000C00000C00000C000018000018000018000030
+0000300000300000600000600000600000C00000C00000C0000011317DA418> 61
+D<00FFFC00000F8000000F0000000F0000001E0000001E0000001E0000001E0000003C00
+00003C0000003C0000003C00000078000000780000007800000078000000F0000000F000
+0000F0000000F0000001E0000001E0000001E0002001E0002003C0004003C0004003C000
+8003C0008007800180078001000780030007800F000F803E00FFFFFE001B227DA121> 76
+D<1FFFFFFE1E01E00E1801E0063001E0062003C0062003C0064003C0044003C004400780
+04800780048007800400078000000F0000000F0000000F0000000F0000001E0000001E00
+00001E0000001E0000003C0000003C0000003C0000003C00000078000000780000007800
+000078000000F0000000F0000000F0000000F0000001F000007FFFC0001F227EA11D> 84
+D<3FFE01FF8003C0003C0003C000300003C0001000078000200007800020000780002000
+07800020000F000040000F000040000F000040000F000040001E000080001E000080001E
+000080001E000080003C000100003C000100003C000100003C0001000078000200007800
+020000780002000078000200007000040000F000040000F0000800007000080000700010
+00007000200000380040000038008000001C01000000060600000001F800000021237DA1
+21> I<007E000381000700800E00801C0080380080780100700600FFF800F00000F00000
+E00000E00000E00000E00000E00080E000807003003004001838000FC00011157D9417>
+101 D<01E00FC001C001C001C0038003800380038007000700070007000E000E000E000E
+001C001C001C001C0038003800380038007000700070007080E100E100E100620062003C
+000B237EA20F> 108 D<03C0F004631C04740E08780E08700708700708700F00E00F00E0
+0F00E00F00E00F01C01E01C01E01C01E01C03C03803803803803C07003C0E0072180071E
+000700000700000E00000E00000E00000E00001C00001C00001C0000FF8000181F819418
+> 112 D<3C0F004630C04741C08783C08783C08701808700000E00000E00000E00000E00
+001C00001C00001C00001C000038000038000038000038000070000030000012157E9416
+> 114 D<01E0F006310C081A1C101A3C201C3C201C18201C000038000038000038000038
+0000700000700000700000700860E010F0E010F0E020E170404230803C1F0016157E941C
+> 120 D E
+%EndDVIPSBitmapFont
+%DVIPSBitmapFont: Fh cmti12 12 22
+/Fh 22 122 df<FFF0FFF0FFE00C037C8B11> 45 D<70F8F8F0E005057A840F> I<00F8
+C00185C00705C00E03800E03801C03803C0380380700780700780700780700F00E00F00E
+00F00E00F00E10F01C20701C20703C20305C40308C400F078014157B9419> 97
+D<03C01F8003800380038007000700070007000E000E000E000E001C001CF81D0C1E0E3C
+0638073807380F700F700F700F700FE01EE01EE01EE03CE038E038607060E031C01F0010
+237BA216> I<007E0001C1000301800703800E07801C07803C0000380000780000780000
+780000F00000F00000F00000F00000F00100700100700200300C001830000FC00011157B
+9416> I<00003C0003F80000380000380000380000700000700000700000700000E00000
+E00000E00000E00001C000F9C00185C00705C00E03800E03801C03803C03803807007807
+00780700780700F00E00F00E00F00E00F00E10F01C20701C20703C20305C40308C400F07
+8016237BA219> I<00F803840E021C023C0238027804F018FFE0F000F000E000E000E000
+E000E002E0026004701830600F800F157A9416> I<00003E0000470000CF00018F000186
+000380000380000380000700000700000700000700000700000E0000FFF0000E00000E00
+000E00001C00001C00001C00001C00001C00003800003800003800003800003800007000
+00700000700000700000700000E00000E00000E00000E00000C00001C00001C000718000
+F18000F300006200003C0000182D82A20F> I<001F180030B800E0B801C07001C0700380
+700780700700E00F00E00F00E00F00E01E01C01E01C01E01C01E01C01E03800E03800E07
+80060B8006170001E700000700000700000E00000E00000E00701C00F01800F0300060E0
+003F8000151F7E9416> I<00C001E001C001C0000000000000000000000000000000001E
+002300430043008700870087000E000E001C001C001C0038003800384070807080708071
+0032001C000B217BA00F> 105 D<00F00007E00000E00000E00000E00001C00001C00001
+C00001C0000380000380000380000380000700000701E00702100704700E08F00E10F00E
+20600E40001D80001E00001FC0001C7000383800383800381C00381C2070384070384070
+3840701880E01880600F0014237DA216> 107 D<01E00FC001C001C001C0038003800380
+038007000700070007000E000E000E000E001C001C001C001C0038003800380038007000
+700070007100E200E200E200E200640038000B237CA20C> I<1C0F80F8002610C10C0047
+6066060087807807008780780700870070070087007007000E00E00E000E00E00E000E00
+E00E000E00E00E001C01C01C001C01C01C001C01C01C001C01C038203803803840380380
+70403803807080380380308070070031003003001E0023157B9428> I<380F804C30C04E
+40608E80708F00708E00708E00701C00E01C00E01C00E01C00E03801C03801C03801C038
+0384700388700308700708700310E003106001E016157B941B> I<007E0001C300038180
+0701C00E01C01C01E03C01E03801E07801E07801E07801E0F003C0F003C0F00380F00780
+700700700E00700C0030180018700007C00013157B9419> I<01C1F002621804741C0878
+0C08700E08700E08701E00E01E00E01E00E01E00E01E01C03C01C03C01C03C01C0780380
+7003807003C0E003C1C0072380071E000700000700000E00000E00000E00000E00001C00
+001C00001C0000FFC000171F7F9419> I<1C1F002620804741C08783C08703C087018087
+00000E00000E00000E00000E00001C00001C00001C00001C000038000038000038000038
+000070000030000012157B9415> 114 D<00FC000183000200800401800C03800C03000C
+00000F00000FF00007FC0003FE00003E00000F00000700700700F00600F00600E0040040
+08002030001FC00011157D9414> I<00C001C001C001C001C003800380038003800700FF
+F8070007000E000E000E000E001C001C001C001C00380038003800381070207020704070
+8031001E000D1F7C9E10> I<1E0060E02300E0F04380E1F04381C0F08381C0708701C030
+8701C030070380200E0380200E0380200E0380201C0700401C0700401C0700401C070080
+1C0700801C0701001C0F01000C0B02000613840003E0F8001C157B9420> 119
+D<03C1E0046210083470103CF02038F020386020380000700000700000700000700000E0
+0000E00000E00000E02061C040F1C040F1C080E2C100446200383C0014157D9416> I<1E
+00302300704380704380E08380E08700E08700E00701C00E01C00E01C00E01C01C03801C
+03801C03801C03801C07001C07001C07001C0F000C3E0003CE00000E00000E00001C0060
+1C00F03800F03000E0600080C0004380003E0000141F7B9418> I
+E
+%EndDVIPSBitmapFont
+%DVIPSBitmapFont: Fi cmbx12 12 20
+/Fi 20 122 df<FFFFFF8000FFFFFFF00007F003FC0007F0007E0007F0003F0007F0001F
+8007F0000FC007F00007E007F00007E007F00007F007F00003F007F00003F007F00003F0
+07F00003F807F00003F807F00003F807F00003F807F00003F807F00003F807F00003F807
+F00003F807F00003F807F00003F007F00003F007F00003F007F00007E007F00007E007F0
+000FC007F0001F8007F0003F0007F0007E0007F003FC00FFFFFFF000FFFFFF800025227E
+A12B> 68 D<01FE0207FF861F01FE3C007E7C001E78000E78000EF80006F80006FC0006
+FC0000FF0000FFE0007FFF007FFFC03FFFF01FFFF80FFFFC03FFFE003FFE0003FE00007F
+00003F00003FC0001FC0001FC0001FE0001EE0001EF0003CFC003CFF00F8C7FFE080FF80
+18227DA11F> 83 D<7FFFFFFF807FFFFFFF807E03F80F807803F807807003F803806003
+F80180E003F801C0E003F801C0C003F800C0C003F800C0C003F800C0C003F800C00003F8
+00000003F800000003F800000003F800000003F800000003F800000003F800000003F800
+000003F800000003F800000003F800000003F800000003F800000003F800000003F80000
+0003F800000003F800000003F800000003F800000003F8000001FFFFF00001FFFFF00022
+227EA127> I<0FFC003FFF807E07C07E03E07E01E07E01F03C01F00001F00001F0003FF0
+03FDF01FC1F03F01F07E01F0FC01F0FC01F0FC01F0FC01F07E02F07E0CF81FF87F07E03F
+18167E951B> 97 D<FF000000FF0000001F0000001F0000001F0000001F0000001F0000
+001F0000001F0000001F0000001F0000001F0000001F0000001F0FE0001F3FF8001FE07C
+001F803E001F001F001F000F801F000F801F000FC01F000FC01F000FC01F000FC01F000F
+C01F000FC01F000FC01F000FC01F000F801F001F801F801F001FC03E001EE07C001C3FF8
+00180FC0001A237EA21F> I<00FF8007FFE00F83F01F03F03E03F07E03F07C01E07C0000
+FC0000FC0000FC0000FC0000FC0000FC00007C00007E00007E00003E00181F00300FC060
+07FFC000FF0015167E9519> I<00FE0007FF800F87C01E01E03E01F07C00F07C00F8FC00
+F8FC00F8FFFFF8FFFFF8FC0000FC0000FC00007C00007C00007E00003E00181F00300FC0
+7003FFC000FF0015167E951A> 101 D<001FC0007FE000F1F001E3F003E3F007C3F007C1
+E007C00007C00007C00007C00007C00007C000FFFE00FFFE0007C00007C00007C00007C0
+0007C00007C00007C00007C00007C00007C00007C00007C00007C00007C00007C00007C0
+0007C00007C0003FFC003FFC00142380A211> I<01FE0F0007FFBF800F87C7801F03E780
+1E01E0003E01F0003E01F0003E01F0003E01F0003E01F0001E01E0001F03E0000F87C000
+0FFF800009FE000018000000180000001C0000001FFFE0000FFFF80007FFFE001FFFFF00
+3C003F0078000F80F0000780F0000780F0000780F000078078000F003C001E001F007C00
+0FFFF80001FFC00019217F951C> I<1C003E007F007F007F003E001C0000000000000000
+00000000000000FF00FF001F001F001F001F001F001F001F001F001F001F001F001F001F
+001F001F001F001F001F00FFE0FFE00B247EA310> 105 D<FF00FF001F001F001F001F00
+1F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F00
+1F001F001F001F001F001F001F001F001F00FFE0FFE00B237EA210> 108
+D<FF07F007F000FF1FFC1FFC001F303E303E001F403E403E001F801F801F001F801F801F
+001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F
+001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F
+001F001F001F001F001F001F00FFE0FFE0FFE0FFE0FFE0FFE02B167E9530> I<FF07E000
+FF1FF8001F307C001F403C001F803E001F803E001F003E001F003E001F003E001F003E00
+1F003E001F003E001F003E001F003E001F003E001F003E001F003E001F003E001F003E00
+1F003E00FFE1FFC0FFE1FFC01A167E951F> I<00FE0007FFC00F83E01E00F03E00F87C00
+7C7C007C7C007CFC007EFC007EFC007EFC007EFC007EFC007EFC007E7C007C7C007C3E00
+F81F01F00F83E007FFC000FE0017167E951C> I<FF0FE000FF3FF8001FE07C001F803E00
+1F001F001F001F801F001F801F000FC01F000FC01F000FC01F000FC01F000FC01F000FC0
+1F000FC01F000FC01F001F801F001F801F803F001FC03E001FE0FC001F3FF8001F0FC000
+1F0000001F0000001F0000001F0000001F0000001F0000001F0000001F000000FFE00000
+FFE000001A207E951F> I<0FF3003FFF00781F00600700E00300E00300F00300FC00007F
+E0007FF8003FFE000FFF0001FF00000F80C00780C00380E00380E00380F00700FC0E00EF
+FC00C7F00011167E9516> 115 D<01800001800001800001800003800003800007800007
+80000F80003F8000FFFF00FFFF000F80000F80000F80000F80000F80000F80000F80000F
+80000F80000F80000F80000F81800F81800F81800F81800F81800F830007C30003FE0000
+F80011207F9F16> I<FF01FE00FF01FE001F003E001F003E001F003E001F003E001F003E
+001F003E001F003E001F003E001F003E001F003E001F003E001F003E001F003E001F003E
+001F003E001F007E001F00FE000F81BE0007FF3FC001FC3FC01A167E951F> I<FFE07FC0
+FFE07FC00F801C0007C0380003E0700003F0600001F8C00000F98000007F8000003F0000
+001F0000001F8000003FC0000037C0000063E00000C1F00001C0F8000380FC0007007E00
+0E003E00FF80FFE0FF80FFE01B167F951E> 120 D<FFE01FE0FFE01FE01F8007000F8006
+000FC00E0007C00C0007E00C0003E0180003E0180001F0300001F0300000F8600000F860
+00007CC000007CC000007FC000003F8000003F8000001F0000001F0000000E0000000E00
+00000C0000000C00000018000078180000FC380000FC300000FC60000069C000007F8000
+001F0000001B207F951E> I E
+%EndDVIPSBitmapFont
+%DVIPSBitmapFont: Fj cmsy10 12 15
+/Fj 15 107 df<FFFFFFFCFFFFFFFC1E027C8C27> 0 D<03F0000FFC001FFE003FFF007F
+FF807FFF80FFFFC0FFFFC0FFFFC0FFFFC0FFFFC0FFFFC0FFFFC0FFFFC07FFF807FFF803F
+FF001FFE000FFC0003F00012147D9519> 15 D<000FFFFC007FFFFC01F0000003800000
+060000000C0000001800000030000000300000006000000060000000C0000000C0000000
+C0000000C0000000C0000000C0000000C0000000C0000000600000006000000030000000
+30000000180000000C000000060000000380000001E00000007FFFFC001FFFFC1E1E7C9A
+27> 26 D<00000001800000000001800000000001800000000001800000000000C00000
+000000C000000000006000000000003000000000003000000000001C00000000000E0000
+0000000700FFFFFFFFFFE0FFFFFFFFFFE0000000000700000000000E00000000001C0000
+000000300000000000300000000000600000000000C00000000000C00000000001800000
+00000180000000000180000000000180002B1A7D9832> 33 D<001FFF007FFF01E00003
+80000600000C0000180000300000300000600000600000600000C00000C00000FFFFFFFF
+FFFFC00000C000006000006000006000003000003000001800000C000006000003800001
+E000007FFF001FFF181E7C9A21> 50 D<00000300000300000600000600000C00000C00
+00180000180000300000300000600000600000C00000C00000C000018000018000030000
+0300000600000600000C00000C0000180000180000300000300000600000600000C00000
+C0000180000180000300000300000300000600000600000C00000C000018000018000030
+0000300000600000600000C00000400000183079A300> 54 D<C0C0C0C0C0C0C0C0E0E0
+C0C0C0C0C0C0C0C003127D9400> I<00008000018001F980070F000C0300180380180780
+3006C03006C0700CE0600C60600C60600C60E01870E01870E01870E03070E03070E03070
+E06070E06070E06070E06070E0C070E0C070E0C070E18070E180706180606300607300E0
+7300E03300C03600C01E01801E01800C03000F0E000DF800180000180000180000142A7E
+A519> 59 D<000100000003000000030000000300000003000000030000000300000003
+000000030000000300000003000000030000000300000003000000030000000300000003
+000000030000000300000003000000030000000300000003000000030000000300000003
+000000030000000300000003000000030000FFFFFFFEFFFFFFFE1F207C9F27> 63
+D<40000040C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000
+C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000
+C0C00000C0C00000C0C00000C0C00000C0C00000C0600001806000018030000300180006
+000E001C000780780001FFE000007F80001A1F7D9D21> 91 D<007F800001FFE0000780
+78000E001C0018000600300003006000018060000180C00000C0C00000C0C00000C0C000
+00C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C000
+00C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C000
+00C0400000401A1F7D9D21> I<000C0000000C0000001E0000001E0000001E0000003300
+0000330000006180000061800000C0C00000C0C00000C0C0000180600001806000030030
+00030030000300300006001800060018000C000C000C000C000C000C0018000600180006
+003000030030000300600001806000018060000180C00000C0C00000401A1F7D9D21> 94
+D<0003C0001E0000380000700000E00000E00000E00000E00000E00000E00000E00000E0
+0000E00000E00000E00000E00000E00000E00000E00000E00000E00001C0000380000F00
+00F800000F000003800001C00000E00000E00000E00000E00000E00000E00000E00000E0
+0000E00000E00000E00000E00000E00000E00000E00000E00000E000007000003800001E
+000003C012317DA419> 102 D<F800000F000003800001C00000E00000E00000E00000E0
+0000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E0
+0000E000007000003800001E000003C0001E0000380000700000E00000E00000E00000E0
+0000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E0
+0000E00001C0000380000F0000F8000012317DA419> I<C0C0C0C0C0C0C0C0C0C0C0C0C0
+C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0
+02317AA40E> 106 D E
+%EndDVIPSBitmapFont
+%DVIPSBitmapFont: Fk cmr12 12 65
+/Fk 65 125 df<001FC1F00070371800C03E3C01807C3C0380783C070038000700380007
+003800070038000700380007003800070038000700380007003800FFFFFFC00700380007
+003800070038000700380007003800070038000700380007003800070038000700380007
+0038000700380007003800070038000700380007003800070038000700380007003C007F
+E1FFC01E2380A21C> 11 D<001FC0000070200000C01000018038000380780007007800
+0700300007000000070000000700000007000000070000000700000007000000FFFFF800
+070078000700380007003800070038000700380007003800070038000700380007003800
+070038000700380007003800070038000700380007003800070038000700380007003800
+070038007FE1FF80192380A21B> I<001FD8000070380000C07800018078000380780007
+0038000700380007003800070038000700380007003800070038000700380007003800FF
+FFF800070038000700380007003800070038000700380007003800070038000700380007
+003800070038000700380007003800070038000700380007003800070038000700380007
+003800070038007FF3FF80192380A21B> I<000FC07F00007031C08000E00B004001801E
+00E003803E01E007003C01E007001C00C007001C000007001C000007001C000007001C00
+0007001C000007001C000007001C0000FFFFFFFFE007001C01E007001C00E007001C00E0
+07001C00E007001C00E007001C00E007001C00E007001C00E007001C00E007001C00E007
+001C00E007001C00E007001C00E007001C00E007001C00E007001C00E007001C00E00700
+1C00E007001C00E07FF1FFCFFE272380A229> I<70F8FCFC740404040408081010204006
+0F7CA20E> 39 D<00200040008001000300060004000C000C0018001800300030003000
+7000600060006000E000E000E000E000E000E000E000E000E000E000E000E000E000E000
+6000600060007000300030003000180018000C000C000400060003000100008000400020
+0B327CA413> I<800040002000100018000C000400060006000300030001800180018001
+C000C000C000C000E000E000E000E000E000E000E000E000E000E000E000E000E000E000
+C000C000C001C0018001800180030003000600060004000C00180010002000400080000B
+327DA413> I<70F8FCFC7404040404080810102040060F7C840E> 44
+D<FFF8FFF80D02808B10> I<70F8F8F87005057C840E> I<01F000071C000C0600180300
+3803803803807001C07001C07001C07001C0F001E0F001E0F001E0F001E0F001E0F001E0
+F001E0F001E0F001E0F001E0F001E0F001E0F001E0F001E07001C07001C07001C07803C0
+3803803803801C07000C0600071C0001F00013227EA018> 48 D<008003800F80F38003
+800380038003800380038003800380038003800380038003800380038003800380038003
+800380038003800380038003800380038007C0FFFE0F217CA018> I<03F0000C1C001007
+002007804003C04003C08003E0F003E0F801E0F801E0F801E02003E00003E00003C00003
+C0000780000700000E00001C0000180000300000600000C0000180000100000200200400
+200800201800603000403FFFC07FFFC0FFFFC013217EA018> I<03F8000C1E00100F0020
+07804007C07807C07803C07807C03807C0000780000780000700000F00000C0000380003
+F000001C00000F000007800007800003C00003C00003E02003E07003E0F803E0F803E0F0
+03C04003C0400780200780100F000C1C0003F00013227EA018> I<000300000300000700
+000700000F00001700001700002700006700004700008700018700010700020700060700
+040700080700080700100700200700200700400700C00700FFFFF8000700000700000700
+000700000700000700000700000F80007FF015217FA018> I<70F8F8F870000000000000
+000000000070F8F8F87005157C940E> 58 D<FFFFFFFEFFFFFFFE000000000000000000
+0000000000000000000000000000000000000000000000FFFFFFFEFFFFFFFE1F0C7D9126
+> 61 D<07E01838201C400E800FF00FF00FF00F000F000E001C00380030006000C000C0
+00800080018001000100010001000100010000000000000000000000038007C007C007C0
+038010237DA217> 63 D<0001800000018000000180000003C0000003C0000003C00000
+05E0000005E0000009F0000008F0000008F00000107800001078000010780000203C0000
+203C0000203C0000401E0000401E0000C01F0000800F0000800F0001FFFF800100078001
+000780020003C0020003C0020003C0040001E0040001E0040001E0080000F01C0000F03E
+0001F8FF800FFF20237EA225> 65 D<FFFFF8000F800E0007800780078003C0078003E0
+078001E0078001F0078001F0078001F0078001F0078001F0078001E0078003E0078007C0
+07800F8007803E0007FFFE0007800780078003C0078001E0078001F0078000F0078000F8
+078000F8078000F8078000F8078000F8078000F8078001F0078001F0078003E0078007C0
+0F800F00FFFFFC001D227EA123> I<0007E0100038183000E0063001C00170038000F007
+0000F00E0000701E0000701C0000303C0000303C0000307C0000107800001078000010F8
+000000F8000000F8000000F8000000F8000000F8000000F8000000F80000007800000078
+0000107C0000103C0000103C0000101C0000201E0000200E000040070000400380008001
+C0010000E0020000381C000007E0001C247DA223> I<FFFFF0000F801E00078007000780
+0380078001C0078000E0078000F007800078078000780780007C0780003C0780003C0780
+003C0780003E0780003E0780003E0780003E0780003E0780003E0780003E0780003E0780
+003E0780003C0780003C0780007C0780007807800078078000F0078000E0078001E00780
+03C0078007000F801E00FFFFF0001F227EA125> I<FFFFFFC00F8007C0078001C0078000
+C00780004007800040078000600780002007800020078000200780202007802000078020
+0007802000078060000780E00007FFE0000780E000078060000780200007802000078020
+000780200007800000078000000780000007800000078000000780000007800000078000
+00078000000FC00000FFFE00001B227EA120> 70 D<0007F008003C0C1800E0021801C0
+01B8038000F8070000780F0000381E0000381E0000183C0000183C0000187C0000087800
+000878000008F8000000F8000000F8000000F8000000F8000000F8000000F8000000F800
+1FFF780000F8780000787C0000783C0000783C0000781E0000781E0000780F0000780700
+0078038000B801C000B800E00318003C0C080007F00020247DA226> I<FFFC3FFF0FC003
+F0078001E0078001E0078001E0078001E0078001E0078001E0078001E0078001E0078001
+E0078001E0078001E0078001E0078001E0078001E007FFFFE0078001E0078001E0078001
+E0078001E0078001E0078001E0078001E0078001E0078001E0078001E0078001E0078001
+E0078001E0078001E0078001E00FC003F0FFFC3FFF20227EA125> I<FFFC0FC007800780
+078007800780078007800780078007800780078007800780078007800780078007800780
+07800780078007800780078007800780078007800FC0FFFC0E227EA112> I<FFFC00FF80
+0FC0007C0007800030000780002000078000400007800080000780010000078002000007
+80040000078008000007801000000780200000078040000007808000000781C000000783
+E000000785E000000788F000000790F0000007A078000007C03C000007803C000007801E
+000007800F000007800F00000780078000078007C000078003C000078001E000078001E0
+00078000F000078000F8000FC000FC00FFFC07FF8021227EA126> 75
+D<FFFC001F80000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00
+000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00010F00
+010F00010F00010F00030F00030F00020F00060F00060F001E1F007EFFFFFE18227DA11E
+> I<FF8007FF07C000F807C0007005E0002004F0002004F0002004780020047C0020043C
+0020041E0020041F0020040F002004078020040780200403C0200401E0200401E0200400
+F0200400F8200400782004003C2004003E2004001E2004000F2004000F20040007A00400
+03E0040003E0040001E0040001E0040000E00E0000601F000060FFE0002020227EA125>
+78 D<000FE00000783C0000E00E0003C00780078003C00F0001E00E0000E01E0000F03C
+0000783C0000787C00007C7C00007C7800003C7800003CF800003EF800003EF800003EF8
+00003EF800003EF800003EF800003EF800003EF800003E7800003C7C00007C7C00007C3C
+0000783E0000F81E0000F00F0001E00F0001E0078003C003C0078000E00E0000783C0000
+0FE0001F247DA226> I<FFFFF0000F803C0007800F0007800780078007C0078003C00780
+03E0078003E0078003E0078003E0078003E0078003E0078003C0078007C0078007800780
+0F0007803C0007FFF0000780000007800000078000000780000007800000078000000780
+0000078000000780000007800000078000000780000007800000078000000FC00000FFFC
+00001B227EA121> I<FFFFE000000F803C000007800E00000780078000078007C0000780
+03C000078003E000078003E000078003E000078003E000078003E000078003C000078007
+C000078007800007800E000007803C000007FFE000000780700000078038000007801C00
+0007801E000007800E000007800F000007800F000007800F000007800F000007800F8000
+07800F800007800F800007800F808007800FC080078007C0800FC003C100FFFC01E20000
+00007C0021237EA124> 82 D<03F0200C0C601802603001E07000E0600060E00060E000
+60E00020E00020E00020F00000F000007800007F00003FF0001FFE000FFF0003FF80003F
+C00007E00001E00000F00000F0000070800070800070800070800070C00060C00060E000
+C0F000C0C80180C6070081FC0014247DA21B> I<7FFFFFF8780780786007801840078008
+4007800840078008C007800C800780048007800480078004800780040007800000078000
+000780000007800000078000000780000007800000078000000780000007800000078000
+000780000007800000078000000780000007800000078000000780000007800000078000
+00078000000FC00001FFFE001E227EA123> I<FFF0007FC01F80001F000F00000C000F80
+000C000780000800078000080003C000100003C000100003C000100001E000200001E000
+200001F000600000F000400000F000400000780080000078008000007C008000003C0100
+00003C010000001E020000001E020000001E020000000F040000000F040000000F8C0000
+000788000000078800000003D000000003D000000003F000000001E000000001E0000000
+00C000000000C000000000C0000022237FA125> 86 D<FFF03FFC03FE1F8007E000F80F
+0003C000700F0003C000200F0001E00020078001E00040078001E00040078003F0004003
+C002F0008003C002F0008003C002F0008003E00478018001E00478010001E00478010001
+E0083C010000F0083C020000F0083C020000F0101E02000078101E04000078101E040000
+78200F0400003C200F0800003C200F0800003C600F8800001E40079000001E4007900000
+1E4007D000001F8003F000000F8003E000000F8003E000000F0001E00000070001C00000
+070001C00000060000C0000002000080002F237FA132> I<FEFEC0C0C0C0C0C0C0C0C0C0
+C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0FE
+FE07317BA40E> 91 D<FEFE060606060606060606060606060606060606060606060606
+060606060606060606060606060606060606060606FEFE07317FA40E> 93
+D<1FE000303800780C00780E0030070000070000070000070000FF0007C7001E07003C07
+00780700700700F00708F00708F00708F00F087817083C23900FC1E015157E9418> 97
+D<0E0000FE00001E00000E00000E00000E00000E00000E00000E00000E00000E00000E00
+000E00000E00000E1F000E61C00E80600F00300E00380E003C0E001C0E001E0E001E0E00
+1E0E001E0E001E0E001E0E001E0E001C0E003C0E00380F00700C80600C41C0083F001723
+7FA21B> I<01FE000703000C07801C0780380300780000700000F00000F00000F00000F0
+0000F00000F00000F000007000007800403800401C00800C010007060001F80012157E94
+16> I<0000E0000FE00001E00000E00000E00000E00000E00000E00000E00000E00000E0
+0000E00000E00000E001F8E00704E00C02E01C01E03800E07800E07000E0F000E0F000E0
+F000E0F000E0F000E0F000E0F000E07000E07800E03800E01801E00C02E0070CF001F0FE
+17237EA21B> I<01FC000707000C03801C01C03801C07801E07000E0F000E0FFFFE0F000
+00F00000F00000F00000F000007000007800203800201C00400E008007030000FC001315
+7F9416> I<003E0000E30001C78003878003078007000007000007000007000007000007
+0000070000070000070000FFF80007000007000007000007000007000007000007000007
+00000700000700000700000700000700000700000700000700000700000700000780007F
+F000112380A20F> I<00007003F1980E1E181C0E18380700380700780780780780780780
+7807803807003807001C0E001E1C0033F0002000002000003000003800003FFE001FFFC0
+0FFFE03000F0600030C00018C00018C00018C000186000306000303800E00E038003FE00
+15217F9518> I<0E0000FE00001E00000E00000E00000E00000E00000E00000E00000E00
+000E00000E00000E00000E00000E1F800E60C00E80E00F00700F00700E00700E00700E00
+700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00
+70FFE7FF18237FA21B> I<1C003E003E003E001C00000000000000000000000000000000
+000E007E001E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E
+000E000E00FFC00A227FA10E> I<00E001F001F001F000E0000000000000000000000000
+00000000007007F000F00070007000700070007000700070007000700070007000700070
+00700070007000700070007000700070007000706070F0E0F0C061803F000C2C83A10F>
+I<0E0000FE00001E00000E00000E00000E00000E00000E00000E00000E00000E00000E00
+000E00000E00000E03FC0E01F00E01C00E01800E02000E04000E08000E10000E38000EF8
+000F1C000E1E000E0E000E07000E07800E03C00E01C00E01E00E00F00E00F8FFE3FE1723
+7FA21A> I<0E00FE001E000E000E000E000E000E000E000E000E000E000E000E000E000E
+000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E
+00FFE00B237FA20E> I<0E1FC07F00FE60E183801E807201C00F003C00E00F003C00E00E
+003800E00E003800E00E003800E00E003800E00E003800E00E003800E00E003800E00E00
+3800E00E003800E00E003800E00E003800E00E003800E00E003800E00E003800E00E0038
+00E0FFE3FF8FFE27157F942A> I<0E1F80FE60C01E80E00F00700F00700E00700E00700E
+00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E
+0070FFE7FF18157F941B> I<01FC000707000C01801800C03800E0700070700070F00078
+F00078F00078F00078F00078F00078F000787000707800F03800E01C01C00E0380070700
+01FC0015157F9418> I<0E1F00FE61C00E80600F00700E00380E003C0E003C0E001E0E00
+1E0E001E0E001E0E001E0E001E0E001E0E003C0E003C0E00380F00700E80E00E41C00E3F
+000E00000E00000E00000E00000E00000E00000E00000E00000E0000FFE000171F7F941B
+> I<01F8200704600E02601C01603801E07800E07800E0F000E0F000E0F000E0F000E0F0
+00E0F000E0F000E07800E07800E03801E01C01E00C02E0070CE001F0E00000E00000E000
+00E00000E00000E00000E00000E00000E00000E0000FFE171F7E941A> I<0E3CFE461E8F
+0F0F0F060F000E000E000E000E000E000E000E000E000E000E000E000E000E000F00FFF0
+10157F9413> I<0F8830786018C018C008C008E008F0007F003FE00FF001F8003C801C80
+0C800CC00CC008E018D0308FC00E157E9413> I<02000200020002000600060006000E00
+1E003E00FFFC0E000E000E000E000E000E000E000E000E000E000E000E040E040E040E04
+0E040E040708030801F00E1F7F9E13> I<0E0070FE07F01E00F00E00700E00700E00700E
+00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00F00E00F006
+017003827800FC7F18157F941B> I<FF80FE1E00781E00300E00200E0020070040070040
+0780C003808003808001C10001C10000E20000E20000E200007400007400003800003800
+00380000100017157F941A> I<FF8FF87F3E01E03C1C01C0181C01E0180E01E0100E0260
+100E027010070270200704302007043820038438400388184003881C4001C81C8001D00C
+8001D00E8000F00F0000E0070000E00700006006000040020020157F9423> I<FF83FE1F
+00F00E00C007008007810003830001C20000E400007800007800003800003C00004E0000
+8F000187000103800201C00401E00C00E03E01F0FF03FE17157F941A> I<FF80FE1E0078
+1E00300E00200E00200700400700400780C003808003808001C10001C10000E20000E200
+00E200007400007400003800003800003800001000001000002000002000002000004000
+F04000F08000F180004300003C0000171F7F941A> I<3FFFC0380380300780200700600E
+00401C00403C0040380000700000E00001E00001C0000380400700400F00400E00C01C00
+80380080780180700780FFFF8012157F9416> I<FFFFFFFFFFFF3001808C31> 124
+D E
+%EndDVIPSBitmapFont
+%DVIPSBitmapFont: Fl cmbx12 14.4 19
+/Fl 19 118 df<00007FE0030007FFFC07001FFFFF0F007FF00F9F00FF0001FF01FC0000
+FF03F800007F07F000003F0FE000001F1FC000001F1FC000000F3F8000000F3F80000007
+7F800000077F800000077F00000000FF00000000FF00000000FF00000000FF00000000FF
+00000000FF00000000FF00000000FF00000000FF000000007F000000007F800000007F80
+0000073F800000073F800000071FC00000071FC000000E0FE000000E07F000001C03F800
+003C01FC00007800FF0001F0007FF007C0001FFFFF800007FFFE0000007FF00028297CA8
+31> 67 D<FFFFFC0000FFFFFC0000FFFFFC000003FC00000003FC00000003FC00000003
+FC00000003FC00000003FC00000003FC00000003FC00000003FC00000003FC00000003FC
+00000003FC00000003FC00000003FC00000003FC00000003FC00000003FC00000003FC00
+000003FC00000003FC00000003FC00000003FC0001C003FC0001C003FC0001C003FC0001
+C003FC0003C003FC00038003FC00038003FC00078003FC00078003FC000F8003FC000F80
+03FC001F8003FC007F8003FC01FF00FFFFFFFF00FFFFFFFF00FFFFFFFF0022297EA828>
+76 D<0000FFC00000000FFFFC0000003F807F000000FE001FC00001F80007E00003F000
+03F00007E00001F8000FE00001FC001FC00000FE001FC00000FE003F8000007F003F8000
+007F007F8000007F807F0000003F807F0000003F807F0000003F80FF0000003FC0FF0000
+003FC0FF0000003FC0FF0000003FC0FF0000003FC0FF0000003FC0FF0000003FC0FF0000
+003FC0FF0000003FC0FF0000003FC07F0000003F807F8000007F807F8000007F803F8000
+007F003F8000007F001FC00000FE001FC00000FE000FE00001FC0007F00003F80003F800
+07F00001FC000FE00000FE001FC000003FC0FF0000000FFFFC00000000FFC000002A297C
+A833> 79 D<FFFFF0007FFFFFFFF0007FFFFFFFF0007FFF03FE000001C001FE00000380
+01FE0000038001FF0000078000FF0000070000FF80000F00007F80000E00007FC0000E00
+003FC0001C00003FC0001C00003FE0003C00001FE0003800001FF0007800000FF0007000
+000FF80070000007F800E0000007F800E0000003FC01C0000003FC01C0000003FE03C000
+0001FE0380000001FF0780000000FF0700000000FF87000000007F8E000000007F8E0000
+00007FDE000000003FDC000000003FFC000000001FF8000000001FF8000000000FF00000
+00000FF0000000000FF00000000007E00000000007E00000000003C00000000003C00000
+30297FA833> 86 D<03FF80000FFFF0001F01FC003F80FE003F807F003F803F003F803F
+801F003F8000003F8000003F8000003F8000003F80003FFF8001FC3F800FE03F801F803F
+803F003F807E003F80FC003F80FC003F80FC003F80FC003F80FC005F807E00DF803F839F
+FC1FFE0FFC03FC03FC1E1B7E9A21> 97 D<FFE00000FFE00000FFE000000FE000000FE0
+00000FE000000FE000000FE000000FE000000FE000000FE000000FE000000FE000000FE0
+00000FE000000FE1FE000FEFFF800FFE07E00FF803F00FF001F80FE000FC0FE000FC0FE0
+007E0FE0007E0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0
+007F0FE0007E0FE0007E0FE0007E0FE000FC0FE000FC0FF001F80FF803F00F9C0FE00F0F
+FF800E01FC00202A7EA925> I<00007FF000007FF000007FF0000007F0000007F0000007
+F0000007F0000007F0000007F0000007F0000007F0000007F0000007F0000007F0000007
+F0003F87F001FFF7F007F03FF00FC00FF01F8007F03F0007F03F0007F07E0007F07E0007
+F07E0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007
+F07E0007F07E0007F03F0007F03F0007F01F800FF00FC01FF007E07FFF01FFE7FF007F87
+FF202A7EA925> 100 D<003FC00001FFF00003E07C000F803E001F801F001F001F003F00
+0F807E000F807E000FC07E000FC0FE0007C0FE0007C0FFFFFFC0FFFFFFC0FE000000FE00
+0000FE0000007E0000007E0000007F0000003F0001C01F0001C00F80038007C0070003F0
+1E0000FFFC00003FE0001A1B7E9A1F> I<0007F8003FFC007E3E01FC7F03F87F03F07F07
+F07F07F03E07F00007F00007F00007F00007F00007F00007F000FFFFC0FFFFC0FFFFC007
+F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007
+F00007F00007F00007F00007F00007F00007F00007F00007F0007FFF807FFF807FFF8018
+2A7EA915> I<FFE00000FFE00000FFE000000FE000000FE000000FE000000FE000000FE0
+00000FE000000FE000000FE000000FE000000FE000000FE000000FE000000FE07E000FE1
+FF800FE30FC00FE40FE00FE807E00FF807F00FF007F00FF007F00FE007F00FE007F00FE0
+07F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE0
+07F00FE007F00FE007F00FE007F00FE007F0FFFE3FFFFFFE3FFFFFFE3FFF202A7DA925>
+104 D<07000F801FC03FE03FE03FE01FC00F8007000000000000000000000000000000FF
+E0FFE0FFE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00F
+E00FE00FE00FE00FE00FE0FFFEFFFEFFFE0F2B7EAA12> I<FFE0FFE0FFE00FE00FE00FE0
+0FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE0
+0FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE0FFFEFFFEFFFE
+0F2A7EA912> 108 D<FFC07E00FFC1FF80FFC30FC00FC40FE00FC807E00FD807F00FD007
+F00FD007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007
+F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F0FFFE3F
+FFFFFE3FFFFFFE3FFF201B7D9A25> 110 D<003FE00001FFFC0003F07E000FC01F801F80
+0FC03F0007E03F0007E07E0003F07E0003F07E0003F0FE0003F8FE0003F8FE0003F8FE00
+03F8FE0003F8FE0003F8FE0003F8FE0003F87E0003F07E0003F03F0007E03F0007E01F80
+0FC00FC01F8007F07F0001FFFC00003FE0001D1B7E9A22> I<FFE1FE00FFEFFF80FFFE0F
+E00FF803F00FF001F80FE001FC0FE000FC0FE000FE0FE000FE0FE0007F0FE0007F0FE000
+7F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007E0FE000FE0FE000FE0FE000
+FC0FE001FC0FF001F80FF807F00FFC0FE00FEFFF800FE1FC000FE000000FE000000FE000
+000FE000000FE000000FE000000FE000000FE000000FE00000FFFE0000FFFE0000FFFE00
+0020277E9A25> I<FFC1F0FFC7FCFFC63E0FCC7F0FD87F0FD07F0FD07F0FF03E0FE0000F
+E0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000F
+E0000FE0000FE000FFFF00FFFF00FFFF00181B7F9A1B> 114 D<03FE300FFFF03E03F078
+00F07000F0F00070F00070F80070FE0000FFE0007FFF007FFFC03FFFE01FFFF007FFF800
+FFF80007FC0000FCE0007CE0003CF0003CF00038F80038FC0070FF01E0E7FFC0C1FF0016
+1B7E9A1B> I<00E00000E00000E00000E00001E00001E00001E00003E00003E00007E000
+0FE0001FFFE0FFFFE0FFFFE00FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE000
+0FE0000FE0000FE0000FE0000FE0000FE0700FE0700FE0700FE0700FE0700FE0700FE070
+07F0E003F0C001FF80007F0014267FA51A> I<FFE07FF0FFE07FF0FFE07FF00FE007F00F
+E007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00F
+E007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE00FF00F
+E00FF007E017F003F067FF01FFC7FF007F87FF201B7D9A25> I E
+%EndDVIPSBitmapFont
+%DVIPSBitmapFont: Fm cmr12 14.4 20
+/Fm 20 118 df<78FCFCFEFE7A02020202040404080810204007127B8510> 44
+D<00200000E00001E0000FE000FFE000F1E00001E00001E00001E00001E00001E00001E0
+0001E00001E00001E00001E00001E00001E00001E00001E00001E00001E00001E00001E0
+0001E00001E00001E00001E00001E00001E00001E00001E00001E00001E00001E00001E0
+0001E00003F000FFFFC0FFFFC012287BA71D> 49 D<01FC0007FF000C0FC01803E02001
+F06001F04000F84000F8F800FCFC00FCFC007CFC007CFC007C7800FC0000FC0000F80000
+F80001F00001F00003E00003C0000780000700000E00001C0000380000300000600000C0
+000180000300040200040400080800081000082000183FFFF87FFFF0FFFFF0FFFFF01628
+7DA71D> I<000FC0003FF000F01801C01803803C07007C0F007C0E00381E00003C00003C
+00003C0000780000780000780000F83F00F8C1C0F900E0FA0070FA0038FC003CFC001EFC
+001EF8001EF8001FF8001FF8001FF8001F78001F78001F78001F78001F3C001E3C001E1C
+003C1E003C0E007807007003C1E001FFC0007E0018297EA71D> 54
+D<007E0001FF800781C00F00E01E00703C00383C003878003C78003CF8001EF8001EF800
+1EF8001EF8001FF8001FF8001FF8001F78001F78003F78003F3C003F1C005F0E005F0700
+9F03831F00FC1F00001E00001E00001E00003E00003C00003C0000381C00783E00703E00
+E03C01C01803801C0F000FFE0003F80018297EA71D> 57 D<0000FF00100007FFE03000
+1FC07830003E000C7000F80006F001F00003F003E00001F007C00000F00F800000700F80
+0000701F000000303F000000303E000000303E000000107E000000107E000000107C0000
+0000FC00000000FC00000000FC00000000FC00000000FC00000000FC00000000FC000000
+00FC00000000FC0000FFFF7C0000FFFF7E000003F07E000001F03E000001F03E000001F0
+3F000001F01F000001F00F800001F00F800001F007C00001F003E00001F001F00002F000
+F80002F0003E000C70001FC038300007FFE0100000FF8000282B7DA92E> 71
+D<01FFFE01FFFE0007E00003E00003E00003E00003E00003E00003E00003E00003E00003
+E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003
+E00003E00003E00003E00003E00003E00003E00003E03003E07803E0FC03E0FC03E0FC03
+C0F807C0400780200F00300E000C3C0003F000172A7DA81E> 74
+D<0001FF0000000F01E000003C0078000078003C0000E0000E0001E0000F0003C0000780
+07800003C00F800003E01F000001F01F000001F03E000000F83E000000F87E000000FC7E
+000000FC7C0000007C7C0000007CFC0000007EFC0000007EFC0000007EFC0000007EFC00
+00007EFC0000007EFC0000007EFC0000007EFC0000007E7C0000007C7E000000FC7E0000
+00FC7E000000FC3E000000F83F000001F81F000001F01F000001F00F800003E007800003
+C007C00007C003E0000F8000F0001E000078003C00003C007800000F01E0000001FF0000
+272B7DA92E> 79 D<03FC00000C070000100380003C01C0003E01E0003E00F0001C00F0
+000800F0000000F0000000F0000000F000007FF00003E0F0000F80F0001E00F0003C00F0
+007C00F0007800F040F800F040F800F040F800F040F801F0407C01F0403C0278801E0C7F
+8007F01E001A1A7E991D> 97 D<0F000000FF000000FF0000001F0000000F0000000F00
+00000F0000000F0000000F0000000F0000000F0000000F0000000F0000000F0000000F00
+00000F0000000F07E0000F1838000F600E000F8007000F8007800F0003C00F0003C00F00
+01E00F0001E00F0001F00F0001F00F0001F00F0001F00F0001F00F0001F00F0001F00F00
+01E00F0001E00F0003E00F0003C00F0003800F8007800E800F000E401C000C303800080F
+C0001C2A7EA921> I<007F0001C0E00700100E00781E00F83C00F83C00707C0020780000
+F80000F80000F80000F80000F80000F80000F80000F800007800007C00003C00083C0008
+1E00100E002007006001C180007E00151A7E991A> I<00FC000387800701C00E01E01C00
+E03C00F03C00F0780078780078F80078F80078FFFFF8F80000F80000F80000F80000F800
+007800007800003C00083C00081E00100E002007004001C180007E00151A7E991A> 101
+D<00000F0001FC3080070743800E03C3801E03C1003C01E0003C01E0007C01F0007C01F0
+007C01F0007C01F0007C01F0003C01E0003C01E0001E03C0000E0380001707000011FC00
+0030000000300000003000000030000000180000001FFF80000FFFF00007FFF80018007C
+0030001E0070000E0060000700E0000700E0000700E0000700E000070070000E0070000E
+0038001C001C0038000781E00000FF000019287E9A1D> 103 D<1E003F003F003F003F00
+1E000000000000000000000000000000000000000F00FF00FF001F000F000F000F000F00
+0F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F00FFF0FFF0
+0C297EA811> 105 D<007E0003C3C00700E00E00701C00383C003C3C003C78001E78001E
+F8001FF8001FF8001FF8001FF8001FF8001FF8001FF8001F78001E78001E3C003C3C003C
+1C00380E00700700E003C3C0007E00181A7E991D> 111 D<003F010001E0830003804300
+0F0027001E0017001E001F003C000F007C000F007C000F0078000F00F8000F00F8000F00
+F8000F00F8000F00F8000F00F8000F00F8000F007C000F007C000F003C000F003E001F00
+1E001F000F002F0007804F0001C18F00007E0F0000000F0000000F0000000F0000000F00
+00000F0000000F0000000F0000000F0000000F0000000F000000FFF00000FFF01C267E99
+1F> 113 D<0F0F80FF11C0FF23E01F43E00F83E00F81C00F80000F00000F00000F00000F
+00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F
+00000F8000FFFC00FFFC00131A7E9917> I<07F0801C0D80300380600180E00180E00080
+E00080F00080F800007E00007FE0003FFC001FFE0007FF00003F800007808003C08003C0
+8001C0C001C0C001C0E00180E00380F00300CC0E0083F800121A7E9917> I<0080000080
+000080000080000180000180000180000380000380000780000F80001FFF80FFFF800780
+000780000780000780000780000780000780000780000780000780000780000780000780
+0007804007804007804007804007804007804007804003C08001C08000E100003E001225
+7FA417> I<0F000F00FF00FF00FF00FF001F001F000F000F000F000F000F000F000F000F
+000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F
+000F000F000F000F000F000F000F001F000F001F0007002F0003804F8001C08FF0007F0F
+F01C1A7E9921> I E
+%EndDVIPSBitmapFont
+%DVIPSBitmapFont: Fn cmr17 20.74 18
+/Fn 18 119 df<000001FF00008000001FFFE0018000007F007801800001F8000E038000
+03E000070780000FC000018780001F000000CF80003E0000006F80007C0000003F8000F8
+0000003F8001F00000001F8003F00000000F8007E00000000F8007C000000007800FC000
+000007800FC000000007801F8000000003801F8000000003803F8000000003803F000000
+0001803F0000000001807F0000000001807F0000000001807E0000000000007E00000000
+0000FE000000000000FE000000000000FE000000000000FE000000000000FE0000000000
+00FE000000000000FE000000000000FE000000000000FE000000000000FE000000000000
+FE0000000000007E0000000000007E0000000000007F0000000000007F0000000001803F
+0000000001803F0000000001803F8000000001801F8000000001801F8000000003000FC0
+00000003000FC0000000030007E0000000060007E0000000060003F0000000060001F000
+00000C0000F80000001800007C0000001800003E0000003000001F0000006000000FC000
+01C0000003E0000380000001F8000E000000007F007C000000001FFFF00000000001FF00
+0000313D7CBB39> 67 D<FFFFFC000000FFFFFC00000003FE0000000001F80000000001
+F80000000001F80000000001F80000000001F80000000001F80000000001F80000000001
+F80000000001F80000000001F80000000001F80000000001F80000000001F80000000001
+F80000000001F80000000001F80000000001F80000000001F80000000001F80000000001
+F80000000001F80000000001F80000000001F80000000001F80000000001F80000000001
+F80000000001F80000000001F80000000001F80000000001F80000000001F80000000001
+F80000000001F80000000001F80000000001F80000006001F80000006001F80000006001
+F80000006001F80000006001F8000000E001F8000000C001F8000000C001F8000000C001
+F8000000C001F8000001C001F8000001C001F8000001C001F8000003C001F8000007C001
+F8000007C001F800000FC001F800003F8001F80000FF8003FC0007FF80FFFFFFFFFF80FF
+FFFFFFFF802B3B7CBA32> 76 D<000003FF00000000001E01E000000000F0003C000000
+03C0000F000000078000078000000F000003C000003E000001F000007C000000F80000F8
+0000007C0001F00000003E0001F00000003E0003E00000001F0007E00000001F8007C000
+00000F800FC00000000FC00F8000000007C01F8000000007E01F8000000007E03F000000
+0003F03F0000000003F03F0000000003F07F0000000003F87E0000000001F87E00000000
+01F87E0000000001F8FE0000000001FCFE0000000001FCFE0000000001FCFE0000000001
+FCFE0000000001FCFE0000000001FCFE0000000001FCFE0000000001FCFE0000000001FC
+FE0000000001FCFE0000000001FC7E0000000001F87F0000000003F87F0000000003F87F
+0000000003F87F0000000003F83F0000000003F03F8000000007F01F8000000007E01F80
+00000007E01FC00000000FE00FC00000000FC007C00000000F8007E00000001F8003E000
+00001F0001F00000003E0001F80000007E0000F80000007C00007C000000F800003E0000
+01F000000F000003C000000780000780000003E0001F00000000F8007C000000001E01E0
+0000000003FF000000363D7CBB3E> 79 D<003F80000001C0F0000003003C000004001E
+00000C000F000018000780001C0007C0003E0003C0003F0003E0003F0003E0003F0003E0
+001E0003E000000003E000000003E000000003E00000003FE000000FF3E000007E03E000
+01F803E00003E003E0000FC003E0001F8003E0003F0003E0003E0003E0007E0003E0007E
+0003E060FC0003E060FC0003E060FC0003E060FC0007E060FC0007E0607C000BE0607E00
+0BE0603E0011F0C01F0060F0C007C1807F8000FE003E0023257CA427> 97
+D<03E0000000FFE0000000FFE000000007E000000003E000000003E000000003E0000000
+03E000000003E000000003E000000003E000000003E000000003E000000003E000000003
+E000000003E000000003E000000003E000000003E000000003E000000003E000000003E0
+00000003E000000003E03FC00003E0E0780003E3001C0003E6000F0003E800078003F800
+03C003F00001E003E00001F003E00000F003E00000F803E00000F803E00000FC03E00000
+7C03E000007C03E000007E03E000007E03E000007E03E000007E03E000007E03E000007E
+03E000007E03E000007E03E000007E03E000007C03E000007C03E00000FC03E00000F803
+E00000F803E00001F003E00001E003F00003E003D80003C003C80007800384000E000383
+001C000381C0F00003003F8000273C7EBB2C> I<0007F800003C0E0000F0018001E000C0
+03C00060078000300F0000701F0000F81F0001F83E0001F83E0001F87E0000F07C000000
+7C000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000
+FC0000007C0000007C0000007E0000003E0000003E00000C1F00000C1F0000180F800018
+0780003003C0006001E000C000F00180003C0E000007F8001E257DA423> I<0007F80000
+3C1E0000F0078001C003C003C001E0078000F00F0000F81F0000781E00007C3E00007C3E
+00007C7E00003E7C00003E7C00003EFC00003EFC00003EFFFFFFFEFC000000FC000000FC
+000000FC000000FC000000FC0000007C0000007C0000007E0000003E0000003E0000061F
+0000060F00000C0F80000C0780001803C0003000E00060007000C0001E07000003FC001F
+257EA423> 101 D<0000FC0000078300000E0380001C07C0003C0FC000780FC000F80FC0
+00F8078000F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000
+01F0000001F0000001F0000001F0000001F0000001F0000001F00000FFFFFC00FFFFFC00
+01F0000001F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000
+01F0000001F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000
+01F0000001F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000
+01F0000001F0000001F0000001F0000001F0000003F800007FFFE0007FFFE0001A3C7FBB
+18> I<07000F801FC01FC01FC00F80070000000000000000000000000000000000000000
+0000000000000007C0FFC0FFC00FC007C007C007C007C007C007C007C007C007C007C007
+C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007
+C007C00FE0FFFEFFFE0F397DB815> 105 D<0003800007C0000FE0000FE0000FE00007C0
+000380000000000000000000000000000000000000000000000000000000000000000000
+0000000000000007E000FFE000FFE0000FE00003E00003E00003E00003E00003E00003E0
+0003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E0
+0003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E0
+0003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E0
+7803C0FC07C0FC0780FC0780FC0F00780E00381C000FE000134A82B818> I<07C0FFC0FF
+C00FC007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007
+C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007
+C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007
+C00FE0FFFEFFFE0F3C7DBB15> 108 D<03E01FE0003FC000FFE0607C00C0F800FFE0801E
+01003C0007E3000F06001E0003E4000F88001F0003E4000F88001F0003E8000790000F00
+03E80007D0000F8003F00007E0000F8003F00007E0000F8003E00007C0000F8003E00007
+C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F80
+03E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007
+C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F80
+03E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007
+C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F80
+07F0000FE0001FC0FFFF81FFFF03FFFEFFFF81FFFF03FFFE3F257EA443> I<03E01FE000
+FFE0607C00FFE0801E0007E3000F0003E4000F8003E4000F8003E800078003E80007C003
+F00007C003F00007C003E00007C003E00007C003E00007C003E00007C003E00007C003E0
+0007C003E00007C003E00007C003E00007C003E00007C003E00007C003E00007C003E000
+07C003E00007C003E00007C003E00007C003E00007C003E00007C003E00007C003E00007
+C003E00007C003E00007C003E00007C003E00007C007F0000FE0FFFF81FFFFFFFF81FFFF
+28257EA42C> I<0007FC0000001C070000007001C00001E000F00003C00078000780003C
+000F00001E001F00001F001E00000F003E00000F803E00000F807C000007C07C000007C0
+7C000007C0FC000007E0FC000007E0FC000007E0FC000007E0FC000007E0FC000007E0FC
+000007E0FC000007E0FC000007E07C000007C07C000007C07E00000FC03E00000F803E00
+000F801E00000F001F00001F000F00001E000780003C0003C000780001E000F000007001
+C000001C0700000007FC000023257EA427> I<03E03E00FFE0C300FFE1078007E20FC003
+E40FC003E80FC003E8078003E8030003F0000003F0000003F0000003E0000003E0000003
+E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003
+E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003
+E0000003E0000003E0000007F00000FFFFC000FFFFC0001A257EA41E> 114
+D<00FF02000700C6000C002E0010001E0030001E0060000E0060000E00E0000600E00006
+00E0000600F0000600F8000600FC0000007F0000003FF000003FFF80000FFFE00007FFF0
+0001FFFC00003FFE000001FE0000003F00C0001F00C0000F80C0000780E0000380E00003
+80E0000380E0000380F0000300F0000300F8000700F8000600E4000C00E2001800C18070
+00807F800019257DA41F> I<003000000030000000300000003000000030000000300000
+0070000000700000007000000070000000F0000000F0000001F0000001F0000003F00000
+07F000001FFFFE00FFFFFE0001F0000001F0000001F0000001F0000001F0000001F00000
+01F0000001F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000
+01F0000001F0000001F0000001F0000001F0018001F0018001F0018001F0018001F00180
+01F0018001F0018001F0018001F0018000F0010000F8030000F8030000780200003C0400
+000E08000003F00019357FB41E> I<FFFE000FFFFFFE000FFF07F00007F803E00003E003
+E00001C001F00001C001F000018001F800018000F800030000F8000300007C000600007C
+000600007E000600003E000C00003E000C00003F001C00001F001800001F001800000F80
+3000000F803000000FC070000007C060000007C060000003E0C0000003E0C0000003F1C0
+000001F180000001F180000000FB00000000FB00000000FF000000007E000000007E0000
+00003C000000003C000000003C0000000018000028257FA42A> 118
+D E
+%EndDVIPSBitmapFont
+end
+%%EndProlog
+%%BeginSetup
+%%Feature: *Resolution 300dpi
+TeXDict begin
+%%PaperSize: a4
+
+userdict/PStoPSxform PStoPSmatrix matrix currentmatrix
+ matrix invertmatrix matrix concatmatrix
+ matrix invertmatrix put
+%%EndSetup
+%%Page: (0,1) 1
+userdict/PStoPSsaved save put
+PStoPSmatrix setmatrix
+595.000000 0.271378 translate
+90 rotate
+0.706651 dup scale
+userdict/PStoPSmatrix matrix currentmatrix put
+userdict/PStoPSclip{0 0 moveto
+ 595.000000 0 rlineto 0 842.000000 rlineto -595.000000 0 rlineto
+ closepath}put initclip
+/showpage{}def/copypage{}def/erasepage{}def
+PStoPSxform concat
+1 0 bop Fn 281 370 a(Cleaner) p 570 370 a(seman) n(tics) p
+927 370 a(for) p 1047 370 a(Ob) t(jectiv) n(e) p 1404
+370 a(Lab) r(el) p Fm 717 518 a(Jacques) p 934 518 a(Garrigue) 719
+634 y(Octob) r(er) p 945 634 a(26,) p 1040 634 a(1999) p
+Fl 11 836 a(Credits) p Fk 11 929 a(This) p 122 929 a(prop) q(osal) p
+319 929 a(con) o(tains) p 510 929 a(ideas) p 632 929
+a(from) p 747 929 a(Damien) p 928 929 a(Doligez) p 1101
+929 a(and) p 1196 929 a(Pierre) p 1340 929 a(W) l(eis.) p
+Fl 11 1073 a(Lab) r(els) p 221 1073 a(and) p 351 1073
+a(optionals) p Fk 11 1165 a(Lab) q(els) p 165 1165 a(and) p
+259 1165 a(optional) p 449 1165 a(argumen) o(ts) p 687
+1165 a(had) p 781 1165 a(t) o(w) o(o) p 873 1165 a(problems) p
+1082 1165 a(in) p 1139 1165 a(Ob) s(jectiv) o(e) p 1360
+1165 a(Lab) q(el.) p Fj 83 1280 a(\017) p Fk 133 1280
+a(They) p 259 1280 a(w) o(ere) p 372 1280 a(not) p 459
+1280 a(fully) p 570 1280 a(coheren) o(t) p 767 1280 a(with) p
+878 1280 a(the) p 963 1280 a(original) p 1139 1280 a(call-b) o(y-v) m
+(alue) p 1423 1280 a(seman) o(tics) p 1644 1280 a(of) p
+1700 1280 a(the) p 1784 1280 a(lan-) 133 1340 y(guage.) p
+303 1340 a(In) p 368 1340 a(some) p 495 1340 a(\(subtle\)) p
+681 1340 a(cases,) p 823 1340 a(a) p 868 1340 a(side-e\013ect) p
+1099 1340 a(migh) o(t) p 1243 1340 a(get) p 1329 1340
+a(dela) o(y) o(ed) p 1508 1340 a(more) p 1635 1340 a(than) p
+1753 1340 a(in) p 1814 1340 a(an) 133 1400 y(un) o(t) o(yp) q(ed) p
+322 1400 a(seman) o(tics.) p Fj 83 1502 a(\017) p Fk
+133 1502 a(F) l(or) p 220 1502 a(optional) p 410 1502
+a(argumen) o(ts,) p 660 1502 a(no) p 728 1502 a(un) o(t) o(yp) q(ed) p
+918 1502 a(seman) o(tics) p 1139 1502 a(existed.) 84
+1616 y(This) p 195 1616 a(new) p 295 1616 a(prop) q(osal) p
+492 1616 a(corrects) p 674 1616 a(these) p 799 1616 a(t) o(w) o(o) p
+891 1616 a(\015a) o(ws.) p Fi 11 1746 a(Syn) n(tax) p
+Fk 11 1838 a(W) l(e) p 95 1838 a(k) o(eep) p 206 1838
+a(Ob) s(jectiv) o(e) p 426 1838 a(Lab) q(el's) p 594
+1838 a(syn) o(tax,) p 764 1838 a(except) p 917 1838 a(for) p
+991 1838 a(default) p 1155 1838 a(v) m(alues) p 1301
+1838 a(in) p 1357 1838 a(optional) p 1547 1838 a(argumen) o(ts.) p
+Fh 329 1944 a(typ) n(expr) p Fk 528 1944 a(::=) p Fg
+634 1944 a(:) p 656 1944 a(:) p 678 1944 a(:) p Fj 579
+2004 a(j) p Fh 634 2004 a(typ) n(expr) p Fj 806 2004
+a(!) p Fh 870 2004 a(typ) n(expr) p Fj 579 2064 a(j) p
+Fk 634 2064 a([?]) p Fi(lab) r(el) p Fk 801 2064 a(:) p
+Fh(typ) n(expr) p Fj 987 2064 a(!) p Fh 1050 2064 a(typ) n(expr) 391
+2124 y(expr) p Fk 528 2124 a(::=) p Fg 634 2124 a(:) p
+656 2124 a(:) p 678 2124 a(:) p Fj 579 2185 a(j) p Fh
+634 2185 a(expr) p 746 2185 a(lab) n(ele) n(d-expr) p
+Ff 991 2163 a(+) p Fj 579 2245 a(j) p Fe 634 2245 a(fun) p
+Fj 728 2245 a(f) p Fh(lab) n(ele) n(d-simple-p) n(attern) p
+Fj 1209 2245 a(g) p Ff 1234 2227 a(+) p Fk 1280 2245
+a([) p Fe(when) p Fh 1412 2245 a(expr) p Fk 1507 2245
+a(]) p Fj 1535 2245 a(!) p Fh 1599 2245 a(expr) p Fj
+579 2305 a(j) p Fe 634 2305 a(function) p Fh 856 2305
+a(lab) n(ele) n(d-p) n(attern) p Fk 1177 2305 a([) p
+Fe(when) p Fh 1309 2305 a(expr) p Fk 1404 2305 a(]) p
+Fj 1432 2305 a(!) p Fh 1496 2305 a(expr) p Fj 785 2365
+a(f) p Fe(|) p Fh 851 2365 a(lab) n(ele) n(d-p) n(attern) p
+Fk 1172 2365 a([) p Fe(when) p Fg 1305 2365 a(expr) p
+Fk 1403 2365 a(]) p Fj 1430 2365 a(!) p Fh 1494 2365
+a(expr) p Fj 1589 2365 a(g) p Fd 1614 2347 a(\003) p
+Fh 242 2425 a(lab) n(ele) n(d-expr) p Fk 528 2425 a(::=) p
+634 2425 a([?]) p Fh(expr) p Fj 579 2486 a(j) p Fk 634
+2486 a([?]) p Fi(lab) r(el) p Fk 801 2486 a(:) p Fh(expr) 182
+2546 y(lab) n(ele) n(d-p) n(attern) p Fk 528 2546 a(::=) p
+Fh 634 2546 a(p) n(attern) p Fj 579 2606 a(j) p Fi 634
+2606 a(lab) r(el) p Fk 751 2606 a(:) p Fh(p) n(attern) p
+Fj 579 2666 a(j) p Fk 634 2666 a(?[) p Fe(\() p Fh(expr) p
+Fe(\)) p Fk(]) p Fi(lab) r(el) p Fk 943 2666 a(:) p Fh
+956 2666 a(p) n(attern) p Fk 926 2937 a(1) p eop
+PStoPSsaved restore
+userdict/PStoPSsaved save put
+PStoPSmatrix setmatrix
+595.000000 421.271378 translate
+90 rotate
+0.706651 dup scale
+userdict/PStoPSmatrix matrix currentmatrix put
+userdict/PStoPSclip{0 0 moveto
+ 595.000000 0 rlineto 0 842.000000 rlineto -595.000000 0 rlineto
+ closepath}put initclip
+PStoPSxform concat
+2 1 bop Fi 11 168 a(Dynamic) p 247 168 a(seman) n(tics) p
+Fj 11 261 a(;) p Fk 52 261 a(is) p 101 261 a(a) p 141
+261 a(notation) p 337 261 a(for) p 411 261 a(the) p 495
+261 a(empt) o(y) p 644 261 a(lab) q(el.) 86 366 y(\() p
+Fe(fun) p Fi 198 366 a(l) p Fc 214 373 a(i) p Fk 227
+366 a(:) p Fg(x) p Fj 282 366 a(!) p Fg 346 366 a(e) p
+Fk(\)) p Fi 404 366 a(l) p Fc 420 373 a(1) p Fk 442 366
+a(:) p Fg 455 366 a(e) p Ff 478 373 a(1) p Fg 506 366
+a(:) p 528 366 a(:) p 550 366 a(:) p Fi 571 366 a(l) p
+Fc 587 373 a(n) p Fk 612 366 a(:) p Fg 625 366 a(e) p
+Fb 648 373 a(n) p Fj 515 427 a(!) p Fk 579 427 a(\() p
+Fg(e) p Fk([) p Fg(e) p Fb 658 434 a(i) p Fg 671 427
+a(=x) p Fk(]) p Fi 752 427 a(l) p Fc 768 434 a(1) p Fk
+790 427 a(:) p Fg(e) p Ff 827 434 a(1) p Fg 855 427 a(:) p
+877 427 a(:) p 899 427 a(:) p Fi 920 427 a(l) p Fc 936
+434 a(i) p Fd(\000) p Fc(1) p Fk 997 427 a(:) p Fg 1010
+427 a(e) p Fb 1033 434 a(i) p Fd(\000) p Ff(1) p Fi 1108
+427 a(l) p Fc 1124 434 a(i) p Ff(+) p Fc(1) p Fk 1185
+427 a(:) p Fg(e) p Fb 1222 434 a(i) p Ff(+1) p Fg 1289
+427 a(:) p 1311 427 a(:) p 1333 427 a(:) p Fi 1354 427
+a(l) p Fc 1370 434 a(n) p Fk 1395 427 a(:) p Fg 1408
+427 a(e) p Fb 1431 434 a(n) p Fk 86 487 a(\() p Fe(fun) p
+Fk 198 487 a(?) p Fi(l) p Fc 237 494 a(i) p Fk 250 487
+a(:) p Fg(x) p Fj 305 487 a(!) p Fg 369 487 a(e) p Fk(\)) p
+Fi 427 487 a(l) p Fc 443 494 a(1) p Fk 465 487 a(:) p
+Fg 478 487 a(e) p Ff 501 494 a(1) p Fg 529 487 a(:) p
+551 487 a(:) p 573 487 a(:) p Fi 594 487 a(l) p Fc 610
+494 a(n) p Fk 635 487 a(:) p Fg 648 487 a(e) p Fb 671
+494 a(n) p Fj 515 547 a(!) p Fg 579 547 a(e) p Fk([) p
+Fe(Some) p Fk 717 547 a(\() p Fg(e) p Fb 759 554 a(i) p
+Fk 773 547 a(\)) p Fg(=x) p Fk(]) p Fi 874 547 a(l) p
+Fc 890 554 a(1) p Fk 912 547 a(:) p Fg 925 547 a(e) p
+Ff 948 554 a(1) p Fg 976 547 a(:) p 998 547 a(:) p 1020
+547 a(:) p Fi 1042 547 a(l) p Fc 1058 554 a(i) p Fd(\000) p
+Fc(1) p Fk 1118 547 a(:) p Fg(e) p Fb 1155 554 a(i) p
+Fd(\000) p Ff(1) p Fi 1230 547 a(l) p Fc 1246 554 a(i) p
+Ff(+) p Fc(1) p Fk 1307 547 a(:) p Fg 1320 547 a(e) p
+Fb 1343 554 a(i) p Ff(+1) p Fg 1410 547 a(:) p 1432 547
+a(:) p 1454 547 a(:) p Fi 1476 547 a(l) p Fc 1492 554
+a(n) p Fk 1516 547 a(:) p Fg(e) p Fb 1553 554 a(n) p
+Fk 86 607 a(\() p Fe(fun) p Fk 198 607 a(?) p Fi(l) p
+Fk(:) p Fg 250 607 a(x) p Fj 292 607 a(!) p Fg 356 607
+a(e) p Fk(\)) p Fi 413 607 a(l) p Fc 429 614 a(1) p Fk
+451 607 a(:) p Fg(e) p Ff 488 614 a(1) p Fg 516 607 a(:) p
+538 607 a(:) p 560 607 a(:) p Fi 581 607 a(l) p Fc 597
+614 a(n) p Fk 621 607 a(:) p Fg(e) p Fb 658 614 a(n) p
+Fk 1154 607 a(when) p Fi 1281 607 a(l) p Fc 1297 614
+a(i) p Fk 1324 607 a(=) p Fj 1376 607 a(;) p Fk 1417
+607 a(and) p Fg 1512 607 a(l) p Fj 1541 607 a(62) p 1588
+607 a(f) p Fi(l) p Fc 1629 614 a(1) p Fg 1660 607 a(:) p
+1682 607 a(:) p 1704 607 a(:) p Fi 1725 607 a(l) p Fc
+1741 614 a(n) p Fj 1765 607 a(g) 515 667 y(!) p Fg 579
+667 a(e) p Fk([) p Fe(None) p Fg 717 667 a(=x) p Fk(]) p
+Fi 799 667 a(l) p Fc 815 674 a(1) p Fk 837 667 a(:) p
+Fg(e) p Ff 874 674 a(1) p Fg 901 667 a(:) p 923 667 a(:) p
+945 667 a(:) p Fi 967 667 a(l) p Fc 983 674 a(n) p Fk
+1007 667 a(:) p Fg(e) p Fb 1044 674 a(n) p Fk 86 728
+a(\(\() p Fe(fun) p Fi 217 728 a(l) p Fk(:) p Fg 246
+728 a(x) p Fj 288 728 a(!) p Fg 352 728 a(e) p Fk(\)) p
+Fi 409 728 a(l) p Fc 425 735 a(1) p Fk 447 728 a(:) p
+Fg(e) p Ff 484 735 a(1) p Fg 511 728 a(:) p 533 728 a(:) p
+555 728 a(:) p Fi 577 728 a(l) p Fc 593 735 a(m) p Fk
+629 728 a(:) p Fg 642 728 a(e) p Fb 665 735 a(m) p Fk
+698 728 a(\)) p Fi 733 728 a(l) p Fc 749 735 a(m) p Ff(+) p
+Fc(1) p Fk 833 728 a(:) p Fg 846 728 a(e) p Fb 869 735
+a(m) p Ff(+1) p Fg 955 728 a(:) p 977 728 a(:) p 999
+728 a(:) p Fi 1021 728 a(l) p Fc 1037 735 a(n) p Fk 1061
+728 a(:) p Fg(e) p Fb 1098 735 a(n) p Fk 1373 728 a(when) p
+Fi 1501 728 a(l) p Fj 1530 728 a(62) p 1577 728 a(f) p
+Fi(l) p Fc 1618 735 a(1) p Fg 1648 728 a(:) p 1670 728
+a(:) p 1692 728 a(:) p Fi 1714 728 a(l) p Fc 1730 735
+a(m) p Fj 1765 728 a(g) 515 788 y(!) p Fk 579 788 a(\() p
+Fe(fun) p Fi 691 788 a(l) p Fk(:) p Fg 720 788 a(x) p
+Fj 761 788 a(!) p Fg 825 788 a(e) p Fk(\)) p Fi 883 788
+a(l) p Fc 899 795 a(1) p Fk 921 788 a(:) p Fg 934 788
+a(e) p Ff 957 795 a(1) p Fg 985 788 a(:) p 1007 788 a(:) p
+1029 788 a(:) p Fi 1051 788 a(l) p Fc 1067 795 a(n) p
+Fk 1091 788 a(:) p Fg 1104 788 a(e) p Fb 1127 795 a(n) p
+Fk 86 848 a(\(\() p Fe(fun) p Fk 217 848 a(?) p Fi(l) p
+Fk(:) p Fg 269 848 a(x) p Fj 311 848 a(!) p Fg 375 848
+a(e) p Fk(\)) p Fi 432 848 a(l) p Fc 448 855 a(1) p Fk
+470 848 a(:) p Fg(e) p Ff 507 855 a(1) p Fg 535 848 a(:) p
+557 848 a(:) p 579 848 a(:) p Fi 600 848 a(l) p Fc 616
+855 a(m) p Fk 652 848 a(:) p Fg 665 848 a(e) p Fb 688
+855 a(m) p Fk 721 848 a(\)) p Fi 756 848 a(l) p Fc 772
+855 a(m) p Ff(+) p Fc(1) p Fk 856 848 a(:) p Fg 869 848
+a(e) p Fb 892 855 a(m) p Ff(+1) p Fg 978 848 a(:) p 1000
+848 a(:) p 1022 848 a(:) p Fi 1044 848 a(l) p Fc 1060
+855 a(n) p Fk 1084 848 a(:) p Fg(e) p Fb 1121 855 a(n) p
+Fk 1261 848 a(when) p Fj 1388 848 a(f) p Fi(l) p Fg(;) p
+Fj 1451 848 a(;g) p 1530 848 a(6) m(\\) p 1577 848 a(f) p
+Fi(l) p Fc 1618 855 a(1) p Fg 1648 848 a(:) p 1670 848
+a(:) p 1692 848 a(:) p Fi 1714 848 a(l) p Fc 1730 855
+a(m) p Fj 1765 848 a(g) 515 908 y(!) p Fk 579 908 a(\() p
+Fe(fun) p Fk 691 908 a(?) p Fi(l) p Fk(:) p Fg 743 908
+a(x) p Fj 785 908 a(!) p Fg 848 908 a(e) p Fk(\)) p Fi
+906 908 a(l) p Fc 922 915 a(1) p Fk 944 908 a(:) p Fg(e) p
+Ff 981 915 a(1) p Fg 1008 908 a(:) p 1030 908 a(:) p
+1052 908 a(:) p Fi 1074 908 a(l) p Fc 1090 915 a(n) p
+Fk 1114 908 a(:) p Fg 1127 908 a(e) p Fb 1150 915 a(n) p
+Fi 11 1035 a(T) n(yping) p Fk 11 1127 a(Seman) o(tics) p
+240 1127 a(are) p 321 1127 a(k) o(ept) p 430 1127 a(throughout) p
+685 1127 a(compilation) p 950 1127 a(b) o(y) p 1018 1127
+a(disallo) o(wing) p 1269 1127 a(lab) q(el) p 1387 1127
+a(comm) o(utation) p 1684 1127 a(for) p 1759 1127 a(func-) 11
+1187 y(tion) p 116 1187 a(t) o(yp) q(es.) p 278 1187
+a(Ho) o(w) o(ev) o(er,) p 494 1187 a(the) p 583 1187
+a(original) p 764 1187 a(comfort) p 949 1187 a(of) p
+1009 1187 a(out-of-order) p 1283 1187 a(application) p
+1540 1187 a(is) p 1594 1187 a(reco) o(v) o(ered) p 1814
+1187 a(b) o(y) 11 1247 y(allo) o(wing) p 207 1247 a(argumen) o(t) p
+431 1247 a(reordering) p 670 1247 a(in) p 732 1247 a(application,) p
+1005 1247 a(when) p 1138 1247 a(the) p 1227 1247 a(function's) p
+1457 1247 a(t) o(yp) q(e) p 1572 1247 a(is) p Fh 1626
+1247 a(wel) r(l) p 1731 1247 a(known) p Fk 11 1308 a(\() p
+Fh(c.f.) p Fk 118 1308 a(p) q(olymorphic) p 400 1308
+a(metho) q(ds\).) p Fl 11 1452 a(V) p 56 1452 a(arian) n(ts) p
+Fk 11 1544 a(V) l(arian) o(t) p 187 1544 a(t) o(yping,) p
+355 1544 a(as) p 417 1544 a(it) p 468 1544 a(is) p 519
+1544 a(presen) o(ted) p 739 1544 a(in) p 798 1544 a(the) p
+884 1544 a(user's) p 1022 1544 a(man) o(ual,) p 1210
+1544 a(is) p 1261 1544 a(not) p 1350 1544 a(principal:) p
+1576 1544 a(in) p 1635 1544 a(some) p 1760 1544 a(cases) 11
+1605 y(t) o(ypabilit) o(y) p 239 1605 a(of) p 301 1605
+a(an) p 375 1605 a(expression) p 616 1605 a(ma) o(y) p
+728 1605 a(dep) q(end) p 904 1605 a(on) p 978 1605 a(the) p
+1069 1605 a(order) p 1202 1605 a(in) p 1265 1605 a(whic) o(h) p
+1411 1605 a(the) p 1502 1605 a(t) o(yping) p 1660 1605
+a(algorithm) 11 1665 y(pro) q(ceeds.) p Fe 133 1779 a(#) p
+184 1779 a(let) p 286 1779 a(f1) p 363 1779 a(\(x) p
+440 1779 a(:) p 491 1779 a([<) p 568 1779 a(a) p 620
+1779 a(b\(int\)]\)) p 850 1779 a(=) p 902 1779 a(\(\)) 184
+1839 y(let) p 286 1839 a(f2) p 363 1839 a(\(x) p 440
+1839 a(:) p 491 1839 a([<) p 568 1839 a(a]\)) p 671 1839
+a(=) p 722 1839 a(\(\)) 184 1899 y(let) p 286 1899 a(f3) p
+363 1899 a(\(x) p 440 1899 a(:) p 491 1899 a([<) p 568
+1899 a(a) p 620 1899 a(b\(bool\)]\)) p 876 1899 a(=) p
+927 1899 a(\(\);;) 133 1960 y(val) p 235 1960 a(f1) p
+312 1960 a(:) p 363 1960 a([<) p 440 1960 a(a) p 491
+1960 a(b\(int\)]) p 696 1960 a(->) p 773 1960 a(unit) p
+902 1960 a(=) p 953 1960 a(<fun>) 133 2020 y(val) p 235
+2020 a(f2) p 312 2020 a(:) p 363 2020 a([<) p 440 2020
+a(a]) p 517 2020 a(->) p 594 2020 a(unit) p 722 2020
+a(=) p 773 2020 a(<fun>) 133 2080 y(val) p 235 2080 a(f3) p
+312 2080 a(:) p 363 2080 a([<) p 440 2080 a(a) p 491
+2080 a(b\(bool\)]) p 722 2080 a(->) p 799 2080 a(unit) p
+927 2080 a(=) p 978 2080 a(<fun>) 133 2140 y(#) p 184
+2140 a(fun) p 286 2140 a(x) p 338 2140 a(->) p 414 2140
+a(f1) p 491 2140 a(x;) p 568 2140 a(f2) p 645 2140 a(x;) p
+722 2140 a(f3) p 799 2140 a(x;;) 133 2200 y(-) p 184
+2200 a(:) p 235 2200 a([<) p 312 2200 a(a]) p 389 2200
+a(->) p 466 2200 a(unit) p 594 2200 a(=) p 645 2200 a(<fun>) 133
+2260 y(#) p 184 2260 a(fun) p 286 2260 a(x) p 338 2260
+a(->) p 414 2260 a(f1) p 491 2260 a(x;) p 568 2260 a(f3) p
+645 2260 a(x;;) 133 2321 y(Character) o(s) p 414 2321
+a(18-19:) 133 2381 y(This) p 261 2381 a(expressio) o(n) p
+543 2381 a(has) p 645 2381 a(type) p 773 2381 a([<) p
+850 2381 a(a) p 902 2381 a(b\(int\)]) p 1107 2381 a(but) p
+1209 2381 a(is) p 1286 2381 a(here) p 1414 2381 a(used) p
+1542 2381 a(with) p 1670 2381 a(type) 184 2441 y([<) p
+261 2441 a(a) p 312 2441 a(b\(bool\)]) p Fk 84 2555 a(Here) p
+204 2555 a(the) p 292 2555 a(constrain) o(t) p 526 2555
+a(in) o(tro) q(duced) p 775 2555 a(b) o(y) p Fe 848 2555
+a(f2) p Fk 920 2555 a(hides) p 1049 2555 a(the) p 1138
+2555 a(constructor) p Fe 1401 2555 a(b) p Fk(,) p 1462
+2555 a(and) p 1562 2555 a(a) o(v) o(oids) p 1714 2555
+a(a) p 1760 2555 a(clash) 11 2615 y(b) q(et) o(w) o(een) p
+Fe 199 2615 a(int) p Fk 292 2615 a(and) p Fe 387 2615
+a(bool) p Fk(.) 84 2676 y(An) p 163 2676 a(easy) p 270
+2676 a(w) o(a) o(y) p 369 2676 a(to) p 428 2676 a(solv) o(e) p
+547 2676 a(this) p 642 2676 a(w) o(ould) p 784 2676 a(b) q(e) p
+850 2676 a(to) p 909 2676 a(restrict) p 1077 2676 a(hiding) p
+1226 2676 a(absen) o(t) p 1379 2676 a(lab) q(els) p 1515
+2676 a(to) p 1575 2676 a(generic) p 1739 2676 a(t) o(yp) q(es.) 11
+2736 y(This) p 124 2736 a(w) o(a) o(y) p 224 2736 a(the) p
+310 2736 a(second) p 469 2736 a(case) p 574 2736 a(w) o(ould) p
+718 2736 a(still) p 814 2736 a(fail,) p 913 2736 a(since) p
+Fe 1034 2736 a(x) p Fk 1077 2736 a(has) p 1166 2736 a(a) p
+1208 2736 a(monorphic) p 1451 2736 a(t) o(yp) q(e.) p
+1584 2736 a(This) p 1697 2736 a(solution) 11 2796 y(w) o(ould) p
+153 2796 a(b) q(e) p 219 2796 a(correct) p 382 2796 a(and) p
+477 2796 a(principal.) 926 2937 y(2) p eop
+PStoPSsaved restore
+%%Page: (2,3) 2
+userdict/PStoPSsaved save put
+PStoPSmatrix setmatrix
+595.000000 0.271378 translate
+90 rotate
+0.706651 dup scale
+userdict/PStoPSmatrix matrix currentmatrix put
+userdict/PStoPSclip{0 0 moveto
+ 595.000000 0 rlineto 0 842.000000 rlineto -595.000000 0 rlineto
+ closepath}put initclip
+/showpage{}def/copypage{}def/erasepage{}def
+PStoPSxform concat
+3 2 bop Fk 84 168 a(Ho) o(w) o(ev) o(er,) p 293 168 a(one) p
+382 168 a(can) p 472 168 a(easily) p 606 168 a(see) p
+684 168 a(that) p 789 168 a(this) p 884 168 a(solution) p
+1068 168 a(is) p 1117 168 a(coun) o(ter-in) o(tuitiv) o(e.) p
+1504 168 a(F) l(or) p 1591 168 a(the) p 1675 168 a(user,) p
+Fe 1791 168 a(b) p Fk 1833 168 a(is) 11 229 y(already) p
+183 229 a(an) p 250 229 a(imp) q(ossible) p 488 229 a(constructor,) p
+759 229 a(and) p 854 229 a(ha) o(ving) p 1011 229 a(a) p
+1052 229 a(clash) p 1174 229 a(on) p 1242 229 a(it) p
+1291 229 a(is) p 1340 229 a(hard) p 1453 229 a(to) p
+1513 229 a(understand.) 84 289 y(Another) p 277 289 a(solution) p
+463 289 a(is) p 514 289 a(to) p 575 289 a(go) p 642 289
+a(the) p 728 289 a(opp) q(osite) p 924 289 a(w) o(a) o(y) l(.) p
+1044 289 a(T) l(o) p 1117 289 a(accept) p 1271 289 a(more) p
+1395 289 a(programs.) p 1634 289 a(This) p 1747 289 a(is) p
+1798 289 a(the) 11 349 y(w) o(a) o(y) p 109 349 a(w) o(e) p
+181 349 a(explore) p 351 349 a(here,) p 470 349 a(with) p
+581 349 a(an) p 649 349 a(unc) o(hanged) p 891 349 a(syn) o(tax.) p
+Fi 11 479 a(T) n(yping) p Fk 11 571 a(The) p 114 571
+a(idea) p 220 571 a(is) p 273 571 a(to) p 336 571 a(dela) o(y) p
+466 571 a(uni\014cation) p 711 571 a(on) p 782 571 a(constructor) p
+1043 571 a(un) o(til) p 1161 571 a(they) p 1274 571 a(are) p
+1359 571 a(explicitely) p 1595 571 a(kno) o(wn) p 1753
+571 a(to) p 1816 571 a(b) q(e) 11 631 y(presen) o(t.) p
+199 631 a(W) l(e) p 280 631 a(k) o(eep) p 390 631 a(the) p
+472 631 a(\() p Fg(T) t(;) p 546 631 a(U;) p 601 631
+a(L) p Fk(\)) p 666 631 a(represen) o(tation) p 983 631
+a(of) p 1036 631 a(v) m(arian) o(t) p 1200 631 a(t) o(yp) q(es,) p
+1341 631 a(but) p Fg 1428 631 a(T) p Fk 1478 631 a(is) p
+1525 631 a(no) p 1591 631 a(longer) p 1735 631 a(a) p
+1774 631 a(map) 11 692 y(from) p 126 692 a(constructors) p
+403 692 a(to) p 462 692 a(t) o(yp) q(es,) p 605 692 a(but) p
+694 692 a(from) p 809 692 a(constructors) p 1086 692
+a(to) p 1146 692 a(sets) p 1241 692 a(of) p 1297 692
+a(t) o(yp) q(es.) 84 752 y(When) p 230 752 a(w) o(e) p
+307 752 a(unify) p 436 752 a(t) o(w) o(o) p 532 752 a(v) m(arian) o(t) p
+702 752 a(t) o(yp) q(es,) p 850 752 a(the) p 938 752
+a(\014rst) p 1043 752 a(step) p 1150 752 a(is) p 1204
+752 a(just) p 1305 752 a(to) p 1369 752 a(tak) o(e) p
+1479 752 a(the) p 1567 752 a(union) p 1707 752 a(of) p
+1767 752 a(b) q(oth) 11 812 y(t) o(yping) p 162 812 a(en) o(vironmen) o
+(ts,) p 476 812 a(dropping) p 682 812 a(unnecessary) p
+952 812 a(t) o(yp) q(es.) 204 932 y(\() p Fg(T) p Ff
+252 939 a(1) p Fg 272 932 a(;) p 294 932 a(U) p Ff 327
+939 a(1) p Fg 346 932 a(;) p 368 932 a(L) p Ff 401 939
+a(1) p Fk 421 932 a(\)) p Fj 451 932 a(^) p Fk 495 932
+a(\() p Fg(T) p Ff 543 939 a(2) p Fg 563 932 a(;) p 585
+932 a(U) p Ff 618 939 a(2) p Fg 637 932 a(;) p 659 932
+a(L) p Ff 692 939 a(2) p Fk 712 932 a(\)) p 745 932 a(=) p
+797 932 a(\(\() p Fg(T) p Ff 864 939 a(1) p Fj 883 932
+a(j) p Fb 897 939 a(U) p Fa 921 944 a(1) p Fd 938 939
+a(\\) p Fb(U) p Fa 986 944 a(2) p Fk 1005 932 a(\)) p
+Fj 1035 932 a([) p Fk 1079 932 a(\() p Fg(T) p Ff 1127
+939 a(2) p Fj 1146 932 a(j) p Fb 1160 939 a(U) p Fa 1184
+944 a(1) p Fd 1201 939 a(\\) p Fb(U) p Fa 1249 944 a(2) p
+Fk 1268 932 a(\)) p Fg(;) p 1309 932 a(U) p Ff 1342 939
+a(1) p Fj 1373 932 a(\\) p Fg 1417 932 a(U) p Ff 1450
+939 a(2) p Fg 1470 932 a(;) p 1492 932 a(L) p Ff 1525
+939 a(1) p Fj 1556 932 a([) p Fg 1600 932 a(L) p Ff 1633
+939 a(2) p Fk 1653 932 a(\)) 84 1042 y(Here) p 203 1042
+a(the) p 291 1042 a(union) p 431 1042 a(of) p 490 1042
+a(t) o(w) o(o) p 587 1042 a(t) o(yping) p 742 1042 a(en) o(vironmen) o
+(ts) p 1046 1042 a(is) p 1099 1042 a(the) p 1187 1042
+a(p) q(oin) o(t) o(wise) p 1407 1042 a(union) p 1547
+1042 a(of) p 1606 1042 a(their) p 1727 1042 a(sets) p
+1826 1042 a(of) 11 1102 y(t) o(yp) q(es) p 140 1102 a(for) p
+214 1102 a(eac) o(h) p 324 1102 a(constructor.) 84 1162
+y(This) p 195 1162 a(\014rst) p 296 1162 a(step) p 399
+1162 a(nev) o(er) p 529 1162 a(fails.) 84 1222 y(In) p
+145 1222 a(a) p 186 1222 a(second) p 343 1222 a(step,) p
+460 1222 a(structural) p 685 1222 a(constrain) o(ts) p
+934 1222 a(are) p 1015 1222 a(enforced) p 1209 1222 a(on) p
+1277 1222 a(the) p 1361 1222 a(resulting) p 1562 1222
+a(t) o(yp) q(e) p 1672 1222 a(\() p Fg(T) t(;) p 1746
+1222 a(U;) p 1801 1222 a(L) p Fk(\).) 11 1282 y(First,) p
+Fg 144 1282 a(L) p Fk 195 1282 a(should) p 351 1282 a(b) q(e) p
+418 1282 a(included) p 614 1282 a(in) p Fg 672 1282 a(U) p
+Fk 710 1282 a(.) p 749 1282 a(Then,) p 892 1282 a(for) p
+967 1282 a(all) p 1036 1282 a(constructors) p 1314 1282
+a(app) q(earing) p 1542 1282 a(in) p Fg 1600 1282 a(L) p
+Fk(,) p 1664 1282 a(the) p 1749 1282 a(set) p 1826 1282
+a(of) 11 1343 y(t) o(yp) q(es) p 136 1343 a(asso) q(ciated) p
+365 1343 a(with) p 472 1343 a(eac) o(h) p 578 1343 a(constructor) p
+833 1343 a(is) p 878 1343 a(collapsed) p 1084 1343 a(b) o(y) p
+1148 1343 a(uni\014cation.) p 1407 1343 a(This) p 1515
+1343 a(can) p 1600 1343 a(b) q(e) p 1663 1343 a(expressed) 11
+1403 y(b) o(y) p 78 1403 a(rewriting) p 287 1403 a(rules,) p
+417 1403 a(where) p Fg 558 1403 a(e) p Fk 597 1403 a(is) p
+646 1403 a(a) p 687 1403 a(m) o(ulti-equation) p 1015
+1403 a(and) p Fg 1109 1403 a(\036) p Fk 1155 1403 a(a) p
+1195 1403 a(set) p 1271 1403 a(of) p 1327 1403 a(m) o(ultiequations) 249
+1509 y(if) p Fg 294 1509 a(L) p Fj 341 1509 a(6\032) p
+Fg 393 1509 a(U) p Fk 448 1509 a(then) p 559 1509 a(\() p
+Fg(T) t(;) p 633 1509 a(U;) p 688 1509 a(L) p Fk(\)) p
+753 1509 a(=) p Fg 805 1509 a(e) p Fj 839 1509 a(^) p
+Fg 883 1509 a(\036) p Fj 926 1509 a(\000) p 956 1509
+a(!) p 1020 1509 a(?) p Fk 249 1629 a(if) p Fg 294 1629
+a(l) p Fj 323 1629 a(2) p Fg 370 1629 a(L) p Fk 420 1629
+a(and) p Fg 515 1629 a(T) p Fk 551 1629 a(\() p Fg(l) p
+Fk 586 1629 a(\)) p 617 1629 a(=) p Fj 669 1629 a(f) p
+Fg(\034) p Ff 715 1636 a(1) p Fg 735 1629 a(;) p 757
+1629 a(:) p 779 1629 a(:) p 801 1629 a(:) p 822 1629
+a(;) p 844 1629 a(\034) p Fb 865 1636 a(n) p Fj 889 1629
+a(g) p Fk 930 1629 a(then) 298 1689 y(\() p Fg(T) t(;) p
+372 1689 a(U;) p 427 1689 a(L) p Fk(\)) p 492 1689 a(=) p
+Fg 544 1689 a(e) p Fj 577 1689 a(^) p Fg 622 1689 a(\036) p
+Fj 664 1689 a(\000) p 695 1689 a(!) p Fk 759 1689 a(\() p
+Fg(T) p Fj 814 1689 a(f) p Fg(l) p Fj 867 1689 a(7!) p
+Fg 931 1689 a(\034) p Ff 952 1696 a(1) p Fj 972 1689
+a(g) p Fg(;) p 1019 1689 a(U;) p 1074 1689 a(L) p Fk(\)) p
+1139 1689 a(=) p Fg 1191 1689 a(e) p Fj 1225 1689 a(^) p
+Fg 1269 1689 a(\034) p Ff 1290 1696 a(1) p Fk 1324 1689
+a(=) p Fg 1376 1689 a(:) p 1398 1689 a(:) p 1420 1689
+a(:) p Fk 1447 1689 a(=) p Fg 1498 1689 a(\034) p Fb
+1519 1696 a(n) p Fj 1554 1689 a(^) p Fg 1598 1689 a(\036) p
+Fk 84 1796 a(Optionally) p 331 1796 a(one) p 425 1796
+a(can) p 519 1796 a(add) p 619 1796 a(rules) p 740 1796
+a(that) p 850 1796 a(remo) o(v) o(e) p 1022 1796 a(a) p
+1067 1796 a(constructor) p Fg 1329 1796 a(l) p Fk 1366
+1796 a(from) p Fg 1486 1796 a(U) p Fk 1545 1796 a(if) p
+1594 1796 a(the) p 1683 1796 a(equation) 11 1856 y(obtained) p
+211 1856 a(from) p Fg 326 1856 a(T) p Fk 362 1856 a(\() p
+Fg(l) p Fk 397 1856 a(\)) p 431 1856 a(has) p 518 1856
+a(no) p 586 1856 a(solution.) p 790 1856 a(Suc) o(h) p
+908 1856 a(rules) p 1024 1856 a(w) o(ould) p 1167 1856
+a(b) q(e) p 1233 1856 a(sound) p 1374 1856 a(and) p 1469
+1856 a(complete.) p Fi 11 1986 a(Syn) n(tax) p 198 1986
+a(of) p 262 1986 a(t) n(yp) r(es) p Fk 11 2078 a(Thanks) p
+188 2078 a(to) p 250 2078 a(the) p 336 2078 a(go) q(o) q(d) p
+458 2078 a(prop) q(erties) p 689 2078 a(of) p 747 2078
+a(these) p 874 2078 a(constrain) o(ts,) p 1139 2078 a(the) p
+1226 2078 a(surface) p 1392 2078 a(syn) o(tax) p 1551
+2078 a(of) p 1608 2078 a(t) o(yp) q(es) p 1740 2078 a(w) o(ould) 11
+2138 y(only) p 118 2138 a(ha) o(v) o(e) p 230 2138 a(to) p
+290 2138 a(b) q(e) p 356 2138 a(sligh) o(tly) p 527 2138
+a(extended.) p Fh 590 2244 a(tag-typ) n(e) p Fk 798 2244
+a(::=) p Fh 904 2244 a(ident) p Fj 849 2304 a(j) p Fh
+904 2304 a(ident) p Fe 1031 2304 a(\() p Fh(typ) n(expr-list) p
+Fe(\)) p Fh 523 2365 a(typ) n(expr-list) p Fk 798 2365
+a(::=) p Fh 904 2365 a(typ) n(expr) p Fj 849 2425 a(j) p
+Fh 904 2425 a(typ) n(expr) p Fe 1078 2425 a(&) p Fh 1120
+2425 a(typ) n(expr-list) p Fk 84 2531 a(Notice) p 234
+2531 a(that) p 336 2531 a(a) p 373 2531 a(0-ary) p 496
+2531 a(constructor) p 751 2531 a(and) p 842 2531 a(an) p
+907 2531 a(1-ary) p 1030 2531 a(construtor) p 1262 2531
+a(are) p 1340 2531 a(con) o(tradictory) l(,) p 1648 2531
+a(and) p 1740 2531 a(w) o(ould) 11 2592 y(result) p 146
+2592 a(in) p 203 2592 a(the) p 287 2592 a(absence) p
+466 2592 a(of) p 522 2592 a(this) p 617 2592 a(constructor.) 926
+2937 y(3) p eop
+PStoPSsaved restore
+userdict/PStoPSsaved save put
+PStoPSmatrix setmatrix
+595.000000 421.271378 translate
+90 rotate
+0.706651 dup scale
+userdict/PStoPSmatrix matrix currentmatrix put
+userdict/PStoPSclip{0 0 moveto
+ 595.000000 0 rlineto 0 842.000000 rlineto -595.000000 0 rlineto
+ closepath}put initclip
+PStoPSxform concat
+4 3 bop Fi 11 168 a(Discussion) p Fk 11 261 a(Suc) o(h) p
+133 261 a(a) p 179 261 a(c) o(hange) p 345 261 a(has) p
+436 261 a(the) p 525 261 a(ma) s(jor) p 672 261 a(adv) m(an) o(tage) p
+907 261 a(of) p 967 261 a(b) q(oth) p 1087 261 a(reco) o(v) o(ering) p
+1324 261 a(principalit) o(y) p 1589 261 a(and) p 1688
+261 a(a) o(v) o(oiding) 11 321 y(unin) o(tuitiv) o(e) p
+266 321 a(error) p 392 321 a(messages.) p 640 321 a(Constrain) o(ts) p
+909 321 a(created) p 1087 321 a(in) p 1152 321 a(suc) o(h) p
+1269 321 a(a) p 1317 321 a(w) o(a) o(y) p 1423 321 a(are) p
+1512 321 a(v) o(ery) p 1626 321 a(ligh) o(t:) p 1772
+321 a(they) 11 381 y(alw) o(a) o(ys) p 165 381 a(app) q(ear) p
+325 381 a(inside) p 463 381 a(a) p 502 381 a(v) m(arian) o(t) p
+666 381 a(t) o(yp) q(e,) p 788 381 a(and) p 882 381 a(if) p
+926 381 a(the) p 1008 381 a(v) m(arian) o(t) p 1172 381
+a(t) o(yp) q(e) p 1281 381 a(do) q(es) p 1390 381 a(not) p
+1475 381 a(app) q(ear) p 1635 381 a(in) p 1691 381 a(the) p
+1774 381 a(\014nal) 11 441 y(t) o(yp) q(e) p 120 441
+a(sc) o(heme,) p 301 441 a(then) p 412 441 a(the) p 496
+441 a(constrain) o(t) p 725 441 a(can) p 815 441 a(b) q(e) p
+881 441 a(discarded) p 1098 441 a(safely) l(.) 84 501
+y(On) p 165 501 a(the) p 249 501 a(other) p 376 501 a(hand,) p
+512 501 a(there) p 637 501 a(are) p 718 501 a(t) o(w) o(o) p
+810 501 a(dra) o(wbac) o(ks.) p Fj 83 616 a(\017) p Fk
+133 616 a(Some) p 259 616 a(errors) p 393 616 a(will) p
+482 616 a(b) q(e) p 544 616 a(dela) o(y) o(ed) p 715
+616 a(longer) p 858 616 a(than) p 968 616 a(no) o(w,) p
+1080 616 a(un) o(til) p 1191 616 a(a) p 1228 616 a(construtor) p
+1460 616 a(is) p 1505 616 a(actually) p 1687 616 a(included) 133
+676 y(in) p Fg 189 676 a(L) p Fk(.) p 258 676 a(It) p
+311 676 a(is) p 360 676 a(not) p 446 676 a(clear) p 563
+676 a(ho) o(w) p 665 676 a(damageable) p 930 676 a(it) p
+979 676 a(is.) p Fj 83 777 a(\017) p Fk 133 777 a(While) p
+272 777 a(t) o(yp) q(e) p 378 777 a(inference) p 579
+777 a(is) p 625 777 a(simple) p 774 777 a(and) p 865
+777 a(costless) p 1036 777 a(for) p 1108 777 a(this) p
+1200 777 a(extension,) p 1426 777 a(simpli\014cation) p
+1724 777 a(of) p 1776 777 a(con-) 133 838 y(strain) o(ts) p
+310 838 a(|marking) p 551 838 a(constructors) p 830 838
+a(with) p 943 838 a(unsolv) m(able) p 1182 838 a(constrain) o(ts) p
+1432 838 a(as) p 1494 838 a(absen) o(t,) p 1663 838 a(and) p
+1760 838 a(elim-) 133 898 y(inating) p 300 898 a(redundan) o(t) p
+536 898 a(t) o(yp) q(es) p 667 898 a(in) p 726 898 a(constrain) o(ts|) p
+1025 898 a(is) p 1076 898 a(a) p 1119 898 a(bit) p 1197
+898 a(more) p 1320 898 a(exp) q(ensiv) o(e.) p 1565 898
+a(Also,) p 1691 898 a(allo) o(wing) 133 958 y(suc) o(h) p
+244 958 a(constrained) p 506 958 a(t) o(yp) q(es) p 637
+958 a(inside) p 777 958 a(signatures) p 1010 958 a(w) o(ould) p
+1154 958 a(mean) p 1286 958 a(ha) o(ving) p 1444 958
+a(to) p 1506 958 a(solv) o(e) p 1627 958 a(a) p 1669
+958 a(matc) o(hing) 133 1018 y(problem,) p 333 1018 a(whic) o(h) p
+469 1018 a(is) p 514 1018 a(exp) q(onen) o(tial) p 772
+1018 a(in) p 825 1018 a(the) p 906 1018 a(n) o(um) o(b) q(er) p
+1080 1018 a(of) p 1132 1018 a(connected) p 1356 1018
+a(constrain) o(ts) p 1600 1018 a(inside) p 1735 1018
+a(a) p 1772 1018 a(t) o(yp) q(e) 133 1078 y(sc) o(heme.) 84
+1193 y(Reasonably) p 340 1193 a(e\016cien) o(t) p 516
+1193 a(algorithms) p 754 1193 a(exist) p 866 1193 a(to) p
+922 1193 a(solv) o(e) p 1038 1193 a(these) p 1159 1193
+a(problems,) p 1379 1193 a(so) p 1435 1193 a(the) p 1515
+1193 a(di\016cult) o(y) p 1715 1193 a(is) p 1760 1193
+a(more) 11 1253 y(in) p 67 1253 a(the) p 151 1253 a(increased) p
+363 1253 a(complexit) o(y) p 611 1253 a(of) p 667 1253
+a(the) p 751 1253 a(t) o(yp) q(e-c) o(hec) o(k) o(er) p
+1031 1253 a(than) p 1145 1253 a(in) p 1202 1253 a(run-time) p
+1402 1253 a(cost.) p Fl 11 1397 a(Other) p 205 1397 a(features) p
+Fk 11 1490 a(Ob) s(jectiv) o(e) p 238 1490 a(Lab) q(el) p
+380 1490 a(con) o(tains) p 579 1490 a(t) o(w) o(o) p
+678 1490 a(other) p 812 1490 a(features:) p 1029 1490
+a(p) q(olymorphic) p 1318 1490 a(metho) q(ds) p 1521
+1490 a(and) p 1623 1490 a(t) o(yp) q(e-driv) o(en) 11
+1550 y(access) p 153 1550 a(of) p 208 1550 a(records.) p
+394 1550 a(Both) p 514 1550 a(of) p 568 1550 a(them) p
+692 1550 a(use) p 775 1550 a(the) p 857 1550 a(same) p
+978 1550 a(metho) q(d) p 1154 1550 a(of) p 1209 1550
+a(enforcing) p 1417 1550 a(principalit) o(y) p 1676 1550
+a(of) p 1730 1550 a(t) o(yping) 11 1610 y(through) p
+191 1610 a(tracing) p 351 1610 a(user) p 450 1610 a(pro) o(vided) p
+647 1610 a(t) o(yp) q(e) p 752 1610 a(information.) p
+1034 1610 a(With) p 1155 1610 a(this) p 1246 1610 a(tracing,) p
+1422 1610 a(their) p 1534 1610 a(implem) o(en) n(tation) 11
+1670 y(is) p 60 1670 a(v) o(ery) p 167 1670 a(easy) l(,) p
+283 1670 a(but) p 373 1670 a(without) p 554 1670 a(it) p
+603 1670 a(they) p 713 1670 a(lo) q(ose) p 834 1670 a(principalit) o(y)
+l(.) 84 1730 y(While) p 229 1730 a(these) p 357 1730
+a(features) p 543 1730 a(pro) o(vide) p 720 1730 a(some) p
+845 1730 a(comfort) p 1029 1730 a(in) p 1089 1730 a(writing) p
+1260 1730 a(user) p 1366 1730 a(programs,) p 1598 1730
+a(they) p 1711 1730 a(are) p 1795 1730 a(not) 11 1791
+y(strictly) p 182 1791 a(necessary) p 403 1791 a(for) p
+482 1791 a(the) p 571 1791 a(v) m(arious) p 742 1791
+a(libraries) p 934 1791 a(coming) p 1107 1791 a(with) p
+1223 1791 a(O'Labl) p 1391 1791 a(\(LablTk,) p 1602 1791
+a(LablGL) p 1787 1791 a(and) 11 1851 y(LablGTK\).) 926
+2937 y(4) p eop
+PStoPSsaved restore
+%%Trailer
+end
+userdict /end-hook known{end-hook}if
+%%EOF
diff --git a/experimental/garrigue/objvariant.diffs b/experimental/garrigue/objvariant.diffs
new file mode 100644
index 000000000..75deb24cd
--- /dev/null
+++ b/experimental/garrigue/objvariant.diffs
@@ -0,0 +1,354 @@
+? objvariants-3.09.1.diffs
+? objvariants.diffs
+Index: btype.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/btype.ml,v
+retrieving revision 1.37.4.1
+diff -u -r1.37.4.1 btype.ml
+--- btype.ml 5 Dec 2005 13:18:42 -0000 1.37.4.1
++++ btype.ml 16 Jan 2006 02:23:14 -0000
+@@ -177,7 +177,8 @@
+ Tvariant row -> iter_row f row
+ | Tvar | Tunivar | Tsubst _ | Tconstr _ ->
+ Misc.may (fun (_,l) -> List.iter f l) row.row_name;
+- List.iter f row.row_bound
++ List.iter f row.row_bound;
++ List.iter (fun (s,k,t) -> f t) row.row_object
+ | _ -> assert false
+
+ let iter_type_expr f ty =
+@@ -224,7 +225,9 @@
+ | Some (path, tl) -> Some (path, List.map f tl) in
+ { row_fields = fields; row_more = more;
+ row_bound = !bound; row_fixed = row.row_fixed && fixed;
+- row_closed = row.row_closed; row_name = name; }
++ row_closed = row.row_closed; row_name = name;
++ row_object = List.map (fun (s,k,t) -> (s,k,f t)) row.row_object;
++ }
+
+ let rec copy_kind = function
+ Fvar{contents = Some k} -> copy_kind k
+Index: ctype.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.ml,v
+retrieving revision 1.197.2.6
+diff -u -r1.197.2.6 ctype.ml
+--- ctype.ml 15 Dec 2005 02:28:38 -0000 1.197.2.6
++++ ctype.ml 16 Jan 2006 02:23:15 -0000
+@@ -1421,7 +1421,7 @@
+ newgenty
+ (Tvariant
+ {row_fields = fields; row_closed = closed; row_more = newvar();
+- row_bound = []; row_fixed = false; row_name = None })
++ row_bound = []; row_fixed = false; row_name = None; row_object=[]})
+
+ (**** Unification ****)
+
+@@ -1724,8 +1724,11 @@
+ else None
+ in
+ let bound = row1.row_bound @ row2.row_bound in
++ let opairs, _, miss2 = associate_fields row1.row_object row2.row_object in
++ let row_object = row1.row_object @ miss2 in
+ let row0 = {row_fields = []; row_more = more; row_bound = bound;
+- row_closed = closed; row_fixed = fixed; row_name = name} in
++ row_closed = closed; row_fixed = fixed; row_name = name;
++ row_object = row_object } in
+ let set_more row rest =
+ let rest =
+ if closed then
+@@ -1758,6 +1761,18 @@
+ raise (Unify ((mkvariant [l,f1] true,
+ mkvariant [l,f2] true) :: trace)))
+ pairs;
++ List.iter (fun (s,_,ty1,_,ty2) -> unify env ty1 ty2) opairs;
++ if row_object <> [] then begin
++ List.iter
++ (fun (l,f) ->
++ match row_field_repr f with
++ Rpresent (Some ty) ->
++ let fi = build_fields generic_level row_object (newgenvar()) in
++ unify env (newgenty (Tobject (fi, ref None))) ty
++ | Rpresent None -> raise (Unify [])
++ | _ -> ())
++ (row_repr row1).row_fields
++ end;
+ with exn ->
+ log_type rm1; rm1.desc <- md1; log_type rm2; rm2.desc <- md2; raise exn
+ end
+@@ -2789,7 +2804,8 @@
+ let row =
+ { row_fields = List.map fst fields; row_more = newvar();
+ row_bound = !bound; row_closed = posi; row_fixed = false;
+- row_name = if c > Unchanged then None else row.row_name }
++ row_name = if c > Unchanged then None else row.row_name;
++ row_object = [] }
+ in
+ (newty (Tvariant row), Changed)
+ | Tobject (t1, _) ->
+Index: oprint.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/oprint.ml,v
+retrieving revision 1.22
+diff -u -r1.22 oprint.ml
+--- oprint.ml 23 Mar 2005 03:08:37 -0000 1.22
++++ oprint.ml 16 Jan 2006 02:23:15 -0000
+@@ -185,7 +185,7 @@
+ fprintf ppf "@[<2>< %a >@]" (print_fields rest) fields
+ | Otyp_stuff s -> fprintf ppf "%s" s
+ | Otyp_var (ng, s) -> fprintf ppf "'%s%s" (if ng then "_" else "") s
+- | Otyp_variant (non_gen, row_fields, closed, tags) ->
++ | Otyp_variant (non_gen, row_fields, closed, tags, obj) ->
+ let print_present ppf =
+ function
+ None | Some [] -> ()
+@@ -198,12 +198,17 @@
+ ppf fields
+ | Ovar_name (id, tyl) ->
+ fprintf ppf "@[%a%a@]" print_typargs tyl print_ident id
++ and print_object ppf obj =
++ if obj <> [] then
++ fprintf ppf "@ as @[<2>< %a >@]" (print_fields (Some false)) obj
+ in
+- fprintf ppf "%s[%s@[<hv>@[<hv>%a@]%a ]@]" (if non_gen then "_" else "")
++ fprintf ppf "%s[%s@[<hv>@[<hv>%a@]%a%a ]@]"
++ (if non_gen then "_" else "")
+ (if closed then if tags = None then " " else "< "
+ else if tags = None then "> " else "? ")
+ print_fields row_fields
+ print_present tags
++ print_object obj
+ | Otyp_alias _ | Otyp_poly _ | Otyp_arrow _ | Otyp_tuple _ as ty ->
+ fprintf ppf "@[<1>(%a)@]" print_out_type ty
+ | Otyp_abstract | Otyp_sum _ | Otyp_record _ | Otyp_manifest (_, _) -> ()
+Index: outcometree.mli
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/outcometree.mli,v
+retrieving revision 1.14
+diff -u -r1.14 outcometree.mli
+--- outcometree.mli 23 Mar 2005 03:08:37 -0000 1.14
++++ outcometree.mli 16 Jan 2006 02:23:15 -0000
+@@ -59,6 +59,7 @@
+ | Otyp_var of bool * string
+ | Otyp_variant of
+ bool * out_variant * bool * (string list) option
++ * (string * out_type) list
+ | Otyp_poly of string list * out_type
+ and out_variant =
+ | Ovar_fields of (string * bool * out_type list) list
+Index: printtyp.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/printtyp.ml,v
+retrieving revision 1.139.2.2
+diff -u -r1.139.2.2 printtyp.ml
+--- printtyp.ml 7 Dec 2005 23:37:27 -0000 1.139.2.2
++++ printtyp.ml 16 Jan 2006 02:23:15 -0000
+@@ -244,7 +244,10 @@
+ visited_objects := px :: !visited_objects;
+ match row.row_name with
+ | Some(p, tyl) when namable_row row ->
+- List.iter (mark_loops_rec visited) tyl
++ List.iter (mark_loops_rec visited) tyl;
++ if not (static_row row) then
++ List.iter (fun (s,k,t) -> mark_loops_rec visited t)
++ row.row_object
+ | _ ->
+ iter_row (mark_loops_rec visited) {row with row_bound = []}
+ end
+@@ -343,25 +346,27 @@
+ | _ -> false)
+ fields in
+ let all_present = List.length present = List.length fields in
++ let static = row.row_closed && all_present in
++ let obj =
++ if static then [] else
++ List.map (fun (s,k,t) -> (s, tree_of_typexp sch t)) row.row_object
++ in
++ let tags = if all_present then None else Some (List.map fst present) in
+ begin match row.row_name with
+ | Some(p, tyl) when namable_row row ->
+ let id = tree_of_path p in
+ let args = tree_of_typlist sch tyl in
+- if row.row_closed && all_present then
++ if static then
+ Otyp_constr (id, args)
+ else
+ let non_gen = is_non_gen sch px in
+- let tags =
+- if all_present then None else Some (List.map fst present) in
+ Otyp_variant (non_gen, Ovar_name(tree_of_path p, args),
+- row.row_closed, tags)
++ row.row_closed, tags, obj)
+ | _ ->
+- let non_gen =
+- not (row.row_closed && all_present) && is_non_gen sch px in
++ let non_gen = not static && is_non_gen sch px in
+ let fields = List.map (tree_of_row_field sch) fields in
+- let tags =
+- if all_present then None else Some (List.map fst present) in
+- Otyp_variant (non_gen, Ovar_fields fields, row.row_closed, tags)
++ Otyp_variant (non_gen, Ovar_fields fields, row.row_closed,
++ tags, obj)
+ end
+ | Tobject (fi, nm) ->
+ tree_of_typobject sch fi nm
+Index: typecore.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/typecore.ml,v
+retrieving revision 1.176.2.2
+diff -u -r1.176.2.2 typecore.ml
+--- typecore.ml 11 Dec 2005 09:56:33 -0000 1.176.2.2
++++ typecore.ml 16 Jan 2006 02:23:15 -0000
+@@ -170,7 +170,8 @@
+ (* Force check of well-formedness *)
+ unify_pat pat.pat_env pat
+ (newty(Tvariant{row_fields=[]; row_more=newvar(); row_closed=false;
+- row_bound=[]; row_fixed=false; row_name=None}));
++ row_bound=[]; row_fixed=false; row_name=None;
++ row_object=[]}));
+ | _ -> ()
+
+ let rec iter_pattern f p =
+@@ -251,7 +252,7 @@
+ let ty = may_map (build_as_type env) p' in
+ newty (Tvariant{row_fields=[l, Rpresent ty]; row_more=newvar();
+ row_bound=[]; row_name=None;
+- row_fixed=false; row_closed=false})
++ row_fixed=false; row_closed=false; row_object=[]})
+ | Tpat_record lpl ->
+ let lbl = fst(List.hd lpl) in
+ if lbl.lbl_private = Private then p.pat_type else
+@@ -318,7 +319,8 @@
+ ([],[]) fields in
+ let row =
+ { row_fields = List.rev fields; row_more = newvar(); row_bound = !bound;
+- row_closed = false; row_fixed = false; row_name = Some (path, tyl) }
++ row_closed = false; row_fixed = false; row_name = Some (path, tyl);
++ row_object = [] }
+ in
+ let ty = newty (Tvariant row) in
+ let gloc = {loc with Location.loc_ghost=true} in
+@@ -428,7 +430,8 @@
+ row_closed = false;
+ row_more = newvar ();
+ row_fixed = false;
+- row_name = None } in
++ row_name = None;
++ row_object = [] } in
+ rp {
+ pat_desc = Tpat_variant(l, arg, row);
+ pat_loc = sp.ppat_loc;
+@@ -976,7 +979,8 @@
+ row_bound = [];
+ row_closed = false;
+ row_fixed = false;
+- row_name = None});
++ row_name = None;
++ row_object = []});
+ exp_env = env }
+ | Pexp_record(lid_sexp_list, opt_sexp) ->
+ let ty = newvar() in
+@@ -1261,8 +1265,30 @@
+ assert false
+ end
+ | _ ->
+- (Texp_send(obj, Tmeth_name met),
+- filter_method env met Public obj.exp_type)
++ let obj, met_ty =
++ match expand_head env obj.exp_type with
++ {desc = Tvariant _} ->
++ let exp_ty = newvar () in
++ let met_ty = filter_method env met Public exp_ty in
++ let row =
++ {row_fields=[]; row_more=newvar();
++ row_bound=[]; row_closed=false;
++ row_fixed=false; row_name=None;
++ row_object=[met, Fpresent, met_ty]} in
++ unify_exp env obj (newty (Tvariant row));
++ let prim = Primitive.parse_declaration 1 ["%field1"] in
++ let ty = newty(Tarrow("", obj.exp_type, exp_ty, Cok)) in
++ let vd = {val_type = ty; val_kind = Val_prim prim} in
++ let esnd =
++ {exp_desc=Texp_ident(Path.Pident(Ident.create"snd"), vd);
++ exp_loc = Location.none; exp_type = ty; exp_env = env}
++ in
++ ({obj with exp_type = exp_ty;
++ exp_desc = Texp_apply(esnd,[Some obj, Required])},
++ met_ty)
++ | _ -> (obj, filter_method env met Public obj.exp_type)
++ in
++ (Texp_send(obj, Tmeth_name met), met_ty)
+ in
+ if !Clflags.principal then begin
+ end_def ();
+Index: types.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/types.ml,v
+retrieving revision 1.25
+diff -u -r1.25 types.ml
+--- types.ml 9 Dec 2004 12:40:53 -0000 1.25
++++ types.ml 16 Jan 2006 02:23:15 -0000
+@@ -44,7 +44,9 @@
+ row_bound: type_expr list;
+ row_closed: bool;
+ row_fixed: bool;
+- row_name: (Path.t * type_expr list) option }
++ row_name: (Path.t * type_expr list) option;
++ row_object: (string * field_kind * type_expr) list;
++ }
+
+ and row_field =
+ Rpresent of type_expr option
+Index: types.mli
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/types.mli,v
+retrieving revision 1.25
+diff -u -r1.25 types.mli
+--- types.mli 9 Dec 2004 12:40:53 -0000 1.25
++++ types.mli 16 Jan 2006 02:23:15 -0000
+@@ -43,7 +43,9 @@
+ row_bound: type_expr list;
+ row_closed: bool;
+ row_fixed: bool;
+- row_name: (Path.t * type_expr list) option }
++ row_name: (Path.t * type_expr list) option;
++ row_object: (string * field_kind * type_expr) list;
++ }
+
+ and row_field =
+ Rpresent of type_expr option
+Index: typetexp.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/typetexp.ml,v
+retrieving revision 1.54
+diff -u -r1.54 typetexp.ml
+--- typetexp.ml 22 Jul 2005 06:42:36 -0000 1.54
++++ typetexp.ml 16 Jan 2006 02:23:15 -0000
+@@ -215,7 +215,8 @@
+ in
+ let row = { row_closed = true; row_fields = fields;
+ row_bound = !bound; row_name = Some (path, args);
+- row_fixed = false; row_more = newvar () } in
++ row_fixed = false; row_more = newvar ();
++ row_object = [] } in
+ let static = Btype.static_row row in
+ let row =
+ if static then row else
+@@ -262,7 +263,7 @@
+ let mkfield l f =
+ newty (Tvariant {row_fields=[l,f]; row_more=newvar();
+ row_bound=[]; row_closed=true;
+- row_fixed=false; row_name=None}) in
++ row_fixed=false; row_name=None; row_object=[]}) in
+ let add_typed_field loc l f fields =
+ try
+ let f' = List.assoc l fields in
+@@ -345,7 +346,7 @@
+ let row =
+ { row_fields = List.rev fields; row_more = newvar ();
+ row_bound = !bound; row_closed = closed;
+- row_fixed = false; row_name = !name } in
++ row_fixed = false; row_name = !name; row_object = [] } in
+ let static = Btype.static_row row in
+ let row =
+ if static then row else
diff --git a/experimental/garrigue/objvariant.ml b/experimental/garrigue/objvariant.ml
new file mode 100644
index 000000000..3233e03c0
--- /dev/null
+++ b/experimental/garrigue/objvariant.ml
@@ -0,0 +1,42 @@
+(* use with [cvs update -r objvariants typing] *)
+
+let f (x : [> ]) = x#m 3;;
+let o = object method m x = x+2 end;;
+f (`A o);;
+let l = [`A o; `B(object method m x = x -2 method y = 3 end)];;
+List.map f l;;
+let g = function `A x -> x#m 3 | `B x -> x#y;;
+List.map g l;;
+fun x -> ignore (x=f); List.map x l;;
+fun (x : [< `A of _ | `B of _] -> int) -> ignore (x=f); List.map x l;;
+
+
+class cvar name =
+ object
+ method name = name
+ method print ppf = Format.pp_print_string ppf name
+ end
+
+type var = [`Var of cvar]
+
+class cint n =
+ object
+ method n = n
+ method print ppf = Format.pp_print_int ppf n
+ end
+
+class ['a] cadd (e1 : 'a) (e2 : 'a) =
+ object
+ constraint 'a = [> ]
+ method e1 = e1
+ method e2 = e2
+ method print ppf = Format.fprintf ppf "(%t, %t)" e1#print e2#print
+ end
+
+type 'a expr = [var | `Int of cint | `Add of 'a cadd]
+
+type expr1 = expr1 expr
+
+let print = Format.printf "%t@."
+
+let e1 : expr1 = `Add (new cadd (`Var (new cvar "x")) (`Int (new cint 2)))
diff --git a/experimental/garrigue/printers.ml b/experimental/garrigue/printers.ml
new file mode 100644
index 000000000..c80c42d66
--- /dev/null
+++ b/experimental/garrigue/printers.ml
@@ -0,0 +1,11 @@
+(* $Id$ *)
+
+open Types
+
+let ignore_abbrevs ppf ab =
+ let s = match ab with
+ Mnil -> "Mnil"
+ | Mlink _ -> "Mlink _"
+ | Mcons _ -> "Mcons _"
+ in
+ Format.pp_print_string ppf s
diff --git a/experimental/garrigue/tests.ml b/experimental/garrigue/tests.ml
new file mode 100644
index 000000000..c39d152fb
--- /dev/null
+++ b/experimental/garrigue/tests.ml
@@ -0,0 +1,22 @@
+(* $Id$ *)
+
+let f1 = function `a x -> x=1 | `b -> true
+let f2 = function `a x -> x | `b -> true
+let f3 = function `b -> true
+let f x = f1 x && f2 x
+
+let sub s ?:pos{=0} ?:len{=String.length s - pos} () =
+ String.sub s pos len
+
+let cCAMLtoTKpack_options w = function
+ `After v1 -> "-after"
+ | `Anchor v1 -> "-anchor"
+ | `Before v1 -> "-before"
+ | `Expand v1 -> "-expand"
+ | `Fill v1 -> "-fill"
+ | `In v1 -> "-in"
+ | `Ipadx v1 -> "-ipadx"
+ | `Ipady v1 -> "-ipady"
+ | `Padx v1 -> "-padx"
+ | `Pady v1 -> "-pady"
+ | `Side v1 -> "-side"
diff --git a/experimental/garrigue/valvirt.diffs b/experimental/garrigue/valvirt.diffs
new file mode 100644
index 000000000..2cf55742b
--- /dev/null
+++ b/experimental/garrigue/valvirt.diffs
@@ -0,0 +1,2349 @@
+Index: utils/warnings.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/utils/warnings.ml,v
+retrieving revision 1.23
+diff -u -r1.23 warnings.ml
+--- utils/warnings.ml 15 Sep 2005 03:09:26 -0000 1.23
++++ utils/warnings.ml 5 Apr 2006 02:25:59 -0000
+@@ -26,7 +26,7 @@
+ | Statement_type (* S *)
+ | Unused_match (* U *)
+ | Unused_pat
+- | Hide_instance_variable of string (* V *)
++ | Instance_variable_override of string (* V *)
+ | Illegal_backslash (* X *)
+ | Implicit_public_methods of string list
+ | Unerasable_optional_argument
+@@ -54,7 +54,7 @@
+ | Statement_type -> 's'
+ | Unused_match
+ | Unused_pat -> 'u'
+- | Hide_instance_variable _ -> 'v'
++ | Instance_variable_override _ -> 'v'
+ | Illegal_backslash
+ | Implicit_public_methods _
+ | Unerasable_optional_argument
+@@ -126,9 +126,9 @@
+ String.concat " "
+ ("the following methods are overridden \
+ by the inherited class:\n " :: slist)
+- | Hide_instance_variable lab ->
+- "this definition of an instance variable " ^ lab ^
+- " hides a previously\ndefined instance variable of the same name."
++ | Instance_variable_override lab ->
++ "the instance variable " ^ lab ^ " is overridden.\n" ^
++ "The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)"
+ | Partial_application ->
+ "this function application is partial,\n\
+ maybe some arguments are missing."
+Index: utils/warnings.mli
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/utils/warnings.mli,v
+retrieving revision 1.16
+diff -u -r1.16 warnings.mli
+--- utils/warnings.mli 15 Sep 2005 03:09:26 -0000 1.16
++++ utils/warnings.mli 5 Apr 2006 02:25:59 -0000
+@@ -26,7 +26,7 @@
+ | Statement_type (* S *)
+ | Unused_match (* U *)
+ | Unused_pat
+- | Hide_instance_variable of string (* V *)
++ | Instance_variable_override of string (* V *)
+ | Illegal_backslash (* X *)
+ | Implicit_public_methods of string list
+ | Unerasable_optional_argument
+Index: parsing/parser.mly
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/parsing/parser.mly,v
+retrieving revision 1.123
+diff -u -r1.123 parser.mly
+--- parsing/parser.mly 23 Mar 2005 03:08:37 -0000 1.123
++++ parsing/parser.mly 5 Apr 2006 02:25:59 -0000
+@@ -623,6 +623,8 @@
+ { [] }
+ | class_fields INHERIT class_expr parent_binder
+ { Pcf_inher ($3, $4) :: $1 }
++ | class_fields VAL virtual_value
++ { Pcf_valvirt $3 :: $1 }
+ | class_fields VAL value
+ { Pcf_val $3 :: $1 }
+ | class_fields virtual_method
+@@ -638,14 +640,20 @@
+ AS LIDENT
+ { Some $2 }
+ | /* empty */
+- {None}
++ { None }
++;
++virtual_value:
++ MUTABLE VIRTUAL label COLON core_type
++ { $3, Mutable, $5, symbol_rloc () }
++ | VIRTUAL mutable_flag label COLON core_type
++ { $3, $2, $5, symbol_rloc () }
+ ;
+ value:
+- mutable_flag label EQUAL seq_expr
+- { $2, $1, $4, symbol_rloc () }
+- | mutable_flag label type_constraint EQUAL seq_expr
+- { $2, $1, (let (t, t') = $3 in ghexp(Pexp_constraint($5, t, t'))),
+- symbol_rloc () }
++ mutable_flag label EQUAL seq_expr
++ { $2, $1, $4, symbol_rloc () }
++ | mutable_flag label type_constraint EQUAL seq_expr
++ { $2, $1, (let (t, t') = $3 in ghexp(Pexp_constraint($5, t, t'))),
++ symbol_rloc () }
+ ;
+ virtual_method:
+ METHOD PRIVATE VIRTUAL label COLON poly_type
+@@ -711,8 +719,12 @@
+ | class_sig_fields CONSTRAINT constrain { Pctf_cstr $3 :: $1 }
+ ;
+ value_type:
+- mutable_flag label COLON core_type
+- { $2, $1, Some $4, symbol_rloc () }
++ VIRTUAL mutable_flag label COLON core_type
++ { $3, $2, Virtual, $5, symbol_rloc () }
++ | MUTABLE virtual_flag label COLON core_type
++ { $3, Mutable, $2, $5, symbol_rloc () }
++ | label COLON core_type
++ { $1, Immutable, Concrete, $3, symbol_rloc () }
+ ;
+ method_type:
+ METHOD private_flag label COLON poly_type
+Index: parsing/parsetree.mli
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/parsing/parsetree.mli,v
+retrieving revision 1.42
+diff -u -r1.42 parsetree.mli
+--- parsing/parsetree.mli 23 Mar 2005 03:08:37 -0000 1.42
++++ parsing/parsetree.mli 5 Apr 2006 02:25:59 -0000
+@@ -152,7 +152,7 @@
+
+ and class_type_field =
+ Pctf_inher of class_type
+- | Pctf_val of (string * mutable_flag * core_type option * Location.t)
++ | Pctf_val of (string * mutable_flag * virtual_flag * core_type * Location.t)
+ | Pctf_virt of (string * private_flag * core_type * Location.t)
+ | Pctf_meth of (string * private_flag * core_type * Location.t)
+ | Pctf_cstr of (core_type * core_type * Location.t)
+@@ -179,6 +179,7 @@
+
+ and class_field =
+ Pcf_inher of class_expr * string option
++ | Pcf_valvirt of (string * mutable_flag * core_type * Location.t)
+ | Pcf_val of (string * mutable_flag * expression * Location.t)
+ | Pcf_virt of (string * private_flag * core_type * Location.t)
+ | Pcf_meth of (string * private_flag * expression * Location.t)
+Index: parsing/printast.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/parsing/printast.ml,v
+retrieving revision 1.29
+diff -u -r1.29 printast.ml
+--- parsing/printast.ml 4 Jan 2006 16:55:50 -0000 1.29
++++ parsing/printast.ml 5 Apr 2006 02:25:59 -0000
+@@ -353,10 +353,11 @@
+ | Pctf_inher (ct) ->
+ line i ppf "Pctf_inher\n";
+ class_type i ppf ct;
+- | Pctf_val (s, mf, cto, loc) ->
++ | Pctf_val (s, mf, vf, ct, loc) ->
+ line i ppf
+- "Pctf_val \"%s\" %a %a\n" s fmt_mutable_flag mf fmt_location loc;
+- option i core_type ppf cto;
++ "Pctf_val \"%s\" %a %a %a\n" s
++ fmt_mutable_flag mf fmt_virtual_flag vf fmt_location loc;
++ core_type (i+1) ppf ct;
+ | Pctf_virt (s, pf, ct, loc) ->
+ line i ppf
+ "Pctf_virt \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc;
+@@ -428,6 +429,10 @@
+ line i ppf "Pcf_inher\n";
+ class_expr (i+1) ppf ce;
+ option (i+1) string ppf so;
++ | Pcf_valvirt (s, mf, ct, loc) ->
++ line i ppf
++ "Pcf_valvirt \"%s\" %a %a\n" s fmt_mutable_flag mf fmt_location loc;
++ core_type (i+1) ppf ct;
+ | Pcf_val (s, mf, e, loc) ->
+ line i ppf
+ "Pcf_val \"%s\" %a %a\n" s fmt_mutable_flag mf fmt_location loc;
+Index: typing/btype.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/btype.ml,v
+retrieving revision 1.38
+diff -u -r1.38 btype.ml
+--- typing/btype.ml 4 Jan 2006 16:55:50 -0000 1.38
++++ typing/btype.ml 5 Apr 2006 02:25:59 -0000
+@@ -330,7 +330,7 @@
+
+ let unmark_class_signature sign =
+ unmark_type sign.cty_self;
+- Vars.iter (fun l (m, t) -> unmark_type t) sign.cty_vars
++ Vars.iter (fun l (m, v, t) -> unmark_type t) sign.cty_vars
+
+ let rec unmark_class_type =
+ function
+Index: typing/ctype.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.ml,v
+retrieving revision 1.200
+diff -u -r1.200 ctype.ml
+--- typing/ctype.ml 6 Jan 2006 02:16:24 -0000 1.200
++++ typing/ctype.ml 5 Apr 2006 02:25:59 -0000
+@@ -857,7 +857,7 @@
+ Tcty_signature
+ {cty_self = copy sign.cty_self;
+ cty_vars =
+- Vars.map (function (mut, ty) -> (mut, copy ty)) sign.cty_vars;
++ Vars.map (function (m, v, ty) -> (m, v, copy ty)) sign.cty_vars;
+ cty_concr = sign.cty_concr;
+ cty_inher =
+ List.map (fun (p,tl) -> (p, List.map copy tl)) sign.cty_inher}
+@@ -2354,10 +2354,11 @@
+ | CM_Val_type_mismatch of string * (type_expr * type_expr) list
+ | CM_Meth_type_mismatch of string * (type_expr * type_expr) list
+ | CM_Non_mutable_value of string
++ | CM_Non_concrete_value of string
+ | CM_Missing_value of string
+ | CM_Missing_method of string
+ | CM_Hide_public of string
+- | CM_Hide_virtual of string
++ | CM_Hide_virtual of string * string
+ | CM_Public_method of string
+ | CM_Private_method of string
+ | CM_Virtual_method of string
+@@ -2390,8 +2391,8 @@
+ end)
+ pairs;
+ Vars.iter
+- (fun lab (mut, ty) ->
+- let (mut', ty') = Vars.find lab sign1.cty_vars in
++ (fun lab (mut, v, ty) ->
++ let (mut', v', ty') = Vars.find lab sign1.cty_vars in
+ try moregen true type_pairs env ty' ty with Unify trace ->
+ raise (Failure [CM_Val_type_mismatch
+ (lab, expand_trace env trace)]))
+@@ -2437,7 +2438,7 @@
+ end
+ in
+ if Concr.mem lab sign1.cty_concr then err
+- else CM_Hide_virtual lab::err)
++ else CM_Hide_virtual ("method", lab) :: err)
+ miss1 []
+ in
+ let missing_method = List.map (fun (m, _, _) -> m) miss2 in
+@@ -2455,11 +2456,13 @@
+ in
+ let error =
+ Vars.fold
+- (fun lab (mut, ty) err ->
++ (fun lab (mut, vr, ty) err ->
+ try
+- let (mut', ty') = Vars.find lab sign1.cty_vars in
++ let (mut', vr', ty') = Vars.find lab sign1.cty_vars in
+ if mut = Mutable && mut' <> Mutable then
+ CM_Non_mutable_value lab::err
++ else if vr = Concrete && vr' <> Concrete then
++ CM_Non_concrete_value lab::err
+ else
+ err
+ with Not_found ->
+@@ -2467,6 +2470,14 @@
+ sign2.cty_vars error
+ in
+ let error =
++ Vars.fold
++ (fun lab (_,vr,_) err ->
++ if vr = Virtual && not (Vars.mem lab sign2.cty_vars) then
++ CM_Hide_virtual ("instance variable", lab) :: err
++ else err)
++ sign1.cty_vars error
++ in
++ let error =
+ List.fold_right
+ (fun e l ->
+ if List.mem e missing_method then l else CM_Virtual_method e::l)
+@@ -2516,8 +2527,8 @@
+ end)
+ pairs;
+ Vars.iter
+- (fun lab (mut, ty) ->
+- let (mut', ty') = Vars.find lab sign1.cty_vars in
++ (fun lab (_, _, ty) ->
++ let (_, _, ty') = Vars.find lab sign1.cty_vars in
+ try eqtype true type_pairs subst env ty ty' with Unify trace ->
+ raise (Failure [CM_Val_type_mismatch
+ (lab, expand_trace env trace)]))
+@@ -2554,7 +2565,7 @@
+ end
+ in
+ if Concr.mem lab sign1.cty_concr then err
+- else CM_Hide_virtual lab::err)
++ else CM_Hide_virtual ("method", lab) :: err)
+ miss1 []
+ in
+ let missing_method = List.map (fun (m, _, _) -> m) miss2 in
+@@ -2578,11 +2589,13 @@
+ in
+ let error =
+ Vars.fold
+- (fun lab (mut, ty) err ->
++ (fun lab (mut, vr, ty) err ->
+ try
+- let (mut', ty') = Vars.find lab sign1.cty_vars in
++ let (mut', vr', ty') = Vars.find lab sign1.cty_vars in
+ if mut = Mutable && mut' <> Mutable then
+ CM_Non_mutable_value lab::err
++ else if vr = Concrete && vr' <> Concrete then
++ CM_Non_concrete_value lab::err
+ else
+ err
+ with Not_found ->
+@@ -2590,6 +2603,14 @@
+ sign2.cty_vars error
+ in
+ let error =
++ Vars.fold
++ (fun lab (_,vr,_) err ->
++ if vr = Virtual && not (Vars.mem lab sign2.cty_vars) then
++ CM_Hide_virtual ("instance variable", lab) :: err
++ else err)
++ sign1.cty_vars error
++ in
++ let error =
+ List.fold_right
+ (fun e l ->
+ if List.mem e missing_method then l else CM_Virtual_method e::l)
+@@ -3279,7 +3300,7 @@
+ let nondep_class_signature env id sign =
+ { cty_self = nondep_type_rec env id sign.cty_self;
+ cty_vars =
+- Vars.map (function (m, t) -> (m, nondep_type_rec env id t))
++ Vars.map (function (m, v, t) -> (m, v, nondep_type_rec env id t))
+ sign.cty_vars;
+ cty_concr = sign.cty_concr;
+ cty_inher =
+Index: typing/ctype.mli
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.mli,v
+retrieving revision 1.53
+diff -u -r1.53 ctype.mli
+--- typing/ctype.mli 9 Dec 2004 12:40:53 -0000 1.53
++++ typing/ctype.mli 5 Apr 2006 02:25:59 -0000
+@@ -170,10 +170,11 @@
+ | CM_Val_type_mismatch of string * (type_expr * type_expr) list
+ | CM_Meth_type_mismatch of string * (type_expr * type_expr) list
+ | CM_Non_mutable_value of string
++ | CM_Non_concrete_value of string
+ | CM_Missing_value of string
+ | CM_Missing_method of string
+ | CM_Hide_public of string
+- | CM_Hide_virtual of string
++ | CM_Hide_virtual of string * string
+ | CM_Public_method of string
+ | CM_Private_method of string
+ | CM_Virtual_method of string
+Index: typing/includeclass.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/includeclass.ml,v
+retrieving revision 1.7
+diff -u -r1.7 includeclass.ml
+--- typing/includeclass.ml 6 Mar 2000 22:11:57 -0000 1.7
++++ typing/includeclass.ml 5 Apr 2006 02:25:59 -0000
+@@ -78,14 +78,17 @@
+ | CM_Non_mutable_value lab ->
+ fprintf ppf
+ "@[The non-mutable instance variable %s cannot become mutable@]" lab
++ | CM_Non_concrete_value lab ->
++ fprintf ppf
++ "@[The virtual instance variable %s cannot become concrete@]" lab
+ | CM_Missing_value lab ->
+ fprintf ppf "@[The first class type has no instance variable %s@]" lab
+ | CM_Missing_method lab ->
+ fprintf ppf "@[The first class type has no method %s@]" lab
+ | CM_Hide_public lab ->
+ fprintf ppf "@[The public method %s cannot be hidden@]" lab
+- | CM_Hide_virtual lab ->
+- fprintf ppf "@[The virtual method %s cannot be hidden@]" lab
++ | CM_Hide_virtual (k, lab) ->
++ fprintf ppf "@[The virtual %s %s cannot be hidden@]" k lab
+ | CM_Public_method lab ->
+ fprintf ppf "@[The public method %s cannot become private" lab
+ | CM_Virtual_method lab ->
+Index: typing/oprint.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/oprint.ml,v
+retrieving revision 1.22
+diff -u -r1.22 oprint.ml
+--- typing/oprint.ml 23 Mar 2005 03:08:37 -0000 1.22
++++ typing/oprint.ml 5 Apr 2006 02:25:59 -0000
+@@ -291,8 +291,10 @@
+ fprintf ppf "@[<2>method %s%s%s :@ %a@]"
+ (if priv then "private " else "") (if virt then "virtual " else "")
+ name !out_type ty
+- | Ocsg_value (name, mut, ty) ->
+- fprintf ppf "@[<2>val %s%s :@ %a@]" (if mut then "mutable " else "")
++ | Ocsg_value (name, mut, vr, ty) ->
++ fprintf ppf "@[<2>val %s%s%s :@ %a@]"
++ (if mut then "mutable " else "")
++ (if vr then "virtual " else "")
+ name !out_type ty
+
+ let out_class_type = ref print_out_class_type
+Index: typing/outcometree.mli
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/outcometree.mli,v
+retrieving revision 1.14
+diff -u -r1.14 outcometree.mli
+--- typing/outcometree.mli 23 Mar 2005 03:08:37 -0000 1.14
++++ typing/outcometree.mli 5 Apr 2006 02:25:59 -0000
+@@ -71,7 +71,7 @@
+ and out_class_sig_item =
+ | Ocsg_constraint of out_type * out_type
+ | Ocsg_method of string * bool * bool * out_type
+- | Ocsg_value of string * bool * out_type
++ | Ocsg_value of string * bool * bool * out_type
+
+ type out_module_type =
+ | Omty_abstract
+Index: typing/printtyp.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/printtyp.ml,v
+retrieving revision 1.140
+diff -u -r1.140 printtyp.ml
+--- typing/printtyp.ml 4 Jan 2006 16:55:50 -0000 1.140
++++ typing/printtyp.ml 5 Apr 2006 02:26:00 -0000
+@@ -650,7 +650,7 @@
+ Ctype.flatten_fields (Ctype.object_fields sign.cty_self)
+ in
+ List.iter (fun met -> mark_loops (method_type met)) fields;
+- Vars.iter (fun _ (_, ty) -> mark_loops ty) sign.cty_vars
++ Vars.iter (fun _ (_, _, ty) -> mark_loops ty) sign.cty_vars
+ | Tcty_fun (_, ty, cty) ->
+ mark_loops ty;
+ prepare_class_type params cty
+@@ -682,13 +682,15 @@
+ csil (tree_of_constraints params)
+ in
+ let all_vars =
+- Vars.fold (fun l (m, t) all -> (l, m, t) :: all) sign.cty_vars [] in
++ Vars.fold (fun l (m, v, t) all -> (l, m, v, t) :: all) sign.cty_vars []
++ in
+ (* Consequence of PR#3607: order of Map.fold has changed! *)
+ let all_vars = List.rev all_vars in
+ let csil =
+ List.fold_left
+- (fun csil (l, m, t) ->
+- Ocsg_value (l, m = Mutable, tree_of_typexp sch t) :: csil)
++ (fun csil (l, m, v, t) ->
++ Ocsg_value (l, m = Mutable, v = Virtual, tree_of_typexp sch t)
++ :: csil)
+ csil all_vars
+ in
+ let csil =
+@@ -763,7 +765,9 @@
+ List.exists
+ (fun (lab, _, ty) ->
+ not (lab = dummy_method || Concr.mem lab sign.cty_concr))
+- fields in
++ fields
++ || Vars.fold (fun _ (_,vr,_) b -> vr = Virtual || b) sign.cty_vars false
++ in
+
+ Osig_class_type
+ (virt, Ident.name id,
+Index: typing/subst.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/subst.ml,v
+retrieving revision 1.49
+diff -u -r1.49 subst.ml
+--- typing/subst.ml 4 Jan 2006 16:55:50 -0000 1.49
++++ typing/subst.ml 5 Apr 2006 02:26:00 -0000
+@@ -178,7 +178,8 @@
+
+ let class_signature s sign =
+ { cty_self = typexp s sign.cty_self;
+- cty_vars = Vars.map (function (m, t) -> (m, typexp s t)) sign.cty_vars;
++ cty_vars =
++ Vars.map (function (m, v, t) -> (m, v, typexp s t)) sign.cty_vars;
+ cty_concr = sign.cty_concr;
+ cty_inher =
+ List.map (fun (p, tl) -> (type_path s p, List.map (typexp s) tl))
+Index: typing/typeclass.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/typeclass.ml,v
+retrieving revision 1.85
+diff -u -r1.85 typeclass.ml
+--- typing/typeclass.ml 22 Jul 2005 06:42:36 -0000 1.85
++++ typing/typeclass.ml 5 Apr 2006 02:26:00 -0000
+@@ -24,7 +24,7 @@
+
+ type error =
+ Unconsistent_constraint of (type_expr * type_expr) list
+- | Method_type_mismatch of string * (type_expr * type_expr) list
++ | Field_type_mismatch of string * string * (type_expr * type_expr) list
+ | Structure_expected of class_type
+ | Cannot_apply of class_type
+ | Apply_wrong_label of label
+@@ -36,7 +36,7 @@
+ | Unbound_class_type_2 of Longident.t
+ | Abbrev_type_clash of type_expr * type_expr * type_expr
+ | Constructor_type_mismatch of string * (type_expr * type_expr) list
+- | Virtual_class of bool * string list
++ | Virtual_class of bool * string list * string list
+ | Parameter_arity_mismatch of Longident.t * int * int
+ | Parameter_mismatch of (type_expr * type_expr) list
+ | Bad_parameters of Ident.t * type_expr * type_expr
+@@ -49,6 +49,7 @@
+ | Non_collapsable_conjunction of
+ Ident.t * Types.class_declaration * (type_expr * type_expr) list
+ | Final_self_clash of (type_expr * type_expr) list
++ | Mutability_mismatch of string * mutable_flag
+
+ exception Error of Location.t * error
+
+@@ -90,7 +91,7 @@
+ generalize_class_type cty
+ | Tcty_signature {cty_self = sty; cty_vars = vars; cty_inher = inher} ->
+ Ctype.generalize sty;
+- Vars.iter (fun _ (_, ty) -> Ctype.generalize ty) vars;
++ Vars.iter (fun _ (_, _, ty) -> Ctype.generalize ty) vars;
+ List.iter (fun (_,tl) -> List.iter Ctype.generalize tl) inher
+ | Tcty_fun (_, ty, cty) ->
+ Ctype.generalize ty;
+@@ -152,7 +153,7 @@
+ | Tcty_signature sign ->
+ Ctype.closed_schema sign.cty_self
+ &&
+- Vars.fold (fun _ (_, ty) cc -> Ctype.closed_schema ty && cc)
++ Vars.fold (fun _ (_, _, ty) cc -> Ctype.closed_schema ty && cc)
+ sign.cty_vars
+ true
+ | Tcty_fun (_, ty, cty) ->
+@@ -172,7 +173,7 @@
+ limited_generalize rv cty
+ | Tcty_signature sign ->
+ Ctype.limited_generalize rv sign.cty_self;
+- Vars.iter (fun _ (_, ty) -> Ctype.limited_generalize rv ty)
++ Vars.iter (fun _ (_, _, ty) -> Ctype.limited_generalize rv ty)
+ sign.cty_vars;
+ List.iter (fun (_, tl) -> List.iter (Ctype.limited_generalize rv) tl)
+ sign.cty_inher
+@@ -201,11 +202,25 @@
+ Env.add_value id {val_type = ty; val_kind = Val_unbound} par_env)
+
+ (* Enter an instance variable in the environment *)
+-let enter_val cl_num vars lab mut ty val_env met_env par_env =
+- let (id, val_env, met_env, par_env) as result =
+- enter_met_env lab (Val_ivar (mut, cl_num)) ty val_env met_env par_env
++let enter_val cl_num vars inh lab mut virt ty val_env met_env par_env loc =
++ let (id, virt) =
++ try
++ let (id, mut', virt', ty') = Vars.find lab !vars in
++ if mut' <> mut then raise (Error(loc, Mutability_mismatch(lab, mut)));
++ Ctype.unify val_env (Ctype.instance ty) (Ctype.instance ty');
++ (if not inh then Some id else None),
++ (if virt' = Concrete then virt' else virt)
++ with
++ Ctype.Unify tr ->
++ raise (Error(loc, Field_type_mismatch("instance variable", lab, tr)))
++ | Not_found -> None, virt
++ in
++ let (id, _, _, _) as result =
++ match id with Some id -> (id, val_env, met_env, par_env)
++ | None ->
++ enter_met_env lab (Val_ivar (mut, cl_num)) ty val_env met_env par_env
+ in
+- vars := Vars.add lab (id, mut, ty) !vars;
++ vars := Vars.add lab (id, mut, virt, ty) !vars;
+ result
+
+ let inheritance self_type env concr_meths warn_meths loc parent =
+@@ -218,7 +233,7 @@
+ with Ctype.Unify trace ->
+ match trace with
+ _::_::_::({desc = Tfield(n, _, _, _)}, _)::rem ->
+- raise(Error(loc, Method_type_mismatch (n, rem)))
++ raise(Error(loc, Field_type_mismatch ("method", n, rem)))
+ | _ ->
+ assert false
+ end;
+@@ -243,7 +258,7 @@
+ in
+ let ty = transl_simple_type val_env false sty in
+ try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
+- raise(Error(loc, Method_type_mismatch (lab, trace)))
++ raise(Error(loc, Field_type_mismatch ("method", lab, trace)))
+
+ let delayed_meth_specs = ref []
+
+@@ -253,7 +268,7 @@
+ in
+ let unif ty =
+ try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
+- raise(Error(loc, Method_type_mismatch (lab, trace)))
++ raise(Error(loc, Field_type_mismatch ("method", lab, trace)))
+ in
+ match sty.ptyp_desc, priv with
+ Ptyp_poly ([],sty), Public ->
+@@ -279,6 +294,15 @@
+
+ (*******************************)
+
++let add_val env loc lab (mut, virt, ty) val_sig =
++ let virt =
++ try
++ let (mut', virt', ty') = Vars.find lab val_sig in
++ if virt' = Concrete then virt' else virt
++ with Not_found -> virt
++ in
++ Vars.add lab (mut, virt, ty) val_sig
++
+ let rec class_type_field env self_type meths (val_sig, concr_meths, inher) =
+ function
+ Pctf_inher sparent ->
+@@ -293,25 +317,12 @@
+ parent
+ in
+ let val_sig =
+- Vars.fold
+- (fun lab (mut, ty) val_sig -> Vars.add lab (mut, ty) val_sig)
+- cl_sig.cty_vars val_sig
+- in
++ Vars.fold (add_val env sparent.pcty_loc) cl_sig.cty_vars val_sig in
+ (val_sig, concr_meths, inher)
+
+- | Pctf_val (lab, mut, sty_opt, loc) ->
+- let (mut, ty) =
+- match sty_opt with
+- None ->
+- let (mut', ty) =
+- try Vars.find lab val_sig with Not_found ->
+- raise(Error(loc, Unbound_val lab))
+- in
+- (if mut = Mutable then mut' else Immutable), ty
+- | Some sty ->
+- mut, transl_simple_type env false sty
+- in
+- (Vars.add lab (mut, ty) val_sig, concr_meths, inher)
++ | Pctf_val (lab, mut, virt, sty, loc) ->
++ let ty = transl_simple_type env false sty in
++ (add_val env loc lab (mut, virt, ty) val_sig, concr_meths, inher)
+
+ | Pctf_virt (lab, priv, sty, loc) ->
+ declare_method env meths self_type lab priv sty loc;
+@@ -397,7 +408,7 @@
+
+ let rec class_field cl_num self_type meths vars
+ (val_env, met_env, par_env, fields, concr_meths, warn_meths,
+- inh_vals, inher) =
++ warn_vals, inher) =
+ function
+ Pcf_inher (sparent, super) ->
+ let parent = class_expr cl_num val_env par_env sparent in
+@@ -411,18 +422,23 @@
+ parent.cl_type
+ in
+ (* Variables *)
+- let (val_env, met_env, par_env, inh_vars, inh_vals) =
++ let (val_env, met_env, par_env, inh_vars, warn_vals) =
+ Vars.fold
+- (fun lab (mut, ty) (val_env, met_env, par_env, inh_vars, inh_vals) ->
++ (fun lab info (val_env, met_env, par_env, inh_vars, warn_vals) ->
++ let mut, vr, ty = info in
+ let (id, val_env, met_env, par_env) =
+- enter_val cl_num vars lab mut ty val_env met_env par_env
++ enter_val cl_num vars true lab mut vr ty val_env met_env par_env
++ sparent.pcl_loc
+ in
+- if StringSet.mem lab inh_vals then
+- Location.prerr_warning sparent.pcl_loc
+- (Warnings.Hide_instance_variable lab);
+- (val_env, met_env, par_env, (lab, id) :: inh_vars,
+- StringSet.add lab inh_vals))
+- cl_sig.cty_vars (val_env, met_env, par_env, [], inh_vals)
++ let warn_vals =
++ if vr = Virtual then warn_vals else
++ if StringSet.mem lab warn_vals then
++ (Location.prerr_warning sparent.pcl_loc
++ (Warnings.Instance_variable_override lab); warn_vals)
++ else StringSet.add lab warn_vals
++ in
++ (val_env, met_env, par_env, (lab, id) :: inh_vars, warn_vals))
++ cl_sig.cty_vars (val_env, met_env, par_env, [], warn_vals)
+ in
+ (* Inherited concrete methods *)
+ let inh_meths =
+@@ -443,11 +459,26 @@
+ in
+ (val_env, met_env, par_env,
+ lazy(Cf_inher (parent, inh_vars, inh_meths))::fields,
+- concr_meths, warn_meths, inh_vals, inher)
++ concr_meths, warn_meths, warn_vals, inher)
++
++ | Pcf_valvirt (lab, mut, styp, loc) ->
++ if !Clflags.principal then Ctype.begin_def ();
++ let ty = Typetexp.transl_simple_type val_env false styp in
++ if !Clflags.principal then begin
++ Ctype.end_def ();
++ Ctype.generalize_structure ty
++ end;
++ let (id, val_env, met_env', par_env) =
++ enter_val cl_num vars false lab mut Virtual ty
++ val_env met_env par_env loc
++ in
++ (val_env, met_env', par_env,
++ lazy(Cf_val (lab, id, None, met_env' == met_env)) :: fields,
++ concr_meths, warn_meths, StringSet.remove lab warn_vals, inher)
+
+ | Pcf_val (lab, mut, sexp, loc) ->
+- if StringSet.mem lab inh_vals then
+- Location.prerr_warning loc (Warnings.Hide_instance_variable lab);
++ if StringSet.mem lab warn_vals then
++ Location.prerr_warning loc (Warnings.Instance_variable_override lab);
+ if !Clflags.principal then Ctype.begin_def ();
+ let exp =
+ try type_exp val_env sexp with Ctype.Unify [(ty, _)] ->
+@@ -457,17 +488,19 @@
+ Ctype.end_def ();
+ Ctype.generalize_structure exp.exp_type
+ end;
+- let (id, val_env, met_env, par_env) =
+- enter_val cl_num vars lab mut exp.exp_type val_env met_env par_env
+- in
+- (val_env, met_env, par_env, lazy(Cf_val (lab, id, exp)) :: fields,
+- concr_meths, warn_meths, inh_vals, inher)
++ let (id, val_env, met_env', par_env) =
++ enter_val cl_num vars false lab mut Concrete exp.exp_type
++ val_env met_env par_env loc
++ in
++ (val_env, met_env', par_env,
++ lazy(Cf_val (lab, id, Some exp, met_env' == met_env)) :: fields,
++ concr_meths, warn_meths, StringSet.add lab warn_vals, inher)
+
+ | Pcf_virt (lab, priv, sty, loc) ->
+ virtual_method val_env meths self_type lab priv sty loc;
+ let warn_meths = Concr.remove lab warn_meths in
+ (val_env, met_env, par_env, fields, concr_meths, warn_meths,
+- inh_vals, inher)
++ warn_vals, inher)
+
+ | Pcf_meth (lab, priv, expr, loc) ->
+ let (_, ty) =
+@@ -493,7 +526,7 @@
+ end
+ | _ -> assert false
+ with Ctype.Unify trace ->
+- raise(Error(loc, Method_type_mismatch (lab, trace)))
++ raise(Error(loc, Field_type_mismatch ("method", lab, trace)))
+ end;
+ let meth_expr = make_method cl_num expr in
+ (* backup variables for Pexp_override *)
+@@ -510,12 +543,12 @@
+ Cf_meth (lab, texp)
+ end in
+ (val_env, met_env, par_env, field::fields,
+- Concr.add lab concr_meths, Concr.add lab warn_meths, inh_vals, inher)
++ Concr.add lab concr_meths, Concr.add lab warn_meths, warn_vals, inher)
+
+ | Pcf_cstr (sty, sty', loc) ->
+ type_constraint val_env sty sty' loc;
+ (val_env, met_env, par_env, fields, concr_meths, warn_meths,
+- inh_vals, inher)
++ warn_vals, inher)
+
+ | Pcf_let (rec_flag, sdefs, loc) ->
+ let (defs, val_env) =
+@@ -545,7 +578,7 @@
+ ([], met_env, par_env)
+ in
+ (val_env, met_env, par_env, lazy(Cf_let(rec_flag, defs, vals))::fields,
+- concr_meths, warn_meths, inh_vals, inher)
++ concr_meths, warn_meths, warn_vals, inher)
+
+ | Pcf_init expr ->
+ let expr = make_method cl_num expr in
+@@ -562,7 +595,7 @@
+ Cf_init texp
+ end in
+ (val_env, met_env, par_env, field::fields,
+- concr_meths, warn_meths, inh_vals, inher)
++ concr_meths, warn_meths, warn_vals, inher)
+
+ and class_structure cl_num final val_env met_env loc (spat, str) =
+ (* Environment for substructures *)
+@@ -616,7 +649,7 @@
+ Ctype.unify val_env self_type (Ctype.newvar ());
+ let sign =
+ {cty_self = public_self;
+- cty_vars = Vars.map (function (id, mut, ty) -> (mut, ty)) !vars;
++ cty_vars = Vars.map (fun (id, mut, vr, ty) -> (mut, vr, ty)) !vars;
+ cty_concr = concr_meths;
+ cty_inher = inher} in
+ let methods = get_methods self_type in
+@@ -628,7 +661,11 @@
+ be modified after this point *)
+ Ctype.close_object self_type;
+ let mets = virtual_methods {sign with cty_self = self_type} in
+- if mets <> [] then raise(Error(loc, Virtual_class(true, mets)));
++ let vals =
++ Vars.fold
++ (fun name (mut, vr, ty) l -> if vr = Virtual then name :: l else l)
++ sign.cty_vars [] in
++ if mets <> [] then raise(Error(loc, Virtual_class(true, mets, vals)));
+ let self_methods =
+ List.fold_right
+ (fun (lab,kind,ty) rem ->
+@@ -1135,9 +1172,14 @@
+ in
+
+ if cl.pci_virt = Concrete then begin
+- match virtual_methods (Ctype.signature_of_class_type typ) with
+- [] -> ()
+- | mets -> raise(Error(cl.pci_loc, Virtual_class(define_class, mets)))
++ let sign = Ctype.signature_of_class_type typ in
++ let mets = virtual_methods sign in
++ let vals =
++ Vars.fold
++ (fun name (mut, vr, ty) l -> if vr = Virtual then name :: l else l)
++ sign.cty_vars [] in
++ if mets <> [] || vals <> [] then
++ raise(Error(cl.pci_loc, Virtual_class(true, mets, vals)));
+ end;
+
+ (* Misc. *)
+@@ -1400,10 +1442,10 @@
+ Printtyp.report_unification_error ppf trace
+ (fun ppf -> fprintf ppf "Type")
+ (fun ppf -> fprintf ppf "is not compatible with type")
+- | Method_type_mismatch (m, trace) ->
++ | Field_type_mismatch (k, m, trace) ->
+ Printtyp.report_unification_error ppf trace
+ (function ppf ->
+- fprintf ppf "The method %s@ has type" m)
++ fprintf ppf "The %s %s@ has type" k m)
+ (function ppf ->
+ fprintf ppf "but is expected to have type")
+ | Structure_expected clty ->
+@@ -1451,15 +1493,20 @@
+ fprintf ppf "The expression \"new %s\" has type" c)
+ (function ppf ->
+ fprintf ppf "but is used with type")
+- | Virtual_class (cl, mets) ->
++ | Virtual_class (cl, mets, vals) ->
+ let print_mets ppf mets =
+ List.iter (function met -> fprintf ppf "@ %s" met) mets in
+ let cl_mark = if cl then "" else " type" in
++ let missings =
++ match mets, vals with
++ [], _ -> "variables"
++ | _, [] -> "methods"
++ | _ -> "methods and variables"
++ in
+ fprintf ppf
+- "@[This class%s should be virtual@ \
+- @[<2>The following methods are undefined :%a@]
+- @]"
+- cl_mark print_mets mets
++ "@[This class%s should be virtual.@ \
++ @[<2>The following %s are undefined :%a@]@]"
++ cl_mark missings print_mets (mets @ vals)
+ | Parameter_arity_mismatch(lid, expected, provided) ->
+ fprintf ppf
+ "@[The class constructor %a@ expects %i type argument(s),@ \
+@@ -1532,3 +1579,10 @@
+ fprintf ppf "This object is expected to have type")
+ (function ppf ->
+ fprintf ppf "but has actually type")
++ | Mutability_mismatch (lab, mut) ->
++ let mut1, mut2 =
++ if mut = Immutable then "mutable", "immutable"
++ else "immutable", "mutable" in
++ fprintf ppf
++ "@[The instance variable is %s,@ it cannot be redefined as %s@]"
++ mut1 mut2
+Index: typing/typeclass.mli
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/typeclass.mli,v
+retrieving revision 1.18
+diff -u -r1.18 typeclass.mli
+--- typing/typeclass.mli 1 Dec 2003 00:32:11 -0000 1.18
++++ typing/typeclass.mli 5 Apr 2006 02:26:00 -0000
+@@ -49,7 +49,7 @@
+
+ type error =
+ Unconsistent_constraint of (type_expr * type_expr) list
+- | Method_type_mismatch of string * (type_expr * type_expr) list
++ | Field_type_mismatch of string * string * (type_expr * type_expr) list
+ | Structure_expected of class_type
+ | Cannot_apply of class_type
+ | Apply_wrong_label of label
+@@ -61,7 +61,7 @@
+ | Unbound_class_type_2 of Longident.t
+ | Abbrev_type_clash of type_expr * type_expr * type_expr
+ | Constructor_type_mismatch of string * (type_expr * type_expr) list
+- | Virtual_class of bool * string list
++ | Virtual_class of bool * string list * string list
+ | Parameter_arity_mismatch of Longident.t * int * int
+ | Parameter_mismatch of (type_expr * type_expr) list
+ | Bad_parameters of Ident.t * type_expr * type_expr
+@@ -74,6 +74,7 @@
+ | Non_collapsable_conjunction of
+ Ident.t * Types.class_declaration * (type_expr * type_expr) list
+ | Final_self_clash of (type_expr * type_expr) list
++ | Mutability_mismatch of string * mutable_flag
+
+ exception Error of Location.t * error
+
+Index: typing/typecore.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/typecore.ml,v
+retrieving revision 1.178
+diff -u -r1.178 typecore.ml
+--- typing/typecore.ml 6 Jan 2006 02:25:37 -0000 1.178
++++ typing/typecore.ml 5 Apr 2006 02:26:00 -0000
+@@ -611,11 +611,11 @@
+ List.for_all
+ (function
+ Cf_meth _ -> true
+- | Cf_val (_,_,e) -> incr count; is_nonexpansive e
++ | Cf_val (_,_,e,_) -> incr count; is_nonexpansive_opt e
+ | Cf_init e -> is_nonexpansive e
+ | Cf_inher _ | Cf_let _ -> false)
+ fields &&
+- Vars.fold (fun _ (mut,_) b -> decr count; b && mut = Immutable)
++ Vars.fold (fun _ (mut,_,_) b -> decr count; b && mut = Immutable)
+ vars true &&
+ !count = 0
+ | _ -> false
+@@ -1356,7 +1356,7 @@
+ (path_self, _) ->
+ let type_override (lab, snewval) =
+ begin try
+- let (id, _, ty) = Vars.find lab !vars in
++ let (id, _, _, ty) = Vars.find lab !vars in
+ (Path.Pident id, type_expect env snewval (instance ty))
+ with
+ Not_found ->
+Index: typing/typecore.mli
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/typecore.mli,v
+retrieving revision 1.37
+diff -u -r1.37 typecore.mli
+--- typing/typecore.mli 4 Mar 2005 14:51:31 -0000 1.37
++++ typing/typecore.mli 5 Apr 2006 02:26:00 -0000
+@@ -38,7 +38,8 @@
+ string -> type_expr -> Env.t -> Env.t -> Env.t -> Parsetree.pattern ->
+ Typedtree.pattern *
+ (Ident.t * type_expr) Meths.t ref *
+- (Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref *
++ (Ident.t * Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr)
++ Vars.t ref *
+ Env.t * Env.t * Env.t
+ val type_expect:
+ ?in_function:(Location.t * type_expr) ->
+Index: typing/typedtree.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/typedtree.ml,v
+retrieving revision 1.36
+diff -u -r1.36 typedtree.ml
+--- typing/typedtree.ml 25 Nov 2003 09:20:43 -0000 1.36
++++ typing/typedtree.ml 5 Apr 2006 02:26:00 -0000
+@@ -106,7 +106,7 @@
+
+ and class_field =
+ Cf_inher of class_expr * (string * Ident.t) list * (string * Ident.t) list
+- | Cf_val of string * Ident.t * expression
++ | Cf_val of string * Ident.t * expression option * bool
+ | Cf_meth of string * expression
+ | Cf_let of rec_flag * (pattern * expression) list *
+ (Ident.t * expression) list
+@@ -140,7 +140,8 @@
+ | Tstr_recmodule of (Ident.t * module_expr) list
+ | Tstr_modtype of Ident.t * module_type
+ | Tstr_open of Path.t
+- | Tstr_class of (Ident.t * int * string list * class_expr) list
++ | Tstr_class of
++ (Ident.t * int * string list * class_expr * virtual_flag) list
+ | Tstr_cltype of (Ident.t * cltype_declaration) list
+ | Tstr_include of module_expr * Ident.t list
+
+Index: typing/typedtree.mli
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/typedtree.mli,v
+retrieving revision 1.34
+diff -u -r1.34 typedtree.mli
+--- typing/typedtree.mli 25 Nov 2003 09:20:43 -0000 1.34
++++ typing/typedtree.mli 5 Apr 2006 02:26:00 -0000
+@@ -107,7 +107,8 @@
+ and class_field =
+ Cf_inher of class_expr * (string * Ident.t) list * (string * Ident.t) list
+ (* Inherited instance variables and concrete methods *)
+- | Cf_val of string * Ident.t * expression
++ | Cf_val of string * Ident.t * expression option * bool
++ (* None = virtual, true = override *)
+ | Cf_meth of string * expression
+ | Cf_let of rec_flag * (pattern * expression) list *
+ (Ident.t * expression) list
+@@ -141,7 +142,8 @@
+ | Tstr_recmodule of (Ident.t * module_expr) list
+ | Tstr_modtype of Ident.t * module_type
+ | Tstr_open of Path.t
+- | Tstr_class of (Ident.t * int * string list * class_expr) list
++ | Tstr_class of
++ (Ident.t * int * string list * class_expr * virtual_flag) list
+ | Tstr_cltype of (Ident.t * cltype_declaration) list
+ | Tstr_include of module_expr * Ident.t list
+
+Index: typing/typemod.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/typemod.ml,v
+retrieving revision 1.73
+diff -u -r1.73 typemod.ml
+--- typing/typemod.ml 8 Aug 2005 09:41:51 -0000 1.73
++++ typing/typemod.ml 5 Apr 2006 02:26:00 -0000
+@@ -17,6 +17,7 @@
+ open Misc
+ open Longident
+ open Path
++open Asttypes
+ open Parsetree
+ open Types
+ open Typedtree
+@@ -667,8 +668,9 @@
+ let (classes, new_env) = Typeclass.class_declarations env cl in
+ let (str_rem, sig_rem, final_env) = type_struct new_env srem in
+ (Tstr_class
+- (List.map (fun (i, _,_,_,_,_,_,_, s, m, c) ->
+- (i, s, m, c)) classes) ::
++ (List.map (fun (i, d, _,_,_,_,_,_, s, m, c) ->
++ let vf = if d.cty_new = None then Virtual else Concrete in
++ (i, s, m, c, vf)) classes) ::
+ Tstr_cltype
+ (List.map (fun (_,_, i, d, _,_,_,_,_,_,_) -> (i, d)) classes) ::
+ Tstr_type
+Index: typing/types.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/types.ml,v
+retrieving revision 1.25
+diff -u -r1.25 types.ml
+--- typing/types.ml 9 Dec 2004 12:40:53 -0000 1.25
++++ typing/types.ml 5 Apr 2006 02:26:00 -0000
+@@ -90,7 +90,8 @@
+ | Val_prim of Primitive.description (* Primitive *)
+ | Val_ivar of mutable_flag * string (* Instance variable (mutable ?) *)
+ | Val_self of (Ident.t * type_expr) Meths.t ref *
+- (Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref *
++ (Ident.t * Asttypes.mutable_flag *
++ Asttypes.virtual_flag * type_expr) Vars.t ref *
+ string * type_expr
+ (* Self *)
+ | Val_anc of (string * Ident.t) list * string
+@@ -156,7 +157,8 @@
+
+ and class_signature =
+ { cty_self: type_expr;
+- cty_vars: (Asttypes.mutable_flag * type_expr) Vars.t;
++ cty_vars:
++ (Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t;
+ cty_concr: Concr.t;
+ cty_inher: (Path.t * type_expr list) list }
+
+Index: typing/types.mli
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/types.mli,v
+retrieving revision 1.25
+diff -u -r1.25 types.mli
+--- typing/types.mli 9 Dec 2004 12:40:53 -0000 1.25
++++ typing/types.mli 5 Apr 2006 02:26:00 -0000
+@@ -91,7 +91,8 @@
+ | Val_prim of Primitive.description (* Primitive *)
+ | Val_ivar of mutable_flag * string (* Instance variable (mutable ?) *)
+ | Val_self of (Ident.t * type_expr) Meths.t ref *
+- (Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref *
++ (Ident.t * Asttypes.mutable_flag *
++ Asttypes.virtual_flag * type_expr) Vars.t ref *
+ string * type_expr
+ (* Self *)
+ | Val_anc of (string * Ident.t) list * string
+@@ -158,7 +159,8 @@
+
+ and class_signature =
+ { cty_self: type_expr;
+- cty_vars: (Asttypes.mutable_flag * type_expr) Vars.t;
++ cty_vars:
++ (Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t;
+ cty_concr: Concr.t;
+ cty_inher: (Path.t * type_expr list) list }
+
+Index: typing/unused_var.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/unused_var.ml,v
+retrieving revision 1.5
+diff -u -r1.5 unused_var.ml
+--- typing/unused_var.ml 4 Jan 2006 16:55:50 -0000 1.5
++++ typing/unused_var.ml 5 Apr 2006 02:26:00 -0000
+@@ -245,7 +245,7 @@
+ match cf with
+ | Pcf_inher (ce, _) -> class_expr ppf tbl ce;
+ | Pcf_val (_, _, e, _) -> expression ppf tbl e;
+- | Pcf_virt _ -> ()
++ | Pcf_virt _ | Pcf_valvirt _ -> ()
+ | Pcf_meth (_, _, e, _) -> expression ppf tbl e;
+ | Pcf_cstr _ -> ()
+ | Pcf_let (recflag, pel, _) -> let_pel ppf tbl recflag pel None;
+Index: bytecomp/translclass.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translclass.ml,v
+retrieving revision 1.38
+diff -u -r1.38 translclass.ml
+--- bytecomp/translclass.ml 13 Aug 2005 20:59:37 -0000 1.38
++++ bytecomp/translclass.ml 5 Apr 2006 02:26:00 -0000
+@@ -133,10 +133,10 @@
+ (fun _ -> lambda_unit) cl
+ in
+ (inh_init, lsequence obj_init' obj_init, true)
+- | Cf_val (_, id, exp) ->
++ | Cf_val (_, id, Some exp, _) ->
+ (inh_init, lsequence (set_inst_var obj id exp) obj_init,
+ has_init)
+- | Cf_meth _ ->
++ | Cf_meth _ | Cf_val _ ->
+ (inh_init, obj_init, has_init)
+ | Cf_init _ ->
+ (inh_init, obj_init, true)
+@@ -213,27 +213,17 @@
+ if len < 2 && nvals = 0 then Meths.fold (bind_method tbl) meths cl_init else
+ if len = 0 && nvals < 2 then transl_vals tbl true vals cl_init else
+ let ids = Ident.create "ids" in
+- let i = ref len in
+- let getter, names, cl_init =
+- match vals with [] -> "get_method_labels", [], cl_init
+- | (_,id0)::vals' ->
+- incr i;
+- let i = ref (List.length vals) in
+- "new_methods_variables",
+- [transl_meth_list (List.map fst vals)],
+- Llet(Strict, id0, lfield ids 0,
+- List.fold_right
+- (fun (name,id) rem ->
+- decr i;
+- Llet(Alias, id, Lprim(Poffsetint !i, [Lvar id0]), rem))
+- vals' cl_init)
++ let i = ref (len + nvals) in
++ let getter, names =
++ if nvals = 0 then "get_method_labels", [] else
++ "new_methods_variables", [transl_meth_list (List.map fst vals)]
+ in
+ Llet(StrictOpt, ids,
+ Lapply (oo_prim getter,
+ [Lvar tbl; transl_meth_list (List.map fst methl)] @ names),
+ List.fold_right
+ (fun (lab,id) lam -> decr i; Llet(StrictOpt, id, lfield ids !i, lam))
+- methl cl_init)
++ (methl @ vals) cl_init)
+
+ let output_methods tbl methods lam =
+ match methods with
+@@ -283,8 +273,9 @@
+ (vals, meths_super cla str.cl_meths meths)
+ inh_init cl_init msubst top cl in
+ (inh_init, cl_init, [], values)
+- | Cf_val (name, id, exp) ->
+- (inh_init, cl_init, methods, (name, id)::values)
++ | Cf_val (name, id, exp, over) ->
++ let values = if over then values else (name, id) :: values in
++ (inh_init, cl_init, methods, values)
+ | Cf_meth (name, exp) ->
+ let met_code = msubst true (transl_exp exp) in
+ let met_code =
+@@ -342,27 +333,24 @@
+ assert (Path.same path path');
+ let lpath = transl_path path in
+ let inh = Ident.create "inh"
+- and inh_vals = Ident.create "vals"
+- and inh_meths = Ident.create "meths"
++ and ofs = List.length vals + 1
+ and valids, methids = super in
+ let cl_init =
+ List.fold_left
+ (fun init (nm, id, _) ->
+- Llet(StrictOpt, id, lfield inh_meths (index nm concr_meths),
++ Llet(StrictOpt, id, lfield inh (index nm concr_meths + ofs),
+ init))
+ cl_init methids in
+ let cl_init =
+ List.fold_left
+ (fun init (nm, id) ->
+- Llet(StrictOpt, id, lfield inh_vals (index nm vals), init))
++ Llet(StrictOpt, id, lfield inh (index nm vals + 1), init))
+ cl_init valids in
+ (inh_init,
+ Llet (Strict, inh,
+ Lapply(oo_prim "inherits", narrow_args @
+ [lpath; Lconst(Const_pointer(if top then 1 else 0))]),
+- Llet(StrictOpt, obj_init, lfield inh 0,
+- Llet(Alias, inh_vals, lfield inh 1,
+- Llet(Alias, inh_meths, lfield inh 2, cl_init)))))
++ Llet(StrictOpt, obj_init, lfield inh 0, cl_init)))
+ | _ ->
+ let core cl_init =
+ build_class_init cla true super inh_init cl_init msubst top cl
+@@ -397,12 +385,16 @@
+ XXX Il devrait etre peu couteux d'ecrire des classes :
+ class c x y = d e f
+ *)
+-let rec transl_class_rebind obj_init cl =
++let rec transl_class_rebind obj_init cl vf =
+ match cl.cl_desc with
+ Tclass_ident path ->
++ if vf = Concrete then begin
++ try if (Env.find_class path cl.cl_env).cty_new = None then raise Exit
++ with Not_found -> raise Exit
++ end;
+ (path, obj_init)
+ | Tclass_fun (pat, _, cl, partial) ->
+- let path, obj_init = transl_class_rebind obj_init cl in
++ let path, obj_init = transl_class_rebind obj_init cl vf in
+ let build params rem =
+ let param = name_pattern "param" [pat, ()] in
+ Lfunction (Curried, param::params,
+@@ -414,14 +406,14 @@
+ Lfunction (Curried, params, rem) -> build params rem
+ | rem -> build [] rem)
+ | Tclass_apply (cl, oexprs) ->
+- let path, obj_init = transl_class_rebind obj_init cl in
++ let path, obj_init = transl_class_rebind obj_init cl vf in
+ (path, transl_apply obj_init oexprs)
+ | Tclass_let (rec_flag, defs, vals, cl) ->
+- let path, obj_init = transl_class_rebind obj_init cl in
++ let path, obj_init = transl_class_rebind obj_init cl vf in
+ (path, Translcore.transl_let rec_flag defs obj_init)
+ | Tclass_structure _ -> raise Exit
+ | Tclass_constraint (cl', _, _, _) ->
+- let path, obj_init = transl_class_rebind obj_init cl' in
++ let path, obj_init = transl_class_rebind obj_init cl' vf in
+ let rec check_constraint = function
+ Tcty_constr(path', _, _) when Path.same path path' -> ()
+ | Tcty_fun (_, _, cty) -> check_constraint cty
+@@ -430,21 +422,21 @@
+ check_constraint cl.cl_type;
+ (path, obj_init)
+
+-let rec transl_class_rebind_0 self obj_init cl =
++let rec transl_class_rebind_0 self obj_init cl vf =
+ match cl.cl_desc with
+ Tclass_let (rec_flag, defs, vals, cl) ->
+- let path, obj_init = transl_class_rebind_0 self obj_init cl in
++ let path, obj_init = transl_class_rebind_0 self obj_init cl vf in
+ (path, Translcore.transl_let rec_flag defs obj_init)
+ | _ ->
+- let path, obj_init = transl_class_rebind obj_init cl in
++ let path, obj_init = transl_class_rebind obj_init cl vf in
+ (path, lfunction [self] obj_init)
+
+-let transl_class_rebind ids cl =
++let transl_class_rebind ids cl vf =
+ try
+ let obj_init = Ident.create "obj_init"
+ and self = Ident.create "self" in
+ let obj_init0 = lapply (Lvar obj_init) [Lvar self] in
+- let path, obj_init' = transl_class_rebind_0 self obj_init0 cl in
++ let path, obj_init' = transl_class_rebind_0 self obj_init0 cl vf in
+ if not (Translcore.check_recursive_lambda ids obj_init') then
+ raise(Error(cl.cl_loc, Illegal_class_expr));
+ let id = (obj_init' = lfunction [self] obj_init0) in
+@@ -592,9 +584,9 @@
+ *)
+
+
+-let transl_class ids cl_id arity pub_meths cl =
++let transl_class ids cl_id arity pub_meths cl vflag =
+ (* First check if it is not only a rebind *)
+- let rebind = transl_class_rebind ids cl in
++ let rebind = transl_class_rebind ids cl vflag in
+ if rebind <> lambda_unit then rebind else
+
+ (* Prepare for heavy environment handling *)
+@@ -696,9 +688,7 @@
+ (* Simplest case: an object defined at toplevel (ids=[]) *)
+ if top && ids = [] then llets (ltable cla (ldirect obj_init)) else
+
+- let concrete =
+- ids = [] ||
+- Typeclass.virtual_methods (Ctype.signature_of_class_type cl.cl_type) = []
++ let concrete = (vflag = Concrete)
+ and lclass lam =
+ let cl_init = llets (Lfunction(Curried, [cla], cl_init)) in
+ Llet(Strict, class_init, cl_init, lam (free_variables cl_init))
+@@ -800,11 +790,11 @@
+
+ (* Wrapper for class compilation *)
+
+-let transl_class ids cl_id arity pub_meths cl =
+- oo_wrap cl.cl_env false (transl_class ids cl_id arity pub_meths) cl
++let transl_class ids cl_id arity pub_meths cl vf =
++ oo_wrap cl.cl_env false (transl_class ids cl_id arity pub_meths cl) vf
+
+ let () =
+- transl_object := (fun id meths cl -> transl_class [] id 0 meths cl)
++ transl_object := (fun id meths cl -> transl_class [] id 0 meths cl Concrete)
+
+ (* Error report *)
+
+Index: bytecomp/translclass.mli
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translclass.mli,v
+retrieving revision 1.11
+diff -u -r1.11 translclass.mli
+--- bytecomp/translclass.mli 12 Aug 2004 12:55:11 -0000 1.11
++++ bytecomp/translclass.mli 5 Apr 2006 02:26:00 -0000
+@@ -16,7 +16,8 @@
+ open Lambda
+
+ val transl_class :
+- Ident.t list -> Ident.t -> int -> string list -> class_expr -> lambda;;
++ Ident.t list -> Ident.t ->
++ int -> string list -> class_expr -> Asttypes.virtual_flag -> lambda;;
+
+ type error = Illegal_class_expr | Tags of string * string
+
+Index: bytecomp/translmod.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translmod.ml,v
+retrieving revision 1.51
+diff -u -r1.51 translmod.ml
+--- bytecomp/translmod.ml 12 Aug 2004 12:55:11 -0000 1.51
++++ bytecomp/translmod.ml 5 Apr 2006 02:26:00 -0000
+@@ -317,10 +317,10 @@
+ | Tstr_open path :: rem ->
+ transl_structure fields cc rootpath rem
+ | Tstr_class cl_list :: rem ->
+- let ids = List.map (fun (i, _, _, _) -> i) cl_list in
++ let ids = List.map (fun (i, _, _, _, _) -> i) cl_list in
+ Lletrec(List.map
+- (fun (id, arity, meths, cl) ->
+- (id, transl_class ids id arity meths cl))
++ (fun (id, arity, meths, cl, vf) ->
++ (id, transl_class ids id arity meths cl vf))
+ cl_list,
+ transl_structure (List.rev ids @ fields) cc rootpath rem)
+ | Tstr_cltype cl_list :: rem ->
+@@ -414,11 +414,11 @@
+ | Tstr_open path :: rem ->
+ transl_store subst rem
+ | Tstr_class cl_list :: rem ->
+- let ids = List.map (fun (i, _, _, _) -> i) cl_list in
++ let ids = List.map (fun (i, _, _, _, _) -> i) cl_list in
+ let lam =
+ Lletrec(List.map
+- (fun (id, arity, meths, cl) ->
+- (id, transl_class ids id arity meths cl))
++ (fun (id, arity, meths, cl, vf) ->
++ (id, transl_class ids id arity meths cl vf))
+ cl_list,
+ store_idents ids) in
+ Lsequence(subst_lambda subst lam,
+@@ -485,7 +485,7 @@
+ | Tstr_modtype(id, decl) :: rem -> defined_idents rem
+ | Tstr_open path :: rem -> defined_idents rem
+ | Tstr_class cl_list :: rem ->
+- List.map (fun (i, _, _, _) -> i) cl_list @ defined_idents rem
++ List.map (fun (i, _, _, _, _) -> i) cl_list @ defined_idents rem
+ | Tstr_cltype cl_list :: rem -> defined_idents rem
+ | Tstr_include(modl, ids) :: rem -> ids @ defined_idents rem
+
+@@ -603,14 +603,14 @@
+ | Tstr_class cl_list ->
+ (* we need to use unique names for the classes because there might
+ be a value named identically *)
+- let ids = List.map (fun (i, _, _, _) -> i) cl_list in
++ let ids = List.map (fun (i, _, _, _, _) -> i) cl_list in
+ List.iter set_toplevel_unique_name ids;
+ Lletrec(List.map
+- (fun (id, arity, meths, cl) ->
+- (id, transl_class ids id arity meths cl))
++ (fun (id, arity, meths, cl, vf) ->
++ (id, transl_class ids id arity meths cl vf))
+ cl_list,
+ make_sequence
+- (fun (id, _, _, _) -> toploop_setvalue_id id)
++ (fun (id, _, _, _, _) -> toploop_setvalue_id id)
+ cl_list)
+ | Tstr_cltype cl_list ->
+ lambda_unit
+Index: driver/main_args.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/driver/main_args.ml,v
+retrieving revision 1.48
+diff -u -r1.48 main_args.ml
+--- driver/main_args.ml 4 Jan 2006 16:55:49 -0000 1.48
++++ driver/main_args.ml 5 Apr 2006 02:26:00 -0000
+@@ -136,11 +136,11 @@
+ \032 E/e enable/disable fragile match\n\
+ \032 F/f enable/disable partially applied function\n\
+ \032 L/l enable/disable labels omitted in application\n\
+- \032 M/m enable/disable overridden method\n\
++ \032 M/m enable/disable overridden methods\n\
+ \032 P/p enable/disable partial match\n\
+ \032 S/s enable/disable non-unit statement\n\
+ \032 U/u enable/disable unused match case\n\
+- \032 V/v enable/disable hidden instance variable\n\
++ \032 V/v enable/disable overridden instance variables\n\
+ \032 Y/y enable/disable suspicious unused variables\n\
+ \032 Z/z enable/disable all other unused variables\n\
+ \032 X/x enable/disable all other warnings\n\
+Index: driver/optmain.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/driver/optmain.ml,v
+retrieving revision 1.87
+diff -u -r1.87 optmain.ml
+--- driver/optmain.ml 4 Jan 2006 16:55:49 -0000 1.87
++++ driver/optmain.ml 5 Apr 2006 02:26:00 -0000
+@@ -173,7 +173,7 @@
+ \032 P/p enable/disable partial match\n\
+ \032 S/s enable/disable non-unit statement\n\
+ \032 U/u enable/disable unused match case\n\
+- \032 V/v enable/disable hidden instance variables\n\
++ \032 V/v enable/disable overridden instance variables\n\
+ \032 Y/y enable/disable suspicious unused variables\n\
+ \032 Z/z enable/disable all other unused variables\n\
+ \032 X/x enable/disable all other warnings\n\
+Index: stdlib/camlinternalOO.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/stdlib/camlinternalOO.ml,v
+retrieving revision 1.14
+diff -u -r1.14 camlinternalOO.ml
+--- stdlib/camlinternalOO.ml 25 Oct 2005 18:34:07 -0000 1.14
++++ stdlib/camlinternalOO.ml 5 Apr 2006 02:26:00 -0000
+@@ -206,7 +206,11 @@
+ (table.methods_by_name, table.methods_by_label, table.hidden_meths,
+ table.vars, virt_meth_labs, vars)
+ :: table.previous_states;
+- table.vars <- Vars.empty;
++ table.vars <-
++ Vars.fold
++ (fun lab info tvars ->
++ if List.mem lab vars then Vars.add lab info tvars else tvars)
++ table.vars Vars.empty;
+ let by_name = ref Meths.empty in
+ let by_label = ref Labs.empty in
+ List.iter2
+@@ -255,9 +259,11 @@
+ index
+
+ let new_variable table name =
+- let index = new_slot table in
+- table.vars <- Vars.add name index table.vars;
+- index
++ try Vars.find name table.vars
++ with Not_found ->
++ let index = new_slot table in
++ table.vars <- Vars.add name index table.vars;
++ index
+
+ let to_array arr =
+ if arr = Obj.magic 0 then [||] else arr
+@@ -265,16 +271,17 @@
+ let new_methods_variables table meths vals =
+ let meths = to_array meths in
+ let nmeths = Array.length meths and nvals = Array.length vals in
+- let index = new_variable table vals.(0) in
+- let res = Array.create (nmeths + 1) index in
+- for i = 1 to nvals - 1 do ignore (new_variable table vals.(i)) done;
++ let res = Array.create (nmeths + nvals) 0 in
+ for i = 0 to nmeths - 1 do
+- res.(i+1) <- get_method_label table meths.(i)
++ res.(i) <- get_method_label table meths.(i)
++ done;
++ for i = 0 to nvals - 1 do
++ res.(i+nmeths) <- new_variable table vals.(i)
+ done;
+ res
+
+ let get_variable table name =
+- Vars.find name table.vars
++ try Vars.find name table.vars with Not_found -> assert false
+
+ let get_variables table names =
+ Array.map (get_variable table) names
+@@ -315,9 +322,12 @@
+ let init =
+ if top then super cla env else Obj.repr (super cla) in
+ widen cla;
+- (init, Array.map (get_variable cla) (to_array vals),
+- Array.map (fun nm -> get_method cla (get_method_label cla nm))
+- (to_array concr_meths))
++ Array.concat
++ [[| repr init |];
++ magic (Array.map (get_variable cla) (to_array vals) : int array);
++ Array.map
++ (fun nm -> repr (get_method cla (get_method_label cla nm) : closure))
++ (to_array concr_meths) ]
+
+ let make_class pub_meths class_init =
+ let table = create_table pub_meths in
+Index: stdlib/camlinternalOO.mli
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/stdlib/camlinternalOO.mli,v
+retrieving revision 1.9
+diff -u -r1.9 camlinternalOO.mli
+--- stdlib/camlinternalOO.mli 25 Oct 2005 18:34:07 -0000 1.9
++++ stdlib/camlinternalOO.mli 5 Apr 2006 02:26:00 -0000
+@@ -46,8 +46,7 @@
+ val init_class : table -> unit
+ val inherits :
+ table -> string array -> string array -> string array ->
+- (t * (table -> obj -> Obj.t) * t * obj) -> bool ->
+- (Obj.t * int array * closure array)
++ (t * (table -> obj -> Obj.t) * t * obj) -> bool -> Obj.t array
+ val make_class :
+ string array -> (table -> Obj.t -> t) ->
+ (t * (table -> Obj.t -> t) * (Obj.t -> t) * Obj.t)
+@@ -79,6 +78,7 @@
+
+ (** {6 Builtins to reduce code size} *)
+
++(*
+ val get_const : t -> closure
+ val get_var : int -> closure
+ val get_env : int -> int -> closure
+@@ -103,6 +103,7 @@
+ val send_var : tag -> int -> int -> closure
+ val send_env : tag -> int -> int -> int -> closure
+ val send_meth : tag -> label -> int -> closure
++*)
+
+ type impl =
+ GetConst
+Index: stdlib/sys.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/stdlib/sys.ml,v
+retrieving revision 1.142
+diff -u -r1.142 sys.ml
+--- stdlib/sys.ml 22 Mar 2006 12:39:39 -0000 1.142
++++ stdlib/sys.ml 5 Apr 2006 02:26:00 -0000
+@@ -78,4 +78,4 @@
+
+ (* OCaml version string, must be in the format described in sys.mli. *)
+
+-let ocaml_version = "3.10+dev4 (2006-03-22)";;
++let ocaml_version = "3.10+dev5 (2006-04-05)";;
+Index: tools/depend.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/tools/depend.ml,v
+retrieving revision 1.9
+diff -u -r1.9 depend.ml
+--- tools/depend.ml 23 Mar 2005 03:08:37 -0000 1.9
++++ tools/depend.ml 5 Apr 2006 02:26:00 -0000
+@@ -87,7 +87,7 @@
+
+ and add_class_type_field bv = function
+ Pctf_inher cty -> add_class_type bv cty
+- | Pctf_val(_, _, oty, _) -> add_opt add_type bv oty
++ | Pctf_val(_, _, _, ty, _) -> add_type bv ty
+ | Pctf_virt(_, _, ty, _) -> add_type bv ty
+ | Pctf_meth(_, _, ty, _) -> add_type bv ty
+ | Pctf_cstr(ty1, ty2, _) -> add_type bv ty1; add_type bv ty2
+@@ -280,6 +280,7 @@
+ and add_class_field bv = function
+ Pcf_inher(ce, _) -> add_class_expr bv ce
+ | Pcf_val(_, _, e, _) -> add_expr bv e
++ | Pcf_valvirt(_, _, ty, _)
+ | Pcf_virt(_, _, ty, _) -> add_type bv ty
+ | Pcf_meth(_, _, e, _) -> add_expr bv e
+ | Pcf_cstr(ty1, ty2, _) -> add_type bv ty1; add_type bv ty2
+Index: tools/ocamlprof.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/tools/ocamlprof.ml,v
+retrieving revision 1.38
+diff -u -r1.38 ocamlprof.ml
+--- tools/ocamlprof.ml 24 Mar 2005 17:20:54 -0000 1.38
++++ tools/ocamlprof.ml 5 Apr 2006 02:26:00 -0000
+@@ -328,7 +328,7 @@
+ rewrite_patexp_list iflag spat_sexp_list
+ | Pcf_init sexp ->
+ rewrite_exp iflag sexp
+- | Pcf_virt _ | Pcf_cstr _ -> ()
++ | Pcf_valvirt _ | Pcf_virt _ | Pcf_cstr _ -> ()
+
+ and rewrite_class_expr iflag cexpr =
+ match cexpr.pcl_desc with
+Index: otherlibs/labltk/browser/searchpos.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/otherlibs/labltk/browser/searchpos.ml,v
+retrieving revision 1.48
+diff -u -r1.48 searchpos.ml
+--- otherlibs/labltk/browser/searchpos.ml 23 Mar 2005 03:08:37 -0000 1.48
++++ otherlibs/labltk/browser/searchpos.ml 5 Apr 2006 02:26:01 -0000
+@@ -141,9 +141,8 @@
+ List.iter cfl ~f:
+ begin function
+ Pctf_inher cty -> search_pos_class_type cty ~pos ~env
+- | Pctf_val (_, _, Some ty, loc) ->
++ | Pctf_val (_, _, _, ty, loc) ->
+ if in_loc loc ~pos then search_pos_type ty ~pos ~env
+- | Pctf_val _ -> ()
+ | Pctf_virt (_, _, ty, loc) ->
+ if in_loc loc ~pos then search_pos_type ty ~pos ~env
+ | Pctf_meth (_, _, ty, loc) ->
+@@ -675,7 +674,7 @@
+ | Tstr_modtype _ -> ()
+ | Tstr_open _ -> ()
+ | Tstr_class l ->
+- List.iter l ~f:(fun (id, _, _, cl) -> search_pos_class_expr cl ~pos)
++ List.iter l ~f:(fun (id, _, _, cl, _) -> search_pos_class_expr cl ~pos)
+ | Tstr_cltype _ -> ()
+ | Tstr_include (m, _) -> search_pos_module_expr m ~pos
+ end
+@@ -685,7 +684,8 @@
+ begin function
+ Cf_inher (cl, _, _) ->
+ search_pos_class_expr cl ~pos
+- | Cf_val (_, _, exp) -> search_pos_expr exp ~pos
++ | Cf_val (_, _, Some exp, _) -> search_pos_expr exp ~pos
++ | Cf_val _ -> ()
+ | Cf_meth (_, exp) -> search_pos_expr exp ~pos
+ | Cf_let (_, pel, iel) ->
+ List.iter pel ~f:
+Index: ocamldoc/Makefile
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/ocamldoc/Makefile,v
+retrieving revision 1.61
+diff -u -r1.61 Makefile
+--- ocamldoc/Makefile 4 Jan 2006 16:55:49 -0000 1.61
++++ ocamldoc/Makefile 5 Apr 2006 02:26:01 -0000
+@@ -31,7 +31,7 @@
+ MKDIR=mkdir -p
+ CP=cp -f
+ OCAMLDOC=ocamldoc
+-OCAMLDOC_RUN=sh ./runocamldoc $(SUPPORTS_SHARED_LIBRARIES)
++OCAMLDOC_RUN=./ocamldoc.opt #sh ./runocamldoc $(SUPPORTS_SHARED_LIBRARIES)
+ OCAMLDOC_OPT=$(OCAMLDOC).opt
+ OCAMLDOC_LIBCMA=odoc_info.cma
+ OCAMLDOC_LIBCMI=odoc_info.cmi
+@@ -188,12 +188,12 @@
+ ../otherlibs/num/num.mli
+
+ all: exe lib
+- $(MAKE) manpages
+
+ exe: $(OCAMLDOC)
+ lib: $(OCAMLDOC_LIBCMA) $(OCAMLDOC_LIBCMI) $(ODOC_TEST)
+
+ opt.opt: exeopt libopt
++ $(MAKE) manpages
+ exeopt: $(OCAMLDOC_OPT)
+ libopt: $(OCAMLDOC_LIBCMXA) $(OCAMLDOC_LIBCMI)
+ debug:
+Index: ocamldoc/odoc_ast.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/ocamldoc/odoc_ast.ml,v
+retrieving revision 1.27
+diff -u -r1.27 odoc_ast.ml
+--- ocamldoc/odoc_ast.ml 4 Jan 2006 16:55:49 -0000 1.27
++++ ocamldoc/odoc_ast.ml 5 Apr 2006 02:26:01 -0000
+@@ -88,7 +88,7 @@
+ ident_type_decl_list
+ | Typedtree.Tstr_class info_list ->
+ List.iter
+- (fun ((id,_,_,_) as ci) ->
++ (fun ((id,_,_,_,_) as ci) ->
+ Hashtbl.add table (C (Name.from_ident id))
+ (Typedtree.Tstr_class [ci]))
+ info_list
+@@ -146,7 +146,7 @@
+
+ let search_class_exp table name =
+ match Hashtbl.find table (C name) with
+- | (Typedtree.Tstr_class [(_,_,_,ce)]) ->
++ | (Typedtree.Tstr_class [(_,_,_,ce,_)]) ->
+ (
+ try
+ let type_decl = search_type_declaration table name in
+@@ -184,7 +184,7 @@
+ let rec iter = function
+ | [] ->
+ raise Not_found
+- | Typedtree.Cf_val (_, ident, exp) :: q
++ | Typedtree.Cf_val (_, ident, Some exp, _) :: q
+ when Name.from_ident ident = name ->
+ exp.Typedtree.exp_type
+ | _ :: q ->
+@@ -523,7 +523,8 @@
+ p_clexp.Parsetree.pcl_loc.Location.loc_end.Lexing.pos_cnum
+ q
+
+- | (Parsetree.Pcf_val (label, mutable_flag, expression, loc)) :: q ->
++ | (Parsetree.Pcf_val (label, mutable_flag, _, loc) |
++ Parsetree.Pcf_valvirt (label, mutable_flag, _, loc)) :: q ->
+ let complete_name = Name.concat current_class_name label in
+ let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
+ let type_exp =
+Index: ocamldoc/odoc_sig.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/ocamldoc/odoc_sig.ml,v
+retrieving revision 1.37
+diff -u -r1.37 odoc_sig.ml
+--- ocamldoc/odoc_sig.ml 4 Jan 2006 16:55:50 -0000 1.37
++++ ocamldoc/odoc_sig.ml 5 Apr 2006 02:26:01 -0000
+@@ -107,7 +107,7 @@
+ | _ -> assert false
+
+ let search_attribute_type name class_sig =
+- let (_, type_expr) = Types.Vars.find name class_sig.Types.cty_vars in
++ let (_, _, type_expr) = Types.Vars.find name class_sig.Types.cty_vars in
+ type_expr
+
+ let search_method_type name class_sig =
+@@ -269,7 +269,7 @@
+ [] -> pos_limit
+ | ele2 :: _ ->
+ match ele2 with
+- Parsetree.Pctf_val (_, _, _, loc)
++ Parsetree.Pctf_val (_, _, _, _, loc)
+ | Parsetree.Pctf_virt (_, _, _, loc)
+ | Parsetree.Pctf_meth (_, _, _, loc)
+ | Parsetree.Pctf_cstr (_, _, loc) -> loc.Location.loc_start.Lexing.pos_cnum
+@@ -330,7 +330,7 @@
+ in
+ ([], ele_comments)
+
+- | Parsetree.Pctf_val (name, mutable_flag, _, loc) :: q ->
++ | Parsetree.Pctf_val (name, mutable_flag, _, _, loc) :: q ->
+ (* of (string * mutable_flag * core_type option * Location.t)*)
+ let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
+ let complete_name = Name.concat current_class_name name in
+Index: camlp4/camlp4/ast2pt.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/camlp4/camlp4/ast2pt.ml,v
+retrieving revision 1.36
+diff -u -r1.36 ast2pt.ml
+--- camlp4/camlp4/ast2pt.ml 29 Jun 2005 04:11:26 -0000 1.36
++++ camlp4/camlp4/ast2pt.ml 5 Apr 2006 02:26:01 -0000
+@@ -244,6 +244,7 @@
+ ;
+ value mkmutable m = if m then Mutable else Immutable;
+ value mkprivate m = if m then Private else Public;
++value mkvirtual m = if m then Virtual else Concrete;
+ value mktrecord (loc, n, m, t) =
+ (n, mkmutable m, ctyp (mkpolytype t), mkloc loc);
+ value mkvariant (loc, c, tl) = (c, List.map ctyp tl, mkloc loc);
+@@ -862,8 +863,8 @@
+ | CgInh loc ct -> [Pctf_inher (class_type ct) :: l]
+ | CgMth loc s pf t ->
+ [Pctf_meth (s, mkprivate pf, ctyp (mkpolytype t), mkloc loc) :: l]
+- | CgVal loc s b t ->
+- [Pctf_val (s, mkmutable b, Some (ctyp t), mkloc loc) :: l]
++ | CgVal loc s b v t ->
++ [Pctf_val (s, mkmutable b, mkvirtual v, ctyp t, mkloc loc) :: l]
+ | CgVir loc s b t ->
+ [Pctf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l] ]
+ and class_expr =
+@@ -907,7 +908,9 @@
+ [Pcf_meth (s, mkprivate b, e, mkloc loc) :: l]
+ | CrVal loc s b e -> [Pcf_val (s, mkmutable b, expr e, mkloc loc) :: l]
+ | CrVir loc s b t ->
+- [Pcf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l] ]
++ [Pcf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l]
++ | CrVvr loc s b t ->
++ [Pcf_valvirt (s, mkmutable b, ctyp t, mkloc loc) :: l] ]
+ ;
+
+ value interf ast = List.fold_right sig_item ast [];
+Index: camlp4/camlp4/mLast.mli
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/camlp4/camlp4/mLast.mli,v
+retrieving revision 1.18
+diff -u -r1.18 mLast.mli
+--- camlp4/camlp4/mLast.mli 29 Jun 2005 04:11:26 -0000 1.18
++++ camlp4/camlp4/mLast.mli 5 Apr 2006 02:26:01 -0000
+@@ -180,7 +180,7 @@
+ | CgDcl of loc and list class_sig_item
+ | CgInh of loc and class_type
+ | CgMth of loc and string and bool and ctyp
+- | CgVal of loc and string and bool and ctyp
++ | CgVal of loc and string and bool and bool and ctyp
+ | CgVir of loc and string and bool and ctyp ]
+ and class_expr =
+ [ CeApp of loc and class_expr and expr
+@@ -196,7 +196,8 @@
+ | CrIni of loc and expr
+ | CrMth of loc and string and bool and expr and option ctyp
+ | CrVal of loc and string and bool and expr
+- | CrVir of loc and string and bool and ctyp ]
++ | CrVir of loc and string and bool and ctyp
++ | CrVvr of loc and string and bool and ctyp ]
+ ;
+
+ external loc_of_ctyp : ctyp -> loc = "%field0";
+Index: camlp4/camlp4/reloc.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/camlp4/camlp4/reloc.ml,v
+retrieving revision 1.18
+diff -u -r1.18 reloc.ml
+--- camlp4/camlp4/reloc.ml 29 Jun 2005 04:11:26 -0000 1.18
++++ camlp4/camlp4/reloc.ml 5 Apr 2006 02:26:01 -0000
+@@ -350,7 +350,7 @@
+ | CgDcl loc x1 -> let nloc = floc loc in CgDcl nloc (List.map (class_sig_item floc sh) x1)
+ | CgInh loc x1 -> let nloc = floc loc in CgInh nloc (class_type floc sh x1)
+ | CgMth loc x1 x2 x3 -> let nloc = floc loc in CgMth nloc x1 x2 (ctyp floc sh x3)
+- | CgVal loc x1 x2 x3 -> let nloc = floc loc in CgVal nloc x1 x2 (ctyp floc sh x3)
++ | CgVal loc x1 x2 x3 x4 -> let nloc = floc loc in CgVal nloc x1 x2 x3 (ctyp floc sh x4)
+ | CgVir loc x1 x2 x3 -> let nloc = floc loc in CgVir nloc x1 x2 (ctyp floc sh x3) ]
+ and class_expr floc sh =
+ self where rec self =
+@@ -377,5 +377,6 @@
+ | CrMth loc x1 x2 x3 x4 ->
+ let nloc = floc loc in CrMth nloc x1 x2 (expr floc sh x3) (option_map (ctyp floc sh) x4)
+ | CrVal loc x1 x2 x3 -> let nloc = floc loc in CrVal nloc x1 x2 (expr floc sh x3)
+- | CrVir loc x1 x2 x3 -> let nloc = floc loc in CrVir nloc x1 x2 (ctyp floc sh x3) ]
++ | CrVir loc x1 x2 x3 -> let nloc = floc loc in CrVir nloc x1 x2 (ctyp floc sh x3)
++ | CrVvr loc x1 x2 x3 -> let nloc = floc loc in CrVvr nloc x1 x2 (ctyp floc sh x3) ]
+ ;
+Index: camlp4/etc/pa_o.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/camlp4/etc/pa_o.ml,v
+retrieving revision 1.66
+diff -u -r1.66 pa_o.ml
+--- camlp4/etc/pa_o.ml 29 Jun 2005 04:11:26 -0000 1.66
++++ camlp4/etc/pa_o.ml 5 Apr 2006 02:26:01 -0000
+@@ -1037,8 +1037,14 @@
+ class_str_item:
+ [ [ "inherit"; ce = class_expr; pb = OPT [ "as"; i = LIDENT -> i ] ->
+ <:class_str_item< inherit $ce$ $opt:pb$ >>
+- | "val"; mf = OPT "mutable"; lab = label; e = cvalue_binding ->
+- <:class_str_item< value $opt:o2b mf$ $lab$ = $e$ >>
++ | "val"; "mutable"; lab = label; e = cvalue_binding ->
++ <:class_str_item< value mutable $lab$ = $e$ >>
++ | "val"; lab = label; e = cvalue_binding ->
++ <:class_str_item< value $lab$ = $e$ >>
++ | "val"; "mutable"; "virtual"; lab = label; ":"; t = ctyp ->
++ <:class_str_item< value virtual mutable $lab$ : $t$ >>
++ | "val"; "virtual"; mf = OPT "mutable"; lab = label; ":"; t = ctyp ->
++ <:class_str_item< value virtual $opt:o2b mf$ $lab$ : $t$ >>
+ | "method"; "private"; "virtual"; l = label; ":"; t = poly_type ->
+ <:class_str_item< method virtual private $l$ : $t$ >>
+ | "method"; "virtual"; "private"; l = label; ":"; t = poly_type ->
+@@ -1087,8 +1093,9 @@
+ ;
+ class_sig_item:
+ [ [ "inherit"; cs = class_signature -> <:class_sig_item< inherit $cs$ >>
+- | "val"; mf = OPT "mutable"; l = label; ":"; t = ctyp ->
+- <:class_sig_item< value $opt:o2b mf$ $l$ : $t$ >>
++ | "val"; mf = OPT "mutable"; vf = OPT "virtual";
++ l = label; ":"; t = ctyp ->
++ <:class_sig_item< value $opt:o2b mf$ $opt:o2b vf$ $l$ : $t$ >>
+ | "method"; "private"; "virtual"; l = label; ":"; t = poly_type ->
+ <:class_sig_item< method virtual private $l$ : $t$ >>
+ | "method"; "virtual"; "private"; l = label; ":"; t = poly_type ->
+Index: camlp4/etc/pr_o.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/camlp4/etc/pr_o.ml,v
+retrieving revision 1.51
+diff -u -r1.51 pr_o.ml
+--- camlp4/etc/pr_o.ml 5 Jan 2006 10:44:29 -0000 1.51
++++ camlp4/etc/pr_o.ml 5 Apr 2006 02:26:01 -0000
+@@ -1768,10 +1768,11 @@
+ [: `S LR "method"; private_flag pf; `label lab;
+ `S LR ":" :];
+ `ctyp t "" k :]
+- | MLast.CgVal _ lab mf t ->
++ | MLast.CgVal _ lab mf vf t ->
+ fun curr next dg k ->
+ [: `HVbox
+- [: `S LR "val"; mutable_flag mf; `label lab; `S LR ":" :];
++ [: `S LR "val"; mutable_flag mf; virtual_flag vf;
++ `label lab; `S LR ":" :];
+ `ctyp t "" k :]
+ | MLast.CgVir _ lab pf t ->
+ fun curr next dg k ->
+Index: camlp4/meta/pa_r.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/camlp4/meta/pa_r.ml,v
+retrieving revision 1.64
+diff -u -r1.64 pa_r.ml
+--- camlp4/meta/pa_r.ml 29 Jun 2005 04:11:26 -0000 1.64
++++ camlp4/meta/pa_r.ml 5 Apr 2006 02:26:01 -0000
+@@ -658,7 +658,9 @@
+ | "inherit"; ce = class_expr; pb = OPT as_lident ->
+ <:class_str_item< inherit $ce$ $opt:pb$ >>
+ | "value"; mf = OPT "mutable"; lab = label; e = cvalue_binding ->
+- <:class_str_item< value $opt:o2b mf$ $lab$ = $e$ >>
++ <:class_str_item< value $opt:o2b mf$ $lab$ = $e$ >>
++ | "value"; "virtual"; mf = OPT "mutable"; l = label; ":"; t = ctyp ->
++ <:class_str_item< value virtual $opt:o2b mf$ $l$ : $t$ >>
+ | "method"; "virtual"; pf = OPT "private"; l = label; ":"; t = ctyp ->
+ <:class_str_item< method virtual $opt:o2b pf$ $l$ : $t$ >>
+ | "method"; pf = OPT "private"; l = label; topt = OPT polyt;
+@@ -701,8 +703,9 @@
+ [ [ "declare"; st = LIST0 [ s = class_sig_item; ";" -> s ]; "end" ->
+ <:class_sig_item< declare $list:st$ end >>
+ | "inherit"; cs = class_type -> <:class_sig_item< inherit $cs$ >>
+- | "value"; mf = OPT "mutable"; l = label; ":"; t = ctyp ->
+- <:class_sig_item< value $opt:o2b mf$ $l$ : $t$ >>
++ | "value"; mf = OPT "mutable"; vf = OPT "virtual";
++ l = label; ":"; t = ctyp ->
++ <:class_sig_item< value $opt:o2b mf$ $opt:o2b vf$ $l$ : $t$ >>
+ | "method"; "virtual"; pf = OPT "private"; l = label; ":"; t = ctyp ->
+ <:class_sig_item< method virtual $opt:o2b pf$ $l$ : $t$ >>
+ | "method"; pf = OPT "private"; l = label; ":"; t = ctyp ->
+Index: camlp4/meta/q_MLast.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/camlp4/meta/q_MLast.ml,v
+retrieving revision 1.60
+diff -u -r1.60 q_MLast.ml
+--- camlp4/meta/q_MLast.ml 29 Jun 2005 04:11:26 -0000 1.60
++++ camlp4/meta/q_MLast.ml 5 Apr 2006 02:26:01 -0000
+@@ -947,6 +947,8 @@
+ Qast.Node "CrDcl" [Qast.Loc; st]
+ | "inherit"; ce = class_expr; pb = SOPT as_lident ->
+ Qast.Node "CrInh" [Qast.Loc; ce; pb]
++ | "value"; "virtual"; mf = SOPT "mutable"; l = label; ":"; t = ctyp ->
++ Qast.Node "CrVvr" [Qast.Loc; l; o2b mf; t]
+ | "value"; mf = SOPT "mutable"; lab = label; e = cvalue_binding ->
+ Qast.Node "CrVal" [Qast.Loc; lab; o2b mf; e]
+ | "method"; "virtual"; pf = SOPT "private"; l = label; ":"; t = ctyp ->
+@@ -992,8 +994,9 @@
+ [ [ "declare"; st = SLIST0 [ s = class_sig_item; ";" -> s ]; "end" ->
+ Qast.Node "CgDcl" [Qast.Loc; st]
+ | "inherit"; cs = class_type -> Qast.Node "CgInh" [Qast.Loc; cs]
+- | "value"; mf = SOPT "mutable"; l = label; ":"; t = ctyp ->
+- Qast.Node "CgVal" [Qast.Loc; l; o2b mf; t]
++ | "value"; mf = SOPT "mutable"; vf = SOPT "virtual";
++ l = label; ":"; t = ctyp ->
++ Qast.Node "CgVal" [Qast.Loc; l; o2b mf; o2b vf; t]
+ | "method"; "virtual"; pf = SOPT "private"; l = label; ":"; t = ctyp ->
+ Qast.Node "CgVir" [Qast.Loc; l; o2b pf; t]
+ | "method"; pf = SOPT "private"; l = label; ":"; t = ctyp ->
+Index: camlp4/ocaml_src/camlp4/ast2pt.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/camlp4/ocaml_src/camlp4/ast2pt.ml,v
+retrieving revision 1.36
+diff -u -r1.36 ast2pt.ml
+--- camlp4/ocaml_src/camlp4/ast2pt.ml 29 Jun 2005 04:11:26 -0000 1.36
++++ camlp4/ocaml_src/camlp4/ast2pt.ml 5 Apr 2006 02:26:01 -0000
+@@ -227,6 +227,7 @@
+ ;;
+ let mkmutable m = if m then Mutable else Immutable;;
+ let mkprivate m = if m then Private else Public;;
++let mkvirtual m = if m then Virtual else Concrete;;
+ let mktrecord (loc, n, m, t) =
+ n, mkmutable m, ctyp (mkpolytype t), mkloc loc
+ ;;
+@@ -878,8 +879,8 @@
+ | CgInh (loc, ct) -> Pctf_inher (class_type ct) :: l
+ | CgMth (loc, s, pf, t) ->
+ Pctf_meth (s, mkprivate pf, ctyp (mkpolytype t), mkloc loc) :: l
+- | CgVal (loc, s, b, t) ->
+- Pctf_val (s, mkmutable b, Some (ctyp t), mkloc loc) :: l
++ | CgVal (loc, s, b, v, t) ->
++ Pctf_val (s, mkmutable b, mkvirtual v, ctyp t, mkloc loc) :: l
+ | CgVir (loc, s, b, t) ->
+ Pctf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l
+ and class_expr =
+@@ -923,6 +924,8 @@
+ | CrVal (loc, s, b, e) -> Pcf_val (s, mkmutable b, expr e, mkloc loc) :: l
+ | CrVir (loc, s, b, t) ->
+ Pcf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l
++ | CrVvr (loc, s, b, t) ->
++ Pcf_valvirt (s, mkmutable b, ctyp t, mkloc loc) :: l
+ ;;
+
+ let interf ast = List.fold_right sig_item ast [];;
+Index: camlp4/ocaml_src/camlp4/mLast.mli
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/camlp4/ocaml_src/camlp4/mLast.mli,v
+retrieving revision 1.20
+diff -u -r1.20 mLast.mli
+--- camlp4/ocaml_src/camlp4/mLast.mli 29 Jun 2005 04:11:26 -0000 1.20
++++ camlp4/ocaml_src/camlp4/mLast.mli 5 Apr 2006 02:26:01 -0000
+@@ -180,7 +180,7 @@
+ | CgDcl of loc * class_sig_item list
+ | CgInh of loc * class_type
+ | CgMth of loc * string * bool * ctyp
+- | CgVal of loc * string * bool * ctyp
++ | CgVal of loc * string * bool * bool * ctyp
+ | CgVir of loc * string * bool * ctyp
+ and class_expr =
+ CeApp of loc * class_expr * expr
+@@ -197,6 +197,7 @@
+ | CrMth of loc * string * bool * expr * ctyp option
+ | CrVal of loc * string * bool * expr
+ | CrVir of loc * string * bool * ctyp
++ | CrVvr of loc * string * bool * ctyp
+ ;;
+
+ external loc_of_ctyp : ctyp -> loc = "%field0";;
+Index: camlp4/ocaml_src/camlp4/reloc.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/camlp4/ocaml_src/camlp4/reloc.ml,v
+retrieving revision 1.20
+diff -u -r1.20 reloc.ml
+--- camlp4/ocaml_src/camlp4/reloc.ml 29 Jun 2005 04:11:26 -0000 1.20
++++ camlp4/ocaml_src/camlp4/reloc.ml 5 Apr 2006 02:26:01 -0000
+@@ -430,8 +430,8 @@
+ let nloc = floc loc in CgInh (nloc, class_type floc sh x1)
+ | CgMth (loc, x1, x2, x3) ->
+ let nloc = floc loc in CgMth (nloc, x1, x2, ctyp floc sh x3)
+- | CgVal (loc, x1, x2, x3) ->
+- let nloc = floc loc in CgVal (nloc, x1, x2, ctyp floc sh x3)
++ | CgVal (loc, x1, x2, x3, x4) ->
++ let nloc = floc loc in CgVal (nloc, x1, x2, x3, ctyp floc sh x4)
+ | CgVir (loc, x1, x2, x3) ->
+ let nloc = floc loc in CgVir (nloc, x1, x2, ctyp floc sh x3)
+ in
+@@ -478,6 +478,8 @@
+ let nloc = floc loc in CrVal (nloc, x1, x2, expr floc sh x3)
+ | CrVir (loc, x1, x2, x3) ->
+ let nloc = floc loc in CrVir (nloc, x1, x2, ctyp floc sh x3)
++ | CrVvr (loc, x1, x2, x3) ->
++ let nloc = floc loc in CrVvr (nloc, x1, x2, ctyp floc sh x3)
+ in
+ self
+ ;;
+Index: camlp4/ocaml_src/meta/pa_r.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/camlp4/ocaml_src/meta/pa_r.ml,v
+retrieving revision 1.59
+diff -u -r1.59 pa_r.ml
+--- camlp4/ocaml_src/meta/pa_r.ml 29 Jun 2005 04:11:26 -0000 1.59
++++ camlp4/ocaml_src/meta/pa_r.ml 5 Apr 2006 02:26:01 -0000
+@@ -2161,6 +2161,15 @@
+ (fun (t : 'ctyp) _ (l : 'label) (pf : string option) _ _
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.CrVir (_loc, l, o2b pf, t) : 'class_str_item));
++ [Gramext.Stoken ("", "value"); Gramext.Stoken ("", "virtual");
++ Gramext.Sopt (Gramext.Stoken ("", "mutable"));
++ Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
++ Gramext.Stoken ("", ":");
++ Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
++ Gramext.action
++ (fun (t : 'ctyp) _ (l : 'label) (mf : string option) _ _
++ (_loc : Lexing.position * Lexing.position) ->
++ (MLast.CrVvr (_loc, l, o2b mf, t) : 'class_str_item));
+ [Gramext.Stoken ("", "value");
+ Gramext.Sopt (Gramext.Stoken ("", "mutable"));
+ Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
+@@ -2338,13 +2347,15 @@
+ (MLast.CgVir (_loc, l, o2b pf, t) : 'class_sig_item));
+ [Gramext.Stoken ("", "value");
+ Gramext.Sopt (Gramext.Stoken ("", "mutable"));
++ Gramext.Sopt (Gramext.Stoken ("", "virtual"));
+ Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
+ Gramext.Stoken ("", ":");
+ Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
+ Gramext.action
+- (fun (t : 'ctyp) _ (l : 'label) (mf : string option) _
++ (fun (t : 'ctyp) _ (l : 'label) (vf : string option)
++ (mf : string option) _
+ (_loc : Lexing.position * Lexing.position) ->
+- (MLast.CgVal (_loc, l, o2b mf, t) : 'class_sig_item));
++ (MLast.CgVal (_loc, l, o2b mf, o2b vf, t) : 'class_sig_item));
+ [Gramext.Stoken ("", "inherit");
+ Gramext.Snterm
+ (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))],
+Index: camlp4/ocaml_src/meta/q_MLast.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/camlp4/ocaml_src/meta/q_MLast.ml,v
+retrieving revision 1.65
+diff -u -r1.65 q_MLast.ml
+--- camlp4/ocaml_src/meta/q_MLast.ml 12 Jan 2006 08:54:21 -0000 1.65
++++ camlp4/ocaml_src/meta/q_MLast.ml 5 Apr 2006 02:26:01 -0000
+@@ -3152,9 +3152,9 @@
+ Gramext.action
+ (fun (x : string)
+ (_loc : Lexing.position * Lexing.position) ->
+- (Qast.Str x : 'e__17))])],
++ (Qast.Str x : 'e__18))])],
+ Gramext.action
+- (fun (a : 'e__17 option)
++ (fun (a : 'e__18 option)
+ (_loc : Lexing.position * Lexing.position) ->
+ (Qast.Option a : 'a_opt));
+ [Gramext.Snterm
+@@ -3191,9 +3191,9 @@
+ Gramext.action
+ (fun (x : string)
+ (_loc : Lexing.position * Lexing.position) ->
+- (Qast.Str x : 'e__16))])],
++ (Qast.Str x : 'e__17))])],
+ Gramext.action
+- (fun (a : 'e__16 option)
++ (fun (a : 'e__17 option)
+ (_loc : Lexing.position * Lexing.position) ->
+ (Qast.Option a : 'a_opt));
+ [Gramext.Snterm
+@@ -3216,9 +3216,9 @@
+ Gramext.action
+ (fun (x : string)
+ (_loc : Lexing.position * Lexing.position) ->
+- (Qast.Str x : 'e__15))])],
++ (Qast.Str x : 'e__16))])],
+ Gramext.action
+- (fun (a : 'e__15 option)
++ (fun (a : 'e__16 option)
+ (_loc : Lexing.position * Lexing.position) ->
+ (Qast.Option a : 'a_opt));
+ [Gramext.Snterm
+@@ -3235,6 +3235,31 @@
+ (_loc : Lexing.position * Lexing.position) ->
+ (Qast.Node ("CrVal", [Qast.Loc; lab; o2b mf; e]) :
+ 'class_str_item));
++ [Gramext.Stoken ("", "value"); Gramext.Stoken ("", "virtual");
++ Gramext.srules
++ [[Gramext.Sopt
++ (Gramext.srules
++ [[Gramext.Stoken ("", "mutable")],
++ Gramext.action
++ (fun (x : string)
++ (_loc : Lexing.position * Lexing.position) ->
++ (Qast.Str x : 'e__15))])],
++ Gramext.action
++ (fun (a : 'e__15 option)
++ (_loc : Lexing.position * Lexing.position) ->
++ (Qast.Option a : 'a_opt));
++ [Gramext.Snterm
++ (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
++ Gramext.action
++ (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) ->
++ (a : 'a_opt))];
++ Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
++ Gramext.Stoken ("", ":");
++ Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
++ Gramext.action
++ (fun (t : 'ctyp) _ (l : 'label) (mf : 'a_opt) _ _
++ (_loc : Lexing.position * Lexing.position) ->
++ (Qast.Node ("CrVvr", [Qast.Loc; l; o2b mf; t]) : 'class_str_item));
+ [Gramext.Stoken ("", "inherit");
+ Gramext.Snterm
+ (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e));
+@@ -3366,9 +3391,9 @@
+ Gramext.action
+ (fun _ (csf : 'class_sig_item)
+ (_loc : Lexing.position * Lexing.position) ->
+- (csf : 'e__18))])],
++ (csf : 'e__19))])],
+ Gramext.action
+- (fun (a : 'e__18 list)
++ (fun (a : 'e__19 list)
+ (_loc : Lexing.position * Lexing.position) ->
+ (Qast.List a : 'a_list));
+ [Gramext.Snterm
+@@ -3446,9 +3471,9 @@
+ Gramext.action
+ (fun (x : string)
+ (_loc : Lexing.position * Lexing.position) ->
+- (Qast.Str x : 'e__22))])],
++ (Qast.Str x : 'e__24))])],
+ Gramext.action
+- (fun (a : 'e__22 option)
++ (fun (a : 'e__24 option)
+ (_loc : Lexing.position * Lexing.position) ->
+ (Qast.Option a : 'a_opt));
+ [Gramext.Snterm
+@@ -3471,9 +3496,9 @@
+ Gramext.action
+ (fun (x : string)
+ (_loc : Lexing.position * Lexing.position) ->
+- (Qast.Str x : 'e__21))])],
++ (Qast.Str x : 'e__23))])],
+ Gramext.action
+- (fun (a : 'e__21 option)
++ (fun (a : 'e__23 option)
+ (_loc : Lexing.position * Lexing.position) ->
+ (Qast.Option a : 'a_opt));
+ [Gramext.Snterm
+@@ -3496,9 +3521,26 @@
+ Gramext.action
+ (fun (x : string)
+ (_loc : Lexing.position * Lexing.position) ->
+- (Qast.Str x : 'e__20))])],
++ (Qast.Str x : 'e__21))])],
+ Gramext.action
+- (fun (a : 'e__20 option)
++ (fun (a : 'e__21 option)
++ (_loc : Lexing.position * Lexing.position) ->
++ (Qast.Option a : 'a_opt));
++ [Gramext.Snterm
++ (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
++ Gramext.action
++ (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) ->
++ (a : 'a_opt))];
++ Gramext.srules
++ [[Gramext.Sopt
++ (Gramext.srules
++ [[Gramext.Stoken ("", "virtual")],
++ Gramext.action
++ (fun (x : string)
++ (_loc : Lexing.position * Lexing.position) ->
++ (Qast.Str x : 'e__22))])],
++ Gramext.action
++ (fun (a : 'e__22 option)
+ (_loc : Lexing.position * Lexing.position) ->
+ (Qast.Option a : 'a_opt));
+ [Gramext.Snterm
+@@ -3510,9 +3552,10 @@
+ Gramext.Stoken ("", ":");
+ Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
+ Gramext.action
+- (fun (t : 'ctyp) _ (l : 'label) (mf : 'a_opt) _
++ (fun (t : 'ctyp) _ (l : 'label) (vf : 'a_opt) (mf : 'a_opt) _
+ (_loc : Lexing.position * Lexing.position) ->
+- (Qast.Node ("CgVal", [Qast.Loc; l; o2b mf; t]) : 'class_sig_item));
++ (Qast.Node ("CgVal", [Qast.Loc; l; o2b mf; o2b vf; t]) :
++ 'class_sig_item));
+ [Gramext.Stoken ("", "inherit");
+ Gramext.Snterm
+ (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))],
+@@ -3531,9 +3574,9 @@
+ Gramext.action
+ (fun _ (s : 'class_sig_item)
+ (_loc : Lexing.position * Lexing.position) ->
+- (s : 'e__19))])],
++ (s : 'e__20))])],
+ Gramext.action
+- (fun (a : 'e__19 list)
++ (fun (a : 'e__20 list)
+ (_loc : Lexing.position * Lexing.position) ->
+ (Qast.List a : 'a_list));
+ [Gramext.Snterm
+@@ -3556,9 +3599,9 @@
+ Gramext.action
+ (fun (x : string)
+ (_loc : Lexing.position * Lexing.position) ->
+- (Qast.Str x : 'e__23))])],
++ (Qast.Str x : 'e__25))])],
+ Gramext.action
+- (fun (a : 'e__23 option)
++ (fun (a : 'e__25 option)
+ (_loc : Lexing.position * Lexing.position) ->
+ (Qast.Option a : 'a_opt));
+ [Gramext.Snterm
+@@ -3593,9 +3636,9 @@
+ Gramext.action
+ (fun (x : string)
+ (_loc : Lexing.position * Lexing.position) ->
+- (Qast.Str x : 'e__24))])],
++ (Qast.Str x : 'e__26))])],
+ Gramext.action
+- (fun (a : 'e__24 option)
++ (fun (a : 'e__26 option)
+ (_loc : Lexing.position * Lexing.position) ->
+ (Qast.Option a : 'a_opt));
+ [Gramext.Snterm
+@@ -3713,9 +3756,9 @@
+ Gramext.action
+ (fun (x : string)
+ (_loc : Lexing.position * Lexing.position) ->
+- (Qast.Str x : 'e__25))])],
++ (Qast.Str x : 'e__27))])],
+ Gramext.action
+- (fun (a : 'e__25 option)
++ (fun (a : 'e__27 option)
+ (_loc : Lexing.position * Lexing.position) ->
+ (Qast.Option a : 'a_opt));
+ [Gramext.Snterm
+@@ -3922,9 +3965,9 @@
+ Gramext.action
+ (fun (x : string)
+ (_loc : Lexing.position * Lexing.position) ->
+- (Qast.Str x : 'e__26))])],
++ (Qast.Str x : 'e__28))])],
+ Gramext.action
+- (fun (a : 'e__26 option)
++ (fun (a : 'e__28 option)
+ (_loc : Lexing.position * Lexing.position) ->
+ (Qast.Option a : 'a_opt));
+ [Gramext.Snterm
+@@ -4390,9 +4433,9 @@
+ Gramext.action
+ (fun _ (e : 'expr)
+ (_loc : Lexing.position * Lexing.position) ->
+- (e : 'e__29))])],
++ (e : 'e__31))])],
+ Gramext.action
+- (fun (a : 'e__29 list)
++ (fun (a : 'e__31 list)
+ (_loc : Lexing.position * Lexing.position) ->
+ (Qast.List a : 'a_list));
+ [Gramext.Snterm
+@@ -4425,9 +4468,9 @@
+ Gramext.action
+ (fun _ (e : 'expr)
+ (_loc : Lexing.position * Lexing.position) ->
+- (e : 'e__28))])],
++ (e : 'e__30))])],
+ Gramext.action
+- (fun (a : 'e__28 list)
++ (fun (a : 'e__30 list)
+ (_loc : Lexing.position * Lexing.position) ->
+ (Qast.List a : 'a_list));
+ [Gramext.Snterm
+@@ -4454,9 +4497,9 @@
+ Gramext.action
+ (fun _ (e : 'expr)
+ (_loc : Lexing.position * Lexing.position) ->
+- (e : 'e__27))])],
++ (e : 'e__29))])],
+ Gramext.action
+- (fun (a : 'e__27 list)
++ (fun (a : 'e__29 list)
+ (_loc : Lexing.position * Lexing.position) ->
+ (Qast.List a : 'a_list));
+ [Gramext.Snterm
+@@ -4547,9 +4590,9 @@
+ Gramext.action
+ (fun _ (cf : 'class_str_item)
+ (_loc : Lexing.position * Lexing.position) ->
+- (cf : 'e__30))])],
++ (cf : 'e__32))])],
+ Gramext.action
+- (fun (a : 'e__30 list)
++ (fun (a : 'e__32 list)
+ (_loc : Lexing.position * Lexing.position) ->
+ (Qast.List a : 'a_list));
+ [Gramext.Snterm
+@@ -4592,9 +4635,9 @@
+ Gramext.action
+ (fun _ (csf : 'class_sig_item)
+ (_loc : Lexing.position * Lexing.position) ->
+- (csf : 'e__32))])],
++ (csf : 'e__34))])],
+ Gramext.action
+- (fun (a : 'e__32 list)
++ (fun (a : 'e__34 list)
+ (_loc : Lexing.position * Lexing.position) ->
+ (Qast.List a : 'a_list));
+ [Gramext.Snterm
+@@ -4623,9 +4666,9 @@
+ Gramext.action
+ (fun _ (csf : 'class_sig_item)
+ (_loc : Lexing.position * Lexing.position) ->
+- (csf : 'e__31))])],
++ (csf : 'e__33))])],
+ Gramext.action
+- (fun (a : 'e__31 list)
++ (fun (a : 'e__33 list)
+ (_loc : Lexing.position * Lexing.position) ->
+ (Qast.List a : 'a_list));
+ [Gramext.Snterm
+Index: camlp4/top/rprint.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/camlp4/top/rprint.ml,v
+retrieving revision 1.18
+diff -u -r1.18 rprint.ml
+--- camlp4/top/rprint.ml 29 Jun 2005 04:11:26 -0000 1.18
++++ camlp4/top/rprint.ml 5 Apr 2006 02:26:01 -0000
+@@ -288,8 +288,9 @@
+ fprintf ppf "@[<2>method %s%s%s :@ %a;@]"
+ (if priv then "private " else "") (if virt then "virtual " else "")
+ name Toploop.print_out_type.val ty
+- | Ocsg_value name mut ty ->
+- fprintf ppf "@[<2>value %s%s :@ %a;@]" (if mut then "mutable " else "")
++ | Ocsg_value name mut virt ty ->
++ fprintf ppf "@[<2>value %s%s%s :@ %a;@]"
++ (if mut then "mutable " else "") (if virt then "virtual " else "")
+ name Toploop.print_out_type.val ty ]
+ ;
+
diff --git a/experimental/garrigue/varunion.ml b/experimental/garrigue/varunion.ml
new file mode 100644
index 000000000..30a410f22
--- /dev/null
+++ b/experimental/garrigue/varunion.ml
@@ -0,0 +1,435 @@
+(* cvs update -r varunion parsing typing bytecomp toplevel *)
+
+type t = private [> ];;
+type u = private [> ] ~ [t];;
+type v = [t | u];;
+let f x = (x : t :> v);;
+
+(* bad *)
+module Mix(X: sig type t = private [> ] end)
+ (Y: sig type t = private [> ] end) =
+ struct type t = [X.t | Y.t] end;;
+
+(* bad *)
+module Mix(X: sig type t = private [> `A of int ] end)
+ (Y: sig type t = private [> `A of bool] ~ [X.t] end) =
+ struct type t = [X.t | Y.t] end;;
+
+(* ok *)
+module Mix(X: sig type t = private [> `A of int ] end)
+ (Y: sig type t = private [> `A of int] ~ [X.t] end) =
+ struct type t = [X.t | Y.t] end;;
+
+(* bad *)
+module Mix(X: sig type t = private [> `A of int ] end)
+ (Y: sig type t = private [> `B of bool] ~ [X.t] end) =
+ struct type t = [X.t | Y.t] end;;
+
+type 'a t = private [> `L of 'a] ~ [`L];;
+
+(* ok *)
+module Mix(X: sig type t = private [> `A of int ] ~ [`B] end)
+ (Y: sig type t = private [> `B of bool] ~ [X.t] end) =
+ struct type t = [X.t | Y.t] let is_t = function #t -> true | _ -> false end;;
+
+module Mix(X: sig type t = private [> `A of int ] ~ [`B] end)
+ (Y: sig type t = private [> `B of bool] ~ [X.t] end) =
+ struct
+ type t = [X.t | Y.t]
+ let which = function #X.t -> `X | #Y.t -> `Y
+ end;;
+
+module Mix(I: sig type t = private [> ] ~ [`A;`B] end)
+ (X: sig type t = private [> I.t | `A of int ] ~ [`B] end)
+ (Y: sig type t = private [> I.t | `B of bool] ~ [X.t] end) =
+ struct
+ type t = [X.t | Y.t]
+ let which = function #X.t -> `X | #Y.t -> `Y
+ end;;
+
+(* ok *)
+module M =
+ Mix(struct type t = [`C of char] end)
+ (struct type t = [`A of int | `C of char] end)
+ (struct type t = [`B of bool | `C of char] end);;
+
+(* bad *)
+module M =
+ Mix(struct type t = [`B of bool] end)
+ (struct type t = [`A of int | `B of bool] end)
+ (struct type t = [`B of bool | `C of char] end);;
+
+(* ok *)
+module M1 = struct type t = [`A of int | `C of char] end
+module M2 = struct type t = [`B of bool | `C of char] end
+module I = struct type t = [`C of char] end
+module M = Mix(I)(M1)(M2) ;;
+
+let c = (`C 'c' : M.t) ;;
+
+module M(X : sig type t = private [> `A] end) =
+ struct let f (#X.t as x) = x end;;
+
+(* code generation *)
+type t = private [> `A ] ~ [`B];;
+match `B with #t -> 1 | `B -> 2;;
+
+module M : sig type t = private [> `A of int | `B] ~ [`C] end =
+ struct type t = [`A of int | `B | `D of bool] end;;
+let f = function (`C | #M.t) -> 1+1 ;;
+let f = function (`A _ | `B #M.t) -> 1+1 ;;
+
+(* expression *)
+module Mix(X:sig type t = private [> ] val show: t -> string end)
+ (Y:sig type t = private [> ] ~ [X.t] val show: t -> string end) =
+ struct
+ type t = [X.t | Y.t]
+ let show : t -> string = function
+ #X.t as x -> X.show x
+ | #Y.t as y -> Y.show y
+ end;;
+
+module EStr = struct
+ type t = [`Str of string]
+ let show (`Str s) = s
+end
+module EInt = struct
+ type t = [`Int of int]
+ let show (`Int i) = string_of_int i
+end
+module M = Mix(EStr)(EInt);;
+
+module type T = sig type t = private [> ] val show: t -> string end
+module Mix(X:T)(Y:T with type t = private [> ] ~ [X.t]) :
+ T with type t = [X.t | Y.t] =
+ struct
+ type t = [X.t | Y.t]
+ let show = function
+ #X.t as x -> X.show x
+ | #Y.t as y -> Y.show y
+ end;;
+module M = Mix(EStr)(EInt);;
+
+(* deep *)
+module M : sig type t = private [> `A] end = struct type t = [`A] end
+module M' : sig type t = private [> ] end = struct type t = [M.t | `A] end;;
+
+(* bad *)
+type t = private [> ]
+type u = private [> `A of int] ~ [t] ;;
+
+(* ok *)
+type t = private [> `A of int]
+type u = private [> `A of int] ~ [t] ;;
+
+module F(X: sig
+ type t = private [> ] ~ [`A;`B;`C;`D]
+ type u = private [> `A|`B|`C] ~ [t; `D]
+end) : sig type v = private [< X.t | X.u | `D] end = struct
+ open X
+ let f = function #u -> 1 | #t -> 2 | `D -> 3
+ let g = function #u|#t|`D -> 2
+ type v = [t|u|`D]
+end
+
+(* ok *)
+module M = struct type t = private [> `A] end;;
+module M' : sig type t = private [> ] ~ [`A] end = M;;
+
+(* ok *)
+module type T = sig type t = private [> ] ~ [`A] end;;
+module type T' = T with type t = private [> `A];;
+
+(* ok *)
+type t = private [> ] ~ [`A]
+let f = function `A x -> x | #t -> 0
+type t' = private [< `A of int | t];;
+
+(* should be ok *)
+module F(X:sig end) :
+ sig type t = private [> ] type u = private [> ] ~ [t] end =
+ struct type t = [ `A] type u = [`B] end
+module M = F(String)
+let f = function #M.t -> 1 | #M.u -> 2
+let f = function #M.t -> 1 | _ -> 2
+type t = [M.t | M.u]
+let f = function #t -> 1 | _ -> 2;;
+module G(X : sig type t = private [> ] type u = private [> ] ~ [t] end) =
+ struct let f = function #X.t -> 1 | _ -> 2 end;;
+module M1 = G(struct module N = F(String) type t = N.t type u = N.u end) ;;
+module M1 = G(struct type t = M.t type u = M.u end) ;;
+(* bad *)
+let f = function #F(String).t -> 1 | _ -> 2;;
+type t = [F(String).t | M.u]
+let f = function #t -> 1 | _ -> 2;;
+module N : sig type t = private [> ] end =
+ struct type t = [F(String).t | M.u] end;;
+
+(* compatibility improvement *)
+type a = [`A of int | `B]
+type b = [`A of bool | `B]
+type c = private [> ] ~ [a;b]
+let f = function #c -> 1 | `A x -> truncate x
+type d = private [> ] ~ [a]
+let g = function #d -> 1 | `A x -> truncate x;;
+
+
+(* Expression Problem: functorial form *)
+
+type num = [ `Num of int ]
+
+module type Exp = sig
+ type t = private [> num]
+ val eval : t -> t
+ val show : t -> string
+end
+
+module Num(X : Exp) = struct
+ type t = num
+ let eval (`Num _ as x) : X.t = x
+ let show (`Num n) = string_of_int n
+end
+
+type 'a add = [ `Add of 'a * 'a ]
+
+module Add(X : Exp with type t = private [> num | 'a add] as 'a) = struct
+ type t = X.t add
+ let show (`Add(e1, e2) : t) = "("^ X.show e1 ^"+"^ X.show e2 ^")"
+ let eval (`Add(e1, e2) : t) =
+ let e1 = X.eval e1 and e2 = X.eval e2 in
+ match e1, e2 with
+ `Num n1, `Num n2 -> `Num (n1+n2)
+ | `Num 0, e | e, `Num 0 -> e
+ | e12 -> `Add e12
+end
+
+type 'a mul = [`Mul of 'a * 'a]
+
+module Mul(X : Exp with type t = private [> num | 'a mul] as 'a) = struct
+ type t = X.t mul
+ let show (`Mul(e1, e2) : t) = "("^ X.show e1 ^"*"^ X.show e2 ^")"
+ let eval (`Mul(e1, e2) : t) =
+ let e1 = X.eval e1 and e2 = X.eval e2 in
+ match e1, e2 with
+ `Num n1, `Num n2 -> `Num (n1*n2)
+ | `Num 0, e | e, `Num 0 -> `Num 0
+ | `Num 1, e | e, `Num 1 -> e
+ | e12 -> `Mul e12
+end
+
+module Ext(X : sig type t = private [> ] end)(Y : sig type t end) = struct
+ module type S =
+ sig
+ type t = private [> ] ~ [ X.t ]
+ val eval : t -> Y.t
+ val show : t -> string
+ end
+end
+
+module Dummy = struct type t = [`Dummy] end
+
+module Mix(E : Exp)(E1 : Ext(Dummy)(E).S)(E2 : Ext(E1)(E).S) =
+ struct
+ type t = [E1.t | E2.t]
+ let eval = function
+ #E1.t as x -> E1.eval x
+ | #E2.t as x -> E2.eval x
+ let show = function
+ #E1.t as x -> E1.show x
+ | #E2.t as x -> E2.show x
+ end
+
+module rec EAdd : (Exp with type t = [num | EAdd.t add]) =
+ Mix(EAdd)(Num(EAdd))(Add(EAdd))
+
+(* A bit heavy: one must pass E to everybody *)
+module rec E : Exp with type t = [num | E.t add | E.t mul] =
+ Mix(E)(Mix(E)(Num(E))(Add(E)))(Mul(E))
+
+let e = E.eval (`Add(`Mul(`Num 2,`Num 3),`Num 1))
+
+(* Alternatives *)
+(* Direct approach, no need of Mix *)
+module rec E : (Exp with type t = [num | E.t add | E.t mul]) =
+ struct
+ module E1 = Num(E)
+ module E2 = Add(E)
+ module E3 = Mul(E)
+ type t = E.t
+ let show = function
+ | #num as x -> E1.show x
+ | #add as x -> E2.show x
+ | #mul as x -> E3.show x
+ let eval = function
+ | #num as x -> E1.eval x
+ | #add as x -> E2.eval x
+ | #mul as x -> E3.eval x
+ end
+
+(* Do functor applications in Mix *)
+module type T = sig type t = private [> ] end
+module type Tnum = sig type t = private [> num] end
+
+module Ext(E : Tnum) = struct
+ module type S = functor (Y : Exp with type t = E.t) ->
+ sig
+ type t = private [> num]
+ val eval : t -> Y.t
+ val show : t -> string
+ end
+end
+
+module Ext'(E : Tnum)(X : T) = struct
+ module type S = functor (Y : Exp with type t = E.t) ->
+ sig
+ type t = private [> ] ~ [ X.t ]
+ val eval : t -> Y.t
+ val show : t -> string
+ end
+end
+
+module Mix(E : Exp)(F1 : Ext(E).S)(F2 : Ext'(E)(F1(E)).S) =
+ struct
+ module E1 = F1(E)
+ module E2 = F2(E)
+ type t = [E1.t | E2.t]
+ let eval = function
+ #E1.t as x -> E1.eval x
+ | #E2.t as x -> E2.eval x
+ let show = function
+ #E1.t as x -> E1.show x
+ | #E2.t as x -> E2.show x
+ end
+
+module Join(E : Exp)(F1 : Ext(E).S)(F2 : Ext'(E)(F1(E)).S)
+ (E' : Exp with type t = E.t) =
+ Mix(E)(F1)(F2)
+
+module rec EAdd : (Exp with type t = [num | EAdd.t add]) =
+ Mix(EAdd)(Num)(Add)
+
+module rec EMul : (Exp with type t = [num | EMul.t mul]) =
+ Mix(EMul)(Num)(Mul)
+
+module rec E : (Exp with type t = [num | E.t add | E.t mul]) =
+ Mix(E)(Join(E)(Num)(Add))(Mul)
+
+(* Linear extension by the end: not so nice *)
+module LExt(X : T) = struct
+ module type S =
+ sig
+ type t
+ val eval : t -> X.t
+ val show : t -> string
+ end
+end
+module LNum(E: Exp)(X : LExt(E).S with type t = private [> ] ~ [num]) =
+ struct
+ type t = [num | X.t]
+ let show = function
+ `Num n -> string_of_int n
+ | #X.t as x -> X.show x
+ let eval = function
+ #num as x -> x
+ | #X.t as x -> X.eval x
+ end
+module LAdd(E : Exp with type t = private [> num | 'a add] as 'a)
+ (X : LExt(E).S with type t = private [> ] ~ [add]) =
+ struct
+ type t = [E.t add | X.t]
+ let show = function
+ `Add(e1,e2) -> "("^ E.show e1 ^"+"^ E.show e2 ^")"
+ | #X.t as x -> X.show x
+ let eval = function
+ `Add(e1,e2) ->
+ let e1 = E.eval e1 and e2 = E.eval e2 in
+ begin match e1, e2 with
+ `Num n1, `Num n2 -> `Num (n1+n2)
+ | `Num 0, e | e, `Num 0 -> e
+ | e12 -> `Add e12
+ end
+ | #X.t as x -> X.eval x
+ end
+module LEnd = struct
+ type t = [`Dummy]
+ let show `Dummy = ""
+ let eval `Dummy = `Dummy
+end
+module rec L : Exp with type t = [num | L.t add | `Dummy] =
+ LAdd(L)(LNum(L)(LEnd))
+
+(* Back to first form, but add map *)
+
+module Num(X : Exp) = struct
+ type t = num
+ let map f x = x
+ let eval1 (`Num _ as x) : X.t = x
+ let show (`Num n) = string_of_int n
+end
+
+module Add(X : Exp with type t = private [> num | 'a add] as 'a) = struct
+ type t = X.t add
+ let show (`Add(e1, e2) : t) = "("^ X.show e1 ^"+"^ X.show e2 ^")"
+ let map f (`Add(e1, e2) : t) = `Add(f e1, f e2)
+ let eval1 (`Add(e1, e2) as e : t) =
+ match e1, e2 with
+ `Num n1, `Num n2 -> `Num (n1+n2)
+ | `Num 0, e | e, `Num 0 -> e
+ | _ -> e
+end
+
+module Mul(X : Exp with type t = private [> num | 'a mul] as 'a) = struct
+ type t = X.t mul
+ let show (`Mul(e1, e2) : t) = "("^ X.show e1 ^"*"^ X.show e2 ^")"
+ let map f (`Mul(e1, e2) : t) = `Mul(f e1, f e2)
+ let eval1 (`Mul(e1, e2) as e : t) =
+ match e1, e2 with
+ `Num n1, `Num n2 -> `Num (n1*n2)
+ | `Num 0, e | e, `Num 0 -> `Num 0
+ | `Num 1, e | e, `Num 1 -> e
+ | _ -> e
+end
+
+module Ext(X : sig type t = private [> ] end)(Y : sig type t end) = struct
+ module type S =
+ sig
+ type t = private [> ] ~ [ X.t ]
+ val map : (Y.t -> Y.t) -> t -> t
+ val eval1 : t -> Y.t
+ val show : t -> string
+ end
+end
+
+module Mix(E : Exp)(E1 : Ext(Dummy)(E).S)(E2 : Ext(E1)(E).S) =
+ struct
+ type t = [E1.t | E2.t]
+ let map f = function
+ #E1.t as x -> (E1.map f x : E1.t :> t)
+ | #E2.t as x -> (E2.map f x : E2.t :> t)
+ let eval1 = function
+ #E1.t as x -> E1.eval1 x
+ | #E2.t as x -> E2.eval1 x
+ let show = function
+ #E1.t as x -> E1.show x
+ | #E2.t as x -> E2.show x
+ end
+
+module type ET = sig
+ type t
+ val map : (t -> t) -> t -> t
+ val eval1 : t -> t
+ val show : t -> string
+end
+
+module Fin(E : ET) = struct
+ include E
+ let rec eval e = eval1 (map eval e)
+end
+
+module rec EAdd : (Exp with type t = [num | EAdd.t add]) =
+ Fin(Mix(EAdd)(Num(EAdd))(Add(EAdd)))
+
+module rec E : Exp with type t = [num | E.t add | E.t mul] =
+ Fin(Mix(E)(Mix(E)(Num(E))(Add(E)))(Mul(E)))
+
+let e = E.eval (`Add(`Mul(`Num 2,`Num 3),`Num 1))
generated by cgit v1.2.3-70-g09d2 (git 2.46.0) at 2025-03-28 03:37:39 +0000