Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

'testlabl' renamed to 'experimental/garrigue'. 

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@11140 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Xavier Clerc 2011-07-21 07:53:50 +00:00
parent 920096846e
commit efb3949fef
15 changed files with 7220 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
experimental/garrigue/.cvsignore Normal file
View File

@ -0,0 +1 @@
*.out *.out2

93
experimental/garrigue/coerce.diffs Normal file
View File

@ -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 ();

1
experimental/garrigue/dirs_multimatch Normal file
View File

@ -0,0 +1 @@
parsing typing bytecomp driver toplevel

1
experimental/garrigue/dirs_poly Normal file
View File

@ -0,0 +1 @@
bytecomp byterun driver parsing stdlib tools toplevel typing utils otherlibs/labltk/browser/searchpos.ml

77
experimental/garrigue/fixedtypes.ml Normal file
View File

@ -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

800
experimental/garrigue/marshal_objects.diffs Normal file
View File

@ -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

1418
experimental/garrigue/multimatch.diffs Normal file
View File

File diff suppressed because it is too large Load Diff

158
experimental/garrigue/multimatch.ml Normal file
View File

@ -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);;

1458
experimental/garrigue/newlabels.ps Normal file
View File

File diff suppressed because it is too large Load Diff

354
experimental/garrigue/objvariant.diffs Normal file
View File

@ -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

42
experimental/garrigue/objvariant.ml Normal file
View File

@ -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)))

11
experimental/garrigue/printers.ml Normal file
View File

@ -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

22
experimental/garrigue/tests.ml Normal file
View File

@ -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"

2349
experimental/garrigue/valvirt.diffs Normal file
View File

File diff suppressed because it is too large Load Diff

435
experimental/garrigue/varunion.ml Normal file
View File

@ -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))