add delegate keyword + <- methods

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/delegate@6266 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

9 files changed, 151 insertions, 14 deletions

diff --git a/parsing/lexer.mll b/parsing/lexer.mll
index 809a37e7b8..c03e48854e 100644
--- a/parsing/lexer.mll
+++ b/parsing/lexer.mll
@@ -41,6 +41,7 @@ let keyword_table =
     "begin", BEGIN;
     "class", CLASS;
     "constraint", CONSTRAINT;
+    "delegate", DELEGATE;
     "do", DO;
     "done", DONE;
     "downto", DOWNTO;
diff --git a/parsing/parser.mly b/parsing/parser.mly
index 18cea539e8..06a505ccf2 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -205,6 +205,7 @@ let bigarray_set arr arg newval =
 %token COLONGREATER
 %token COMMA
 %token CONSTRAINT
+%token DELEGATE
 %token DO
 %token DONE
 %token DOT
@@ -623,6 +624,8 @@ class_fields:
       { [] }
   | class_fields INHERIT class_expr parent_binder
       { Pcf_inher ($3, $4) :: $1 }
+  | class_fields DELEGATE simple_core_type TO simple_expr
+      { Pcf_deleg ($3, $5) :: $1 }
   | class_fields VAL value
       { Pcf_val $3 :: $1 }
   | class_fields virtual_method
@@ -648,15 +651,15 @@ value:
             symbol_rloc () }
 ;
 virtual_method:
-    METHOD PRIVATE VIRTUAL label COLON poly_type
+    METHOD PRIVATE VIRTUAL method_label COLON poly_type
       { $4, Private, $6, symbol_rloc () }
-  | METHOD VIRTUAL private_flag label COLON poly_type
+  | METHOD VIRTUAL private_flag method_label COLON poly_type
       { $4, $3, $6, symbol_rloc () }
 ;
 concrete_method :
-    METHOD private_flag label strict_binding
+    METHOD private_flag method_label strict_binding
       { $3, $2, ghexp(Pexp_poly ($4, None)), symbol_rloc () }
-  | METHOD private_flag label COLON poly_type EQUAL seq_expr
+  | METHOD private_flag method_label COLON poly_type EQUAL seq_expr
       { $3, $2, ghexp(Pexp_poly($7,Some $5)), symbol_rloc () }
   | METHOD private_flag LABEL poly_type EQUAL seq_expr
       { $3, $2, ghexp(Pexp_poly($6,Some $4)), symbol_rloc () }
@@ -715,7 +718,7 @@ value_type:
       { $2, $1, Some $4, symbol_rloc () }
 ;
 method_type:
-    METHOD private_flag label COLON poly_type
+    METHOD private_flag method_label COLON poly_type
       { $3, $2, $5, symbol_rloc () }
 ;
 constrain:
@@ -884,6 +887,14 @@ expr:
       { mkexp (Pexp_object($2)) }
   | OBJECT class_structure error
       { unclosed "object" 1 "end" 3 }
+  | send_assign
+      { $1 }
+  | send_assign expr
+      { mkexp(Pexp_apply($1, ["",$2])) }
+;
+send_assign:
+    simple_expr SHARP label LESSMINUS
+      { mkexp(Pexp_send($1, $3 ^ "<-")) }
 ;
 simple_expr:
     val_longident
@@ -1345,7 +1356,11 @@ meth_list:
   | DOTDOT                                      { [mkfield Pfield_var] }
 ;
 field:
-    label COLON poly_type                       { mkfield(Pfield($1, $3)) }
+    method_label COLON poly_type                { mkfield(Pfield($1, $3)) }
+;
+method_label:
+    label                                       { $1 }
+  | label LESSMINUS                             { $1 ^ "<-" }
 ;
 label:
     LIDENT                                      { $1 }
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index d0db6b8483..df68be90d5 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -177,6 +177,7 @@ and class_structure = pattern * class_field list
 
 and class_field =
     Pcf_inher of class_expr * string option
+  | Pcf_deleg of core_type * expression
   | Pcf_val   of (string * mutable_flag * expression * Location.t)
   | Pcf_virt  of (string * private_flag * core_type * Location.t)
   | Pcf_meth  of (string * private_flag * expression * Location.t)
diff --git a/parsing/printast.ml b/parsing/printast.ml
index 340917155f..cc054c9970 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -426,6 +426,10 @@ and class_field i ppf x =
       printf "Pcf_inher\n";
       class_expr (i+1) ppf ce;
       option (i+1) string ppf so;
+  | Pcf_deleg (t, e) ->
+      printf "Pcf_deleg\n";
+      core_type (i+1) ppf t;
+      expression (i+1) ppf e;
   | Pcf_val (s, mf, e, loc) ->
       line i ppf
         "Pcf_val \"%s\" %a %a\n" s fmt_mutable_flag mf fmt_location loc;
diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml
index 1f8766c804..e8fa52cc40 100644
--- a/toplevel/genprintval.ml
+++ b/toplevel/genprintval.ml
@@ -52,6 +52,21 @@ module type S =
           Env.t -> t -> type_expr -> Outcometree.out_value
   end
 
+let get_const = CamlinternalOO.get_const (Obj.magic 0)
+let get_var = CamlinternalOO.get_var 0
+let get_env = CamlinternalOO.get_env 0 0
+let get_pointer clos : int = Obj.obj (Obj.field (Obj.repr clos) 0)
+let label_step = Sys.word_size / 16
+let bucket_size = 32
+let decode_label (label : CamlinternalOO.label) =
+  let label = Obj.magic label in
+  (label / 65536 / label_step,
+   (label mod (label_step * bucket_size)) / label_step)
+let is_abstract env p =
+  try (Env.find_type p env).type_kind = Type_abstract
+  with Not_found -> true
+
+
 module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct
 
     type t = O.t
@@ -310,8 +325,45 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct
                       else find fields
                   | [] -> Oval_stuff "<variant>" in
                 find row.row_fields
-          | Tobject (_, _) ->
-              Oval_stuff "<obj>"
+          | Tobject (fi, _) ->
+              let meths = O.field obj 0 in
+              let rec get_fields = function
+                  [] -> []
+                | (label, _, ty) :: rem ->
+                    let l = get_fields rem in
+                    begin match (Ctype.repr ty).desc with
+                      Tpoly (ty, _) ->
+                        begin match (Ctype.expand_head env ty).desc with
+                          Tvar | Tunivar | Tarrow _ -> l
+                        (*| Tconstr (p, _, _) when is_abstract env p -> l *)
+                        | _ ->
+                            let lab = CamlinternalOO.new_method label in
+                            let (buck, elem) = decode_label lab in
+                            let bucko = O.field meths buck in
+                            let clos = O.field bucko elem in
+                            (* cette ligne cause: Debugcom.Marshalling_error *)
+                            let ptr : int = O.obj (O.field clos 0) in
+                            if ptr == get_pointer get_const then
+                              (label, O.field clos 1, ty) :: l
+                            else if ptr == get_pointer get_var then
+                              let n : int = O.obj (O.field clos 1) in
+                              (label, O.field obj n, ty) :: l
+                            else if ptr == get_pointer get_env then
+                              let e : int = O.obj (O.field clos 1) in
+                              let n : int = O.obj (O.field clos 2) in
+                              (label, O.field (O.field obj e) n, ty) :: l
+                            else l
+                        end
+                    | _ -> l
+                    end
+              in
+              let fields = get_fields (fst (Ctype.flatten_fields fi)) in
+              if fields = [] then Oval_stuff "<obj>" else
+              Oval_record
+                (List.map
+                   (fun (label, obj, ty) ->
+                     Oide_ident label, tree_of_val (depth - 1) obj ty)
+                   fields)
           | Tsubst ty ->
               tree_of_val (depth - 1) obj ty
           | Tfield(_, _, _, _) | Tnil | Tlink _ ->
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index a0f9dd64ec..81eaf157df 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -49,6 +49,7 @@ type error =
   | Non_collapsable_conjunction of
       Ident.t * Types.class_declaration * (type_expr * type_expr) list
   | Final_self_clash of (type_expr * type_expr) list
+  | Not_a_variable
 
 exception Error of Location.t * error
 
@@ -373,6 +374,28 @@ and class_type env scty =
 
 (*******************************)
 
+let extract_fields env sty =
+  let loc = sty.ptyp_loc in
+  let ty, lid =
+    match sty.ptyp_desc with
+      Ptyp_constr (lid, _) ->
+        let path, decl =
+          try Env.lookup_type lid env
+          with Not_found ->
+            raise(Typetexp.Error(loc, Unbound_type_constructor lid))
+        in
+        let tyl = List.map (fun _ -> Ctype.newvar()) decl.type_params in
+        Ctype.newty(Tconstr(path, tyl, ref Mnil)), Some lid
+    | _ ->
+        transl_type_scheme env sty, None
+  in
+  match (Ctype.expand_head env ty).desc with
+    Tobject (ty, _) ->
+      List.map (fun (f,_,t) -> (f,t)) (fst (Ctype.flatten_fields ty))
+  | _ ->
+      raise(Typecore.Error (loc, Wrong_type_kind("an object", lid)))
+
+
 module StringSet = Set.Make(struct type t = string let compare = compare end)
 
 let rec class_field cl_num self_type meths vars
@@ -419,6 +442,39 @@ let rec class_field cl_num self_type meths vars
        lazy(Cf_inher (parent, inh_vars, inh_meths))::fields,
        concr_meths, warn_meths, inh_vals)
 
