diff options
| author | Jacques Garrigue <garrigue at math.nagoya-u.ac.jp> | 2012-06-01 04:47:14 +0000 |
|---|---|---|
| committer | Jacques Garrigue <garrigue at math.nagoya-u.ac.jp> | 2012-06-01 04:47:14 +0000 |
| commit | a430934c06bf4737d963b43da69b1d5203dc20bf (patch) | |
| tree | ddf53a58e1e575568f9359c4071454b90d04a2b6 | |
| parent | 493e57678b9e378a7c18a6e2dc8673191199e86f (diff) | |
Fix PR#5291
git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@12531 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
| -rw-r--r-- | Changes | 1 | ||||
| -rw-r--r-- | bytecomp/translclass.ml | 18 | ||||
| -rw-r--r-- | testsuite/tests/typing-objects/Tests.ml | 7 | ||||
| -rw-r--r-- | testsuite/tests/typing-objects/Tests.ml.principal.reference | 8 | ||||
| -rw-r--r-- | testsuite/tests/typing-objects/Tests.ml.reference | 8 |
5 files changed, 34 insertions, 8 deletions
@@ -98,6 +98,7 @@ Bug Fixes: - PR#5211: updated Genlex documentation to state that camlp4 is mandatory for 'parser' keyword and associated notation - PR#5238, PR#5277: Sys_error when getting error location +- PR#5291: undetected loop in class initialization - PR#5295: OS threads: problem with caml_c_thread_unregister() - PR#5301: camlp4r and exception equal to another one with parameters - PR#5305: prevent ocamlbuild from complaining about links to _build/ diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml index e4b415376..a5116f629 100644 --- a/bytecomp/translclass.ml +++ b/bytecomp/translclass.ml @@ -362,11 +362,15 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = cl_init)) end -let rec build_class_lets cl = +let rec build_class_lets cl ids = match cl.cl_desc with - Tcl_let (rec_flag, defs, vals, cl) -> - let env, wrap = build_class_lets cl in - (env, fun x -> Translcore.transl_let rec_flag defs (wrap x)) + Tcl_let (rec_flag, defs, vals, cl') -> + let env, wrap = build_class_lets cl' [] in + (env, fun x -> + let lam = Translcore.transl_let rec_flag defs (wrap x) in + (* Check recursion in toplevel let-definitions *) + if ids = [] || Translcore.check_recursive_lambda ids lam then lam + else raise(Error(cl.cl_loc, Illegal_class_expr))) | _ -> (cl.cl_env, fun x -> x) @@ -595,7 +599,7 @@ let transl_class ids cl_id pub_meths cl vflag = let tables = Ident.create (Ident.name cl_id ^ "_tables") in let (top_env, req) = oo_add_class tables in let top = not req in - let cl_env, llets = build_class_lets cl in + let cl_env, llets = build_class_lets cl ids in let new_ids = if top then [] else Env.diff top_env cl_env in let env2 = Ident.create "env" in let meth_ids = get_class_meths cl in @@ -662,8 +666,6 @@ let transl_class ids cl_id pub_meths cl vflag = let cla = Ident.create "class" in let (inh_init, obj_init) = 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 @@ -817,7 +819,7 @@ open Format let report_error ppf = function | Illegal_class_expr -> - fprintf ppf "This kind of class expression is not allowed" + fprintf ppf "This kind of recursive class expression is not allowed" | Tags (lab1, lab2) -> fprintf ppf "Method labels `%s' and `%s' are incompatible.@ %s" lab1 lab2 "Change one of them." diff --git a/testsuite/tests/typing-objects/Tests.ml b/testsuite/tests/typing-objects/Tests.ml index c7a5cb3d1..759f5d955 100644 --- a/testsuite/tests/typing-objects/Tests.ml +++ b/testsuite/tests/typing-objects/Tests.ml @@ -325,3 +325,10 @@ let o = object val x = 33 val y = 44 method m = x end in let o' : <m:int> = Marshal.from_string s 0 in let o'' : <m:int> = Marshal.from_string s 0 in (Oo.id o, Oo.id o', Oo.id o'', o#m, o'#m);; + +(* Recursion (cf. PR#5291) *) + +class a = let _ = new b in object end +and b = let _ = new a in object end;; + +class a = let _ = new a in object end;; diff --git a/testsuite/tests/typing-objects/Tests.ml.principal.reference b/testsuite/tests/typing-objects/Tests.ml.principal.reference index 34a5071d7..ff3980e26 100644 --- a/testsuite/tests/typing-objects/Tests.ml.principal.reference +++ b/testsuite/tests/typing-objects/Tests.ml.principal.reference @@ -299,4 +299,12 @@ Warning 10: this expression should have type unit. # - : int * int * int = (18, 19, 20) # - : int * int * int * int * int = (21, 22, 23, 33, 33) # - : int * int * int * int * int = (24, 25, 26, 33, 33) +# Characters 42-69: + class a = let _ = new b in object end + ^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This kind of recursive class expression is not allowed +# Characters 11-38: + class a = let _ = new a in object end;; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This kind of recursive class expression is not allowed # diff --git a/testsuite/tests/typing-objects/Tests.ml.reference b/testsuite/tests/typing-objects/Tests.ml.reference index 45130d58c..098096597 100644 --- a/testsuite/tests/typing-objects/Tests.ml.reference +++ b/testsuite/tests/typing-objects/Tests.ml.reference @@ -298,4 +298,12 @@ Warning 10: this expression should have type unit. # - : int * int * int = (18, 19, 20) # - : int * int * int * int * int = (21, 22, 23, 33, 33) # - : int * int * int * int * int = (24, 25, 26, 33, 33) +# Characters 42-69: + class a = let _ = new b in object end + ^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This kind of recursive class expression is not allowed +# Characters 11-38: + class a = let _ = new a in object end;; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This kind of recursive class expression is not allowed # |