2065 lines
71 KiB
OCaml
2065 lines
71 KiB
OCaml
(**************************************************************************)
|
|
(* *)
|
|
(* OCaml *)
|
|
(* *)
|
|
(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
|
|
(* *)
|
|
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
|
(* en Automatique. *)
|
|
(* *)
|
|
(* All rights reserved. This file is distributed under the terms of *)
|
|
(* the GNU Lesser General Public License version 2.1, with the *)
|
|
(* special exception on linking described in the file LICENSE. *)
|
|
(* *)
|
|
(**************************************************************************)
|
|
|
|
open Parsetree
|
|
open Asttypes
|
|
open Path
|
|
open Types
|
|
open Typecore
|
|
open Typetexp
|
|
open Format
|
|
|
|
type 'a class_info = {
|
|
cls_id : Ident.t;
|
|
cls_id_loc : string loc;
|
|
cls_decl : class_declaration;
|
|
cls_ty_id : Ident.t;
|
|
cls_ty_decl : class_type_declaration;
|
|
cls_obj_id : Ident.t;
|
|
cls_obj_abbr : type_declaration;
|
|
cls_typesharp_id : Ident.t;
|
|
cls_abbr : type_declaration;
|
|
cls_arity : int;
|
|
cls_pub_methods : string list;
|
|
cls_info : 'a;
|
|
}
|
|
|
|
type class_type_info = {
|
|
clsty_ty_id : Ident.t;
|
|
clsty_id_loc : string loc;
|
|
clsty_ty_decl : class_type_declaration;
|
|
clsty_obj_id : Ident.t;
|
|
clsty_obj_abbr : type_declaration;
|
|
clsty_typesharp_id : Ident.t;
|
|
clsty_abbr : type_declaration;
|
|
clsty_info : Typedtree.class_type_declaration;
|
|
}
|
|
|
|
type 'a full_class = {
|
|
id : Ident.t;
|
|
id_loc : tag loc;
|
|
clty: class_declaration;
|
|
ty_id: Ident.t;
|
|
cltydef: class_type_declaration;
|
|
obj_id: Ident.t;
|
|
obj_abbr: type_declaration;
|
|
cl_id: Ident.t;
|
|
cl_abbr: type_declaration;
|
|
arity: int;
|
|
pub_meths: string list;
|
|
coe: Warnings.loc list;
|
|
expr: 'a;
|
|
req: 'a Typedtree.class_infos;
|
|
}
|
|
|
|
type class_env = { val_env : Env.t; met_env : Env.t; par_env : Env.t }
|
|
|
|
type error =
|
|
Unconsistent_constraint of Ctype.Unification_trace.t
|
|
| Field_type_mismatch of string * string * Ctype.Unification_trace.t
|
|
| Structure_expected of class_type
|
|
| Cannot_apply of class_type
|
|
| Apply_wrong_label of arg_label
|
|
| Pattern_type_clash of type_expr
|
|
| Repeated_parameter
|
|
| Unbound_class_2 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 * Ctype.Unification_trace.t
|
|
| Virtual_class of bool * bool * string list * string list
|
|
| Parameter_arity_mismatch of Longident.t * int * int
|
|
| Parameter_mismatch of Ctype.Unification_trace.t
|
|
| 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 (formatter -> unit) * Ctype.closed_class_failure
|
|
| Non_generalizable_class of Ident.t * Types.class_declaration
|
|
| Cannot_coerce_self of type_expr
|
|
| Non_collapsable_conjunction of
|
|
Ident.t * Types.class_declaration * Ctype.Unification_trace.t
|
|
| Final_self_clash of Ctype.Unification_trace.t
|
|
| Mutability_mismatch of string * mutable_flag
|
|
| No_overriding of string * string
|
|
| Duplicate of string * string
|
|
| Closing_self_type of type_expr
|
|
|
|
exception Error of Location.t * Env.t * error
|
|
exception Error_forward of Location.error
|
|
|
|
open Typedtree
|
|
|
|
let type_open_descr :
|
|
(?used_slot:bool ref -> Env.t -> Parsetree.open_description
|
|
-> open_description * Env.t) ref =
|
|
ref (fun ?used_slot:_ _ -> assert false)
|
|
|
|
let ctyp desc typ env loc =
|
|
{ ctyp_desc = desc; ctyp_type = typ; ctyp_loc = loc; ctyp_env = env;
|
|
ctyp_attributes = [] }
|
|
|
|
(**********************)
|
|
(* Useful constants *)
|
|
(**********************)
|
|
|
|
|
|
(*
|
|
Self type have a dummy private method, thus preventing it to become
|
|
closed.
|
|
*)
|
|
let dummy_method = Btype.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_local "*undef*")
|
|
|
|
|
|
(************************************)
|
|
(* Some operations on class types *)
|
|
(************************************)
|
|
|
|
|
|
(* Fully expand the head of a class type *)
|
|
let rec scrape_class_type =
|
|
function
|
|
Cty_constr (_, _, cty) -> scrape_class_type cty
|
|
| cty -> cty
|
|
|
|
(* Generalize a class type *)
|
|
let rec generalize_class_type gen =
|
|
function
|
|
Cty_constr (_, params, cty) ->
|
|
List.iter gen params;
|
|
generalize_class_type gen cty
|
|
| Cty_signature {csig_self = sty; csig_vars = vars; csig_inher = inher} ->
|
|
gen sty;
|
|
Vars.iter (fun _ (_, _, ty) -> gen ty) vars;
|
|
List.iter (fun (_,tl) -> List.iter gen tl) inher
|
|
| Cty_arrow (_, ty, cty) ->
|
|
gen ty;
|
|
generalize_class_type gen cty
|
|
|
|
let generalize_class_type vars =
|
|
let gen = if vars then Ctype.generalize else Ctype.generalize_structure in
|
|
generalize_class_type gen
|
|
|
|
(* Return the virtual methods of a class type *)
|
|
let virtual_methods sign =
|
|
let (fields, _) =
|
|
Ctype.flatten_fields (Ctype.object_fields sign.Types.csig_self)
|
|
in
|
|
List.fold_left
|
|
(fun virt (lab, _, _) ->
|
|
if lab = dummy_method then virt else
|
|
if Concr.mem lab sign.csig_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
|
|
Cty_constr (_, _, cty) ->
|
|
constructor_type constr cty
|
|
| Cty_signature _ ->
|
|
constr
|
|
| Cty_arrow (l, ty, cty) ->
|
|
Ctype.newty (Tarrow (l, ty, constructor_type constr cty, Cok))
|
|
|
|
let rec class_body cty =
|
|
match cty with
|
|
Cty_constr _ ->
|
|
cty (* Only class bodies can be abbreviated *)
|
|
| Cty_signature _ ->
|
|
cty
|
|
| Cty_arrow (_, _, cty) ->
|
|
class_body cty
|
|
|
|
let extract_constraints cty =
|
|
let sign = Ctype.signature_of_class_type cty in
|
|
(Vars.fold (fun lab _ vars -> lab :: vars) sign.csig_vars [],
|
|
begin let (fields, _) =
|
|
Ctype.flatten_fields (Ctype.object_fields sign.csig_self)
|
|
in
|
|
List.fold_left
|
|
(fun meths (lab, _, _) ->
|
|
if lab = dummy_method then meths else lab::meths)
|
|
[] fields
|
|
end,
|
|
sign.csig_concr)
|
|
|
|
let rec abbreviate_class_type path params cty =
|
|
match cty with
|
|
Cty_constr (_, _, _) | Cty_signature _ ->
|
|
Cty_constr (path, params, cty)
|
|
| Cty_arrow (l, ty, cty) ->
|
|
Cty_arrow (l, ty, abbreviate_class_type path params cty)
|
|
|
|
(* Check that all type variables are generalizable *)
|
|
(* Use Env.empty to prevent expansion of recursively defined object types;
|
|
cf. typing-poly/poly.ml *)
|
|
let rec closed_class_type =
|
|
function
|
|
Cty_constr (_, params, _) ->
|
|
List.for_all (Ctype.closed_schema Env.empty) params
|
|
| Cty_signature sign ->
|
|
Ctype.closed_schema Env.empty sign.csig_self
|
|
&&
|
|
Vars.fold (fun _ (_, _, ty) cc -> Ctype.closed_schema Env.empty ty && cc)
|
|
sign.csig_vars
|
|
true
|
|
| Cty_arrow (_, ty, cty) ->
|
|
Ctype.closed_schema Env.empty ty
|
|
&&
|
|
closed_class_type cty
|
|
|
|
let closed_class cty =
|
|
List.for_all (Ctype.closed_schema Env.empty) cty.cty_params
|
|
&&
|
|
closed_class_type cty.cty_type
|
|
|
|
let rec limited_generalize rv =
|
|
function
|
|
Cty_constr (_path, params, cty) ->
|
|
List.iter (Ctype.limited_generalize rv) params;
|
|
limited_generalize rv cty
|
|
| Cty_signature sign ->
|
|
Ctype.limited_generalize rv sign.csig_self;
|
|
Vars.iter (fun _ (_, _, ty) -> Ctype.limited_generalize rv ty)
|
|
sign.csig_vars;
|
|
List.iter (fun (_, tl) -> List.iter (Ctype.limited_generalize rv) tl)
|
|
sign.csig_inher
|
|
| Cty_arrow (_, ty, cty) ->
|
|
Ctype.limited_generalize rv ty;
|
|
limited_generalize rv cty
|
|
|
|
(* Record a class type *)
|
|
let rc node =
|
|
Cmt_format.add_saved_type (Cmt_format.Partial_class_expr node);
|
|
node
|
|
|
|
|
|
(***********************************)
|
|
(* Primitives for typing classes *)
|
|
(***********************************)
|
|
|
|
|
|
(* Enter a value in the method environment only *)
|
|
let enter_met_env ?check loc lab kind unbound_kind ty class_env =
|
|
let {val_env; met_env; par_env} = class_env in
|
|
let val_env = Env.enter_unbound_value lab unbound_kind val_env in
|
|
let par_env = Env.enter_unbound_value lab unbound_kind par_env in
|
|
let (id, met_env) =
|
|
Env.enter_value ?check lab
|
|
{val_type = ty; val_kind = kind;
|
|
val_attributes = []; Types.val_loc = loc;
|
|
val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); } met_env
|
|
in
|
|
let class_env = {val_env; met_env; par_env} in
|
|
(id,class_env )
|
|
|
|
(* Enter an instance variable in the environment *)
|
|
let enter_val cl_num vars inh lab mut virt ty class_env loc =
|
|
let val_env = class_env.val_env in
|
|
let (id, virt) =
|
|
try
|
|
let (id, mut', virt', ty') = Vars.find lab !vars in
|
|
if mut' <> mut then
|
|
raise (Error(loc, val_env, Mutability_mismatch(lab, mut)));
|
|
Ctype.unify val_env (Ctype.instance ty) (Ctype.instance ty');
|
|
(if not inh then Some id else None),
|
|
(if virt' = Concrete then virt' else virt)
|
|
with
|
|
Ctype.Unify tr ->
|
|
raise (Error(loc, val_env,
|
|
Field_type_mismatch("instance variable", lab, tr)))
|
|
| Not_found -> None, virt
|
|
in
|
|
let (id, _) as result =
|
|
match id with Some id -> (id, class_env)
|
|
| None ->
|
|
enter_met_env Location.none lab (Val_ivar (mut, cl_num))
|
|
Val_unbound_instance_variable ty class_env
|
|
in
|
|
vars := Vars.add lab (id, mut, virt, ty) !vars;
|
|
result
|
|
|
|
let concr_vals vars =
|
|
Vars.fold
|
|
(fun id (_, vf, _) s -> if vf = Virtual then s else Concr.add id s)
|
|
vars Concr.empty
|
|
|
|
let inheritance self_type env ovf concr_meths warn_vals loc parent =
|
|
match scrape_class_type parent with
|
|
Cty_signature cl_sig ->
|
|
|
|
(* Methods *)
|
|
begin try
|
|
Ctype.unify env self_type cl_sig.csig_self
|
|
with Ctype.Unify trace ->
|
|
let open Ctype.Unification_trace in
|
|
match trace with
|
|
| Diff _ :: Incompatible_fields {name = n; _ } :: rem ->
|
|
raise(Error(loc, env, Field_type_mismatch ("method", n, rem)))
|
|
| _ -> assert false
|
|
end;
|
|
|
|
(* Overriding *)
|
|
let over_meths = Concr.inter cl_sig.csig_concr concr_meths in
|
|
let concr_vals = concr_vals cl_sig.csig_vars in
|
|
let over_vals = Concr.inter concr_vals warn_vals in
|
|
begin match ovf with
|
|
Some Fresh ->
|
|
let cname =
|
|
match parent with
|
|
Cty_constr (p, _, _) -> Path.name p
|
|
| _ -> "inherited"
|
|
in
|
|
if not (Concr.is_empty over_meths) then
|
|
Location.prerr_warning loc
|
|
(Warnings.Method_override (cname :: Concr.elements over_meths));
|
|
if not (Concr.is_empty over_vals) then
|
|
Location.prerr_warning loc
|
|
(Warnings.Instance_variable_override
|
|
(cname :: Concr.elements over_vals));
|
|
| Some Override
|
|
when Concr.is_empty over_meths && Concr.is_empty over_vals ->
|
|
raise (Error(loc, env, No_overriding ("","")))
|
|
| _ -> ()
|
|
end;
|
|
|
|
let concr_meths = Concr.union cl_sig.csig_concr concr_meths
|
|
and warn_vals = Concr.union concr_vals warn_vals in
|
|
|
|
(cl_sig, concr_meths, warn_vals)
|
|
|
|
| _ ->
|
|
raise(Error(loc, env, 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 sty = Ast_helper.Typ.force_poly sty in
|
|
let cty = transl_simple_type val_env false sty in
|
|
let ty = cty.ctyp_type in
|
|
begin
|
|
try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
|
|
raise(Error(loc, val_env, Field_type_mismatch ("method", lab, trace)));
|
|
end;
|
|
cty
|
|
|
|
let delayed_meth_specs = ref []
|
|
|
|
let declare_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 unif ty =
|
|
try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
|
|
raise(Error(loc, val_env, Field_type_mismatch ("method", lab, trace)))
|
|
in
|
|
let sty = Ast_helper.Typ.force_poly sty in
|
|
match sty.ptyp_desc, priv with
|
|
Ptyp_poly ([],sty'), Public ->
|
|
(* TODO: we moved the [transl_simple_type_univars] outside of the lazy,
|
|
so that we can get an immediate value. Is that correct ? Ask Jacques. *)
|
|
let returned_cty = ctyp Ttyp_any (Ctype.newty Tnil) val_env loc in
|
|
delayed_meth_specs :=
|
|
Warnings.mk_lazy (fun () ->
|
|
let cty = transl_simple_type_univars val_env sty' in
|
|
let ty = cty.ctyp_type in
|
|
unif ty;
|
|
returned_cty.ctyp_desc <- Ttyp_poly ([], cty);
|
|
returned_cty.ctyp_type <- ty;
|
|
) ::
|
|
!delayed_meth_specs;
|
|
returned_cty
|
|
| _ ->
|
|
let cty = transl_simple_type val_env false sty in
|
|
let ty = cty.ctyp_type in
|
|
unif ty;
|
|
cty
|
|
|
|
let type_constraint val_env sty sty' loc =
|
|
let cty = transl_simple_type val_env false sty in
|
|
let ty = cty.ctyp_type in
|
|
let cty' = transl_simple_type val_env false sty' in
|
|
let ty' = cty'.ctyp_type in
|
|
begin
|
|
try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
|
|
raise(Error(loc, val_env, Unconsistent_constraint trace));
|
|
end;
|
|
(cty, cty')
|
|
|
|
let make_method loc cl_num expr =
|
|
let open Ast_helper in
|
|
let mkid s = mkloc s loc in
|
|
Exp.fun_ ~loc:expr.pexp_loc Nolabel None
|
|
(Pat.alias ~loc (Pat.var ~loc (mkid "self-*")) (mkid ("self-" ^ cl_num)))
|
|
expr
|
|
|
|
(*******************************)
|
|
|
|
let add_val lab (mut, virt, ty) val_sig =
|
|
let virt =
|
|
try
|
|
let (_mut', virt', _ty') = Vars.find lab val_sig in
|
|
if virt' = Concrete then virt' else virt
|
|
with Not_found -> virt
|
|
in
|
|
Vars.add lab (mut, virt, ty) val_sig
|
|
|
|
let rec class_type_field env self_type meths arg ctf =
|
|
Builtin_attributes.warning_scope ctf.pctf_attributes
|
|
(fun () -> class_type_field_aux env self_type meths arg ctf)
|
|
|
|
and class_type_field_aux env self_type meths
|
|
(fields, val_sig, concr_meths, inher) ctf =
|
|
|
|
let loc = ctf.pctf_loc in
|
|
let mkctf desc =
|
|
{ ctf_desc = desc; ctf_loc = loc; ctf_attributes = ctf.pctf_attributes }
|
|
in
|
|
match ctf.pctf_desc with
|
|
Pctf_inherit sparent ->
|
|
let parent = class_type env sparent in
|
|
let inher =
|
|
match parent.cltyp_type with
|
|
Cty_constr (p, tl, _) -> (p, tl) :: inher
|
|
| _ -> inher
|
|
in
|
|
let (cl_sig, concr_meths, _) =
|
|
inheritance self_type env None concr_meths Concr.empty sparent.pcty_loc
|
|
parent.cltyp_type
|
|
in
|
|
let val_sig =
|
|
Vars.fold add_val cl_sig.csig_vars val_sig in
|
|
(mkctf (Tctf_inherit parent) :: fields,
|
|
val_sig, concr_meths, inher)
|
|
|
|
| Pctf_val ({txt=lab}, mut, virt, sty) ->
|
|
let cty = transl_simple_type env false sty in
|
|
let ty = cty.ctyp_type in
|
|
(mkctf (Tctf_val (lab, mut, virt, cty)) :: fields,
|
|
add_val lab (mut, virt, ty) val_sig, concr_meths, inher)
|
|
|
|
| Pctf_method ({txt=lab}, priv, virt, sty) ->
|
|
let cty =
|
|
declare_method env meths self_type lab priv sty ctf.pctf_loc in
|
|
let concr_meths =
|
|
match virt with
|
|
| Concrete -> Concr.add lab concr_meths
|
|
| Virtual -> concr_meths
|
|
in
|
|
(mkctf (Tctf_method (lab, priv, virt, cty)) :: fields,
|
|
val_sig, concr_meths, inher)
|
|
|
|
| Pctf_constraint (sty, sty') ->
|
|
let (cty, cty') = type_constraint env sty sty' ctf.pctf_loc in
|
|
(mkctf (Tctf_constraint (cty, cty')) :: fields,
|
|
val_sig, concr_meths, inher)
|
|
|
|
| Pctf_attribute x ->
|
|
Builtin_attributes.warning_attribute x;
|
|
(mkctf (Tctf_attribute x) :: fields,
|
|
val_sig, concr_meths, inher)
|
|
|
|
| Pctf_extension ext ->
|
|
raise (Error_forward (Builtin_attributes.error_of_extension ext))
|
|
|
|
and class_signature env {pcsig_self=sty; pcsig_fields=sign} =
|
|
let meths = ref Meths.empty in
|
|
let self_cty = transl_simple_type env false sty in
|
|
let self_cty = { self_cty with
|
|
ctyp_type = Ctype.expand_head env self_cty.ctyp_type } in
|
|
let self_type = self_cty.ctyp_type in
|
|
|
|
(* Check that the binder is a correct type, and introduce a dummy
|
|
method preventing self type from being closed. *)
|
|
let dummy_obj = Ctype.newvar () in
|
|
Ctype.unify env (Ctype.filter_method env dummy_method Private dummy_obj)
|
|
(Ctype.newty (Ttuple []));
|
|
begin try
|
|
Ctype.unify env self_type dummy_obj
|
|
with Ctype.Unify _ ->
|
|
raise(Error(sty.ptyp_loc, env, Pattern_type_clash self_type))
|
|
end;
|
|
|
|
(* Class type fields *)
|
|
let (rev_fields, val_sig, concr_meths, inher) =
|
|
Builtin_attributes.warning_scope []
|
|
(fun () ->
|
|
List.fold_left (class_type_field env self_type meths)
|
|
([], Vars.empty, Concr.empty, [])
|
|
sign
|
|
)
|
|
in
|
|
let cty = {csig_self = self_type;
|
|
csig_vars = val_sig;
|
|
csig_concr = concr_meths;
|
|
csig_inher = inher}
|
|
in
|
|
{ csig_self = self_cty;
|
|
csig_fields = List.rev rev_fields;
|
|
csig_type = cty;
|
|
}
|
|
|
|
and class_type env scty =
|
|
Builtin_attributes.warning_scope scty.pcty_attributes
|
|
(fun () -> class_type_aux env scty)
|
|
|
|
and class_type_aux env scty =
|
|
let cltyp desc typ =
|
|
{
|
|
cltyp_desc = desc;
|
|
cltyp_type = typ;
|
|
cltyp_loc = scty.pcty_loc;
|
|
cltyp_env = env;
|
|
cltyp_attributes = scty.pcty_attributes;
|
|
}
|
|
in
|
|
match scty.pcty_desc with
|
|
Pcty_constr (lid, styl) ->
|
|
let (path, decl) = Env.lookup_cltype ~loc:scty.pcty_loc lid.txt env in
|
|
if Path.same decl.clty_path unbound_class then
|
|
raise(Error(scty.pcty_loc, env, Unbound_class_type_2 lid.txt));
|
|
let (params, clty) =
|
|
Ctype.instance_class decl.clty_params decl.clty_type
|
|
in
|
|
if List.length params <> List.length styl then
|
|
raise(Error(scty.pcty_loc, env,
|
|
Parameter_arity_mismatch (lid.txt, List.length params,
|
|
List.length styl)));
|
|
let ctys = List.map2
|
|
(fun sty ty ->
|
|
let cty' = transl_simple_type env false sty in
|
|
let ty' = cty'.ctyp_type in
|
|
begin
|
|
try Ctype.unify env ty' ty with Ctype.Unify trace ->
|
|
raise(Error(sty.ptyp_loc, env, Parameter_mismatch trace))
|
|
end;
|
|
cty'
|
|
) styl params
|
|
in
|
|
let typ = Cty_constr (path, params, clty) in
|
|
cltyp (Tcty_constr ( path, lid , ctys)) typ
|
|
|
|
| Pcty_signature pcsig ->
|
|
let clsig = class_signature env pcsig in
|
|
let typ = Cty_signature clsig.csig_type in
|
|
cltyp (Tcty_signature clsig) typ
|
|
|
|
| Pcty_arrow (l, sty, scty) ->
|
|
let cty = transl_simple_type env false sty in
|
|
let ty = cty.ctyp_type in
|
|
let ty =
|
|
if Btype.is_optional l
|
|
then Ctype.newty (Tconstr(Predef.path_option,[ty], ref Mnil))
|
|
else ty in
|
|
let clty = class_type env scty in
|
|
let typ = Cty_arrow (l, ty, clty.cltyp_type) in
|
|
cltyp (Tcty_arrow (l, cty, clty)) typ
|
|
|
|
| Pcty_open (od, e) ->
|
|
let (od, newenv) = !type_open_descr env od in
|
|
let clty = class_type newenv e in
|
|
cltyp (Tcty_open (od, clty)) clty.cltyp_type
|
|
|
|
| Pcty_extension ext ->
|
|
raise (Error_forward (Builtin_attributes.error_of_extension ext))
|
|
|
|
let class_type env scty =
|
|
delayed_meth_specs := [];
|
|
let cty = class_type env scty in
|
|
List.iter Lazy.force (List.rev !delayed_meth_specs);
|
|
delayed_meth_specs := [];
|
|
cty
|
|
|
|
(*******************************)
|
|
|
|
let rec class_field self_loc cl_num self_type meths vars arg cf =
|
|
Builtin_attributes.warning_scope cf.pcf_attributes
|
|
(fun () -> class_field_aux self_loc cl_num self_type meths vars arg cf)
|
|
|
|
and class_field_aux self_loc cl_num self_type meths vars
|
|
(class_env, fields, concr_meths, warn_vals, inher,
|
|
local_meths, local_vals) cf =
|
|
let loc = cf.pcf_loc in
|
|
let mkcf desc =
|
|
{ cf_desc = desc; cf_loc = loc; cf_attributes = cf.pcf_attributes }
|
|
in
|
|
let {val_env; met_env; par_env} = class_env in
|
|
match cf.pcf_desc with
|
|
Pcf_inherit (ovf, sparent, super) ->
|
|
let parent = class_expr cl_num val_env par_env sparent in
|
|
let inher =
|
|
match parent.cl_type with
|
|
Cty_constr (p, tl, _) -> (p, tl) :: inher
|
|
| _ -> inher
|
|
in
|
|
let (cl_sig, concr_meths, warn_vals) =
|
|
inheritance self_type val_env (Some ovf) concr_meths warn_vals
|
|
sparent.pcl_loc parent.cl_type
|
|
in
|
|
(* Variables *)
|
|
let (class_env, inh_vars) =
|
|
Vars.fold
|
|
(fun lab info (class_env, inh_vars) ->
|
|
let mut, vr, ty = info in
|
|
let (id, class_env) =
|
|
enter_val cl_num vars true lab mut vr ty class_env
|
|
sparent.pcl_loc ;
|
|
in
|
|
(class_env, (lab, id) :: inh_vars))
|
|
cl_sig.csig_vars (class_env, [])
|
|
in
|
|
(* Inherited concrete methods *)
|
|
let inh_meths =
|
|
Concr.fold (fun lab rem -> (lab, Ident.create_local lab)::rem)
|
|
cl_sig.csig_concr []
|
|
in
|
|
(* Super *)
|
|
let (class_env,super) =
|
|
match super with
|
|
None ->
|
|
(class_env,None)
|
|
| Some {txt=name} ->
|
|
let (_id, class_env) =
|
|
enter_met_env ~check:(fun s -> Warnings.Unused_ancestor s)
|
|
sparent.pcl_loc name (Val_anc (inh_meths, cl_num))
|
|
Val_unbound_ancestor self_type class_env
|
|
in
|
|
(class_env,Some name)
|
|
in
|
|
(class_env,
|
|
lazy (mkcf (Tcf_inherit (ovf, parent, super, inh_vars, inh_meths)))
|
|
:: fields,
|
|
concr_meths, warn_vals, inher, local_meths, local_vals)
|
|
|
|
| Pcf_val (lab, mut, Cfk_virtual styp) ->
|
|
if !Clflags.principal then Ctype.begin_def ();
|
|
let cty = Typetexp.transl_simple_type val_env false styp in
|
|
let ty = cty.ctyp_type in
|
|
if !Clflags.principal then begin
|
|
Ctype.end_def ();
|
|
Ctype.generalize_structure ty
|
|
end;
|
|
let (id, class_env') =
|
|
enter_val cl_num vars false lab.txt mut Virtual ty
|
|
class_env loc
|
|
in
|
|
(class_env',
|
|
lazy (mkcf (Tcf_val (lab, mut, id, Tcfk_virtual cty,
|
|
met_env == class_env'.met_env)))
|
|
:: fields,
|
|
concr_meths, warn_vals, inher, local_meths, local_vals)
|
|
|
|
| Pcf_val (lab, mut, Cfk_concrete (ovf, sexp)) ->
|
|
if Concr.mem lab.txt local_vals then
|
|
raise(Error(loc, val_env, Duplicate ("instance variable", lab.txt)));
|
|
if Concr.mem lab.txt warn_vals then begin
|
|
if ovf = Fresh then
|
|
Location.prerr_warning lab.loc
|
|
(Warnings.Instance_variable_override[lab.txt])
|
|
end else begin
|
|
if ovf = Override then
|
|
raise(Error(loc, val_env,
|
|
No_overriding ("instance variable", lab.txt)))
|
|
end;
|
|
if !Clflags.principal then Ctype.begin_def ();
|
|
let exp = type_exp val_env sexp in
|
|
if !Clflags.principal then begin
|
|
Ctype.end_def ();
|
|
Ctype.generalize_structure exp.exp_type
|
|
end;
|
|
let (id, class_env') =
|
|
enter_val cl_num vars false lab.txt mut Concrete exp.exp_type
|
|
class_env loc
|
|
in
|
|
(class_env',
|
|
lazy (mkcf (Tcf_val (lab, mut, id,
|
|
Tcfk_concrete (ovf, exp), met_env == class_env'.met_env)))
|
|
:: fields,
|
|
concr_meths, Concr.add lab.txt warn_vals, inher, local_meths,
|
|
Concr.add lab.txt local_vals)
|
|
|
|
| Pcf_method (lab, priv, Cfk_virtual sty) ->
|
|
let cty = virtual_method val_env meths self_type lab.txt priv sty loc in
|
|
(class_env,
|
|
lazy (mkcf(Tcf_method (lab, priv, Tcfk_virtual cty)))
|
|
::fields,
|
|
concr_meths, warn_vals, inher, local_meths, local_vals)
|
|
|
|
| Pcf_method (lab, priv, Cfk_concrete (ovf, expr)) ->
|
|
let expr =
|
|
match expr.pexp_desc with
|
|
| Pexp_poly _ -> expr
|
|
| _ -> Ast_helper.Exp.poly ~loc:expr.pexp_loc expr None
|
|
in
|
|
if Concr.mem lab.txt local_meths then
|
|
raise(Error(loc, val_env, Duplicate ("method", lab.txt)));
|
|
if Concr.mem lab.txt concr_meths then begin
|
|
if ovf = Fresh then
|
|
Location.prerr_warning loc (Warnings.Method_override [lab.txt])
|
|
end else begin
|
|
if ovf = Override then
|
|
raise(Error(loc, val_env, No_overriding("method", lab.txt)))
|
|
end;
|
|
let (_, ty) =
|
|
Ctype.filter_self_method val_env lab.txt priv meths self_type
|
|
in
|
|
begin try match expr.pexp_desc with
|
|
Pexp_poly (sbody, sty) ->
|
|
begin match sty with None -> ()
|
|
| Some sty ->
|
|
let sty = Ast_helper.Typ.force_poly sty in
|
|
let cty' = Typetexp.transl_simple_type val_env false sty in
|
|
let ty' = cty'.ctyp_type in
|
|
Ctype.unify val_env ty' ty
|
|
end;
|
|
begin match (Ctype.repr ty).desc with
|
|
Tvar _ ->
|
|
let ty' = Ctype.newvar () in
|
|
Ctype.unify val_env (Ctype.newty (Tpoly (ty', []))) ty;
|
|
Ctype.unify val_env (type_approx val_env sbody) ty'
|
|
| Tpoly (ty1, tl) ->
|
|
let _, ty1' = Ctype.instance_poly false tl ty1 in
|
|
let ty2 = type_approx val_env sbody in
|
|
Ctype.unify val_env ty2 ty1'
|
|
| _ -> assert false
|
|
end
|
|
| _ -> assert false
|
|
with Ctype.Unify trace ->
|
|
raise(Error(loc, val_env,
|
|
Field_type_mismatch ("method", lab.txt, trace)))
|
|
end;
|
|
let meth_expr = make_method self_loc cl_num expr in
|
|
(* backup variables for Pexp_override *)
|
|
let vars_local = !vars in
|
|
|
|
let field =
|
|
Warnings.mk_lazy
|
|
(fun () ->
|
|
(* Read the generalized type *)
|
|
let (_, ty) = Meths.find lab.txt !meths in
|
|
let meth_type = mk_expected (
|
|
Btype.newgenty (Tarrow(Nolabel, self_type, ty, Cok))
|
|
) in
|
|
Ctype.raise_nongen_level ();
|
|
vars := vars_local;
|
|
let texp = type_expect met_env meth_expr meth_type in
|
|
Ctype.end_def ();
|
|
mkcf (Tcf_method (lab, priv, Tcfk_concrete (ovf, texp)))
|
|
)
|
|
in
|
|
(class_env, field::fields,
|
|
Concr.add lab.txt concr_meths, warn_vals, inher,
|
|
Concr.add lab.txt local_meths, local_vals)
|
|
|
|
| Pcf_constraint (sty, sty') ->
|
|
let (cty, cty') = type_constraint val_env sty sty' loc in
|
|
(class_env,
|
|
lazy (mkcf (Tcf_constraint (cty, cty'))) :: fields,
|
|
concr_meths, warn_vals, inher, local_meths, local_vals)
|
|
|
|
| Pcf_initializer expr ->
|
|
let expr = make_method self_loc cl_num expr in
|
|
let vars_local = !vars in
|
|
let field =
|
|
lazy begin
|
|
Ctype.raise_nongen_level ();
|
|
let meth_type = mk_expected (
|
|
Ctype.newty
|
|
(Tarrow (Nolabel, self_type,
|
|
Ctype.instance Predef.type_unit, Cok))
|
|
) in
|
|
vars := vars_local;
|
|
let texp = type_expect met_env expr meth_type in
|
|
Ctype.end_def ();
|
|
mkcf (Tcf_initializer texp)
|
|
end in
|
|
(class_env, field::fields, concr_meths, warn_vals,
|
|
inher, local_meths, local_vals)
|
|
| Pcf_attribute x ->
|
|
Builtin_attributes.warning_attribute x;
|
|
(class_env,
|
|
lazy (mkcf (Tcf_attribute x)) :: fields,
|
|
concr_meths, warn_vals, inher, local_meths, local_vals)
|
|
| Pcf_extension ext ->
|
|
raise (Error_forward (Builtin_attributes.error_of_extension ext))
|
|
|
|
(* N.B. the self type of a final object type doesn't contain a dummy method in
|
|
the beginning.
|
|
We only explicitly add a dummy method to class definitions (and class (type)
|
|
declarations)), which are later removed (made absent) by [final_decl].
|
|
|
|
If we ever find a dummy method in a final object self type, it means that
|
|
somehow we've unified the self type of the object with the self type of a not
|
|
yet finished class.
|
|
When this happens, we cannot close the object type and must error. *)
|
|
and class_structure cl_num final val_env met_env loc
|
|
{ pcstr_self = spat; pcstr_fields = str } =
|
|
(* Environment for substructures *)
|
|
let par_env = met_env in
|
|
|
|
(* Location of self. Used for locations of self arguments *)
|
|
let self_loc = {spat.ppat_loc with Location.loc_ghost = true} in
|
|
|
|
let self_type = Ctype.newobj (Ctype.newvar ()) in
|
|
|
|
(* Adding a dummy method to the self type prevents it from being closed /
|
|
escaping.
|
|
That isn't needed for objects though. *)
|
|
if not final then
|
|
Ctype.unify val_env
|
|
(Ctype.filter_method val_env dummy_method Private self_type)
|
|
(Ctype.newty (Ttuple []));
|
|
|
|
(* Private self is used for private method calls *)
|
|
let private_self = if final then Ctype.newvar () else self_type in
|
|
|
|
(* Self binder *)
|
|
let (pat, meths, vars, val_env, met_env, par_env) =
|
|
type_self_pattern cl_num private_self val_env met_env par_env spat
|
|
in
|
|
let public_self = pat.pat_type in
|
|
|
|
(* Check that the binder has a correct type *)
|
|
let ty =
|
|
if final then Ctype.newobj (Ctype.newvar()) else self_type in
|
|
begin try Ctype.unify val_env public_self ty with
|
|
Ctype.Unify _ ->
|
|
raise(Error(spat.ppat_loc, val_env, Pattern_type_clash public_self))
|
|
end;
|
|
let get_methods ty =
|
|
(fst (Ctype.flatten_fields
|
|
(Ctype.object_fields (Ctype.expand_head val_env ty)))) in
|
|
if final then begin
|
|
(* Copy known information to still empty self_type *)
|
|
List.iter
|
|
(fun (lab,kind,ty) ->
|
|
let k =
|
|
if Btype.field_kind_repr kind = Fpresent then Public else Private in
|
|
try Ctype.unify val_env ty
|
|
(Ctype.filter_method val_env lab k self_type)
|
|
with _ -> assert false)
|
|
(get_methods public_self)
|
|
end;
|
|
|
|
(* Typing of class fields *)
|
|
let class_env = {val_env; met_env; par_env} in
|
|
let (_, fields, concr_meths, _, inher, _local_meths, _local_vals) =
|
|
Builtin_attributes.warning_scope []
|
|
(fun () ->
|
|
List.fold_left (class_field self_loc cl_num self_type meths vars)
|
|
( class_env,[], Concr.empty, Concr.empty, [],
|
|
Concr.empty, Concr.empty)
|
|
str
|
|
)
|
|
in
|
|
Ctype.unify val_env self_type (Ctype.newvar ()); (* useless ? *)
|
|
let sign =
|
|
{csig_self = public_self;
|
|
csig_vars = Vars.map (fun (_id, mut, vr, ty) -> (mut, vr, ty)) !vars;
|
|
csig_concr = concr_meths;
|
|
csig_inher = inher} in
|
|
let methods = get_methods self_type in
|
|
let priv_meths =
|
|
List.filter (fun (_,kind,_) -> Btype.field_kind_repr kind <> Fpresent)
|
|
methods in
|
|
(* ensure that inherited methods are listed too *)
|
|
List.iter (fun (met, _kind, _ty) ->
|
|
if Meths.mem met !meths then () else
|
|
ignore (Ctype.filter_self_method val_env met Private meths self_type))
|
|
methods;
|
|
if final then begin
|
|
(* Unify private_self and a copy of self_type. self_type will not
|
|
be modified after this point *)
|
|
if not (Ctype.close_object self_type) then
|
|
raise(Error(loc, val_env, Closing_self_type self_type));
|
|
let mets = virtual_methods {sign with csig_self = self_type} in
|
|
let vals =
|
|
Vars.fold
|
|
(fun name (_mut, vr, _ty) l -> if vr = Virtual then name :: l else l)
|
|
sign.csig_vars [] in
|
|
if mets <> [] || vals <> [] then
|
|
raise(Error(loc, val_env, Virtual_class(true, final, mets, vals)));
|
|
let self_methods =
|
|
List.fold_right
|
|
(fun (lab,kind,ty) rem ->
|
|
Ctype.newty(Tfield(lab, Btype.copy_kind kind, ty, rem)))
|
|
methods (Ctype.newty Tnil) in
|
|
begin try
|
|
Ctype.unify val_env private_self
|
|
(Ctype.newty (Tobject(self_methods, ref None)));
|
|
Ctype.unify val_env public_self self_type
|
|
with Ctype.Unify trace -> raise(Error(loc, val_env, Final_self_clash trace))
|
|
end;
|
|
end;
|
|
|
|
(* Typing of method bodies *)
|
|
(* if !Clflags.principal then *) begin
|
|
let ms = !meths in
|
|
(* Generalize the spine of methods accessed through self *)
|
|
Meths.iter (fun _ (_,ty) -> Ctype.generalize_spine ty) ms;
|
|
meths :=
|
|
Meths.map (fun (id,ty) -> (id, Ctype.generic_instance ty)) ms;
|
|
(* But keep levels correct on the type of self *)
|
|
Meths.iter (fun _ (_,ty) -> Ctype.unify val_env ty (Ctype.newvar ())) ms
|
|
end;
|
|
let fields = List.map Lazy.force (List.rev fields) in
|
|
let meths = Meths.map (function (id, _ty) -> id) !meths in
|
|
|
|
(* Check for private methods made public *)
|
|
let pub_meths' =
|
|
List.filter (fun (_,kind,_) -> Btype.field_kind_repr kind = Fpresent)
|
|
(get_methods public_self) in
|
|
let names = List.map (fun (x,_,_) -> x) in
|
|
let l1 = names priv_meths and l2 = names pub_meths' in
|
|
let added = List.filter (fun x -> List.mem x l1) l2 in
|
|
if added <> [] then
|
|
Location.prerr_warning loc (Warnings.Implicit_public_methods added);
|
|
let sign = if final then sign else
|
|
{sign with Types.csig_self = Ctype.expand_head val_env public_self} in
|
|
{
|
|
cstr_self = pat;
|
|
cstr_fields = fields;
|
|
cstr_type = sign;
|
|
cstr_meths = meths}, sign (* redondant, since already in cstr_type *)
|
|
|
|
and class_expr cl_num val_env met_env scl =
|
|
Builtin_attributes.warning_scope scl.pcl_attributes
|
|
(fun () -> class_expr_aux cl_num val_env met_env scl)
|
|
|
|
and class_expr_aux cl_num val_env met_env scl =
|
|
match scl.pcl_desc with
|
|
Pcl_constr (lid, styl) ->
|
|
let (path, decl) = Env.lookup_class ~loc:scl.pcl_loc lid.txt val_env in
|
|
if Path.same decl.cty_path unbound_class then
|
|
raise(Error(scl.pcl_loc, val_env, Unbound_class_2 lid.txt));
|
|
let tyl = List.map
|
|
(fun sty -> transl_simple_type val_env false sty)
|
|
styl
|
|
in
|
|
let (params, clty) =
|
|
Ctype.instance_class decl.cty_params decl.cty_type
|
|
in
|
|
let clty' = abbreviate_class_type path params clty in
|
|
if List.length params <> List.length tyl then
|
|
raise(Error(scl.pcl_loc, val_env,
|
|
Parameter_arity_mismatch (lid.txt, List.length params,
|
|
List.length tyl)));
|
|
List.iter2
|
|
(fun cty' ty ->
|
|
let ty' = cty'.ctyp_type in
|
|
try Ctype.unify val_env ty' ty with Ctype.Unify trace ->
|
|
raise(Error(cty'.ctyp_loc, val_env, Parameter_mismatch trace)))
|
|
tyl params;
|
|
let cl =
|
|
rc {cl_desc = Tcl_ident (path, lid, tyl);
|
|
cl_loc = scl.pcl_loc;
|
|
cl_type = clty';
|
|
cl_env = val_env;
|
|
cl_attributes = scl.pcl_attributes;
|
|
}
|
|
in
|
|
let (vals, meths, concrs) = extract_constraints clty in
|
|
rc {cl_desc = Tcl_constraint (cl, None, vals, meths, concrs);
|
|
cl_loc = scl.pcl_loc;
|
|
cl_type = clty';
|
|
cl_env = val_env;
|
|
cl_attributes = []; (* attributes are kept on the inner cl node *)
|
|
}
|
|
| Pcl_structure cl_str ->
|
|
let (desc, ty) =
|
|
class_structure cl_num false val_env met_env scl.pcl_loc cl_str in
|
|
rc {cl_desc = Tcl_structure desc;
|
|
cl_loc = scl.pcl_loc;
|
|
cl_type = Cty_signature ty;
|
|
cl_env = val_env;
|
|
cl_attributes = scl.pcl_attributes;
|
|
}
|
|
| Pcl_fun (l, Some default, spat, sbody) ->
|
|
let loc = default.pexp_loc in
|
|
let open Ast_helper in
|
|
let scases = [
|
|
Exp.case
|
|
(Pat.construct ~loc
|
|
(mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))))
|
|
(Some (Pat.var ~loc (mknoloc "*sth*"))))
|
|
(Exp.ident ~loc (mknoloc (Longident.Lident "*sth*")));
|
|
|
|
Exp.case
|
|
(Pat.construct ~loc
|
|
(mknoloc (Longident.(Ldot (Lident "*predef*", "None"))))
|
|
None)
|
|
default;
|
|
]
|
|
in
|
|
let smatch =
|
|
Exp.match_ ~loc (Exp.ident ~loc (mknoloc (Longident.Lident "*opt*")))
|
|
scases
|
|
in
|
|
let sfun =
|
|
Cl.fun_ ~loc:scl.pcl_loc
|
|
l None
|
|
(Pat.var ~loc (mknoloc "*opt*"))
|
|
(Cl.let_ ~loc:scl.pcl_loc Nonrecursive [Vb.mk spat smatch] sbody)
|
|
(* Note: we don't put the '#default' attribute, as it
|
|
is not detected for class-level let bindings. See #5975.*)
|
|
in
|
|
class_expr cl_num val_env met_env sfun
|
|
| Pcl_fun (l, None, spat, scl') ->
|
|
if !Clflags.principal then Ctype.begin_def ();
|
|
let (pat, pv, val_env', met_env) =
|
|
Typecore.type_class_arg_pattern cl_num val_env met_env l spat
|
|
in
|
|
if !Clflags.principal then begin
|
|
Ctype.end_def ();
|
|
let gen {pat_type = ty} = Ctype.generalize_structure ty in
|
|
iter_pattern gen pat
|
|
end;
|
|
let pv =
|
|
List.map
|
|
begin fun (id, id', _ty) ->
|
|
let path = Pident id' in
|
|
(* do not mark the value as being used *)
|
|
let vd = Env.find_value path val_env' in
|
|
(id,
|
|
{exp_desc =
|
|
Texp_ident(path, mknoloc (Longident.Lident (Ident.name id)), vd);
|
|
exp_loc = Location.none; exp_extra = [];
|
|
exp_type = Ctype.instance vd.val_type;
|
|
exp_attributes = []; (* check *)
|
|
exp_env = val_env'})
|
|
end
|
|
pv
|
|
in
|
|
let rec not_nolabel_function = function
|
|
| Cty_arrow(Nolabel, _, _) -> false
|
|
| Cty_arrow(_, _, cty) -> not_nolabel_function cty
|
|
| _ -> true
|
|
in
|
|
let partial =
|
|
let dummy = type_exp val_env (Ast_helper.Exp.unreachable ()) in
|
|
Typecore.check_partial val_env pat.pat_type pat.pat_loc
|
|
[{c_lhs = pat; c_guard = None; c_rhs = dummy}]
|
|
in
|
|
Ctype.raise_nongen_level ();
|
|
let cl = class_expr cl_num val_env' met_env scl' in
|
|
Ctype.end_def ();
|
|
if Btype.is_optional l && not_nolabel_function cl.cl_type then
|
|
Location.prerr_warning pat.pat_loc
|
|
Warnings.Unerasable_optional_argument;
|
|
rc {cl_desc = Tcl_fun (l, pat, pv, cl, partial);
|
|
cl_loc = scl.pcl_loc;
|
|
cl_type = Cty_arrow
|
|
(l, Ctype.instance pat.pat_type, cl.cl_type);
|
|
cl_env = val_env;
|
|
cl_attributes = scl.pcl_attributes;
|
|
}
|
|
| Pcl_apply (scl', sargs) ->
|
|
assert (sargs <> []);
|
|
if !Clflags.principal then Ctype.begin_def ();
|
|
let cl = class_expr cl_num val_env met_env scl' in
|
|
if !Clflags.principal then begin
|
|
Ctype.end_def ();
|
|
generalize_class_type false cl.cl_type;
|
|
end;
|
|
let rec nonopt_labels ls ty_fun =
|
|
match ty_fun with
|
|
| Cty_arrow (l, _, ty_res) ->
|
|
if Btype.is_optional l then nonopt_labels ls ty_res
|
|
else nonopt_labels (l::ls) ty_res
|
|
| _ -> ls
|
|
in
|
|
let ignore_labels =
|
|
!Clflags.classic ||
|
|
let labels = nonopt_labels [] cl.cl_type in
|
|
List.length labels = List.length sargs &&
|
|
List.for_all (fun (l,_) -> l = Nolabel) sargs &&
|
|
List.exists (fun l -> l <> Nolabel) labels &&
|
|
begin
|
|
Location.prerr_warning
|
|
cl.cl_loc
|
|
(Warnings.Labels_omitted
|
|
(List.map Printtyp.string_of_label
|
|
(List.filter ((<>) Nolabel) labels)));
|
|
true
|
|
end
|
|
in
|
|
let rec type_args args omitted ty_fun ty_fun0 sargs =
|
|
match ty_fun, ty_fun0 with
|
|
| Cty_arrow (l, ty, ty_fun), Cty_arrow (_, ty0, ty_fun0)
|
|
when sargs <> [] ->
|
|
let name = Btype.label_name l
|
|
and optional = Btype.is_optional l in
|
|
let use_arg sarg l' =
|
|
Some (
|
|
if not optional || Btype.is_optional l' then
|
|
type_argument val_env sarg ty ty0
|
|
else
|
|
let ty' = extract_option_type val_env ty
|
|
and ty0' = extract_option_type val_env ty0 in
|
|
let arg = type_argument val_env sarg ty' ty0' in
|
|
option_some val_env arg
|
|
)
|
|
in
|
|
let eliminate_optional_arg () =
|
|
Some (option_none val_env ty0 Location.none)
|
|
in
|
|
let remaining_sargs, arg =
|
|
if ignore_labels then begin
|
|
match sargs with
|
|
| [] -> assert false
|
|
| (l', sarg) :: remaining_sargs ->
|
|
if name = Btype.label_name l' ||
|
|
(not optional && l' = Nolabel)
|
|
then
|
|
(remaining_sargs, use_arg sarg l')
|
|
else if
|
|
optional &&
|
|
not (List.exists (fun (l, _) -> name = Btype.label_name l)
|
|
remaining_sargs)
|
|
then
|
|
(sargs, eliminate_optional_arg ())
|
|
else
|
|
raise(Error(sarg.pexp_loc, val_env, Apply_wrong_label l'))
|
|
end else
|
|
match Btype.extract_label name sargs with
|
|
| Some (l', sarg, _, remaining_sargs) ->
|
|
if not optional && Btype.is_optional l' then
|
|
Location.prerr_warning sarg.pexp_loc
|
|
(Warnings.Nonoptional_label
|
|
(Printtyp.string_of_label l));
|
|
remaining_sargs, use_arg sarg l'
|
|
| None ->
|
|
sargs,
|
|
if Btype.is_optional l && List.mem_assoc Nolabel sargs then
|
|
eliminate_optional_arg ()
|
|
else
|
|
None
|
|
in
|
|
let omitted = if arg = None then (l,ty0) :: omitted else omitted in
|
|
type_args ((l,arg)::args) omitted ty_fun ty_fun0 remaining_sargs
|
|
| _ ->
|
|
match sargs with
|
|
(l, sarg0)::_ ->
|
|
if omitted <> [] then
|
|
raise(Error(sarg0.pexp_loc, val_env, Apply_wrong_label l))
|
|
else
|
|
raise(Error(cl.cl_loc, val_env, Cannot_apply cl.cl_type))
|
|
| [] ->
|
|
(List.rev args,
|
|
List.fold_left
|
|
(fun ty_fun (l,ty) -> Cty_arrow(l,ty,ty_fun))
|
|
ty_fun0 omitted)
|
|
in
|
|
let (args, cty) =
|
|
let (_, ty_fun0) = Ctype.instance_class [] cl.cl_type in
|
|
type_args [] [] cl.cl_type ty_fun0 sargs
|
|
in
|
|
rc {cl_desc = Tcl_apply (cl, args);
|
|
cl_loc = scl.pcl_loc;
|
|
cl_type = cty;
|
|
cl_env = val_env;
|
|
cl_attributes = scl.pcl_attributes;
|
|
}
|
|
| Pcl_let (rec_flag, sdefs, scl') ->
|
|
let (defs, val_env) =
|
|
Typecore.type_let In_class_def val_env rec_flag sdefs in
|
|
let (vals, met_env) =
|
|
List.fold_right
|
|
(fun (id, _id_loc, _typ) (vals, met_env) ->
|
|
let path = Pident id in
|
|
(* do not mark the value as used *)
|
|
let vd = Env.find_value path val_env in
|
|
Ctype.begin_def ();
|
|
let expr =
|
|
{exp_desc =
|
|
Texp_ident(path, mknoloc(Longident.Lident (Ident.name id)),vd);
|
|
exp_loc = Location.none; exp_extra = [];
|
|
exp_type = Ctype.instance vd.val_type;
|
|
exp_attributes = [];
|
|
exp_env = val_env;
|
|
}
|
|
in
|
|
Ctype.end_def ();
|
|
Ctype.generalize expr.exp_type;
|
|
let desc =
|
|
{val_type = expr.exp_type; val_kind = Val_ivar (Immutable,
|
|
cl_num);
|
|
val_attributes = [];
|
|
Types.val_loc = vd.Types.val_loc;
|
|
val_uid = vd.val_uid;
|
|
}
|
|
in
|
|
let id' = Ident.create_local (Ident.name id) in
|
|
((id', expr)
|
|
:: vals,
|
|
Env.add_value id' desc met_env))
|
|
(let_bound_idents_full defs)
|
|
([], met_env)
|
|
in
|
|
let cl = class_expr cl_num val_env met_env scl' in
|
|
let () = if rec_flag = Recursive then
|
|
check_recursive_bindings val_env defs
|
|
in
|
|
rc {cl_desc = Tcl_let (rec_flag, defs, vals, cl);
|
|
cl_loc = scl.pcl_loc;
|
|
cl_type = cl.cl_type;
|
|
cl_env = val_env;
|
|
cl_attributes = scl.pcl_attributes;
|
|
}
|
|
| Pcl_constraint (scl', scty) ->
|
|
Ctype.begin_class_def ();
|
|
let context = Typetexp.narrow () in
|
|
let cl = class_expr cl_num val_env met_env scl' in
|
|
Typetexp.widen context;
|
|
let context = Typetexp.narrow () in
|
|
let clty = class_type val_env scty in
|
|
Typetexp.widen context;
|
|
Ctype.end_def ();
|
|
|
|
limited_generalize (Ctype.row_variable (Ctype.self_type cl.cl_type))
|
|
cl.cl_type;
|
|
limited_generalize (Ctype.row_variable (Ctype.self_type clty.cltyp_type))
|
|
clty.cltyp_type;
|
|
|
|
begin match
|
|
Includeclass.class_types val_env cl.cl_type clty.cltyp_type
|
|
with
|
|
[] -> ()
|
|
| error -> raise(Error(cl.cl_loc, val_env, Class_match_failure error))
|
|
end;
|
|
let (vals, meths, concrs) = extract_constraints clty.cltyp_type in
|
|
rc {cl_desc = Tcl_constraint (cl, Some clty, vals, meths, concrs);
|
|
cl_loc = scl.pcl_loc;
|
|
cl_type = snd (Ctype.instance_class [] clty.cltyp_type);
|
|
cl_env = val_env;
|
|
cl_attributes = scl.pcl_attributes;
|
|
}
|
|
| Pcl_open (pod, e) ->
|
|
let used_slot = ref false in
|
|
let (od, new_val_env) = !type_open_descr ~used_slot val_env pod in
|
|
let ( _, new_met_env) = !type_open_descr ~used_slot met_env pod in
|
|
let cl = class_expr cl_num new_val_env new_met_env e in
|
|
rc {cl_desc = Tcl_open (od, cl);
|
|
cl_loc = scl.pcl_loc;
|
|
cl_type = cl.cl_type;
|
|
cl_env = val_env;
|
|
cl_attributes = scl.pcl_attributes;
|
|
}
|
|
| Pcl_extension ext ->
|
|
raise (Error_forward (Builtin_attributes.error_of_extension ext))
|
|
|
|
(*******************************)
|
|
|
|
(* Approximate the type of the constructor to allow recursive use *)
|
|
(* of optional parameters *)
|
|
|
|
let var_option = Predef.type_option (Btype.newgenvar ())
|
|
|
|
let rec approx_declaration cl =
|
|
match cl.pcl_desc with
|
|
Pcl_fun (l, _, _, cl) ->
|
|
let arg =
|
|
if Btype.is_optional l then Ctype.instance var_option
|
|
else Ctype.newvar () in
|
|
Ctype.newty (Tarrow (l, arg, approx_declaration cl, Cok))
|
|
| Pcl_let (_, _, cl) ->
|
|
approx_declaration cl
|
|
| Pcl_constraint (cl, _) ->
|
|
approx_declaration cl
|
|
| _ -> Ctype.newvar ()
|
|
|
|
let rec approx_description ct =
|
|
match ct.pcty_desc with
|
|
Pcty_arrow (l, _, ct) ->
|
|
let arg =
|
|
if Btype.is_optional l then Ctype.instance var_option
|
|
else Ctype.newvar () in
|
|
Ctype.newty (Tarrow (l, arg, approx_description ct, Cok))
|
|
| _ -> Ctype.newvar ()
|
|
|
|
(*******************************)
|
|
|
|
let temp_abbrev loc env id arity uid =
|
|
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 ~check:true id
|
|
{type_params = !params;
|
|
type_arity = arity;
|
|
type_kind = Type_abstract;
|
|
type_private = Public;
|
|
type_manifest = Some ty;
|
|
type_variance = Variance.unknown_signature ~injective:false ~arity;
|
|
type_separability = Types.Separability.default_signature ~arity;
|
|
type_is_newtype = false;
|
|
type_expansion_scope = Btype.lowest_level;
|
|
type_loc = loc;
|
|
type_attributes = []; (* or keep attrs from the class decl? *)
|
|
type_immediate = Unknown;
|
|
type_unboxed = unboxed_false_default_false;
|
|
type_uid = uid;
|
|
}
|
|
env
|
|
in
|
|
(!params, ty, env)
|
|
|
|
let initial_env define_class approx
|
|
(res, env) (cl, id, ty_id, obj_id, cl_id, uid) =
|
|
(* Temporary abbreviations *)
|
|
let arity = List.length cl.pci_params in
|
|
let (obj_params, obj_ty, env) = temp_abbrev cl.pci_loc env obj_id arity uid in
|
|
let (cl_params, cl_ty, env) = temp_abbrev cl.pci_loc env cl_id arity uid in
|
|
|
|
(* Temporary type for the class constructor *)
|
|
let constr_type = approx cl.pci_expr in
|
|
if !Clflags.principal then Ctype.generalize_spine constr_type;
|
|
let dummy_cty =
|
|
Cty_signature
|
|
{ csig_self = Ctype.newvar ();
|
|
csig_vars = Vars.empty;
|
|
csig_concr = Concr.empty;
|
|
csig_inher = [] }
|
|
in
|
|
let dummy_class =
|
|
{Types.cty_params = []; (* Dummy value *)
|
|
cty_variance = [];
|
|
cty_type = dummy_cty; (* Dummy value *)
|
|
cty_path = unbound_class;
|
|
cty_new =
|
|
begin match cl.pci_virt with
|
|
| Virtual -> None
|
|
| Concrete -> Some constr_type
|
|
end;
|
|
cty_loc = Location.none;
|
|
cty_attributes = [];
|
|
cty_uid = uid;
|
|
}
|
|
in
|
|
let env =
|
|
Env.add_cltype ty_id
|
|
{clty_params = []; (* Dummy value *)
|
|
clty_variance = [];
|
|
clty_type = dummy_cty; (* Dummy value *)
|
|
clty_path = unbound_class;
|
|
clty_loc = Location.none;
|
|
clty_attributes = [];
|
|
clty_uid = uid;
|
|
}
|
|
(
|
|
if define_class then
|
|
Env.add_class id dummy_class env
|
|
else
|
|
env
|
|
)
|
|
in
|
|
((cl, id, ty_id,
|
|
obj_id, obj_params, obj_ty,
|
|
cl_id, cl_params, cl_ty,
|
|
constr_type, dummy_class)::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, dummy_class)
|
|
(res, env) =
|
|
|
|
reset_type_variables ();
|
|
Ctype.begin_class_def ();
|
|
|
|
(* Introduce class parameters *)
|
|
let ci_params =
|
|
let make_param (sty, v) =
|
|
try
|
|
(transl_type_param env sty, v)
|
|
with Already_bound ->
|
|
raise(Error(sty.ptyp_loc, env, Repeated_parameter))
|
|
in
|
|
List.map make_param cl.pci_params
|
|
in
|
|
let params = List.map (fun (cty, _) -> cty.ctyp_type) ci_params in
|
|
|
|
(* Allow self coercions (only for class declarations) *)
|
|
let coercion_locs = ref [] in
|
|
|
|
(* Type the class expression *)
|
|
let (expr, typ) =
|
|
try
|
|
Typecore.self_coercion :=
|
|
(Path.Pident obj_id, coercion_locs) :: !Typecore.self_coercion;
|
|
let res = kind env cl.pci_expr in
|
|
Typecore.self_coercion := List.tl !Typecore.self_coercion;
|
|
res
|
|
with exn ->
|
|
Typecore.self_coercion := []; raise exn
|
|
in
|
|
|
|
Ctype.end_def ();
|
|
|
|
let sty = Ctype.self_type typ in
|
|
|
|
(* First generalize the type of the dummy method (cf PR#6123) *)
|
|
let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sty) in
|
|
List.iter (fun (met, _, ty) -> if met = dummy_method then Ctype.generalize ty)
|
|
fields;
|
|
(* Generalize the row variable *)
|
|
let rv = Ctype.row_variable sty 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;
|
|
if not (Ctype.close_object ty) then
|
|
raise(Error(cl.pci_loc, env, Closing_self_type ty));
|
|
begin try
|
|
List.iter2 (Ctype.unify env) obj_params obj_params'
|
|
with Ctype.Unify _ ->
|
|
raise(Error(cl.pci_loc, env,
|
|
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, env,
|
|
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, env,
|
|
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, env, Abbrev_type_clash (constr, ty, cl_ty)))
|
|
end
|
|
end;
|
|
|
|
(* Type of the class constructor *)
|
|
begin try
|
|
Ctype.unify env
|
|
(constructor_type constr obj_type)
|
|
(Ctype.instance constr_type)
|
|
with Ctype.Unify trace ->
|
|
raise(Error(cl.pci_loc, env,
|
|
Constructor_type_mismatch (cl.pci_name.txt, trace)))
|
|
end;
|
|
|
|
(* Class and class type temporary definitions *)
|
|
let cty_variance =
|
|
Variance.unknown_signature ~injective:false ~arity:(List.length params) in
|
|
let cltydef =
|
|
{clty_params = params; clty_type = class_body typ;
|
|
clty_variance = cty_variance;
|
|
clty_path = Path.Pident obj_id;
|
|
clty_loc = cl.pci_loc;
|
|
clty_attributes = cl.pci_attributes;
|
|
clty_uid = dummy_class.cty_uid;
|
|
}
|
|
and clty =
|
|
{cty_params = params; cty_type = typ;
|
|
cty_variance = cty_variance;
|
|
cty_path = Path.Pident obj_id;
|
|
cty_new =
|
|
begin match cl.pci_virt with
|
|
| Virtual -> None
|
|
| Concrete -> Some constr_type
|
|
end;
|
|
cty_loc = cl.pci_loc;
|
|
cty_attributes = cl.pci_attributes;
|
|
cty_uid = dummy_class.cty_uid;
|
|
}
|
|
in
|
|
dummy_class.cty_type <- typ;
|
|
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
|
|
let sign = Ctype.signature_of_class_type typ in
|
|
let mets = virtual_methods sign in
|
|
let vals =
|
|
Vars.fold
|
|
(fun name (_mut, vr, _ty) l -> if vr = Virtual then name :: l else l)
|
|
sign.csig_vars [] in
|
|
if mets <> [] || vals <> [] then
|
|
raise(Error(cl.pci_loc, env, Virtual_class(define_class, false, mets,
|
|
vals)));
|
|
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_variance = cty_variance;
|
|
clty_path = Path.Pident obj_id;
|
|
clty_loc = cl.pci_loc;
|
|
clty_attributes = cl.pci_attributes;
|
|
clty_uid = dummy_class.cty_uid;
|
|
}
|
|
and clty =
|
|
{cty_params = params'; cty_type = typ';
|
|
cty_variance = cty_variance;
|
|
cty_path = Path.Pident obj_id;
|
|
cty_new =
|
|
begin match cl.pci_virt with
|
|
| Virtual -> None
|
|
| Concrete -> Some (Ctype.instance constr_type)
|
|
end;
|
|
cty_loc = cl.pci_loc;
|
|
cty_attributes = cl.pci_attributes;
|
|
cty_uid = dummy_class.cty_uid;
|
|
}
|
|
in
|
|
let obj_abbr =
|
|
let arity = List.length obj_params in
|
|
{
|
|
type_params = obj_params;
|
|
type_arity = arity;
|
|
type_kind = Type_abstract;
|
|
type_private = Public;
|
|
type_manifest = Some obj_ty;
|
|
type_variance = Variance.unknown_signature ~injective:false ~arity;
|
|
type_separability = Types.Separability.default_signature ~arity;
|
|
type_is_newtype = false;
|
|
type_expansion_scope = Btype.lowest_level;
|
|
type_loc = cl.pci_loc;
|
|
type_attributes = []; (* or keep attrs from cl? *)
|
|
type_immediate = Unknown;
|
|
type_unboxed = unboxed_false_default_false;
|
|
type_uid = dummy_class.cty_uid;
|
|
}
|
|
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 =
|
|
let arity = List.length cl_params in
|
|
{
|
|
type_params = cl_params;
|
|
type_arity = arity;
|
|
type_kind = Type_abstract;
|
|
type_private = Public;
|
|
type_manifest = Some cl_ty;
|
|
type_variance = Variance.unknown_signature ~injective:false ~arity;
|
|
type_separability = Types.Separability.default_signature ~arity;
|
|
type_is_newtype = false;
|
|
type_expansion_scope = Btype.lowest_level;
|
|
type_loc = cl.pci_loc;
|
|
type_attributes = []; (* or keep attrs from cl? *)
|
|
type_immediate = Unknown;
|
|
type_unboxed = unboxed_false_default_false;
|
|
type_uid = dummy_class.cty_uid;
|
|
}
|
|
in
|
|
((cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, ci_params,
|
|
arity, pub_meths, List.rev !coercion_locs, expr) :: res,
|
|
env)
|
|
|
|
let final_decl env define_class
|
|
(cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, ci_params,
|
|
arity, pub_meths, coe, expr) =
|
|
|
|
begin try Ctype.collapse_conj_params env clty.cty_params
|
|
with Ctype.Unify trace ->
|
|
raise(Error(cl.pci_loc, env, Non_collapsable_conjunction (id, clty, trace)))
|
|
end;
|
|
|
|
(* make the dummy method disappear *)
|
|
begin
|
|
let self_type = Ctype.self_type clty.cty_type in
|
|
let methods, _ =
|
|
Ctype.flatten_fields
|
|
(Ctype.object_fields (Ctype.expand_head env self_type))
|
|
in
|
|
List.iter (fun (lab,kind,_) ->
|
|
if lab = dummy_method then
|
|
match Btype.field_kind_repr kind with
|
|
Fvar r -> Btype.set_kind r Fabsent
|
|
| _ -> ()
|
|
) methods
|
|
end;
|
|
|
|
List.iter Ctype.generalize clty.cty_params;
|
|
generalize_class_type true clty.cty_type;
|
|
Option.iter Ctype.generalize clty.cty_new;
|
|
List.iter Ctype.generalize obj_abbr.type_params;
|
|
Option.iter Ctype.generalize obj_abbr.type_manifest;
|
|
List.iter Ctype.generalize cl_abbr.type_params;
|
|
Option.iter Ctype.generalize cl_abbr.type_manifest;
|
|
|
|
if not (closed_class clty) then
|
|
raise(Error(cl.pci_loc, env, Non_generalizable_class (id, clty)));
|
|
|
|
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 function ppf -> Printtyp.class_declaration id ppf clty
|
|
else function ppf -> Printtyp.cltype_declaration id ppf cltydef
|
|
in
|
|
raise(Error(cl.pci_loc, env, Unbound_type_var(printer, reason)))
|
|
end;
|
|
{ id; clty; ty_id; cltydef; obj_id; obj_abbr; cl_id; cl_abbr; arity;
|
|
pub_meths; coe; expr;
|
|
id_loc = cl.pci_name;
|
|
req = { ci_loc = cl.pci_loc;
|
|
ci_virt = cl.pci_virt;
|
|
ci_params = ci_params;
|
|
(* TODO : check that we have the correct use of identifiers *)
|
|
ci_id_name = cl.pci_name;
|
|
ci_id_class = id;
|
|
ci_id_class_type = ty_id;
|
|
ci_id_object = obj_id;
|
|
ci_id_typehash = cl_id;
|
|
ci_expr = expr;
|
|
ci_decl = clty;
|
|
ci_type_decl = cltydef;
|
|
ci_attributes = cl.pci_attributes;
|
|
}
|
|
}
|
|
(* (cl.pci_variance, cl.pci_loc)) *)
|
|
|
|
let class_infos define_class kind
|
|
(cl, id, ty_id,
|
|
obj_id, obj_params, obj_ty,
|
|
cl_id, cl_params, cl_ty,
|
|
constr_type, dummy_class)
|
|
(res, env) =
|
|
Builtin_attributes.warning_scope cl.pci_attributes
|
|
(fun () ->
|
|
class_infos define_class kind
|
|
(cl, id, ty_id,
|
|
obj_id, obj_params, obj_ty,
|
|
cl_id, cl_params, cl_ty,
|
|
constr_type, dummy_class)
|
|
(res, env)
|
|
)
|
|
|
|
let extract_type_decls { clty; cltydef; obj_id; obj_abbr; cl_abbr; req} decls =
|
|
(obj_id, obj_abbr, cl_abbr, clty, cltydef, req) :: decls
|
|
|
|
let merge_type_decls decl (obj_abbr, cl_abbr, clty, cltydef) =
|
|
{decl with obj_abbr; cl_abbr; clty; cltydef}
|
|
|
|
let final_env define_class env { id; clty; ty_id; cltydef; obj_id; obj_abbr;
|
|
cl_id; cl_abbr } =
|
|
(* Add definitions after cleaning them *)
|
|
Env.add_type ~check:true obj_id
|
|
(Subst.type_declaration Subst.identity obj_abbr) (
|
|
Env.add_type ~check:true cl_id
|
|
(Subst.type_declaration Subst.identity cl_abbr) (
|
|
Env.add_cltype ty_id (Subst.cltype_declaration Subst.identity cltydef) (
|
|
if define_class then
|
|
Env.add_class id (Subst.class_declaration Subst.identity clty) env
|
|
else env)))
|
|
|
|
(* Check that #c is coercible to c if there is a self-coercion *)
|
|
let check_coercions env { id; id_loc; clty; ty_id; cltydef; obj_id; obj_abbr;
|
|
cl_id; cl_abbr; arity; pub_meths; coe; req } =
|
|
begin match coe with [] -> ()
|
|
| loc :: _ ->
|
|
let cl_ty, obj_ty =
|
|
match cl_abbr.type_manifest, obj_abbr.type_manifest with
|
|
Some cl_ab, Some obj_ab ->
|
|
let cl_params, cl_ty =
|
|
Ctype.instance_parameterized_type cl_abbr.type_params cl_ab
|
|
and obj_params, obj_ty =
|
|
Ctype.instance_parameterized_type obj_abbr.type_params obj_ab
|
|
in
|
|
List.iter2 (Ctype.unify env) cl_params obj_params;
|
|
cl_ty, obj_ty
|
|
| _ -> assert false
|
|
in
|
|
begin try Ctype.subtype env cl_ty obj_ty ()
|
|
with Ctype.Subtype (tr1, tr2) ->
|
|
raise(Typecore.Error(loc, env, Typecore.Not_subtype(tr1, tr2)))
|
|
end;
|
|
if not (Ctype.opened_object cl_ty) then
|
|
raise(Error(loc, env, Cannot_coerce_self obj_ty))
|
|
end;
|
|
{cls_id = id;
|
|
cls_id_loc = id_loc;
|
|
cls_decl = clty;
|
|
cls_ty_id = ty_id;
|
|
cls_ty_decl = cltydef;
|
|
cls_obj_id = obj_id;
|
|
cls_obj_abbr = obj_abbr;
|
|
cls_typesharp_id = cl_id;
|
|
cls_abbr = cl_abbr;
|
|
cls_arity = arity;
|
|
cls_pub_methods = pub_meths;
|
|
cls_info=req}
|
|
|
|
(*******************************)
|
|
|
|
let type_classes define_class approx kind env cls =
|
|
let scope = Ctype.create_scope () in
|
|
let cls =
|
|
List.map
|
|
(function cl ->
|
|
(cl,
|
|
Ident.create_scoped ~scope cl.pci_name.txt,
|
|
Ident.create_scoped ~scope cl.pci_name.txt,
|
|
Ident.create_scoped ~scope cl.pci_name.txt,
|
|
Ident.create_scoped ~scope ("#" ^ cl.pci_name.txt),
|
|
Uid.mk ~current_unit:(Env.get_unit_name ())
|
|
))
|
|
cls
|
|
in
|
|
Ctype.begin_class_def ();
|
|
let (res, env) =
|
|
List.fold_left (initial_env define_class approx) ([], env) cls
|
|
in
|
|
let (res, env) =
|
|
List.fold_right (class_infos define_class kind) res ([], env)
|
|
in
|
|
Ctype.end_def ();
|
|
let res = List.rev_map (final_decl env define_class) res in
|
|
let decls = List.fold_right extract_type_decls res [] in
|
|
let decls =
|
|
try Typedecl_variance.update_class_decls env decls
|
|
with Typedecl_variance.Error(loc, err) ->
|
|
raise (Typedecl.Error(loc, Typedecl.Variance err))
|
|
in
|
|
let res = List.map2 merge_type_decls res decls in
|
|
let env = List.fold_left (final_env define_class) env res in
|
|
let res = List.map (check_coercions env) res in
|
|
(res, env)
|
|
|
|
let class_num = ref 0
|
|
let class_declaration env sexpr =
|
|
incr class_num;
|
|
let expr = class_expr (Int.to_string !class_num) env env sexpr in
|
|
(expr, expr.cl_type)
|
|
|
|
let class_description env sexpr =
|
|
let expr = class_type env sexpr in
|
|
(expr, expr.cltyp_type)
|
|
|
|
let class_declarations env cls =
|
|
let info, env =
|
|
type_classes true approx_declaration class_declaration env cls
|
|
in
|
|
let ids, exprs =
|
|
List.split
|
|
(List.map
|
|
(fun ci -> ci.cls_id, ci.cls_info.ci_expr)
|
|
info)
|
|
in
|
|
check_recursive_class_bindings env ids exprs;
|
|
info, env
|
|
|
|
let class_descriptions env cls =
|
|
type_classes true approx_description class_description env cls
|
|
|
|
let class_type_declarations env cls =
|
|
let (decls, env) =
|
|
type_classes false approx_description class_description env cls
|
|
in
|
|
(List.map
|
|
(fun decl ->
|
|
{clsty_ty_id = decl.cls_ty_id;
|
|
clsty_id_loc = decl.cls_id_loc;
|
|
clsty_ty_decl = decl.cls_ty_decl;
|
|
clsty_obj_id = decl.cls_obj_id;
|
|
clsty_obj_abbr = decl.cls_obj_abbr;
|
|
clsty_typesharp_id = decl.cls_typesharp_id;
|
|
clsty_abbr = decl.cls_abbr;
|
|
clsty_info = decl.cls_info})
|
|
decls,
|
|
env)
|
|
|
|
let rec unify_parents env ty cl =
|
|
match cl.cl_desc with
|
|
Tcl_ident (p, _, _) ->
|
|
begin try
|
|
let decl = Env.find_class p env in
|
|
let _, body = Ctype.find_cltype_for_path env decl.cty_path in
|
|
Ctype.unify env ty (Ctype.instance body)
|
|
with
|
|
Not_found -> ()
|
|
| _exn -> assert false
|
|
end
|
|
| Tcl_structure st -> unify_parents_struct env ty st
|
|
| Tcl_open (_, cl)
|
|
| Tcl_fun (_, _, _, cl, _)
|
|
| Tcl_apply (cl, _)
|
|
| Tcl_let (_, _, _, cl)
|
|
| Tcl_constraint (cl, _, _, _, _) -> unify_parents env ty cl
|
|
and unify_parents_struct env ty st =
|
|
List.iter
|
|
(function
|
|
| {cf_desc = Tcf_inherit (_, cl, _, _, _)} ->
|
|
unify_parents env ty cl
|
|
| _ -> ())
|
|
st.cstr_fields
|
|
|
|
let type_object env loc s =
|
|
incr class_num;
|
|
let (desc, sign) =
|
|
class_structure (Int.to_string !class_num) true env env loc s in
|
|
let sty = Ctype.expand_head env sign.csig_self in
|
|
Ctype.hide_private_methods sty;
|
|
let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sty) in
|
|
let meths = List.map (fun (s,_,_) -> s) fields in
|
|
unify_parents_struct env sign.csig_self desc;
|
|
(desc, sign, meths)
|
|
|
|
let () =
|
|
Typecore.type_object := type_object
|
|
|
|
(*******************************)
|
|
|
|
(* Approximate the class declaration as class ['params] id = object end *)
|
|
let approx_class sdecl =
|
|
let open Ast_helper in
|
|
let self' = Typ.any () in
|
|
let clty' = Cty.signature ~loc:sdecl.pci_expr.pcty_loc (Csig.mk self' []) in
|
|
{ sdecl with pci_expr = clty' }
|
|
|
|
let approx_class_declarations env sdecls =
|
|
fst (class_type_declarations env (List.map approx_class sdecls))
|
|
|
|
(*******************************)
|
|
|
|
(* Error report *)
|
|
|
|
open Format
|
|
|
|
let report_error env ppf = function
|
|
| Repeated_parameter ->
|
|
fprintf ppf "A type parameter occurs several times"
|
|
| Unconsistent_constraint trace ->
|
|
fprintf ppf "The class constraints are not consistent.@.";
|
|
Printtyp.report_unification_error ppf env trace
|
|
(fun ppf -> fprintf ppf "Type")
|
|
(fun ppf -> fprintf ppf "is not compatible with type")
|
|
| Field_type_mismatch (k, m, trace) ->
|
|
Printtyp.report_unification_error ppf env trace
|
|
(function ppf ->
|
|
fprintf ppf "The %s %s@ has type" k m)
|
|
(function ppf ->
|
|
fprintf ppf "but is expected to have type")
|
|
| Structure_expected clty ->
|
|
fprintf ppf
|
|
"@[This class expression is not a class structure; it has type@ %a@]"
|
|
Printtyp.class_type clty
|
|
| Cannot_apply _ ->
|
|
fprintf ppf
|
|
"This class expression is not a class function, it cannot be applied"
|
|
| Apply_wrong_label l ->
|
|
let mark_label = function
|
|
| Nolabel -> "out label"
|
|
| l -> sprintf " label %s" (Btype.prefixed_label_name l) in
|
|
fprintf ppf "This argument cannot be applied with%s" (mark_label l)
|
|
| Pattern_type_clash ty ->
|
|
(* XXX Trace *)
|
|
(* XXX Revoir message d'erreur | Improve error message *)
|
|
fprintf ppf "@[%s@ %a@]"
|
|
"This pattern cannot match self: it only matches values of type"
|
|
Printtyp.type_expr ty
|
|
| Unbound_class_2 cl ->
|
|
fprintf ppf "@[The class@ %a@ is not yet completely defined@]"
|
|
Printtyp.longident cl
|
|
| Unbound_class_type_2 cl ->
|
|
fprintf ppf "@[The class type@ %a@ is not yet completely defined@]"
|
|
Printtyp.longident cl
|
|
| Abbrev_type_clash (abbrev, actual, expected) ->
|
|
(* XXX Afficher une trace ? | Print a trace? *)
|
|
Printtyp.reset_and_mark_loops_list [abbrev; actual; expected];
|
|
fprintf ppf "@[The abbreviation@ %a@ expands to type@ %a@ \
|
|
but is used with type@ %a@]"
|
|
!Oprint.out_type (Printtyp.tree_of_typexp false abbrev)
|
|
!Oprint.out_type (Printtyp.tree_of_typexp false actual)
|
|
!Oprint.out_type (Printtyp.tree_of_typexp false expected)
|
|
| Constructor_type_mismatch (c, trace) ->
|
|
Printtyp.report_unification_error ppf env trace
|
|
(function ppf ->
|
|
fprintf ppf "The expression \"new %s\" has type" c)
|
|
(function ppf ->
|
|
fprintf ppf "but is used with type")
|
|
| Virtual_class (cl, imm, mets, vals) ->
|
|
let print_mets ppf mets =
|
|
List.iter (function met -> fprintf ppf "@ %s" met) mets in
|
|
let missings =
|
|
match mets, vals with
|
|
[], _ -> "variables"
|
|
| _, [] -> "methods"
|
|
| _ -> "methods and variables"
|
|
in
|
|
let print_msg ppf =
|
|
if imm then fprintf ppf "This object has virtual %s" missings
|
|
else if cl then fprintf ppf "This class should be virtual"
|
|
else fprintf ppf "This class type should be virtual"
|
|
in
|
|
fprintf ppf
|
|
"@[%t.@ @[<2>The following %s are undefined :%a@]@]"
|
|
print_msg missings print_mets (mets @ vals)
|
|
| Parameter_arity_mismatch(lid, expected, provided) ->
|
|
fprintf ppf
|
|
"@[The class constructor %a@ expects %i type argument(s),@ \
|
|
but is here applied to %i type argument(s)@]"
|
|
Printtyp.longident lid expected provided
|
|
| Parameter_mismatch trace ->
|
|
Printtyp.report_unification_error ppf env trace
|
|
(function ppf ->
|
|
fprintf ppf "The type parameter")
|
|
(function ppf ->
|
|
fprintf ppf "does not meet its constraint: it should be")
|
|
| Bad_parameters (id, params, cstrs) ->
|
|
Printtyp.reset_and_mark_loops_list [params; cstrs];
|
|
fprintf ppf
|
|
"@[The abbreviation %a@ is used with parameters@ %a@ \
|
|
which are incompatible with constraints@ %a@]"
|
|
Printtyp.ident id
|
|
!Oprint.out_type (Printtyp.tree_of_typexp false params)
|
|
!Oprint.out_type (Printtyp.tree_of_typexp false cstrs)
|
|
| Class_match_failure error ->
|
|
Includeclass.report_error ppf error
|
|
| Unbound_val lab ->
|
|
fprintf ppf "Unbound instance variable %s" lab
|
|
| Unbound_type_var (printer, reason) ->
|
|
let print_common ppf kind ty0 real lab ty =
|
|
let ty1 =
|
|
if real then ty0 else Btype.newgenty(Tobject(ty0, ref None)) in
|
|
List.iter Printtyp.mark_loops [ty; ty1];
|
|
fprintf ppf
|
|
"The %s %s@ has type@;<1 2>%a@ where@ %a@ is unbound"
|
|
kind lab
|
|
!Oprint.out_type (Printtyp.tree_of_typexp false ty)
|
|
!Oprint.out_type (Printtyp.tree_of_typexp false ty0)
|
|
in
|
|
let print_reason ppf = function
|
|
| Ctype.CC_Method (ty0, real, lab, ty) ->
|
|
print_common ppf "method" ty0 real lab ty
|
|
| Ctype.CC_Value (ty0, real, lab, ty) ->
|
|
print_common ppf "instance variable" ty0 real lab ty
|
|
in
|
|
Printtyp.reset ();
|
|
fprintf ppf
|
|
"@[<v>@[Some type variables are unbound in this type:@;<1 2>%t@]@ \
|
|
@[%a@]@]"
|
|
printer print_reason reason
|
|
| Non_generalizable_class (id, clty) ->
|
|
fprintf ppf
|
|
"@[The type of this class,@ %a,@ \
|
|
contains type variables that cannot be generalized@]"
|
|
(Printtyp.class_declaration id) clty
|
|
| Cannot_coerce_self ty ->
|
|
fprintf ppf
|
|
"@[The type of self cannot be coerced to@ \
|
|
the type of the current class:@ %a.@.\
|
|
Some occurrences are contravariant@]"
|
|
Printtyp.type_scheme ty
|
|
| Non_collapsable_conjunction (id, clty, trace) ->
|
|
fprintf ppf
|
|
"@[The type of this class,@ %a,@ \
|
|
contains non-collapsible conjunctive types in constraints.@ %t@]"
|
|
(Printtyp.class_declaration id) clty
|
|
(fun ppf -> Printtyp.report_unification_error ppf env trace
|
|
(fun ppf -> fprintf ppf "Type")
|
|
(fun ppf -> fprintf ppf "is not compatible with type")
|
|
)
|
|
| Final_self_clash trace ->
|
|
Printtyp.report_unification_error ppf env trace
|
|
(function ppf ->
|
|
fprintf ppf "This object is expected to have type")
|
|
(function ppf ->
|
|
fprintf ppf "but actually has type")
|
|
| Mutability_mismatch (_lab, mut) ->
|
|
let mut1, mut2 =
|
|
if mut = Immutable then "mutable", "immutable"
|
|
else "immutable", "mutable" in
|
|
fprintf ppf
|
|
"@[The instance variable is %s;@ it cannot be redefined as %s@]"
|
|
mut1 mut2
|
|
| No_overriding (_, "") ->
|
|
fprintf ppf "@[This inheritance does not override any method@ %s@]"
|
|
"instance variable"
|
|
| No_overriding (kind, name) ->
|
|
fprintf ppf "@[The %s `%s'@ has no previous definition@]" kind name
|
|
| Duplicate (kind, name) ->
|
|
fprintf ppf "@[The %s `%s'@ has multiple definitions in this object@]"
|
|
kind name
|
|
| Closing_self_type self ->
|
|
fprintf ppf
|
|
"@[Cannot close type of object literal:@ %a@,\
|
|
it has been unified with the self type of a class that is not yet@ \
|
|
completely defined.@]"
|
|
Printtyp.type_scheme self
|
|
|
|
let report_error env ppf err =
|
|
Printtyp.wrap_printing_env ~error:true
|
|
env (fun () -> report_error env ppf err)
|
|
|
|
let () =
|
|
Location.register_error_of_exn
|
|
(function
|
|
| Error (loc, env, err) ->
|
|
Some (Location.error_of_printer ~loc (report_error env) err)
|
|
| Error_forward err ->
|
|
Some err
|
|
| _ ->
|
|
None
|
|
)
|