summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--bytecomp/translclass.ml57
-rw-r--r--bytecomp/translcore.ml7
-rw-r--r--parsing/parser.mly146
-rw-r--r--parsing/parsetree.mli8
-rw-r--r--stdlib/oo.ml81
-rw-r--r--stdlib/oo.mli7
-rw-r--r--testobjects/Exemples.exp64
-rw-r--r--testobjects/Tests.exp14
-rw-r--r--testobjects/Tests.ml14
-rw-r--r--tools/ocamlprof.ml4
-rw-r--r--toplevel/genprintval.ml2
-rw-r--r--typing/btype.ml6
-rw-r--r--typing/btype.mli4
-rw-r--r--typing/includecore.ml31
-rw-r--r--typing/printtyp.ml54
-rw-r--r--typing/subst.ml15
-rw-r--r--typing/typeclass.ml333
-rw-r--r--typing/typecore.ml62
-rw-r--r--typing/typecore.mli4
-rw-r--r--typing/typedtree.ml10
-rw-r--r--typing/typedtree.mli10
-rw-r--r--typing/types.ml16
-rw-r--r--typing/types.mli16
-rw-r--r--typing/typetexp.ml2
24 files changed, 625 insertions, 342 deletions
diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml
index bb3882c365..856bf22689 100644
--- a/bytecomp/translclass.ml
+++ b/bytecomp/translclass.ml
@@ -22,17 +22,23 @@ open Translcore
let transl_label l = Lconst (Const_base (Const_string l))
+let rec transl_meth_list =
+ function
+ [] -> Const_pointer 0
+ | lab::rem -> Const_block (0, [Const_base (Const_string lab);
+ transl_meth_list rem])
+
(* Instance variable initialization *)
let set_inst_var obj var id expr =
Lprim(Parraysetu (if maybe_pointer expr then Paddrarray else Pintarray),
[Lvar obj; Lvar id; transl_exp expr])
-let transl_super tbl inh_methods rem =
+let transl_super tbl meths inh_methods rem =
List.fold_right
(fun (nm, id) rem ->
Llet(StrictOpt, id, Lapply (oo_prim "get_method",
- [Lvar tbl; Lvar (meth nm)]),
+ [Lvar tbl; Lvar (Meths.find nm meths)]),
rem))
inh_methods rem
@@ -58,9 +64,16 @@ let inherited_values vals =
Const_block(0, [Const_base (Const_string v); rem]))
vals (Const_pointer 0))
+let inherited_meths methods =
+ Lconst
+ (List.fold_right
+ (fun v rem ->
+ Const_block(0, [Const_base (Const_string v); rem]))
+ methods (Const_pointer 0))
+
let transl_field_obj obj field (obj_init, anc_id) =
match field with
- Cf_inher (name, args, vals, meths) ->
+ Cf_inher (name, args, vals, inh_meths, meths') ->
let init = Ident.create "init" in
(Lsequence(Lapply(Lvar init, Lvar obj :: (List.map transl_exp args)),
obj_init),
@@ -73,13 +86,15 @@ let transl_field_obj obj field (obj_init, anc_id) =
| Cf_meth (name, exp) ->
(obj_init, anc_id)
-let transl_field_cl tbl field cl_init =
+let transl_field_cl tbl meths field cl_init =
match field with
- Cf_inher (name, args, vals, meths) ->
- Lsequence(Lapply (oo_prim "inheritance", [Lvar tbl; transl_path name;
- inherited_values vals]),
+ Cf_inher (name, args, vals, inh_meths, meths') ->
+ Lsequence(Lapply (oo_prim "inheritance",
+ [Lvar tbl; transl_path name;
+ inherited_values vals;
+ inherited_meths meths']),
transl_vals tbl vals (
- transl_super tbl meths cl_init))
+ transl_super tbl meths inh_meths cl_init))
| Cf_val (name, id, priv, exp) ->
if priv = Private then
transl_private_val tbl name id cl_init
@@ -87,7 +102,7 @@ let transl_field_cl tbl field cl_init =
transl_val tbl name id cl_init
| Cf_meth (name, exp) ->
Lsequence(Lapply (oo_prim "set_method",
- [Lvar tbl; Lvar (meth name); transl_exp exp]),
+ [Lvar tbl; transl_label name; transl_exp exp]),
cl_init)
let transl_val_hiding tbl cl_init =
@@ -99,7 +114,27 @@ let transl_val_hiding tbl cl_init =
[Lvar tbl; transl_label name]),
cl_init)
+let bind_methods tbl public_methods lab id cl_init =
+ if List.mem lab public_methods then
+ Llet(Alias, id, Lvar (meth lab), cl_init)
+ else
+ Llet(StrictOpt, id, Lapply (oo_prim "get_method_label",
+ [Lvar tbl; transl_label lab]),
+ cl_init)
+
+let transl_fields tbl public_methods meths fields cl_init =
+ match fields with
+ Cf_inher _ as inh :: fields ->
+ transl_field_cl tbl meths inh
+ (Meths.fold (bind_methods tbl public_methods) meths
+ (List.fold_right (transl_field_cl tbl meths) fields cl_init))
+ | fields ->
+ Meths.fold (bind_methods tbl public_methods) meths
+ (List.fold_right (transl_field_cl tbl meths) fields cl_init)
+
+
let transl_class cl_id cl =
+ let public_methods = Lconst (transl_meth_list cl.cl_pub_meths) in
let obj = Ident.create "obj" in
let (field_init, anc_id) =
List.fold_right (transl_field_obj obj) cl.cl_field (Lvar obj, [])
@@ -118,12 +153,12 @@ let transl_class cl_id cl =
let cl_init =
Lfunction (Curried, [table],
List.fold_left (transl_val_hiding table)
- (List.fold_right (transl_field_cl table) cl.cl_field
+ (transl_fields table cl.cl_pub_meths cl.cl_meths cl.cl_field
(Lapply (oo_prim "set_initializer",
[Lvar table; obj_init])))
cl.cl_field)
in
- Lapply (oo_prim "create_class", [Lvar cl_id; cl_init])
+ Lapply (oo_prim "create_class", [Lvar cl_id; public_methods; cl_init])
let class_stub =
Lprim(Pmakeblock(0, Mutable), [lambda_unit; lambda_unit; lambda_unit])
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index 71c65ec7bc..bbb23821a6 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -480,7 +480,12 @@ let rec transl_exp e =
(Lifthenelse(transl_exp cond, event_before body (transl_exp body),
Lstaticfail))
| Texp_send(expr, met) ->
- event_after e (Lsend(Lvar (meth met), transl_exp expr, []))
+ let met_id =
+ match met with
+ Tmeth_name nm -> meth nm
+ | Tmeth_val id -> id
+ in
+ event_after e (Lsend(Lvar met_id, transl_exp expr, []))
| Texp_new cl ->
Lprim(Pfield 0, [transl_path cl])
| Texp_instvar(path_self, path) ->
diff --git a/parsing/parser.mly b/parsing/parser.mly
index 6973c3407a..b8721c19a5 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -202,7 +202,7 @@ let rec mkrangepat c1 c2 =
%right prec_unary_minus /* - unary */
%left prec_appl /* function application */
%right prec_constr_appl /* constructor application */
-%left SHARP /* method call */
+%left SHARP /* method call */
%left DOT DOTLPAREN DOTLBRACKET /* record access, array access */
%right PREFIXOP /* ! */
@@ -652,20 +652,20 @@ primitive_declaration:
/* Class definitions */
class_list:
- class_list AND class_def
+ class_list AND class_def
{ $3 :: $1 }
| class_def
- { [$1] }
+ { [$1] }
;
class_def:
virtual_flag closed_flag
- class_type_parameters LIDENT simple_pattern_list self self_type EQUAL
+ class_type_parameters LIDENT simple_pattern_list self self_type EQUAL
constraints class_fields
- { { pcl_name = $4; pcl_param = $3; pcl_args = List.rev $5;
- pcl_self = $6; pcl_self_ty = $7; pcl_cstr = List.rev $9;
- pcl_field = List.rev $10;
- pcl_kind = $1; pcl_closed = $2;
- pcl_loc = symbol_loc () } }
+ { { pcl_name = $4; pcl_param = $3; pcl_args = List.rev $5;
+ pcl_self = $6; pcl_self_ty = $7; pcl_cstr = List.rev $9;
+ pcl_field = List.rev $10;
+ pcl_kind = $1; pcl_closed = $2;
+ pcl_loc = symbol_loc () } }
;
class_type_parameters:
type_parameters
@@ -675,122 +675,122 @@ simple_pattern_list:
simple_pattern
{ [$1] }
| simple_pattern_list simple_pattern
- { $2::$1 }
+ { $2::$1 }
;
self:
- AS LIDENT
- { Some $2 }
+ AS LIDENT
+ { Some $2 }
| /* empty */
- { None }
+ { None }
;
class_fields:
/* empty */
- { [] }
+ { [] }
| class_fields INHERIT ancestor
- { Pcf_inher $3 :: $1 }
+ { Pcf_inher $3 :: $1 }
| class_fields VAL value
- { Pcf_val $3 :: $1 }
- | class_fields VIRTUAL method_type
- { Pcf_virt $3 :: $1 }
- | class_fields METHOD method_def
- { Pcf_meth $3 :: $1 }
+ { Pcf_val $3 :: $1 }
+ | class_fields virtual_method
+ { Pcf_virt $2 :: $1 }
+ | class_fields method_def
+ { Pcf_meth $2 :: $1 }
;
ancestor:
LPAREN core_type_comma_list RPAREN class_longident simple_expr_list
- self
+ self
{ $4, List.rev $2, List.rev $5, $6, symbol_loc () }
| LPAREN core_type RPAREN class_longident simple_expr_list self
- { $4, [$2], List.rev $5, $6, symbol_loc () }
+ { $4, [$2], List.rev $5, $6, symbol_loc () }
| class_longident simple_expr_list self
- { $1, [], List.rev $2, $3, symbol_loc () }
+ { $1, [], List.rev $2, $3, symbol_loc () }
;
value:
private_flag mutable_flag label EQUAL expr
- { $3, $1, $2, Some $5, symbol_loc () }
+ { $3, $1, $2, Some $5, symbol_loc () }
| private_flag mutable_flag label
- { $3, $1, $2, None, symbol_loc () }
+ { $3, $1, $2, None, symbol_loc () }
;
+virtual_method:
+ private_flag VIRTUAL label COLON core_type
+ { $3, $1, $5, symbol_loc () }
+
method_def :
- label fun_binding
- { $1, $2, symbol_loc () }
+ private_flag METHOD label fun_binding
+ { $3, $1, $4, symbol_loc () }
;
/* Class type definitions */
class_type_list:
- class_type_list AND class_type
+ class_type_list AND class_type
{ $3 :: $1 }
| class_type
- { [$1] }
+ { [$1] }
;
class_type:
virtual_flag closed_flag class_type_parameters LIDENT type_list
self_type
- EQUAL
+ EQUAL
constraints class_type_fields
- { { pcty_name = $4; pcty_param = $3; pcty_args = $5;
- pcty_self = $6; pcty_cstr = List.rev $8;
+ { { pcty_name = $4; pcty_param = $3; pcty_args = $5;
+ pcty_self = $6; pcty_cstr = List.rev $8;
pcty_field = List.rev $9;
- pcty_kind = $1; pcty_closed = $2;
- pcty_loc = symbol_loc () } }
+ pcty_kind = $1; pcty_closed = $2;
+ pcty_loc = symbol_loc () } }
;
type_list:
- LPAREN core_type RPAREN type_list
- { $2 :: $4 }
+ LPAREN core_type RPAREN type_list
+ { $2 :: $4 }
| LPAREN core_type RPAREN
- { [$2] }
+ { [$2] }
;
self_type:
- COLON type_parameter
- { Some $2 }
+ COLON type_parameter
+ { Some $2 }
| /* empty */
- { None }
+ { None }
;
constraints:
- constraints CONSTRAINT constrain
- { $3 :: $1 }
+ constraints CONSTRAINT constrain
+ { $3 :: $1 }
| /* empty */
- { [] }
+ { [] }
;
constrain:
- type_parameter EQUAL core_type
- { $1, $3, symbol_loc () }
+ type_parameter EQUAL core_type
+ { $1, $3, symbol_loc () }
;
class_type_fields:
/* empty */
- { [] }
+ { [] }
| class_type_fields INHERIT ancestor_type
- { Pctf_inher $3 :: $1 }
+ { Pctf_inher $3 :: $1 }
| class_type_fields VAL value_type
- { Pctf_val $3 :: $1 }
- | class_type_fields VIRTUAL method_type
- { Pctf_virt $3 :: $1 }
- | class_type_fields METHOD method_type_opt
- { Pctf_meth $3 :: $1 }
+ { Pctf_val $3 :: $1 }
+ | class_type_fields virtual_method
+ { Pctf_virt $2 :: $1 }
+ | class_type_fields method_type
+ { Pctf_meth $2 :: $1 }
;
ancestor_type:
LPAREN core_type_comma_list RPAREN class_longident
{ $4, List.rev $2, symbol_loc () }
| LPAREN core_type RPAREN class_longident
- { $4, [$2], symbol_loc () }
+ { $4, [$2], symbol_loc () }
| class_longident
- { $1, [], symbol_loc () }
+ { $1, [], symbol_loc () }
;
value_type :
private_flag mutable_flag label COLON core_type
- { $3, $1, $2, Some $5, symbol_loc () }
+ { $3, $1, $2, Some $5, symbol_loc () }
| private_flag mutable_flag label
- { $3, $1, $2, None, symbol_loc () }
+ { $3, $1, $2, None, symbol_loc () }
;
method_type :
- label COLON core_type
- { $1, $3, symbol_loc () }
-;
-method_type_opt :
- label COLON core_type
- { $1, Some $3, symbol_loc () }
- | label
- { $1, None, symbol_loc () }
+ private_flag METHOD label COLON core_type
+ { $3, $1, $5, symbol_loc () }
+ | private_flag METHOD label
+ { $3, $1, mktyp(Ptyp_any), symbol_loc () }
;
/* Type declarations */
@@ -1030,7 +1030,7 @@ mty_longident:
;
class_longident:
LIDENT { Lident $1 }
- | mod_longident DOT LIDENT { Ldot($1, $3) }
+ | mod_longident DOT LIDENT { Ldot($1, $3) }
;
/* Toplevel directives */
@@ -1053,23 +1053,23 @@ direction_flag:
| DOWNTO { Downto }
;
private_flag:
- /* empty */ { Public }
- | PRIVATE { Private }
+ /* empty */ { Public }
+ | PRIVATE { Private }
;
mutable_flag:
/* empty */ { Immutable }
| MUTABLE { Mutable }
;
virtual_flag:
- /* empty */ { Concrete }
- | VIRTUAL { Virtual }
+ /* empty */ { Concrete }
+ | VIRTUAL { Virtual }
;
closed_flag:
- /* empty */ { Open }
- | CLOSED { Closed }
+ /* empty */ { Open }
+ | CLOSED { Closed }
;
opt_bar:
- /* empty */ { () }
- | BAR { () }
+ /* empty */ { () }
+ | BAR { () }
;
%%
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index 7b57b7cc23..1f6ed64706 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -113,8 +113,8 @@ type class_type_field =
Pctf_inher of (Longident.t * core_type list * Location.t)
| Pctf_val of
(string * private_flag * mutable_flag * core_type option * Location.t)
- | Pctf_virt of (string * core_type * Location.t)
- | Pctf_meth of (string * core_type option * Location.t)
+ | Pctf_virt of (string * private_flag * core_type * Location.t)
+ | Pctf_meth of (string * private_flag * core_type * Location.t)
type class_type =
{ pcty_name: string;
@@ -132,8 +132,8 @@ type class_field =
string option * Location.t)
| Pcf_val of
(string * private_flag * mutable_flag * expression option * Location.t)
- | Pcf_virt of (string * core_type * Location.t)
- | Pcf_meth of (string * expression * Location.t)
+ | Pcf_virt of (string * private_flag * core_type * Location.t)
+ | Pcf_meth of (string * private_flag * expression * Location.t)
type class_def =
{ pcl_name: string;
diff --git a/stdlib/oo.ml b/stdlib/oo.ml
index bfdb189fec..ef7c947920 100644
--- a/stdlib/oo.ml
+++ b/stdlib/oo.ml
@@ -27,7 +27,7 @@ let bucket_small_size = ref 16
let step = Sys.word_size / 16
-let first_label = 0
+let first_bucket = 0
let bucket_size = 32 (* Must be 256 or less *)
@@ -172,6 +172,8 @@ let compact_buckets buckets =
(**** Labels ****)
+let first_label = first_bucket * 65536 * step
+
let last_label = ref first_label
let methods = Hashtbl.create 101
@@ -188,15 +190,23 @@ let new_method met =
Hashtbl.add methods met label;
label
+let new_anonymous_method =
+ new_label
+
(**** Sparse array ****)
module Vars = Map.Make(struct type t = string let compare = compare end)
type vars = int Vars.t
+module Meths = Map.Make(struct type t = string let compare = compare end)
+type meths = label list Meths.t
+
type obj_init
type table =
{ mutable buckets: bucket array;
- mutable methods: (label * item) list;
+ mutable methods: meths;
+ mutable saved_methods: meths list;
+ mutable meth_defs: (label * item) list;
mutable vars: vars;
mutable saved_vars: vars list;
mutable saved_var_lst: int option list;
@@ -210,7 +220,9 @@ let initial_size = 1
let new_table () =
incr table_count;
{ buckets = [| |];
- methods = [];
+ methods = Meths.empty;
+ saved_methods = [];
+ meth_defs = [];
vars = Vars.empty;
saved_vars = [];
saved_var_lst = [];
@@ -221,6 +233,8 @@ let copy_table array1 array2 =
incr version;
array1.buckets <- Array.copy array2.buckets;
array1.methods <- array2.methods;
+ array1.saved_methods <- [];
+ array1.meth_defs <- array2.meth_defs;
array1.vars <- array2.vars;
array1.saved_vars <- [];
array1.saved_var_lst <- array1.saved_var_lst;
@@ -250,7 +264,7 @@ let put array label element =
(!bucket.(elem) != dummy_item)
then begin
if !clean_when_copying then
- bucket := new_filled_bucket buck array.methods
+ bucket := new_filled_bucket buck array.meth_defs
else
bucket := copy_bucket !bucket;
array.buckets.(buck) <- !bucket
@@ -278,10 +292,11 @@ let set_initializer table init =
| _ ->
invalid_arg "Fatal error in Oo.set_initializer."
-let inheritance table cl vars =
+let inheritance table cl vars meths =
if
- !copy_parent & (table.methods = []) & (table.size = initial_size)
- & (table.init = [[]; []])
+ !copy_parent
+ && (table.methods = Meths.empty) && (table.size = initial_size)
+ && (table.init = [[]; []])
then begin
copy_table table cl.table;
table.init <- table.init@[[]];
@@ -290,7 +305,13 @@ let inheritance table cl vars =
(fun s v ->
try Vars.add v (Vars.find v table.vars) s with Not_found -> s)
Vars.empty
- vars
+ vars;
+ table.methods <-
+ List.fold_left
+ (fun s m ->
+ try Meths.add m (Meths.find m table.methods) s with Not_found -> s)
+ Meths.empty
+ meths
end else begin
table.init <- []::table.init;
table.saved_vars <- table.vars::table.saved_vars;
@@ -300,6 +321,13 @@ let inheritance table cl vars =
try Vars.add v (Vars.find v table.vars) s with Not_found -> s)
Vars.empty
vars;
+ table.saved_methods <- table.methods::table.saved_methods;
+ table.methods <-
+ List.fold_left
+ (fun s m ->
+ try Meths.add m (Meths.find m table.methods) s with Not_found -> s)
+ Meths.empty
+ meths;
cl.class_init table;
table.vars <-
List.fold_left
@@ -307,12 +335,33 @@ let inheritance table cl vars =
try Vars.add v (Vars.find v table.vars) s with Not_found -> s)
(List.hd table.saved_vars)
vars;
- table.saved_vars <- List.tl table.saved_vars
+ table.saved_vars <- List.tl table.saved_vars;
+ table.methods <-
+ List.fold_left
+ (fun s m ->
+ try Meths.add m (Meths.find m table.methods) s with Not_found -> s)
+ (List.hd table.saved_methods)
+ meths;
+ table.saved_methods <- List.tl table.saved_methods
end
-let set_method table label element =
- table.methods <- (label, element) :: table.methods;
- put table label element
+let get_method_labels table name =
+ try
+ Meths.find name table.methods
+ with Not_found ->
+ let label = new_anonymous_method () in
+ table.methods <- Meths.add name [label] table.methods;
+ [label]
+
+let get_method_label table name =
+ List.hd (get_method_labels table name)
+
+let set_method table name element =
+ List.iter
+ (function label ->
+ table.meth_defs <- (label, element) :: table.meth_defs;
+ put table label element)
+ (get_method_labels table name)
let get_method table label =
let (buck, elem) = decode label in
@@ -369,10 +418,14 @@ let new_object table =
obj.(0) <- (magic table.buckets : t);
obj
-let create_class class_info class_init =
+let create_class class_info public_methods class_init =
let table = new_table () in
+ List.iter
+ (function met ->
+ table.methods <- Meths.add met [new_method met] table.methods)
+ public_methods;
class_init table;
- method_count := !method_count + List.length table.methods;
+ method_count := !method_count + List.length table.meth_defs;
if !compact_table then
compact_buckets table.buckets;
inst_var_count := !inst_var_count + table.size - 1;
diff --git a/stdlib/oo.mli b/stdlib/oo.mli
index a4ea63c46e..dc52813129 100644
--- a/stdlib/oo.mli
+++ b/stdlib/oo.mli
@@ -31,13 +31,14 @@ type item
type obj_init
type class_info
val set_initializer: table -> obj_init -> unit
-val inheritance: table -> class_info -> string list -> unit
+val inheritance: table -> class_info -> string list -> string list -> unit
val get_method: table -> label -> item
-val set_method: table -> label -> item -> unit
+val set_method: table -> string -> item -> unit
+val get_method_label: table -> string -> label
val get_variable: table -> string -> int
val hide_variable: table -> string -> unit
val get_private_variable: table -> string -> int
-val create_class: class_info -> (table -> unit) -> unit
+val create_class: class_info -> string list -> (table -> unit) -> unit
(* Objects *)
type t
diff --git a/testobjects/Exemples.exp b/testobjects/Exemples.exp
index 82bd956c10..5d55e083d1 100644
--- a/testobjects/Exemples.exp
+++ b/testobjects/Exemples.exp
@@ -12,9 +12,9 @@ end
# class color_point (int) (string) =
val c : string
val mutable x : int
+ method color : string
method get_x : int
method move : int -> unit
- method color : string
end
# val p' : color_point = <obj>
# - : int * string = 5, "red"
@@ -41,15 +41,15 @@ end
constraint 'a = < move : int -> unit; .. >
val mutable center : 'a
method center : 'a
- method set_center : 'a -> unit
method move : int -> unit
+ method set_center : 'a -> unit
end
# class 'a circle ('a) =
constraint 'a = #point
val mutable center : 'a
method center : 'a
- method set_center : 'a -> unit
method move : int -> unit
+ method set_center : 'a -> unit
end
# val c : point circle = <obj>
val c' : color_point circle = <obj>
@@ -57,9 +57,9 @@ val c' : color_point circle = <obj>
constraint 'a = #color_point
val mutable center : 'a
method center : 'a
- method set_center : 'a -> unit
- method move : int -> unit
method color : string
+ method move : int -> unit
+ method set_center : 'a -> unit
end
# Characters 28-29:
This expression has type point = < get_x : int; move : int -> unit >
@@ -102,9 +102,9 @@ end
# class printable_color_point (int) (string) =
val c : string
val mutable x : int
+ method color : string
method get_x : int
method move : int -> unit
- method color : string
method print : unit
end
# val p' : printable_color_point = <obj>
@@ -120,30 +120,30 @@ end
# - : int = 7
# - : (< get_x : int; move : int -> 'a; .. > as 'a) -> functional_point = <fun>
# class virtual 'a lst (unit) =
- method map : ('a -> 'a) -> 'a lst
+ virtual hd : 'a
method iter : ('a -> unit) -> unit
- method print : ('a -> unit) -> unit
+ method map : ('a -> 'a) -> 'a lst
virtual null : bool
- virtual hd : 'a
+ method print : ('a -> unit) -> unit
virtual tl : 'a lst
end
class 'a nil (unit) =
- method null : bool
method hd : 'a
- method tl : 'a lst
- method map : ('a -> 'a) -> 'a lst
method iter : ('a -> unit) -> unit
+ method map : ('a -> 'a) -> 'a lst
+ method null : bool
method print : ('a -> unit) -> unit
+ method tl : 'a lst
end
class 'a cons ('a) ('a lst) =
val h : 'a
val t : 'a lst
- method null : bool
method hd : 'a
- method tl : 'a lst
- method map : ('a -> 'a) -> 'a lst
method iter : ('a -> unit) -> unit
+ method map : ('a -> 'a) -> 'a lst
+ method null : bool
method print : ('a -> unit) -> unit
+ method tl : 'a lst
end
# val l1 : int cons = <obj>
# (3::10::[])- : unit = ()
@@ -160,8 +160,8 @@ end
end
# class int_comparable2 (int) : 'a =
method leq : 'a -> bool
- method x : int
method set_x : int -> unit
+ method x : int
end
# class 'a sorted_list (unit) =
constraint 'a = #comparable
@@ -190,8 +190,8 @@ is not compatible with type
# class int_comparable3 (int) =
val mutable x : int
method leq : int_comparable -> bool
- method x : int
method setx : int -> unit
+ method x : int
end
# val c3 : int_comparable3 = <obj>
# - : unit = ()
@@ -223,32 +223,32 @@ is not compatible with type
# class 'a link ('a) : 'b =
val mutable next : 'b option
val mutable x : 'a
- method x : 'a
+ method append : 'b option -> unit
method next : 'b option
- method set_x : 'a -> unit
method set_next : 'b option -> unit
- method append : 'b option -> unit
+ method set_x : 'a -> unit
+ method x : 'a
end
# class 'a double_link ('a) : 'b =
val mutable next : 'b option
val mutable prev : 'b option
val mutable x : 'a
- method x : 'a
- method next : 'b option
- method set_x : 'a -> unit
- method set_next : 'b option -> unit
method append : 'b option -> unit
+ method next : 'b option
method prev : 'b option
+ method set_next : 'b option -> unit
method set_prev : 'b option -> unit
+ method set_x : 'a -> unit
+ method x : 'a
end
# val fold_right : ('a -> 'b -> 'b) -> 'a #link option -> 'b -> 'b = <fun>
# class calculator (unit) : 'a =
val mutable acc : float
val mutable arg : float
val mutable equals : 'a -> float
- method arg : float
method acc : float
method add : 'a
+ method arg : float
method enter : float -> 'a
method equals : float
method sub : 'a
@@ -260,9 +260,9 @@ end
val mutable acc : float
val mutable arg : float
val mutable equals : 'a -> float
- method arg : float
method acc : float
method add : 'a
+ method arg : float
method enter : float -> 'a
method equals : float
method sub : 'a
@@ -273,26 +273,26 @@ end
# class calculator (float) (float) =
val acc : float
val arg : float
- method enter : float -> calculator
method add : calculator_add
- method sub : calculator_sub
+ method enter : float -> calculator
method equals : float
+ method sub : calculator_sub
end
class calculator_add (float) (float) =
val acc : float
val arg : float
- method enter : float -> calculator
method add : calculator_add
- method sub : calculator_sub
+ method enter : float -> calculator
method equals : float
+ method sub : calculator_sub
end
class calculator_sub (float) (float) =
val acc : float
val arg : float
- method enter : float -> calculator
method add : calculator_add
- method sub : calculator_sub
+ method enter : float -> calculator
method equals : float
+ method sub : calculator_sub
end
# val calculator : calculator = <obj>
# - : float = 5
diff --git a/testobjects/Tests.exp b/testobjects/Tests.exp
index 9dba19fbf5..c28ef5adb3 100644
--- a/testobjects/Tests.exp
+++ b/testobjects/Tests.exp
@@ -131,13 +131,13 @@ end
val x : int
val y : int
val z : int
+ method a : int
+ method b : int
+ method t : int
+ method u : int
method x : int
method y : int
method z : int
- method t : int
- method u : int
- method a : int
- method b : int
end
# val e : e = <obj>
# - : int * int * int * int * int * int * int = 1, 3, 2, 2, 3, 5, 7
@@ -175,7 +175,7 @@ end
end
# - : int * int * int * int = 2, 1, 1, 1
# module M : sig class c (unit) = method xc : int end end
-# class d (unit) = val x : int method xd : int method xc : int end
+# class d (unit) = val x : int method xc : int method xd : int end
# - : int * int = 1, 2
# Characters 7-143:
The type variable 'a is not bound in implicit type definition
@@ -221,4 +221,8 @@ Type bool is not a subtype of type int
# type 'a t = < x : 'a >
# - : (< x : 'a > as 'a) t -> unit = <fun>
# - : (< x : 'a > as 'a) t -> unit = <fun>
+# class c (unit) = private method m : int method n : int end
+# class d (unit) = private method m : int method n : int method o : int end
+# - : int * int = 1, 1
+# class c (unit) = method m : int end
#
diff --git a/testobjects/Tests.ml b/testobjects/Tests.ml
index 0513888141..29051fa70d 100644
--- a/testobjects/Tests.ml
+++ b/testobjects/Tests.ml
@@ -300,3 +300,17 @@ class 'a c () =
constraint 'a = unit -> < .. >
method m (f : 'a) = f ()
end;;
+
+class c () as self =
+ private method m = 1
+ method n = self#m
+end;;
+
+class d () as self =
+ inherit c ()
+ method o = self#m
+end;;
+
+let x = new d () in x#n, x#o;;
+
+class c () = virtual m : int private method m = 1 end;;
diff --git a/tools/ocamlprof.ml b/tools/ocamlprof.ml
index 7467f645a0..43de3b4cd3 100644
--- a/tools/ocamlprof.ml
+++ b/tools/ocamlprof.ml
@@ -264,9 +264,9 @@ let rewrite_class_field =
Pcf_inher (_, _, l, _, _) -> List.iter rewrite_exp l
| Pcf_val (_, _, _, Some sexp, _) -> rewrite_exp sexp
| Pcf_val (_, _, _, None, _) | Pcf_virt _ -> ()
- | Pcf_meth (_, ({pexp_desc = Pexp_function _} as sexp), _) ->
+ | Pcf_meth (_, _, ({pexp_desc = Pexp_function _} as sexp), _) ->
rewrite_exp sexp
- | Pcf_meth (_, sexp, _) ->
+ | Pcf_meth (_, _, sexp, _) ->
if !instr_fun then
insert_profile sexp.pexp_loc;
rewrite_exp sexp
diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml
index e6a4a5065a..167489d459 100644
--- a/toplevel/genprintval.ml
+++ b/toplevel/genprintval.ml
@@ -328,7 +328,7 @@ module Make(Obj : Obj) = struct
end
| Tobject (_, _) ->
print_string "<obj>"
- | Tfield(_, _, _) | Tnil | Tlink _ ->
+ | Tfield(_, _, _, _) | Tnil | Tlink _ ->
fatal_error "Printval.print_value"
and print_val_list prio depth obj ty_list =
diff --git a/typing/btype.ml b/typing/btype.ml
index 957570d9bf..e1bd4c9f7a 100644
--- a/typing/btype.ml
+++ b/typing/btype.ml
@@ -44,6 +44,10 @@ let rec repr =
repr t'
| t -> t
+let rec field_kind_repr =
+ function
+ Fvar {contents = Some kind} -> field_kind_repr kind
+ | kind -> kind
(**********************************)
(* Utilities for type traversal *)
@@ -59,7 +63,7 @@ let iter_type_expr f ty =
| Tobject(ty, {contents = Some (_, p)})
-> f ty; List.iter f p
| Tobject (ty, _) -> f ty
- | Tfield (_, ty1, ty2) -> f ty1; f ty2
+ | Tfield (_, _, ty1, ty2) -> f ty1; f ty2
| Tnil -> ()
| Tlink ty -> f ty
diff --git a/typing/btype.mli b/typing/btype.mli
index d19bb3666b..2fcf24f04e 100644
--- a/typing/btype.mli
+++ b/typing/btype.mli
@@ -27,6 +27,10 @@ val newmarkedgenvar: unit -> type_expr
val repr: type_expr -> type_expr
(* Return the canonical representative of a type. *)
+val field_kind_repr: field_kind -> field_kind
+ (* Return the canonical representative of an object field
+ kind. *)
+
(**** Utilities for type traversal ****)
val iter_type_expr: (type_expr -> unit) -> type_expr -> unit
diff --git a/typing/includecore.ml b/typing/includecore.ml
index 2265dcf8b6..e3f7b75cf7 100644
--- a/typing/includecore.ml
+++ b/typing/includecore.ml
@@ -86,6 +86,17 @@ let encode_val (mut, ty) rem =
end
::ty::rem
+let meths meths1 meths2 =
+ Meths.fold
+ (fun nam t2 (ml1, ml2) ->
+ (begin try
+ Meths.find nam meths1 :: ml1
+ with Not_found ->
+ ml1
+ end,
+ t2 :: ml2))
+ meths2 ([], [])
+
let vars vars1 vars2 =
Vars.fold
(fun lab v2 (vl1, vl2) ->
@@ -102,14 +113,26 @@ let class_types env d1 d2 =
Ctype.equal env true
(d1.cty_self::d1.cty_params) (d2.cty_self::d2.cty_params)
&&
- (* Same concretes methods *)
- Concr.equal d1.cty_concr d2.cty_concr
+ (* Fewer concretes methods *)
+ Concr.subset d2.cty_concr d1.cty_concr
&&
(* If virtual, stays virtual *)
(d1.cty_new <> None or d2.cty_new = None)
&&
+ (* Virtual methods cannot be hidden *)
+ Meths.fold
+ (fun lab ty res ->
+ res &&
+ (Concr.mem lab d1.cty_concr ||
+ try Meths.find lab d2.cty_meths; true with Not_found -> false))
+ d1.cty_meths
+ true
+ &&
(* Less general *)
+ let (m1, m2) = meths d1.cty_meths d2.cty_meths in
let (v1, v2) = vars d1.cty_vars d2.cty_vars in
- let t1 = Ctype.newgenty (Ttuple (d1.cty_self::v1@d1.cty_args)) in
- let t2 = Ctype.newgenty (Ttuple (d2.cty_self::v2@d2.cty_args)) in
+ let t1 = Ctype.newgenty (Ttuple (d1.cty_self::m1@v1@d1.cty_args)) in
+ let t2 = Ctype.newgenty (Ttuple (d2.cty_self::m2@v2@d2.cty_args)) in
+ List.length d1.cty_args = List.length d2.cty_args
+ &&
Ctype.moregeneral env true t1 t2
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index 11a002239e..ab1814dceb 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -126,7 +126,7 @@ let rec mark_loops_rec visited ty =
List.iter (mark_loops_rec visited) l
end
end
- | Tfield(_, ty1, ty2) ->
+ | Tfield(_, kind, ty1, ty2) when field_kind_repr kind = Fpresent ->
mark_loops_rec visited ty1; mark_loops_rec visited ty2
| Tnil -> ()
| Tlink _ -> fatal_error "Printtyp.mark_loops_rec (2)"
@@ -220,7 +220,17 @@ and typobject sch ty fi nm =
open_box 2;
print_string "< ";
(let (fields, rest) = flatten_fields fi in
- typfields sch rest fields);
+ let present_fields =
+ List.fold_right
+ (fun (n, k, t) l ->
+ match field_kind_repr k with
+ Fpresent ->
+ (n, t)::l
+ | _ ->
+ l)
+ fields []
+ in
+ typfields sch rest present_fields);
print_string " >";
close_box ()
| Some (p, {desc = Tvar}::tyl) ->
@@ -400,25 +410,26 @@ let class_var l (m, t) =
type_sch t;
close_box()
-let metho kind (l, t) =
+let metho public concrete lab ty =
print_space ();
open_box 2;
- print_string kind;
- print_string l;
+ if not (List.mem_assoc lab public) then print_string "private ";
+ if Concr.mem lab concrete then print_string "method "
+ else print_string "virtual ";
+ print_string lab;
print_string " :";
- print_space();
- type_sch t;
- close_box()
+ print_space ();
+ type_sch ty;
+ close_box ()
let methods_of_type ty =
match (repr ty).desc with
Tobject (m, _) -> m
| _ -> fatal_error "Printtyp.methods_of_type"
-let rec list_meths ty =
- match (repr ty).desc with
- Tfield(lab, ty, ty') -> (lab, ty) :: (list_meths ty')
- | _ -> []
+let rec list_public_methods ty =
+ let (fields, _) = flatten_fields ty in
+ List.map (function (m, _, t) -> (m, t)) fields
let class_type id cl_ty =
let self = repr cl_ty.cty_self in
@@ -437,6 +448,7 @@ let class_type id cl_ty =
List.iter mark_loops params;
List.iter mark_loops args;
Vars.iter (fun _ (_, ty) -> mark_loops ty) vars;
+ Meths.iter (fun _ ty -> mark_loops ty) cl_ty.cty_meths;
List.iter name_of_type params;
open_hvbox 2;
open_box 0;
@@ -458,18 +470,12 @@ let class_type id cl_ty =
close_box ();
List.iter constrain params;
Vars.iter class_var vars;
- let meths = list_meths (methods_of_type self) in
- let (meths, virt) =
- List.fold_right
- (fun ((lab, ty) as m) (ml, vl) ->
- if Concr.mem lab cl_ty.cty_concr then
- (m::ml, vl)
- else
- (ml, m::vl))
- meths
- ([], []) in
- List.iter (metho "method ") meths;
- List.iter (metho "virtual ") virt;
+ let public_methods = list_public_methods (methods_of_type self) in
+ let methods =
+ List.fold_left (fun m (lab, ty) -> Meths.add lab ty m)
+ cl_ty.cty_meths public_methods
+ in
+ Meths.iter (metho public_methods cl_ty.cty_concr) methods;
print_break 1 (-2);
print_string "end";
close_box()
diff --git a/typing/subst.ml b/typing/subst.ml
index 1f39890095..4e199642e3 100644
--- a/typing/subst.ml
+++ b/typing/subst.ml
@@ -98,8 +98,13 @@ let rec typexp s ty =
None -> None
| Some (p, tl) ->
Some (type_path s p, List.map (typexp s) tl)))
- | Tfield(label, t1, t2) ->
- Tfield(label, typexp s t1, typexp s t2)
+ | Tfield(label, kind, t1, t2) ->
+ begin match field_kind_repr kind with
+ Fpresent ->
+ Tfield(label, Fpresent, typexp s t1, typexp s t2)
+ | _ ->
+ Tlink(typexp s t2)
+ end
| Tnil ->
Tnil
end;
@@ -158,9 +163,8 @@ let class_type s decl =
let decl =
{ cty_params = List.map (typexp s) decl.cty_params;
cty_args = List.map (typexp s) decl.cty_args;
- cty_vars =
- Vars.fold (fun l (m, t) -> Vars.add l (m, typexp s t))
- decl.cty_vars Vars.empty;
+ cty_vars = Vars.map (function (m, t) -> (m, typexp s t)) decl.cty_vars;
+ cty_meths = Meths.map (typexp s) decl.cty_meths;
cty_self = typexp s decl.cty_self;
cty_concr = decl.cty_concr;
cty_new =
@@ -173,6 +177,7 @@ let class_type s decl =
List.iter unmark_type decl.cty_params;
List.iter unmark_type decl.cty_args;
Vars.iter (fun l (m, t) -> unmark_type t) decl.cty_vars;
+ Meths.iter (fun l t -> unmark_type t) decl.cty_meths;
unmark_type decl.cty_self;
begin match decl.cty_new with
None -> ()
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index fdd2ca6fe1..2d85edeee3 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -68,24 +68,26 @@ let check_mutable loc lab mut mut' =
| _ ->
()
-let rec add_methods env self concr concr_lst t =
+let rec add_methods env self t =
match (Ctype.repr t).desc with
- Tfield (lab, _, t') ->
- Ctype.filter_method env lab self;
- if Concr.mem lab concr_lst then
- (Ctype.filter_method env lab concr; ());
- add_methods env self concr concr_lst t'
+ Tfield (lab, k, _, t') ->
+ if Btype.field_kind_repr k = Fpresent then begin
+ Ctype.filter_method env lab Public self;
+ end;
+ add_methods env self t'
| _ ->
()
-(* Make sure taht [self] has at least the methods of [obj]. *)
+(* Make sure that [self] has at least the methods of [obj]. *)
let equalize_methods env self obj =
match (Ctype.expand_head env obj).desc with
Tobject (ty, _) ->
let rec equalize_methods_rec t =
match (Ctype.repr t).desc with
- Tfield (lab, _, t') ->
- Ctype.filter_method env lab self;
+ Tfield (lab, k, _, t') ->
+ if Btype.field_kind_repr k = Fpresent then begin
+ Ctype.filter_method env lab Public self; ()
+ end;
equalize_methods_rec t'
| _ ->
()
@@ -97,12 +99,14 @@ let equalize_methods env self obj =
let rec type_meth env loc self ty =
match (Ctype.repr ty).desc with
- Tfield (lab, ty, ty') ->
- let ty0 = Ctype.filter_method env lab self in
- begin try
- Ctype.unify env ty ty0
- with Ctype.Unify trace ->
- raise(Error(loc, Method_type_mismatch (lab, trace)))
+ Tfield (lab, k, ty, ty') ->
+ if Btype.field_kind_repr k = Fpresent then begin
+ let ty0 = Ctype.filter_method env lab Public self in
+ begin try
+ Ctype.unify env ty ty0
+ with Ctype.Unify trace ->
+ raise(Error(loc, Method_type_mismatch (lab, trace)))
+ end
end;
type_meth env loc self ty'
| _ ->
@@ -126,10 +130,12 @@ let insert_value env lab priv mut ty loc vals =
let rec closed_scheme t =
match (Ctype.repr t).desc with
- Tfield (lab, _, t') ->
- Ctype.newty (Tfield (lab, Ctype.newvar (), closed_scheme t'))
+ Tfield (lab, k, _, t') when Btype.field_kind_repr k = Fpresent ->
+ Ctype.newty (Tfield (lab, Fpresent, Ctype.newvar (), closed_scheme t'))
+ | Tfield (lab, _, _, t') ->
+ closed_scheme t'
| Tnil ->
- Ctype.newty Tnil
+ Ctype.newty Tnil
| _ ->
fatal_error "Typeclass.closed_scheme"
@@ -147,9 +153,11 @@ let change_value_status lab priv mut loc vals =
let missing_method env ty ty' =
let rec missing_method_rec met=
match (Ctype.repr met).desc with
- Tfield(lab, _, met') ->
+ Tfield(lab, k, _, met') ->
begin try
- Ctype.filter_method env lab ty;
+ if Btype.field_kind_repr k = Fpresent then begin
+ Ctype.filter_method env lab Public ty; ()
+ end;
missing_method_rec met'
with Ctype.Unify _ ->
lab
@@ -167,6 +175,7 @@ let generalize_class cl_sig =
List.iter Ctype.generalize cl_sig.cty_params;
List.iter Ctype.generalize cl_sig.cty_args;
Vars.iter (fun l (m, t) -> Ctype.generalize t) cl_sig.cty_vars;
+ Meths.iter (fun l t -> Ctype.generalize t) cl_sig.cty_meths;
Ctype.generalize cl_sig.cty_self;
match cl_sig.cty_new with Some ty -> Ctype.generalize ty | None -> ()
@@ -181,7 +190,6 @@ let make_stub env (cl, obj_id, cl_id) =
(* Create self (class type) *)
let self = Ctype.newobj (Ctype.newvar ()) in
- let concr = Ctype.newobj (Ctype.newvar ()) in
(* Find concrete methods and marks methods *)
let concr_meths =
@@ -197,26 +205,23 @@ let make_stub env (cl, obj_id, cl_id) =
in
begin match (Ctype.expand_head env anc.cty_self).desc with
Tobject (ty, _) ->
- add_methods env self concr anc.cty_concr ty;
+ add_methods env self ty;
Concr.union anc.cty_concr meths
| _ -> fatal_error "Typeclass.make_stub"
end
| Pcf_val _ ->
meths
- | Pcf_virt (lab, _, _) ->
- Ctype.filter_method env lab self;
+ | Pcf_virt (lab, priv, _, _) ->
+ Ctype.filter_method env lab priv self;
meths
- | Pcf_meth (lab, _, _) ->
- Ctype.filter_method env lab self;
- Ctype.filter_method env lab concr;
+ | Pcf_meth (lab, priv, _, _) ->
+ Ctype.filter_method env lab priv self;
Concr.add lab meths)
Concr.empty cl.pcl_field
in
- Ctype.close_object concr;
Ctype.end_def ();
Ctype.generalize self;
- Ctype.generalize concr;
(* Temporary object type *)
let temp_obj_params =
@@ -267,15 +272,17 @@ let make_stub env (cl, obj_id, cl_id) =
in let cl_temp_sig =
{ cty_params = [];
cty_args = []; cty_vars = Vars.empty;
+ cty_meths = Meths.empty;
cty_self = self; cty_concr = concr_meths;
cty_new = new_ty }
in let (id, temp_env) = Env.enter_class cl.pcl_name cl_temp_sig temp_env in
- ((cl, id, cl_id, obj_id, self, concr, concr_meths, new_args, new_ty,
+ ((cl, id, cl_id, obj_id, self, concr_meths, new_args, new_ty,
temp_cl, temp_cl_params, cl_abbrev, temp_obj, temp_obj_params, abbrev),
temp_env)
-let type_class_field env var_env self cl (met_env, fields, vars_sig) =
+let type_class_field env var_env self cl
+ (met_env, fields, vars_sig, meths) =
function
Pcf_inher (cl_name, params, args, super, loc) ->
(* Find class type *)
@@ -285,7 +292,9 @@ let type_class_field env var_env self cl (met_env, fields, vars_sig) =
with Not_found ->
raise(Error(loc, Unbound_class cl_name))
in
- let (params', args', vars', self') = Ctype.instance_class cl_type in
+ let (params', args', vars', meths', self') =
+ Ctype.instance_class cl_type
+ in
(* Unify parameters *)
if List.length params <> List.length params' then
@@ -318,21 +327,35 @@ let type_class_field env var_env self cl (met_env, fields, vars_sig) =
vars' ([], vars_sig, met_env)
in
+ (* Methods *)
+ let meths =
+ Meths.fold
+ (fun lab ty m ->
+ let (id, ty') =
+ try Meths.find lab m with Not_found ->
+ (Ident.create lab,
+ Ctype.filter_method var_env lab Private self)
+ in
+ begin try Ctype.unify env ty ty' with Ctype.Unify trace ->
+ raise(Error(loc, Method_type_mismatch (lab, trace)))
+ end;
+ Meths.add lab (id, ty) m)
+ meths' meths
+ in
+
(* Self type *)
let ty' = Ctype.expand_head var_env self' in
begin match ty'.desc with
Tobject (fi, _) ->
- if ty' != Ctype.expand_head var_env self then begin
- if not (Ctype.opened_object self') then
- begin try
- Ctype.unify var_env self (Ctype.newobj (closed_scheme fi))
- with Ctype.Unify _ ->
- let lab = missing_method var_env self' self in
- raise(Error(loc, Closed_ancestor (cl.pcl_name, path, lab)))
- end;
- ty'.desc <- Tlink self;
- type_meth var_env loc self fi
- end
+ if not (Ctype.opened_object self') then
+ begin try
+ Ctype.unify var_env self (Ctype.newobj (closed_scheme fi))
+ with Ctype.Unify _ ->
+ let lab = missing_method var_env self' self in
+ raise(Error(loc, Closed_ancestor (cl.pcl_name, path, lab)))
+ end;
+ Ctype.unify var_env ty' self;
+ type_meth var_env loc self fi
| _ ->
fatal_error "Typeclass.transl_class"
end;
@@ -347,8 +370,9 @@ let type_class_field env var_env self cl (met_env, fields, vars_sig) =
let used_methods =
Concr.fold
(fun lab rem ->
- Ctype.unify met_env (Ctype.filter_method met_env lab ty)
- (Ctype.filter_method met_env lab self);
+ Ctype.unify met_env
+ (Ctype.filter_method met_env lab Public ty)
+ (Ctype.filter_method met_env lab Public self);
(lab, Ident.create lab)::rem)
cl_type.cty_concr
[]
@@ -360,7 +384,9 @@ let type_class_field env var_env self cl (met_env, fields, vars_sig) =
in
(used_methods, met_env)
in
- (met_env, Cf_inher (path, args, vars, met)::fields, vars_sig)
+ let met' = Meths.fold (fun lab _ rem -> lab::rem) cl_type.cty_meths [] in
+ (met_env, Cf_inher (path, args, vars, met, met')::fields,
+ vars_sig, meths)
| Pcf_val (lab, priv, mut, sinit, loc) ->
begin match sinit with
@@ -371,7 +397,8 @@ let type_class_field env var_env self cl (met_env, fields, vars_sig) =
{val_type = exp.exp_type; val_kind = Val_ivar mut} met_env
in
(met_env, Cf_val (lab, id, priv, Some exp)::fields,
- insert_value var_env lab priv mut exp.exp_type loc vars_sig)
+ insert_value var_env lab priv mut exp.exp_type loc vars_sig,
+ meths)
| None ->
let (vars_sig, ty) =
change_value_status lab priv mut loc vars_sig
@@ -380,24 +407,31 @@ let type_class_field env var_env self cl (met_env, fields, vars_sig) =
Env.enter_value lab
{val_type = ty; val_kind = Val_ivar mut} met_env
in
- (met_env, Cf_val (lab, id, priv, None)::fields, vars_sig)
+ (met_env, Cf_val (lab, id, priv, None)::fields, vars_sig, meths)
end
- | Pcf_virt (lab, ty, loc) ->
+ | Pcf_virt (lab, priv, ty, loc) ->
let ty = transl_simple_type met_env false ty in
- let ty' = Ctype.filter_method var_env lab self in
- begin try Ctype.unify var_env ty ty' with Ctype.Unify trace ->
+ let ty'' = Ctype.filter_method var_env lab priv self in
+ let (id, ty') =
+ try Meths.find lab meths with Not_found -> (Ident.create lab, ty'')
+ in
+ begin try Ctype.unify var_env ty ty'' with Ctype.Unify trace ->
raise(Error(loc, Method_type_mismatch (lab, trace)))
end;
- (met_env, fields, vars_sig)
+ (met_env, fields, vars_sig, Meths.add lab (id, ty) meths)
+
+ | Pcf_meth (lab, priv, expr, loc) ->
+ let ty' = Ctype.filter_method var_env lab priv self in
+ let (id, ty) =
+ try Meths.find lab meths with Not_found -> (Ident.create lab, ty')
+ in
+ let meths = Meths.add lab (id, ty) meths in
+ let (texp, meths) = type_method met_env self cl.pcl_self meths expr ty in
+ (met_env, Cf_meth (lab, texp)::fields, vars_sig, meths)
- | Pcf_meth (lab, expr, loc) ->
- let ty = Ctype.filter_method var_env lab self in
- let texp = type_method met_env self cl.pcl_self expr ty in
- (met_env, Cf_meth (lab, texp)::fields, vars_sig)
-
let transl_class temp_env env
- (cl, id, cl_id, obj_id, self, concr, concr_meths, new_args, new_ty,
+ (cl, id, cl_id, obj_id, self, concr_meths, new_args, new_ty,
temp_cl, temp_cl_params, cl_abbrev, temp_obj, temp_obj_params, abbrev)
=
reset_type_variables ();
@@ -437,9 +471,9 @@ let transl_class temp_env env
(* Type arguments and fields *)
let (args, var_env) = type_pattern_list temp_env cl.pcl_args in
let arg_sig = List.map (fun exp -> exp.pat_type) args in
- let (_, fields, vars_sig) =
+ let (_, fields, vars_sig, meths) =
List.fold_left (type_class_field env var_env self cl)
- (temp_env, [], Vars.empty)
+ (temp_env, [], Vars.empty, Meths.empty)
cl.pcl_field
in
@@ -452,6 +486,7 @@ let transl_class temp_env env
List.iter Ctype.generalize params;
List.iter Ctype.generalize arg_sig;
Vars.iter (fun l (m, t) -> Ctype.generalize t) vars_sig;
+ Meths.iter (fun l (i, t) -> Ctype.generalize t) meths;
Ctype.generalize self;
(* Temporary class abbreviation *)
@@ -498,53 +533,73 @@ let transl_class temp_env env
let cl_imp =
{ cl_args = args;
cl_field = List.rev fields;
+ cl_pub_meths = [];
+ cl_meths = Meths.map (function (id, ty) -> id) meths;
cl_loc = cl.pcl_loc }
in let cl_sig =
{ cty_params = params;
cty_args = arg_sig;
cty_vars = vars_sig;
+ cty_meths = Meths.map (function (id, ty) -> ty) meths;
cty_self = self;
cty_concr = concr_meths;
cty_new = new_ty }
in let new_env = Env.add_class id cl_sig env in
- ((cl, id, cl_id, obj_id, cl_sig, cl_imp, concr, temp_obj,
+ ((cl, id, cl_id, obj_id, cl_sig, cl_imp, temp_obj,
temp_obj_params),
new_env)
let build_new_type temp_env env
- (cl, id, cl_id, obj_id, cl_sig, cl_imp, concr, temp_obj,
+ (cl, id, cl_id, obj_id, cl_sig, cl_imp, temp_obj,
temp_obj_params)
=
(* Modify constrainsts to ensure the object abbreviation is well-formed *)
- let (params, args, vars, self) = Ctype.instance_class cl_sig in
+ let (params, args, vars, meths, self) = Ctype.instance_class cl_sig in
List.iter2 (Ctype.unify temp_env) params temp_obj_params;
(* Never fails *)
+ (* Hide private methods *)
+ Ctype.hide_private_methods cl_sig.cty_self;
+
(* Closeness of self (2) *)
if (cl.pcl_closed <> Closed) & not (Ctype.opened_object self) then
raise(Error(cl.pcl_loc, Closed_class cl.pcl_name));
- (* Check whether the class can be concrete *)
- if cl.pcl_kind = Concrete then begin
- let concr = Ctype.instance concr in
- try
- Ctype.unify temp_env concr temp_obj
- with Ctype.Unify _ ->
- let lab = missing_method temp_env concr temp_obj in
- raise(Error(cl.pcl_loc, Virtual_class (cl.pcl_name, lab)))
- end;
-
equalize_methods temp_env self temp_obj;
(* self should not be an abbreviation (printtyp) *)
let exp_self = Ctype.expand_head temp_env self in
- (* Final class type *)
+ let public_methods =
+ match (Ctype.repr exp_self).desc with
+ Tobject (fi, _) ->
+ let (meths, _) = Ctype.flatten_fields fi in
+ List.map (function (lab, _, _) -> lab) meths
+ | _ -> fatal_error "Typeclass.build_new_type"
+ in
+
+ (* Check whether the class can be concrete *)
+ if cl.pcl_kind = Concrete then
+ List.iter
+ (function m ->
+ if not (Concr.mem m cl_sig.cty_concr) then
+ raise(Error(cl.pcl_loc, Virtual_class (cl.pcl_name, m))))
+ public_methods;
+
+ (* Final class implementation and interface *)
+ let cl_imp =
+ { cl_args = cl_imp.cl_args;
+ cl_field = cl_imp.cl_field;
+ cl_pub_meths = public_methods;
+ cl_meths = cl_imp.cl_meths;
+ cl_loc = cl_imp.cl_loc }
+ in
let cl_sig =
{ cty_params = params;
cty_args = args;
cty_vars = vars;
+ cty_meths = meths;
cty_self = exp_self;
cty_concr = cl_sig.cty_concr;
cty_new = cl_sig.cty_new } (* new is still monomorphic *)
@@ -630,7 +685,6 @@ let make_stub env (cl, obj_id, cl_id) =
(* Create self (class type) *)
let self = Ctype.newobj (Ctype.newvar ()) in
- let concr = Ctype.newobj (Ctype.newvar ()) in
(* Find concrete methods and marks methods *)
let concr_meths =
@@ -646,26 +700,23 @@ let make_stub env (cl, obj_id, cl_id) =
in
begin match (Ctype.expand_head env anc.cty_self).desc with
Tobject (ty, _) ->
- add_methods env self concr anc.cty_concr ty;
+ add_methods env self ty;
Concr.union anc.cty_concr meths
| _ -> fatal_error "Typeclass.make_stub (type)"
end
| Pctf_val _ ->
meths
- | Pctf_virt (lab, _, _) ->
- Ctype.filter_method env lab self;
+ | Pctf_virt (lab, priv, _, _) ->
+ Ctype.filter_method env lab priv self;
meths
- | Pctf_meth (lab, _, _) ->
- Ctype.filter_method env lab self;
- Ctype.filter_method env lab concr;
+ | Pctf_meth (lab, priv, _, _) ->
+ Ctype.filter_method env lab priv self;
Concr.add lab meths)
Concr.empty cl.pcty_field
in
- Ctype.close_object concr;
Ctype.end_def ();
Ctype.generalize self;
- Ctype.generalize concr;
(* Temporary object type *)
let temp_obj_params =
@@ -708,17 +759,17 @@ let make_stub env (cl, obj_id, cl_id) =
(* Temporary class type *)
let cl_temp_sig =
{ cty_params = [];
- cty_args = []; cty_vars = Vars.empty;
+ cty_args = []; cty_vars = Vars.empty; cty_meths = Meths.empty;
cty_self = self; cty_concr = concr_meths;
cty_new = None }
in
let (id, temp_env) = Env.enter_class cl.pcty_name cl_temp_sig temp_env in
- ((cl, id, cl_id, obj_id, self, concr, concr_meths, temp_cl,
+ ((cl, id, cl_id, obj_id, self, concr_meths, temp_cl,
temp_cl_params, cl_abbrev, temp_obj, temp_obj_params, abbrev),
temp_env)
-let type_class_field env var_env self cl vars_sig =
+let type_class_field env var_env self cl (vars_sig, meths_sig) =
function
Pctf_inher (cl_name, params, loc) ->
(* Find class type *)
@@ -728,7 +779,7 @@ let type_class_field env var_env self cl vars_sig =
with Not_found ->
raise (Error (loc, Unbound_class cl_name))
in
- let (params', _, vars', self') = Ctype.instance_class cl_type in
+ let (params', _, vars', meths', self') = Ctype.instance_class cl_type in
(* Unify parameters *)
if List.length params <> List.length params' then
@@ -748,56 +799,70 @@ let type_class_field env var_env self cl vars_sig =
vars' vars_sig
in
+ let meths_sig =
+ Meths.fold
+ (fun lab ty m_sig ->
+ let ty' =
+ try Meths.find lab m_sig with Not_found ->
+ Ctype.filter_method var_env lab Private self
+ in
+ begin try Ctype.unify env ty ty' with Ctype.Unify trace ->
+ raise(Error(loc, Method_type_mismatch (lab, trace)))
+ end;
+ Meths.add lab ty m_sig)
+ meths' meths_sig
+ in
+
(* Self type *)
let ty' = Ctype.expand_head var_env self' in
begin match ty'.desc with
- Tobject (fi, _) ->
- if not (Ctype.opened_object self') then
- begin try
- Ctype.unify var_env self (Ctype.newobj (closed_scheme fi))
- with Ctype.Unify _ ->
- let lab = missing_method var_env self' self in
- raise(Error(loc, Closed_ancestor (cl.pcty_name, path, lab)))
- end;
- ty'.desc <- Tlink self;
- type_meth var_env loc self fi
- | _ ->
- fatal_error "Typeclass.type_class_field (type)"
+ Tobject (fi, _) ->
+ if ty' != Ctype.expand_head var_env self then begin
+ if not (Ctype.opened_object self') then
+ begin try
+ Ctype.unify var_env self (Ctype.newobj (closed_scheme fi))
+ with Ctype.Unify _ ->
+ let lab = missing_method var_env self' self in
+ raise(Error(loc, Closed_ancestor (cl.pcty_name, path, lab)))
+ end;
+ Ctype.unify var_env ty' self;
+ type_meth var_env loc self fi
+ end
+ | _ ->
+ fatal_error "Typeclass.type_class_field (type)"
end;
- vars_sig
+ (vars_sig, meths_sig)
| Pctf_val (lab, priv, mut, sty, loc) ->
begin match sty with
Some sty ->
let ty = transl_simple_type var_env false sty in
- insert_value var_env lab priv mut ty loc vars_sig
+ (insert_value var_env lab priv mut ty loc vars_sig, meths_sig)
| None ->
- fst (change_value_status lab priv mut loc vars_sig)
+ (fst (change_value_status lab priv mut loc vars_sig), meths_sig)
end
- | Pctf_virt (lab, sty, loc) ->
+ | Pctf_virt (lab, priv, sty, loc) ->
let ty = transl_simple_type var_env false sty in
- let ty' = Ctype.filter_method var_env lab self in
+ let ty'' = Ctype.filter_method var_env lab priv self in
+ let ty' = try Meths.find lab meths_sig with Not_found -> ty'' in
begin try Ctype.unify var_env ty ty' with Ctype.Unify trace ->
raise(Error(loc, Method_type_mismatch (lab, trace)))
end;
- vars_sig
+ (vars_sig, Meths.add lab ty meths_sig)
- | Pctf_meth (lab, Some sty, loc) ->
+ | Pctf_meth (lab, priv, sty, loc) ->
let ty = transl_simple_type var_env false sty in
- let ty' = Ctype.filter_method var_env lab self in
+ let ty'' = Ctype.filter_method var_env lab priv self in
+ let ty' = try Meths.find lab meths_sig with Not_found -> ty'' in
begin try Ctype.unify var_env ty ty' with Ctype.Unify trace ->
raise(Error(loc, Method_type_mismatch (lab, trace)))
end;
- vars_sig
-
- | Pctf_meth (lab, None, loc) ->
- Ctype.filter_method var_env lab self;
- vars_sig
+ (vars_sig, Meths.add lab ty meths_sig)
let transl_class temp_env env
- (cl, id, cl_id, obj_id, self, concr, concr_meths, temp_cl,
+ (cl, id, cl_id, obj_id, self, concr_meths, temp_cl,
temp_cl_params, cl_abbrev, temp_obj, temp_obj_params, abbrev)
=
reset_type_variables ();
@@ -838,9 +903,9 @@ let transl_class temp_env env
let arg_sig = List.map (transl_simple_type temp_env false) cl.pcty_args in
(* Translate fields *)
- let vars_sig =
+ let (vars_sig, meths_sig) =
List.fold_left (type_class_field env temp_env self cl)
- Vars.empty cl.pcty_field
+ (Vars.empty, Meths.empty) cl.pcty_field
in
(* Closeness of self *)
@@ -852,6 +917,7 @@ let transl_class temp_env env
List.iter Ctype.generalize params;
List.iter Ctype.generalize arg_sig;
Vars.iter (fun l (m, t) -> Ctype.generalize t) vars_sig;
+ Meths.iter (fun l t -> Ctype.generalize t) meths_sig;
Ctype.generalize self;
(* Temporary class abbreviation *)
@@ -891,39 +957,33 @@ let transl_class temp_env env
{ cty_params = params;
cty_args = arg_sig;
cty_vars = vars_sig;
+ cty_meths = meths_sig;
cty_self = self;
cty_concr = concr_meths;
cty_new = None }
in
let new_env = Env.add_class id cl_sig env in
- ((cl, id, cl_id, obj_id, cl_sig, concr, abbrev, temp_obj,
+ ((cl, id, cl_id, obj_id, cl_sig, abbrev, temp_obj,
temp_obj_params),
new_env)
let build_new_type temp_env env
- (cl, id, cl_id, obj_id, cl_sig, concr, abbrev, temp_obj,
+ (cl, id, cl_id, obj_id, cl_sig, abbrev, temp_obj,
temp_obj_params)
=
(* Modify constrainsts to ensure the object abbreviation is well-formed *)
- let (params, args, vars, self) = Ctype.instance_class cl_sig in
+ let (params, args, vars, meths, self) = Ctype.instance_class cl_sig in
List.iter2 (Ctype.unify temp_env) params temp_obj_params;
(* Never fails *)
+ (* Hide private methods *)
+ Ctype.hide_private_methods cl_sig.cty_self;
+
(* Closeness of self (2) *)
if (cl.pcty_closed <> Closed) & not (Ctype.opened_object self) then
raise(Error(cl.pcty_loc, Closed_class cl.pcty_name));
- (* Check whether the class can be concrete *)
- if cl.pcty_kind = Concrete then begin
- let concr = Ctype.instance concr in
- try
- Ctype.unify temp_env concr temp_obj
- with Ctype.Unify _ ->
- let lab = missing_method temp_env concr temp_obj in
- raise(Error(cl.pcty_loc, Virtual_class (cl.pcty_name, lab)))
- end;
-
equalize_methods temp_env self temp_obj;
(* self should not be an abbreviation (printtyp) *)
@@ -938,11 +998,28 @@ let build_new_type temp_env env
None
in
+ let public_methods =
+ match (Ctype.repr exp_self).desc with
+ Tobject (fi, _) ->
+ let (meths, _) = Ctype.flatten_fields fi in
+ List.map (function (lab, _, _) -> lab) meths
+ | _ -> fatal_error "Typeclass.build_new_type"
+ in
+
+ (* Check whether the class can be concrete *)
+ if cl.pcty_kind = Concrete then
+ List.iter
+ (function m ->
+ if not (Concr.mem m cl_sig.cty_concr) then
+ raise(Error(cl.pcty_loc, Virtual_class (cl.pcty_name, m))))
+ public_methods;
+
(* Final class type *)
let cl_sig =
{ cty_params = params;
cty_args = args;
cty_vars = vars;
+ cty_meths = meths;
cty_self = exp_self;
cty_concr = cl_sig.cty_concr;
cty_new = new_ty }
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 556a9c893a..0ce889fa4f 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -541,37 +541,49 @@ let rec type_exp env sexp =
| Pexp_send (e, met) ->
let object = type_exp env e in
begin try
- let typ = filter_method env met object.exp_type in
- let exp =
- match object.exp_desc with
- Texp_ident(path, {val_kind = Val_anc methods}) ->
- let (path, desc) =
+ let (exp, typ) =
+ match object.exp_desc with
+ Texp_ident(path, {val_kind = Val_self meths}) ->
+ begin try (* Private method *)
+ let (id, typ) = Meths.find met !meths in
+ (Texp_send(object, Tmeth_val id), typ)
+ with Not_found -> (* Implicitely defined method *)
+ let id = Ident.create met in
+ let typ = filter_method env met Private object.exp_type in
+ meths := Meths.add met (id, typ) !meths;
+ (Texp_send(object, Tmeth_val id), typ)
+ end
+ | Texp_ident(path, {val_kind = Val_anc methods}) ->
+ let typ = filter_method env met Public object.exp_type in
+ let (path, desc) =
Env.lookup_value (Longident.Lident "*self*") env
in
let method_id = List.assoc met methods in
- let method_type = newvar () in
- let (obj_ty, res_ty) = filter_arrow env method_type in
- unify env obj_ty desc.val_type;
- unify env res_ty typ;
- Texp_apply({exp_desc = Texp_ident(Path.Pident method_id,
- {val_type = method_type;
- val_kind = Val_reg});
- exp_loc = sexp.pexp_loc;
- exp_type = method_type;
- exp_env = env },
- [{exp_desc = Texp_ident(path, desc);
- exp_loc = object.exp_loc;
- exp_type = desc.val_type;
- exp_env = env }])
+ let method_type = newvar () in
+ let (obj_ty, res_ty) = filter_arrow env method_type in
+ unify env obj_ty desc.val_type;
+ unify env res_ty typ;
+ (Texp_apply({exp_desc = Texp_ident(Path.Pident method_id,
+ {val_type = method_type;
+ val_kind = Val_reg});
+ exp_loc = sexp.pexp_loc;
+ exp_type = method_type;
+ exp_env = env },
+ [{exp_desc = Texp_ident(path, desc);
+ exp_loc = object.exp_loc;
+ exp_type = desc.val_type;
+ exp_env = env }]),
+ typ)
| _ ->
- Texp_send(object, met)
+ (Texp_send(object, Tmeth_name met),
+ filter_method env met Public object.exp_type)
in
{ exp_desc = exp;
exp_loc = sexp.pexp_loc;
exp_type = typ;
exp_env = env }
with Unify _ ->
- raise(Error(e.pexp_loc, Undefined_method_err met))
+ raise(Error(e.pexp_loc, Undefined_method_err met))
end
| Pexp_new cl ->
let (cl_path, cl_typ) =
@@ -776,7 +788,8 @@ let rec type_expect_fun env sexp ty_expected =
| _ ->
type_expect env sexp ty_expected
-let type_method env self self_name sexp ty_expected =
+let type_method env self self_name meths sexp ty_expected =
+ let meths = ref meths in
let (obj, env) =
Env.enter_value "*self*" {val_type = self; val_kind = Val_reg} env
in
@@ -791,7 +804,7 @@ let type_method env self self_name sexp ty_expected =
(pattern, env)
| Some name ->
let (self_name, env) =
- Env.enter_value name {val_type = self; val_kind = Val_reg} env
+ Env.enter_value name {val_type = self; val_kind = Val_self meths} env
in
({ pat_desc = Tpat_alias (pattern, self_name);
pat_loc = Location.none;
@@ -802,7 +815,8 @@ let type_method env self self_name sexp ty_expected =
{ exp_desc = Texp_function [(pattern, exp)];
exp_loc = sexp.pexp_loc;
exp_type = newty (Tarrow(pattern.pat_type, exp.exp_type));
- exp_env = env }
+ exp_env = env },
+ !meths
(* Error report *)
diff --git a/typing/typecore.mli b/typing/typecore.mli
index 3dddcbbccb..d3d210860d 100644
--- a/typing/typecore.mli
+++ b/typing/typecore.mli
@@ -24,7 +24,9 @@ val type_expression:
Env.t -> Parsetree.expression -> Typedtree.expression
val type_method:
Env.t -> type_expr -> string option ->
- Parsetree.expression -> type_expr -> Typedtree.expression
+ (Ident.t * Types.type_expr) Meths.t ->
+ Parsetree.expression -> type_expr ->
+ Typedtree.expression * (Ident.t * Types.type_expr) Meths.t
val type_pattern_list:
Env.t -> Parsetree.pattern list -> Typedtree.pattern list * Env.t
val type_expect:
diff --git a/typing/typedtree.ml b/typing/typedtree.ml
index d1734d28e7..a5d09e6cac 100644
--- a/typing/typedtree.ml
+++ b/typing/typedtree.ml
@@ -60,24 +60,30 @@ and expression_desc =
| Texp_for of
Ident.t * expression * expression * direction_flag * expression
| Texp_when of expression * expression
- | Texp_send of expression * string
+ | Texp_send of expression * meth
| Texp_new of Path.t
| Texp_instvar of Path.t * Path.t
| Texp_setinstvar of Path.t * Path.t * expression
| Texp_override of Path.t * (Path.t * expression) list
+and meth =
+ Tmeth_name of string
+ | Tmeth_val of Ident.t
+
(* Value expressions for classes *)
type class_field =
Cf_inher of
Path.t * expression list * (string * Ident.t) list *
- (string * Ident.t) list
+ (string * Ident.t) list * string list
| Cf_val of string * Ident.t * private_flag * expression option
| Cf_meth of string * expression
type class_def =
{ cl_args: pattern list;
cl_field: class_field list;
+ cl_pub_meths: string list;
+ cl_meths: Ident.t Meths.t;
cl_loc: Location.t }
(* Value expressions for the module language *)
diff --git a/typing/typedtree.mli b/typing/typedtree.mli
index 403696103f..7e57dc9575 100644
--- a/typing/typedtree.mli
+++ b/typing/typedtree.mli
@@ -59,24 +59,30 @@ and expression_desc =
| Texp_for of
Ident.t * expression * expression * direction_flag * expression
| Texp_when of expression * expression
- | Texp_send of expression * string
+ | Texp_send of expression * meth
| Texp_new of Path.t
| Texp_instvar of Path.t * Path.t
| Texp_setinstvar of Path.t * Path.t * expression
| Texp_override of Path.t * (Path.t * expression) list
+and meth =
+ Tmeth_name of string
+ | Tmeth_val of Ident.t
+
(* Value expressions for classes *)
type class_field =
Cf_inher of
Path.t * expression list * (string * Ident.t) list *
- (string * Ident.t) list
+ (string * Ident.t) list * string list
| Cf_val of string * Ident.t * private_flag * expression option
| Cf_meth of string * expression
type class_def =
{ cl_args: pattern list;
cl_field: class_field list;
+ cl_pub_meths: string list;
+ cl_meths: Ident.t Meths.t;
cl_loc: Location.t }
(* Value expressions for the module language *)
diff --git a/typing/types.ml b/typing/types.ml
index 84808ffe51..b742ef6272 100644
--- a/typing/types.ml
+++ b/typing/types.ml
@@ -28,7 +28,7 @@ and type_desc =
| Ttuple of type_expr list
| Tconstr of Path.t * type_expr list * abbrev_memo ref
| Tobject of type_expr * (Path.t * type_expr list) option ref
- | Tfield of string * type_expr * type_expr
+ | Tfield of string * field_kind * type_expr * type_expr
| Tnil
| Tlink of type_expr
@@ -37,6 +37,16 @@ and abbrev_memo =
| Mcons of Path.t * type_expr * abbrev_memo
| Mlink of abbrev_memo ref
+and field_kind =
+ Fvar of field_kind option ref
+ | Fpresent
+ | Fabsent
+
+(* A set of methods, with their types *)
+
+module OrderedString = struct type t = string let compare = compare end
+module Meths = Map.Make(OrderedString)
+
(* Value descriptions *)
type value_description =
@@ -47,6 +57,8 @@ and value_kind =
Val_reg (* Regular value *)
| Val_prim of Primitive.description (* Primitive *)
| Val_ivar of mutable_flag (* Instance variable (mutable ?) *)
+ | Val_self of (Ident.t * type_expr) Meths.t ref
+ (* Self *)
| Val_anc of (string * Ident.t) list (* Ancestor *)
(* Constructor descriptions *)
@@ -80,7 +92,6 @@ and record_representation =
(* Type expressions for classes *)
-module OrderedString = struct type t = string let compare = compare end
module Vars = Map.Make(OrderedString)
module Concr = Set.Make(OrderedString)
@@ -88,6 +99,7 @@ type class_type =
{ cty_params: type_expr list;
cty_args: type_expr list;
cty_vars: (Asttypes.mutable_flag * type_expr) Vars.t;
+ cty_meths: type_expr Meths.t;
cty_self: type_expr;
cty_concr: Concr.t;
mutable cty_new: type_expr option }
diff --git a/typing/types.mli b/typing/types.mli
index a2abd320fb..292966e299 100644
--- a/typing/types.mli
+++ b/typing/types.mli
@@ -27,7 +27,7 @@ and type_desc =
| Ttuple of type_expr list
| Tconstr of Path.t * type_expr list * abbrev_memo ref
| Tobject of type_expr * (Path.t * type_expr list) option ref
- | Tfield of string * type_expr * type_expr
+ | Tfield of string * field_kind * type_expr * type_expr
| Tnil
| Tlink of type_expr
@@ -36,6 +36,15 @@ and abbrev_memo =
| Mcons of Path.t * type_expr * abbrev_memo
| Mlink of abbrev_memo ref
+and field_kind =
+ Fvar of field_kind option ref
+ | Fpresent
+ | Fabsent
+
+(* A set of methods, with their types *)
+
+module Meths : Map.S with type key = string
+
(* Value descriptions *)
type value_description =
@@ -46,6 +55,8 @@ and value_kind =
Val_reg (* Regular value *)
| Val_prim of Primitive.description (* Primitive *)
| Val_ivar of mutable_flag (* Instance variable (mutable ?) *)
+ | Val_self of (Ident.t * type_expr) Meths.t ref
+ (* Self *)
| Val_anc of (string * Ident.t) list (* Ancestor *)
(* Constructor descriptions *)
@@ -79,13 +90,14 @@ and record_representation =
(* Type expressions for classes *)
-module Vars : Map.S with type key = string
+module Vars : Map.S with type key = string
module Concr : Set.S with type elt = string
type class_type =
{ cty_params: type_expr list;
cty_args: type_expr list;
cty_vars: (mutable_flag * type_expr) Vars.t;
+ cty_meths: type_expr Meths.t;
cty_self: type_expr;
cty_concr: Concr.t;
mutable cty_new: type_expr option }
diff --git a/typing/typetexp.ml b/typing/typetexp.ml
index aa9e4d1680..70a59e76b8 100644
--- a/typing/typetexp.ml
+++ b/typing/typetexp.ml
@@ -181,7 +181,7 @@ and transl_fields env policy =
| {pfield_desc = Pfield(s, e)}::l ->
let ty1 = transl_type env policy e in
let ty2 = transl_fields env policy l in
- newty (Tfield (s, ty1, ty2))
+ newty (Tfield (s, Fpresent, ty1, ty2))
let transl_simple_type env fixed styp =
aliases := Tbl.empty;
View Lorry Controller Status