diff options
| author | Alain Frisch <alain@frisch.fr> | 2014-04-04 12:25:21 +0000 |
|---|---|---|
| committer | Alain Frisch <alain@frisch.fr> | 2014-04-04 12:25:21 +0000 |
| commit | ab7b60aa8d8d24e1a4c0f613e566e9114f0cd508 (patch) | |
| tree | d12b0cc8052b9883931315b91ada657127091fba /typing/typedecl.ml | |
| parent | 1d5122c2ef591571333f7d81f49c3b479eee4e44 (diff) | |
Support exception rebinding.
git-svn-id: http://caml.inria.fr/svn/ocaml/branches/constructors_with_record2@14530 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
Diffstat (limited to 'typing/typedecl.ml')
| -rw-r--r-- | typing/typedecl.ml | 41 |
1 files changed, 32 insertions, 9 deletions
diff --git a/typing/typedecl.ml b/typing/typedecl.ml index c264864e7..0a99a3c70 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -278,7 +278,7 @@ let transl_declaration ?exnid env sdecl id = match sdecl.ptype_attributes with | [{txt="#tag#"}, PStr [{pstr_desc=Pstr_eval({pexp_desc=Pexp_constant(Const_int tag)}, _)}]] -> begin match exnid with - | Some id -> print_endline "XXX"; Record_exception (Path.Pident id) + | Some id -> Record_exception (Path.Pident id) | None -> Record_regular tag end | _ -> @@ -1189,20 +1189,43 @@ let transl_exception env excdecl = let transl_type_decl = transl_type_decl ?exnid:None (* Translate an exception rebinding *) -let transl_exn_rebind env loc lid = +let transl_exn_rebind env loc name lid = let cdescr = try Env.lookup_constructor lid env with Not_found -> raise(Error(loc, Unbound_exception lid)) in Env.mark_constructor Env.Positive env (Longident.last lid) cdescr; - match cdescr.cstr_tag with - Cstr_exception (path, _) -> - (path, {exn_args = cdescr.cstr_args; - exn_attributes = []; - exn_inlined = cdescr.cstr_inlined; - Types.exn_loc = loc}) - | _ -> raise(Error(loc, Not_an_exception lid)) + let path = + match cdescr.cstr_tag with + | Cstr_exception (path, _) -> path + | _ -> raise(Error(loc, Not_an_exception lid)) + in + let tdecls, exn_args = + if cdescr.cstr_inlined then + match cdescr.cstr_args with + | [{desc=Tconstr(p, [], _)} as ty] -> + let tdecl = + try Env.find_type p env + with Not_found -> assert false + in + let tdecl = {tdecl with type_manifest = Some ty} in + let (id, env) = + Env.enter_type ("exn." ^ name) tdecl env + in + ([id, tdecl], env), [ Ctype.newconstr (Path.Pident id) [] ] + | _ -> assert false + else + ([], env), cdescr.cstr_args + in + let d = { + Types.exn_args; + exn_attributes = []; + exn_inlined = cdescr.cstr_inlined; + exn_loc = loc + } + in + (tdecls, path, d) (* Translate a value declaration *) let transl_value_decl env loc valdecl = |