+  | Pcf_deleg (sty, sexp) ->
+      let labs = extract_fields met_env sty in
+      let loc = sexp.pexp_loc in
+      begin match sexp.pexp_desc with
+        Pexp_ident _ -> ()
+      | Pexp_send ({pexp_desc=Pexp_ident lid}, lab) when
+          begin try match Env.lookup_value lid met_env with
+            (_, {val_kind=Val_self(_,_,num,_)}) when num = cl_num -> true
+          | _ -> false
+          with Not_found -> false
+          end -> ()
+      | _ -> raise(Error(loc, Not_a_variable))
+      end;
+      let mets =
+        List.map
+          (fun (lab,t) ->
+            let (_, ty) =
+              Ctype.filter_self_method val_env lab Public meths self_type
+            in
+            begin try Ctype.unify val_env t ty with Ctype.Unify trace ->
+              raise(Error(loc, Method_type_mismatch (lab, trace)))
+            end;
+            let sexp =
+              {sexp with pexp_desc =
+               Pexp_poly({sexp with pexp_desc = Pexp_send(sexp, lab)}, None)}
+            in Pcf_meth (lab, Public, sexp, loc))
+          labs
+      in
+      List.fold_left
+        (class_field cl_num self_type meths vars)
+        (val_env, met_env, par_env, fields, concr_meths, warn_meths, inh_vals)
+        mets
+
   | Pcf_val (lab, mut, sexp, loc) ->
       if StringSet.mem lab inh_vals then
         Location.prerr_warning loc (Warnings.Hide_instance_variable lab);
@@ -1493,3 +1549,6 @@ let report_error ppf = function
            fprintf ppf "This object is expected to have type")
         (function ppf ->
            fprintf ppf "but has actually type")
+  | Not_a_variable ->
+      fprintf ppf "@[%s@ %s@]" "You can only delegate to a variable"
+        "or a method of self (without arguments)"
diff --git a/typing/typeclass.mli b/typing/typeclass.mli
index b26b9e72e7..6b74abd715 100644
--- a/typing/typeclass.mli
+++ b/typing/typeclass.mli
@@ -74,6 +74,7 @@ type error =
   | Non_collapsable_conjunction of
       Ident.t * Types.class_declaration * (type_expr * type_expr) list
   | Final_self_clash of (type_expr * type_expr) list
+  | Not_a_variable
 
 exception Error of Location.t * error
 
diff --git a/typing/typecore.ml b/typing/typecore.ml
index bb54705380..3f8f271e92 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -55,7 +55,7 @@ type error =
   | Abstract_wrong_label of label * type_expr
   | Scoping_let_module of string * type_expr
   | Masked_instance_variable of Longident.t
-  | Not_a_variant_type of Longident.t
+  | Wrong_type_kind of string * Longident.t option
   | Incoherent_label_order
   | Less_general of string * (type_expr * type_expr) list
 
@@ -296,7 +296,7 @@ let build_or_pat env loc lid =
     match ty.desc with
       Tvariant row when static_row row ->
         (row_repr row).row_fields
-    | _ -> raise(Error(loc, Not_a_variant_type lid))
+    | _ -> raise(Error(loc, Wrong_type_kind ("a variant", Some lid)))
   in
   let bound = ref [] in
   let pats, fields =
@@ -326,7 +326,7 @@ let build_or_pat env loc lid =
       pats
   in
   match pats with
-    [] -> raise(Error(loc, Not_a_variant_type lid))
+    [] -> raise(Error(loc, Wrong_type_kind ("a variant", Some lid)))
   | pat :: pats ->
       let r =
         List.fold_left
@@ -2013,8 +2013,12 @@ let report_error ppf = function
   | Private_label (lid, ty) ->
       fprintf ppf "Cannot assign field %a of the private type %a"
         longident lid type_expr ty
-  | Not_a_variant_type lid ->
-      fprintf ppf "The type %a@ is not a variant type" longident lid
+  | Wrong_type_kind (kind, lid) ->
+      begin match lid with
+        None -> fprintf ppf "This type"
+      | Some lid -> fprintf ppf "The type %a" longident lid
+      end;
+      fprintf ppf "@ is not %s type" kind
   | Incoherent_label_order ->
       fprintf ppf "This function is applied to arguments@ ";
       fprintf ppf "in an order different from other calls.@ ";
diff --git a/typing/typecore.mli b/typing/typecore.mli
index 3511b93b5a..80727d1106 100644
--- a/typing/typecore.mli
+++ b/typing/typecore.mli
@@ -92,7 +92,7 @@ type error =
   | Abstract_wrong_label of label * type_expr
   | Scoping_let_module of string * type_expr
   | Masked_instance_variable of Longident.t
-  | Not_a_variant_type of Longident.t
+  | Wrong_type_kind of string * Longident.t option
   | Incoherent_label_order
   | Less_general of string * (type_expr * type_expr) list