1087 lines
36 KiB
OCaml
1087 lines
36 KiB
OCaml
(***********************************************************************)
|
|
(* *)
|
|
(* Objective Caml *)
|
|
(* *)
|
|
(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
|
|
(* *)
|
|
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
|
(* Automatique. Distributed only by permission. *)
|
|
(* *)
|
|
(***********************************************************************)
|
|
|
|
(* $Id$ *)
|
|
|
|
open Misc
|
|
open Parsetree
|
|
open Asttypes
|
|
open Types
|
|
open Typedtree
|
|
open Typecore
|
|
open Typetexp
|
|
|
|
type error =
|
|
Unconsistent_constraint of (type_expr * type_expr) list
|
|
| Method_type_mismatch of string * (type_expr * type_expr) list
|
|
| Structure_expected of class_type
|
|
| Cannot_apply of class_type
|
|
| Pattern_type_clash of type_expr
|
|
| Repeated_parameter
|
|
| Unbound_class of Longident.t
|
|
| Unbound_class_2 of Longident.t
|
|
| Unbound_class_type of Longident.t
|
|
| 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
|
|
| 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
|
|
| Class_match_failure of Ctype.class_match_failure list
|
|
| Unbound_val of string
|
|
| Unbound_type_var of (unit -> unit) * Ctype.closed_class_failure
|
|
| Make_nongen_seltype of type_expr
|
|
|
|
exception Error of Location.t * error
|
|
|
|
|
|
(**********************)
|
|
(* Useful constants *)
|
|
(**********************)
|
|
|
|
|
|
(*
|
|
Self type have a dummy private method, thus preventing it to become
|
|
closed.
|
|
*)
|
|
let dummy_method = "*dummy method*"
|
|
|
|
(*
|
|
Path associated to the temporary class type of a class being typed
|
|
(its constructor is not available).
|
|
*)
|
|
let unbound_class = Path.Pident (Ident.create "")
|
|
|
|
|
|
(************************************)
|
|
(* Some operations on class types *)
|
|
(************************************)
|
|
|
|
|
|
(* Fully expand the head of a class type *)
|
|
let rec scrape_class_type =
|
|
function
|
|
Tcty_constr (_, _, cty) -> scrape_class_type cty
|
|
| cty -> cty
|
|
|
|
(* Generalize a class type *)
|
|
let rec generalize_class_type =
|
|
function
|
|
Tcty_constr (_, params, cty) ->
|
|
List.iter Ctype.generalize params;
|
|
generalize_class_type cty
|
|
| Tcty_signature {cty_self = sty; cty_vars = vars } ->
|
|
Ctype.generalize sty;
|
|
Vars.iter (fun _ (_, ty) -> Ctype.generalize ty) vars
|
|
| Tcty_fun (ty, cty) ->
|
|
Ctype.generalize ty;
|
|
generalize_class_type cty
|
|
|
|
(* Return the virtual methods of a class type *)
|
|
let virtual_methods cty =
|
|
let sign = Ctype.signature_of_class_type cty in
|
|
let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sign.cty_self) in
|
|
List.fold_left
|
|
(fun virt (lab, _, _) ->
|
|
if lab = dummy_method then virt else
|
|
if Concr.mem lab sign.cty_concr then virt else
|
|
lab::virt)
|
|
[] fields
|
|
|
|
(* Return the constructor type associated to a class type *)
|
|
let rec constructor_type constr cty =
|
|
match cty with
|
|
Tcty_constr (_, _, cty) ->
|
|
constructor_type constr cty
|
|
| Tcty_signature sign ->
|
|
constr
|
|
| Tcty_fun (ty, cty) ->
|
|
Ctype.newty (Tarrow (ty, constructor_type constr cty))
|
|
|
|
let rec class_body cty =
|
|
match cty with
|
|
Tcty_constr (_, _, cty) ->
|
|
class_body cty
|
|
| Tcty_signature sign ->
|
|
cty
|
|
| Tcty_fun (ty, cty) ->
|
|
class_body cty
|
|
|
|
let rec extract_constraints cty =
|
|
let sign = Ctype.signature_of_class_type cty in
|
|
(Vars.fold (fun lab _ vars -> lab :: vars) sign.cty_vars [],
|
|
begin let (fields, _) =
|
|
Ctype.flatten_fields (Ctype.object_fields sign.cty_self)
|
|
in
|
|
List.fold_left
|
|
(fun meths (lab, _, _) ->
|
|
if lab = dummy_method then meths else lab::meths)
|
|
[] fields
|
|
end,
|
|
sign.cty_concr)
|
|
|
|
|
|
(***********************************)
|
|
(* Primitives for typing classes *)
|
|
(***********************************)
|
|
|
|
|
|
(* Enter a value in the method environment only *)
|
|
let enter_met_env lab kind ty val_env met_env par_env =
|
|
let (id, val_env) =
|
|
Env.enter_value lab {val_type = ty; val_kind = Val_unbound} val_env
|
|
in
|
|
(id, val_env,
|
|
Env.add_value id {val_type = ty; val_kind = kind} met_env,
|
|
Env.add_value id {val_type = ty; val_kind = Val_unbound} par_env)
|
|
|
|
(* Enter an instance variable in the environment *)
|
|
let enter_val 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) ty val_env met_env par_env
|
|
in
|
|
vars := Vars.add lab (id, mut, ty) !vars;
|
|
result
|
|
|
|
let rec make_nongen_class_type env =
|
|
function
|
|
Tcty_constr (_, _, cty) ->
|
|
make_nongen_class_type env cty
|
|
| Tcty_signature sign ->
|
|
Vars.iter (fun _ (_, ty) -> Ctype.make_nongen ty) sign.cty_vars;
|
|
Concr.iter
|
|
(function nm ->
|
|
Ctype.make_nongen
|
|
(Ctype.filter_method env nm Private sign.cty_self))
|
|
sign.cty_concr
|
|
| Tcty_fun (ty, cty) ->
|
|
Ctype.make_nongen ty;
|
|
make_nongen_class_type env cty
|
|
|
|
let inheritance impl self_type env concr_meths loc parent =
|
|
match scrape_class_type parent with
|
|
Tcty_signature cl_sig ->
|
|
|
|
(* Methods *)
|
|
begin try
|
|
Ctype.unify env self_type cl_sig.cty_self
|
|
with Ctype.Unify trace ->
|
|
match trace with
|
|
_::_::_::({desc = Tfield(n, _, _, _)}, _)::rem ->
|
|
raise(Error(loc, Method_type_mismatch (n, rem)))
|
|
| _ ->
|
|
assert false
|
|
end;
|
|
|
|
if impl then begin
|
|
let overridings = Concr.inter cl_sig.cty_concr concr_meths in
|
|
if not (Concr.is_empty overridings) then begin
|
|
Location.print_warning loc
|
|
("the following methods are overriden by the inherited class:\n "
|
|
^ (String.concat " " (Concr.elements overridings)))
|
|
end
|
|
end;
|
|
let concr_meths = Concr.union cl_sig.cty_concr concr_meths in
|
|
|
|
(cl_sig, concr_meths)
|
|
|
|
| _ ->
|
|
raise(Error(loc, Structure_expected parent))
|
|
|
|
let virtual_method val_env meths self_type lab priv sty loc =
|
|
let (_, ty') =
|
|
Ctype.filter_self_method val_env lab priv meths self_type
|
|
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)))
|
|
|
|
let type_constraint val_env sty sty' loc =
|
|
let ty = transl_simple_type val_env false sty 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, Unconsistent_constraint trace))
|
|
|
|
(*******************************)
|
|
|
|
let rec class_type_field env self_type meths (val_sig, concr_meths) =
|
|
function
|
|
Pctf_inher sparent ->
|
|
let parent = class_type env sparent in
|
|
let (cl_sig, concr_meths) =
|
|
inheritance false self_type env concr_meths sparent.pcty_loc 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
|
|
(val_sig, concr_meths)
|
|
|
|
| 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)
|
|
|
|
| Pctf_virt (lab, priv, sty, loc) ->
|
|
virtual_method env meths self_type lab priv sty loc;
|
|
(val_sig, concr_meths)
|
|
|
|
| Pctf_meth (lab, priv, sty, loc) ->
|
|
virtual_method env meths self_type lab priv sty loc;
|
|
(val_sig, Concr.add lab concr_meths)
|
|
|
|
| Pctf_cstr (sty, sty', loc) ->
|
|
type_constraint env sty sty' loc;
|
|
(val_sig, concr_meths)
|
|
|
|
and class_signature env sty sign =
|
|
let meths = ref Meths.empty in
|
|
let self_type = transl_simple_type env false sty in
|
|
|
|
(* Check that the binder is a correct type, and introduce a dummy
|
|
method preventing self type from being closed. *)
|
|
begin try
|
|
Ctype.filter_method env dummy_method Private self_type
|
|
with Ctype.Unify _ ->
|
|
raise(Error(sty.ptyp_loc, Pattern_type_clash self_type))
|
|
end;
|
|
|
|
(* Class type fields *)
|
|
let (val_sig, concr_meths) =
|
|
List.fold_left (class_type_field env self_type meths)
|
|
(Vars.empty, Concr.empty)
|
|
sign
|
|
in
|
|
|
|
{cty_self = self_type;
|
|
cty_vars = val_sig;
|
|
cty_concr = concr_meths }
|
|
|
|
and class_type env scty =
|
|
match scty.pcty_desc with
|
|
Pcty_constr (lid, styl) ->
|
|
let (path, decl) =
|
|
try Env.lookup_cltype lid env with Not_found ->
|
|
raise(Error(scty.pcty_loc, Unbound_class_type lid))
|
|
in
|
|
if Path.same decl.clty_path unbound_class then
|
|
raise(Error(scty.pcty_loc, Unbound_class_type_2 lid));
|
|
let (params, clty) =
|
|
Ctype.instance_class decl.clty_params decl.clty_type
|
|
in
|
|
let sty = Ctype.self_type clty in
|
|
(* XXX Usage incorrect de Ctype.row_variable *)
|
|
let rv = Ctype.row_variable sty in
|
|
if List.length params <> List.length styl then
|
|
raise(Error(scty.pcty_loc,
|
|
Parameter_arity_mismatch (lid, List.length params,
|
|
List.length styl)));
|
|
List.iter2
|
|
(fun sty ty ->
|
|
let ty' = transl_simple_type env false sty in
|
|
try Ctype.unify env ty' ty with Ctype.Unify trace ->
|
|
raise(Error(sty.ptyp_loc, Parameter_mismatch trace)))
|
|
styl params;
|
|
Tcty_constr (path, rv::params, clty)
|
|
|
|
| Pcty_signature (sty, sign) ->
|
|
Tcty_signature (class_signature env sty sign)
|
|
|
|
| Pcty_fun (sty, scty) ->
|
|
let ty = transl_simple_type env false sty in
|
|
let cty = class_type env scty in
|
|
Tcty_fun (ty, cty)
|
|
|
|
(*******************************)
|
|
|
|
let rec class_field self_type meths vars
|
|
(val_env, met_env, par_env, fields, concr_meths) =
|
|
function
|
|
Pcf_inher (sparent, super) ->
|
|
let parent = class_expr val_env par_env sparent in
|
|
let (cl_sig, concr_meths) =
|
|
inheritance true self_type val_env concr_meths sparent.pcl_loc
|
|
parent.cl_type
|
|
in
|
|
(* Variables *)
|
|
let (val_env, met_env, par_env, inh_vars) =
|
|
Vars.fold
|
|
(fun lab (mut, ty) (val_env, met_env, par_env, inh_vars) ->
|
|
let (id, val_env, met_env, par_env) =
|
|
enter_val vars lab mut ty val_env met_env par_env
|
|
in
|
|
(val_env, met_env, par_env, (lab, id) :: inh_vars))
|
|
cl_sig.cty_vars (val_env, met_env, par_env, [])
|
|
in
|
|
(* Inherited concrete methods *)
|
|
let inh_meths =
|
|
Concr.fold (fun lab rem -> (lab, Ident.create lab)::rem)
|
|
cl_sig.cty_concr []
|
|
in
|
|
(* Super *)
|
|
let (val_env, met_env, par_env) =
|
|
match super with
|
|
None ->
|
|
(val_env, met_env, par_env)
|
|
| Some name ->
|
|
let (id, val_env, met_env, par_env) =
|
|
enter_met_env name (Val_anc inh_meths) self_type
|
|
val_env met_env par_env
|
|
in
|
|
(val_env, met_env, par_env)
|
|
in
|
|
(val_env, met_env, par_env,
|
|
Cf_inher (parent, inh_vars, inh_meths)::fields, concr_meths)
|
|
|
|
| Pcf_val (lab, mut, sexp, loc) ->
|
|
let exp = type_exp val_env sexp in
|
|
if not (Typecore.is_nonexpansive exp) then
|
|
begin try
|
|
Ctype.make_nongen exp.exp_type
|
|
with Ctype.Unify [(ty, _)] ->
|
|
raise(Error(loc, Make_nongen_seltype ty))
|
|
end;
|
|
let (id, val_env, met_env, par_env) =
|
|
enter_val vars lab mut exp.exp_type val_env met_env par_env
|
|
in
|
|
(val_env, met_env, par_env, Cf_val (lab, id, exp) :: fields, concr_meths)
|
|
|
|
| Pcf_virt (lab, priv, sty, loc) ->
|
|
virtual_method val_env meths self_type lab priv sty loc;
|
|
(val_env, met_env, par_env, fields, concr_meths)
|
|
|
|
| Pcf_meth (lab, priv, expr, loc) ->
|
|
Ctype.raise_nongen_level ();
|
|
let (_, ty) =
|
|
Ctype.filter_self_method val_env lab priv meths self_type
|
|
in
|
|
let meth_type = Ctype.newvar () in
|
|
let (obj_ty, res_ty) = Ctype.filter_arrow val_env meth_type in
|
|
Ctype.unify val_env obj_ty self_type;
|
|
Ctype.unify val_env res_ty ty;
|
|
let texp = type_expect met_env expr meth_type in
|
|
Ctype.end_def ();
|
|
(val_env, met_env, par_env, Cf_meth (lab, texp)::fields,
|
|
Concr.add lab concr_meths)
|
|
|
|
| Pcf_cstr (sty, sty', loc) ->
|
|
type_constraint val_env sty sty' loc;
|
|
(val_env, met_env, par_env, fields, concr_meths)
|
|
|
|
| Pcf_let (rec_flag, sdefs, loc) ->
|
|
let (defs, val_env) =
|
|
try
|
|
Typecore.type_let val_env rec_flag sdefs
|
|
with Ctype.Unify [(ty, _)] ->
|
|
raise(Error(loc, Make_nongen_seltype ty))
|
|
in
|
|
let (vals, met_env, par_env) =
|
|
List.fold_right
|
|
(fun id (vals, met_env, par_env) ->
|
|
let expr =
|
|
Typecore.type_exp val_env
|
|
{pexp_desc = Pexp_ident (Longident.Lident (Ident.name id));
|
|
pexp_loc = Location.none}
|
|
in
|
|
let desc =
|
|
{val_type = expr.exp_type; val_kind = Val_ivar Immutable}
|
|
in
|
|
let id' = Ident.create (Ident.name id) in
|
|
((id', expr)
|
|
:: vals,
|
|
Env.add_value id' desc met_env,
|
|
Env.add_value id' desc par_env))
|
|
(let_bound_idents defs)
|
|
([], met_env, par_env)
|
|
in
|
|
(val_env, met_env, par_env, Cf_let (rec_flag, defs, vals)::fields,
|
|
concr_meths)
|
|
|
|
| Pcf_init expr ->
|
|
Ctype.raise_nongen_level ();
|
|
let meth_type = Ctype.newvar () in
|
|
let (obj_ty, res_ty) = Ctype.filter_arrow val_env meth_type in
|
|
Ctype.unify val_env obj_ty self_type;
|
|
Ctype.unify val_env res_ty (Ctype.instance Predef.type_unit);
|
|
let texp = type_expect met_env expr meth_type in
|
|
Ctype.end_def ();
|
|
(val_env, met_env, par_env, Cf_init texp::fields, concr_meths)
|
|
|
|
and class_structure val_env met_env (spat, str) =
|
|
(* Environment for substructures *)
|
|
let par_env = met_env in
|
|
|
|
(* Self binder *)
|
|
let (pat, meths, vars, val_env, meth_env, par_env) =
|
|
type_self_pattern val_env met_env par_env spat
|
|
in
|
|
let self_type = pat.pat_type in
|
|
|
|
(* Check that the binder has a correct type, and introduce a dummy
|
|
method preventing self type from being closed. *)
|
|
begin try Ctype.filter_method val_env dummy_method Private self_type with
|
|
Ctype.Unify _ ->
|
|
raise(Error(pat.pat_loc, Pattern_type_clash self_type))
|
|
end;
|
|
|
|
(* Class fields *)
|
|
let (_, _, _, fields, concr_meths) =
|
|
List.fold_left (class_field self_type meths vars)
|
|
(val_env, meth_env, par_env, [], Concr.empty)
|
|
str
|
|
in
|
|
|
|
{cl_field = List.rev fields;
|
|
cl_meths = Meths.map (function (id, ty) -> id) !meths},
|
|
|
|
{cty_self = self_type;
|
|
cty_vars = Vars.map (function (id, mut, ty) -> (mut, ty)) !vars;
|
|
cty_concr = concr_meths }
|
|
|
|
and class_expr val_env met_env scl =
|
|
match scl.pcl_desc with
|
|
Pcl_constr (lid, styl) ->
|
|
let (path, decl) =
|
|
try Env.lookup_class lid val_env with Not_found ->
|
|
raise(Error(scl.pcl_loc, Unbound_class lid))
|
|
in
|
|
if Path.same decl.cty_path unbound_class then
|
|
raise(Error(scl.pcl_loc, Unbound_class_2 lid));
|
|
let tyl = List.map (transl_simple_type val_env false) styl in
|
|
let (params, clty) =
|
|
Ctype.instance_class decl.cty_params decl.cty_type
|
|
in
|
|
if List.length params <> List.length styl then
|
|
raise(Error(scl.pcl_loc,
|
|
Parameter_arity_mismatch (lid, List.length params,
|
|
List.length styl)));
|
|
List.iter2
|
|
(fun sty ty ->
|
|
let ty' = transl_simple_type val_env false sty in
|
|
try Ctype.unify val_env ty' ty with Ctype.Unify trace ->
|
|
raise(Error(sty.ptyp_loc, Parameter_mismatch trace)))
|
|
styl params;
|
|
let cl =
|
|
{cl_desc = Tclass_ident path;
|
|
cl_loc = scl.pcl_loc;
|
|
cl_type = clty}
|
|
in
|
|
let (vals, meths, concrs) = extract_constraints clty in
|
|
{cl_desc = Tclass_constraint (cl, vals, meths, concrs);
|
|
cl_loc = scl.pcl_loc;
|
|
cl_type = clty}
|
|
| Pcl_structure cl_str ->
|
|
let (desc, ty) = class_structure val_env met_env cl_str in
|
|
{cl_desc = Tclass_structure desc;
|
|
cl_loc = scl.pcl_loc;
|
|
cl_type = Tcty_signature ty}
|
|
| Pcl_fun (spat, scl') ->
|
|
let (pat, pv, val_env, met_env) =
|
|
Typecore.type_class_arg_pattern val_env met_env spat
|
|
in
|
|
let pv =
|
|
List.map
|
|
(function (id, id', ty) ->
|
|
(id,
|
|
Typecore.type_exp val_env
|
|
{pexp_desc = Pexp_ident (Longident.Lident (Ident.name id));
|
|
pexp_loc = Location.none}))
|
|
pv
|
|
in
|
|
Parmatch.check_partial pat.pat_loc
|
|
[pat, (* Dummy expression *)
|
|
{exp_desc = Texp_constant (Asttypes.Const_int 1);
|
|
exp_loc = Location.none;
|
|
exp_type = Ctype.none;
|
|
exp_env = Env.empty }];
|
|
Ctype.raise_nongen_level ();
|
|
let cl = class_expr val_env met_env scl' in
|
|
Ctype.end_def ();
|
|
{cl_desc = Tclass_fun (pat, pv, cl);
|
|
cl_loc = scl.pcl_loc;
|
|
cl_type = Tcty_fun (pat.pat_type, cl.cl_type)}
|
|
| Pcl_apply (scl', sargs) ->
|
|
let cl = class_expr val_env met_env scl' in
|
|
let rec type_args ty_fun =
|
|
function
|
|
[] ->
|
|
([], ty_fun)
|
|
| sarg1 :: sargl ->
|
|
begin match ty_fun with
|
|
Tcty_fun (ty, cty) ->
|
|
let arg1 = type_expect val_env sarg1 ty in
|
|
let (argl, ty_res) = type_args cty sargl in
|
|
(arg1 :: argl, ty_res)
|
|
| _ ->
|
|
raise(Error(cl.cl_loc, Cannot_apply cl.cl_type))
|
|
end
|
|
in
|
|
let (args, cty) = type_args cl.cl_type sargs in
|
|
begin try
|
|
make_nongen_class_type val_env cty
|
|
with Ctype.Unify [(ty, _)] ->
|
|
raise(Error(scl.pcl_loc, Make_nongen_seltype ty))
|
|
end;
|
|
{cl_desc = Tclass_apply (cl, args);
|
|
cl_loc = scl.pcl_loc;
|
|
cl_type = cty}
|
|
| Pcl_let (rec_flag, sdefs, scl') ->
|
|
let (defs, val_env) =
|
|
try
|
|
Typecore.type_let val_env rec_flag sdefs
|
|
with Ctype.Unify [(ty, _)] ->
|
|
raise(Error(scl.pcl_loc, Make_nongen_seltype ty))
|
|
in
|
|
let (vals, met_env) =
|
|
List.fold_right
|
|
(fun id (vals, met_env) ->
|
|
let expr =
|
|
Typecore.type_exp val_env
|
|
{pexp_desc = Pexp_ident (Longident.Lident (Ident.name id));
|
|
pexp_loc = Location.none}
|
|
in
|
|
let desc =
|
|
{val_type = expr.exp_type; val_kind = Val_ivar Immutable}
|
|
in
|
|
let id' = Ident.create (Ident.name id) in
|
|
((id', expr)
|
|
:: vals,
|
|
Env.add_value id' desc met_env))
|
|
(let_bound_idents defs)
|
|
([], met_env)
|
|
in
|
|
let cl = class_expr val_env met_env scl' in
|
|
{cl_desc = Tclass_let (rec_flag, defs, vals, cl);
|
|
cl_loc = scl.pcl_loc;
|
|
cl_type = cl.cl_type}
|
|
| Pcl_constraint (scl', scty) ->
|
|
Ctype.begin_class_def ();
|
|
Typetexp.narrow ();
|
|
let cl = class_expr val_env met_env scl' in
|
|
Typetexp.widen ();
|
|
Typetexp.narrow ();
|
|
let clty = class_type val_env scty in
|
|
Typetexp.widen ();
|
|
Ctype.end_def ();
|
|
generalize_class_type cl.cl_type;
|
|
generalize_class_type clty;
|
|
begin match Includeclass.class_types val_env cl.cl_type clty with
|
|
[] -> ()
|
|
| error -> raise(Error(cl.cl_loc, Class_match_failure error))
|
|
end;
|
|
let (vals, meths, concrs) = extract_constraints clty in
|
|
{cl_desc = Tclass_constraint (cl, vals, meths, concrs);
|
|
cl_loc = scl.pcl_loc;
|
|
cl_type = snd (Ctype.instance_class [] clty)}
|
|
|
|
(*******************************)
|
|
|
|
let temp_abbrev env id arity =
|
|
let params = ref [] in
|
|
for i = 1 to arity do
|
|
params := Ctype.newvar () :: !params
|
|
done;
|
|
let ty = Ctype.newobj (Ctype.newvar ()) in
|
|
let env =
|
|
Env.add_type id
|
|
{type_params = !params;
|
|
type_arity = arity;
|
|
type_kind = Type_abstract;
|
|
type_manifest = Some ty }
|
|
env
|
|
in
|
|
(!params, ty, env)
|
|
|
|
let rec initial_env define_class (res, env) (cl, id, ty_id, obj_id, cl_id) =
|
|
(* Temporary abbreviations *)
|
|
let arity = List.length (fst cl.pci_params) in
|
|
let (obj_params, obj_ty, env) = temp_abbrev env obj_id arity in
|
|
let (cl_params, cl_ty, env) = temp_abbrev env cl_id arity in
|
|
|
|
(* Temporary type for the class constructor *)
|
|
let constr_type = Ctype.newvar () in
|
|
let env =
|
|
let dummy_cty =
|
|
Tcty_signature
|
|
{ cty_self = Ctype.newvar ();
|
|
cty_vars = Vars.empty;
|
|
cty_concr = Concr.empty }
|
|
in
|
|
Env.add_cltype ty_id
|
|
{clty_params = []; (* Dummy value *)
|
|
clty_type = dummy_cty; (* Dummy value *)
|
|
clty_path = unbound_class} (
|
|
if define_class then
|
|
Env.add_class id
|
|
{cty_params = []; (* Dummy value *)
|
|
cty_type = dummy_cty; (* Dummy value *)
|
|
cty_path = unbound_class;
|
|
cty_new =
|
|
match cl.pci_virt with
|
|
Virtual -> None
|
|
| Concrete -> Some constr_type}
|
|
env
|
|
else
|
|
env)
|
|
in
|
|
((cl, id, ty_id,
|
|
obj_id, obj_params, obj_ty,
|
|
cl_id, cl_params, cl_ty,
|
|
constr_type)::res,
|
|
env)
|
|
|
|
let class_infos define_class kind
|
|
(cl, id, ty_id,
|
|
obj_id, obj_params, obj_ty,
|
|
cl_id, cl_params, cl_ty,
|
|
constr_type)
|
|
(res, env) =
|
|
|
|
reset_type_variables ();
|
|
Ctype.begin_class_def ();
|
|
|
|
(* Introduce class parameters *)
|
|
let params =
|
|
try
|
|
List.map (enter_type_variable true) (fst cl.pci_params)
|
|
with Already_bound ->
|
|
raise(Error(snd cl.pci_params, Repeated_parameter))
|
|
in
|
|
|
|
(* Type the class expression *)
|
|
let (expr, typ) = kind env cl.pci_expr in
|
|
|
|
Ctype.end_def ();
|
|
|
|
let sty = Ctype.self_type typ in
|
|
|
|
(* Generalize the row variable *)
|
|
let rv = Ctype.row_variable sty in
|
|
let rec limited_generalize rv =
|
|
function
|
|
Tcty_constr (path, params, cty) ->
|
|
List.iter (Ctype.limited_generalize rv) params;
|
|
limited_generalize rv cty
|
|
| Tcty_signature sign ->
|
|
Ctype.limited_generalize rv sign.cty_self;
|
|
Vars.iter (fun _ (_, ty) -> Ctype.limited_generalize rv ty)
|
|
sign.cty_vars
|
|
| Tcty_fun (ty, cty) ->
|
|
Ctype.limited_generalize rv ty;
|
|
limited_generalize rv cty
|
|
in
|
|
List.iter (Ctype.limited_generalize rv) params;
|
|
limited_generalize rv typ;
|
|
|
|
(* Check the abbreviation for the object type *)
|
|
let (obj_params', obj_type) = Ctype.instance_class params typ in
|
|
let constr = Ctype.newconstr (Path.Pident obj_id) obj_params in
|
|
begin
|
|
let ty = Ctype.self_type obj_type in
|
|
Ctype.hide_private_methods ty;
|
|
Ctype.close_object ty;
|
|
begin try
|
|
List.iter2 (Ctype.unify env) obj_params obj_params'
|
|
with Ctype.Unify _ ->
|
|
raise(Error(cl.pci_loc,
|
|
Bad_parameters (obj_id, constr,
|
|
Ctype.newconstr (Path.Pident obj_id)
|
|
obj_params')))
|
|
end;
|
|
begin try
|
|
Ctype.unify env ty constr
|
|
with Ctype.Unify _ ->
|
|
raise(Error(cl.pci_loc,
|
|
Abbrev_type_clash (constr, ty, Ctype.expand_head env constr)))
|
|
end
|
|
end;
|
|
|
|
(* Check the other temporary abbreviation (#-type) *)
|
|
begin
|
|
let (cl_params', cl_type) = Ctype.instance_class params typ in
|
|
let ty = Ctype.self_type cl_type in
|
|
Ctype.hide_private_methods ty;
|
|
Ctype.set_object_name obj_id (Ctype.row_variable ty) cl_params ty;
|
|
begin try
|
|
List.iter2 (Ctype.unify env) cl_params cl_params'
|
|
with Ctype.Unify _ ->
|
|
raise(Error(cl.pci_loc,
|
|
Bad_parameters (cl_id,
|
|
Ctype.newconstr (Path.Pident cl_id)
|
|
cl_params,
|
|
Ctype.newconstr (Path.Pident cl_id)
|
|
cl_params')))
|
|
end;
|
|
begin try
|
|
Ctype.unify env ty cl_ty
|
|
with Ctype.Unify _ ->
|
|
let constr = Ctype.newconstr (Path.Pident cl_id) params in
|
|
raise(Error(cl.pci_loc, Abbrev_type_clash (constr, ty, cl_ty)))
|
|
end
|
|
end;
|
|
|
|
(* Type of the class constructor *)
|
|
begin try
|
|
Ctype.unify env (constructor_type constr obj_type) constr_type
|
|
with Ctype.Unify trace ->
|
|
raise(Error(cl.pci_loc,
|
|
Constructor_type_mismatch (cl.pci_name, trace)))
|
|
end;
|
|
|
|
(* Class and class type temporary definitions *)
|
|
let cltydef =
|
|
{clty_params = params; clty_type = class_body typ;
|
|
clty_path = Path.Pident obj_id}
|
|
and clty =
|
|
{cty_params = params; cty_type = typ;
|
|
cty_path = Path.Pident obj_id;
|
|
cty_new =
|
|
match cl.pci_virt with
|
|
Virtual -> None
|
|
| Concrete -> Some constr_type}
|
|
in
|
|
let env =
|
|
Env.add_cltype ty_id cltydef (
|
|
if define_class then Env.add_class id clty env else env)
|
|
in
|
|
|
|
if cl.pci_virt = Concrete then begin
|
|
match virtual_methods typ with
|
|
[] -> ()
|
|
| mets -> raise(Error(cl.pci_loc, Virtual_class(define_class, mets)))
|
|
end;
|
|
|
|
(* Misc. *)
|
|
let arity = Ctype.class_type_arity typ in
|
|
let pub_meths =
|
|
let (fields, _) =
|
|
Ctype.flatten_fields (Ctype.object_fields (Ctype.expand_head env obj_ty))
|
|
in
|
|
List.map (function (lab, _, _) -> lab) fields
|
|
in
|
|
|
|
(* Final definitions *)
|
|
let (params', typ') = Ctype.instance_class params typ in
|
|
let cltydef =
|
|
{clty_params = params'; clty_type = class_body typ';
|
|
clty_path = Path.Pident obj_id}
|
|
and clty =
|
|
{cty_params = params'; cty_type = typ';
|
|
cty_path = Path.Pident obj_id;
|
|
cty_new =
|
|
match cl.pci_virt with
|
|
Virtual -> None
|
|
| Concrete -> Some constr_type}
|
|
in
|
|
let obj_abbr =
|
|
{type_params = obj_params;
|
|
type_arity = List.length obj_params;
|
|
type_kind = Type_abstract;
|
|
type_manifest = Some obj_ty }
|
|
in
|
|
let (cl_params, cl_ty) =
|
|
Ctype.instance_parameterized_type params (Ctype.self_type typ)
|
|
in
|
|
Ctype.hide_private_methods cl_ty;
|
|
Ctype.set_object_name obj_id (Ctype.row_variable cl_ty) cl_params cl_ty;
|
|
let cl_abbr =
|
|
{type_params = cl_params;
|
|
type_arity = List.length cl_params;
|
|
type_kind = Type_abstract;
|
|
type_manifest = Some cl_ty }
|
|
in
|
|
((cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
|
|
arity, pub_meths, expr) :: res,
|
|
env)
|
|
|
|
let final_env define_class
|
|
(cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
|
|
arity, pub_meths, expr)
|
|
(res, env) =
|
|
|
|
List.iter Ctype.generalize clty.cty_params;
|
|
generalize_class_type clty.cty_type;
|
|
begin match clty.cty_new with
|
|
None -> ()
|
|
| Some ty -> Ctype.generalize ty
|
|
end;
|
|
List.iter Ctype.generalize obj_abbr.type_params;
|
|
begin match obj_abbr.type_manifest with
|
|
None -> ()
|
|
| Some ty -> Ctype.generalize ty
|
|
end;
|
|
List.iter Ctype.generalize cl_abbr.type_params;
|
|
begin match cl_abbr.type_manifest with
|
|
None -> ()
|
|
| Some ty -> Ctype.generalize ty
|
|
end;
|
|
|
|
begin match
|
|
Ctype.closed_class clty.cty_params
|
|
(Ctype.signature_of_class_type clty.cty_type)
|
|
with
|
|
None -> ()
|
|
| Some reason ->
|
|
let printer =
|
|
if define_class then fun () -> Printtyp.class_declaration id clty
|
|
else fun () -> Printtyp.cltype_declaration id cltydef
|
|
in
|
|
raise(Error(cl.pci_loc, Unbound_type_var(printer, reason)))
|
|
end;
|
|
|
|
let env =
|
|
Env.add_type obj_id obj_abbr (
|
|
Env.add_type cl_id cl_abbr (
|
|
Env.add_cltype ty_id cltydef (
|
|
if define_class then Env.add_class id clty env else env)))
|
|
in
|
|
((id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
|
|
arity, pub_meths, expr)::res,
|
|
env)
|
|
|
|
(*******************************)
|
|
|
|
let type_classes define_class kind env cls =
|
|
let cls =
|
|
List.map
|
|
(function cl ->
|
|
(cl,
|
|
Ident.create cl.pci_name, Ident.create cl.pci_name,
|
|
Ident.create cl.pci_name, Ident.create ("#" ^ cl.pci_name)))
|
|
cls
|
|
in
|
|
Ctype.init_def (Ident.current_time ());
|
|
Ctype.begin_class_def ();
|
|
let (res, env) =
|
|
List.fold_left (initial_env define_class) ([], env) cls
|
|
in
|
|
let (res, env) =
|
|
List.fold_right (class_infos define_class kind) res ([], env)
|
|
in
|
|
Ctype.end_def ();
|
|
(* Make type abbreviations fully generic *)
|
|
let (res, env) =
|
|
List.fold_right (final_env define_class) res ([], env)
|
|
in
|
|
(*
|
|
let env =
|
|
List.fold_right
|
|
(fun (_, _, _, _, obj_id, obj_abbr, cl_id, cl_abbr, _, _, _) env ->
|
|
Env.add_type obj_id
|
|
(Subst.type_declaration Subst.identity obj_abbr) (
|
|
Env.add_type cl_id
|
|
(Subst.type_declaration Subst.identity cl_abbr) env))
|
|
res env
|
|
in
|
|
*)
|
|
(List.rev res, env)
|
|
|
|
let class_declaration env sexpr =
|
|
let expr = class_expr env env sexpr in
|
|
(expr, expr.cl_type)
|
|
|
|
let class_description env sexpr =
|
|
let expr = class_type env sexpr in
|
|
(expr, expr)
|
|
|
|
let class_declarations env cls =
|
|
type_classes true class_declaration env cls
|
|
|
|
let class_descriptions env cls =
|
|
type_classes true class_description env cls
|
|
|
|
let class_type_declarations env cls =
|
|
let (decl, env) =
|
|
type_classes false class_description env cls
|
|
in
|
|
(List.map
|
|
(function
|
|
(_, _, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, _, _, _) ->
|
|
(ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr))
|
|
decl,
|
|
env)
|
|
|
|
(*******************************)
|
|
|
|
(* Error report *)
|
|
|
|
open Format
|
|
|
|
let report_error = function
|
|
| Repeated_parameter ->
|
|
print_string "A type parameter occurs several times"
|
|
| Unconsistent_constraint trace ->
|
|
Printtyp.unification_error trace
|
|
(function () ->
|
|
print_string "The class constraints are not consistent : type")
|
|
(function () ->
|
|
print_string "is not compatible with type")
|
|
| Method_type_mismatch (m, trace) ->
|
|
Printtyp.unification_error trace
|
|
(function () ->
|
|
print_string "The method ";
|
|
print_string m; print_space ();
|
|
print_string "has type")
|
|
(function () ->
|
|
print_string "but is expected to have type")
|
|
| Structure_expected clty ->
|
|
open_box 0;
|
|
print_string
|
|
"This class expression is not a class structure; it has type";
|
|
print_space();
|
|
Printtyp.class_type clty;
|
|
close_box()
|
|
| Cannot_apply clty ->
|
|
print_string
|
|
"This class expression is not a class function, it cannot be applied"
|
|
| Pattern_type_clash ty ->
|
|
(* XXX Trace *)
|
|
(* XXX Revoir message d'erreur *)
|
|
open_box 0;
|
|
print_string "This pattern cannot match self: \
|
|
it only matches values of type";
|
|
print_space ();
|
|
Printtyp.type_expr ty;
|
|
close_box ()
|
|
| Unbound_class cl ->
|
|
print_string "Unbound class"; print_space ();
|
|
Printtyp.longident cl
|
|
| Unbound_class_2 cl ->
|
|
print_string "The class"; print_space ();
|
|
Printtyp.longident cl; print_space ();
|
|
print_string "is not yet completely defined"
|
|
| Unbound_class_type cl ->
|
|
print_string "Unbound class type"; print_space ();
|
|
Printtyp.longident cl
|
|
| Unbound_class_type_2 cl ->
|
|
print_string "The class type"; print_space ();
|
|
Printtyp.longident cl; print_space ();
|
|
print_string "is not yet completely defined"
|
|
| Abbrev_type_clash (abbrev, actual, expected) ->
|
|
(* XXX Afficher une trace ? *)
|
|
open_box 0;
|
|
Printtyp.reset ();
|
|
Printtyp.mark_loops abbrev; Printtyp.mark_loops actual;
|
|
Printtyp.mark_loops expected;
|
|
print_string "The abbreviation"; print_space ();
|
|
Printtyp.type_expr abbrev; print_space ();
|
|
print_string "expands to type"; print_space ();
|
|
Printtyp.type_expr actual; print_space ();
|
|
print_string "but is used with type"; print_space ();
|
|
Printtyp.type_expr expected;
|
|
close_box ()
|
|
| Constructor_type_mismatch (c, trace) ->
|
|
Printtyp.unification_error trace
|
|
(function () ->
|
|
print_string "The expression \"new ";
|
|
print_string c;
|
|
print_string "\" has type")
|
|
(function () ->
|
|
print_string "but is used with type")
|
|
| Virtual_class (cl, mets) ->
|
|
open_vbox 0;
|
|
if cl then
|
|
print_string "This class should be virtual"
|
|
else
|
|
print_string "This class type should be virtual";
|
|
print_space ();
|
|
open_box 2;
|
|
print_string "The following methods are undefined :";
|
|
List.iter
|
|
(function met ->
|
|
print_space (); print_string met)
|
|
mets;
|
|
close_box (); close_box()
|
|
| Parameter_arity_mismatch(lid, expected, provided) ->
|
|
open_box 0;
|
|
print_string "The class constructor "; Printtyp.longident lid;
|
|
print_space(); print_string "expects "; print_int expected;
|
|
print_string " type argument(s),"; print_space();
|
|
print_string "but is here applied to "; print_int provided;
|
|
print_string " type argument(s)";
|
|
close_box()
|
|
| Parameter_mismatch trace ->
|
|
Printtyp.unification_error trace
|
|
(function () ->
|
|
print_string "The type parameter")
|
|
(function () ->
|
|
print_string "does not meet its constraint: it should be")
|
|
| Bad_parameters (id, params, cstrs) ->
|
|
open_box 0;
|
|
Printtyp.reset ();
|
|
Printtyp.mark_loops params; Printtyp.mark_loops cstrs;
|
|
print_string "The abbreviation"; print_space ();
|
|
Printtyp.ident id; print_space ();
|
|
print_string "is used with parameters"; print_space ();
|
|
Printtyp.type_expr params; print_space ();
|
|
print_string "wich are incompatible with constraints"; print_space ();
|
|
Printtyp.type_expr cstrs; print_space ();
|
|
close_box ()
|
|
| Class_match_failure error ->
|
|
Includeclass.report_error error
|
|
| Unbound_val lab ->
|
|
print_string "Unbound instance variable "; print_string lab
|
|
| Unbound_type_var (printer, reason) ->
|
|
open_vbox 0;
|
|
open_box 0;
|
|
print_string "Some type variables are unbound in this type:";
|
|
print_break 1 2;
|
|
printer ();
|
|
close_box ();
|
|
print_space ();
|
|
open_box 0;
|
|
begin match reason with
|
|
Ctype.CC_Method (ty0, lab, ty) ->
|
|
(* XXX Cas ou une row variable n'est pas liee... *)
|
|
Printtyp.reset ();
|
|
Printtyp.mark_loops ty; Printtyp.mark_loops ty0;
|
|
print_string "The method"; print_space ();
|
|
print_string lab; print_space ();
|
|
print_string "has type"; print_break 1 2;
|
|
Printtyp.type_expr ty; print_space ();
|
|
print_string "where"; print_space ();
|
|
Printtyp.type_expr ty0; print_space ();
|
|
print_string "is unbound"
|
|
| Ctype.CC_Value (ty0, lab, ty) ->
|
|
Printtyp.reset ();
|
|
Printtyp.mark_loops ty; Printtyp.mark_loops ty0;
|
|
print_string "The instance variable"; print_space ();
|
|
print_string lab; print_space ();
|
|
print_string "has type"; print_break 1 2;
|
|
Printtyp.type_expr ty; print_space ();
|
|
print_string "where"; print_space ();
|
|
Printtyp.type_expr ty0; print_space ();
|
|
print_string "is unbound"
|
|
end;
|
|
close_box ();
|
|
close_box ()
|
|
| Make_nongen_seltype ty ->
|
|
open_vbox 0;
|
|
open_box 0;
|
|
print_string "Self type should not occur in the non-generic type";
|
|
print_break 1 2;
|
|
Printtyp.type_scheme ty;
|
|
close_box ();
|
|
print_cut ();
|
|
print_string "It would escape the scope of its class";
|
|
close_box ()
|