val ... with [private] {reader|writer|accessor}delegate

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

5 files changed, 68 insertions, 14 deletions

diff --git a/parsing/parser.mly b/parsing/parser.mly
index 06a505ccf2..6183eb5109 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -644,11 +644,29 @@ parent_binder:
           {None}
 ;
 value:
-        mutable_flag label EQUAL seq_expr
-          { $2, $1, $4, symbol_rloc () }
-      | mutable_flag label type_constraint EQUAL seq_expr
-          { $2, $1, (let (t, t') = $3 in ghexp(Pexp_constraint($5, t, t'))),
-            symbol_rloc () }
+        mutable_flag label value_may_expr access_flags
+          { let e = match $3 with Some e -> e
+                    | None -> mkexp(Pexp_ident(Lident $2)) in
+            $2, $1, $4, e, symbol_rloc () }
+      | mutable_flag label type_constraint value_may_expr access_flags
+          { let (t, t') = $3 in
+            let e = match $4 with Some e -> e
+                    | None -> mkexp(Pexp_ident(Lident $2)) in
+            $2, $1, $5, ghexp(Pexp_constraint(e, t, t')), symbol_rloc () }
+;
+value_may_expr:
+    EQUAL seq_expr
+      { Some $2 }
+  | /* empty */
+      { None }
+;
+access_flags:
+    WITH label
+      { Some(Public, $2) }
+  | WITH PRIVATE label
+      { Some(Private, $3) }
+  | /* empty */
+      { None }
 ;
 virtual_method:
     METHOD PRIVATE VIRTUAL method_label COLON poly_type
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index df68be90d5..dc542bfbde 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -178,7 +178,8 @@ 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_val   of (string * mutable_flag * (private_flag * string) option *
+                    expression * Location.t)
   | Pcf_virt  of (string * private_flag * core_type * Location.t)
   | Pcf_meth  of (string * private_flag * expression * Location.t)
   | Pcf_cstr  of (core_type * core_type * Location.t)
diff --git a/parsing/printast.ml b/parsing/printast.ml
index cc054c9970..edeb21dd4b 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -430,7 +430,7 @@ and class_field i ppf x =
       printf "Pcf_deleg\n";
       core_type (i+1) ppf t;
       expression (i+1) ppf e;
-  | Pcf_val (s, mf, e, loc) ->
+  | Pcf_val (s, mf, _, e, loc) ->
       line i ppf
         "Pcf_val \"%s\" %a %a\n" s fmt_mutable_flag mf fmt_location loc;
       expression (i+1) ppf e;
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index 81eaf157df..def5d052b9 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -50,6 +50,7 @@ type error =
       Ident.t * Types.class_declaration * (type_expr * type_expr) list
   | Final_self_clash of (type_expr * type_expr) list
   | Not_a_variable
+  | Bad_field_access of string
 
 exception Error of Location.t * error
 
@@ -470,12 +471,15 @@ let rec class_field cl_num self_type meths vars
             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
+      let (val_env, met_env, par_env, fields, concr_meths, _, inh_vals) =
+        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
+      in
+      (val_env, met_env, par_env, fields, concr_meths, warn_meths, inh_vals)
 
-  | Pcf_val (lab, mut, sexp, loc) ->
+  | Pcf_val (lab, mut, attrs, sexp, loc) ->
       if StringSet.mem lab inh_vals then
         Location.prerr_warning loc (Warnings.Hide_instance_variable lab);
       if !Clflags.principal then Ctype.begin_def ();
@@ -490,8 +494,36 @@ let rec class_field cl_num self_type meths vars
       let (id, val_env, met_env, par_env) =
         enter_val cl_num vars lab mut exp.exp_type val_env met_env par_env
       in
-      (val_env, met_env, par_env, lazy(Cf_val (lab, id, exp)) :: fields,
-       concr_meths, warn_meths, inh_vals)
+      let env =
+        (val_env, met_env, par_env, lazy(Cf_val (lab, id, exp)) :: fields,
+         concr_meths, warn_meths, inh_vals) in
+      begin match attrs with
+        None -> env
+      | Some (priv, ("accessor"|"reader"|"writer" as attr)) ->
+          let ident s =
+            {pexp_desc=Pexp_ident(Longident.Lident s); pexp_loc=loc} in
+          let env =
+            if attr <> "writer" then
+              class_field cl_num self_type meths vars env
+                (Pcf_meth(lab, priv,
+                          {pexp_desc=Pexp_poly(ident lab, None); pexp_loc=loc},
+                          loc))
+            else env
+          in
+          if attr <> "reader" then
+            class_field cl_num self_type meths vars env
+              (Pcf_meth(
+               lab^"<-", priv,
+               {pexp_desc=Pexp_poly(
+                {pexp_desc=Pexp_function(
+                 "",None,[{ppat_desc=Ppat_var"*arg*";ppat_loc=loc},
+                          {pexp_desc=Pexp_setinstvar(lab, ident "*arg*");
+                           pexp_loc=loc}]);
+                 pexp_loc=loc}, None);
+                pexp_loc=loc}, loc))
+          else env
+      | Some(_,attr) -> raise(Error(loc, Bad_field_access attr))
+      end
 
   | Pcf_virt (lab, priv, sty, loc) ->
       virtual_method val_env meths self_type lab priv sty loc;
@@ -1552,3 +1584,5 @@ let report_error ppf = function
   | Not_a_variable ->
       fprintf ppf "@[%s@ %s@]" "You can only delegate to a variable"
         "or a method of self (without arguments)"
+  | Bad_field_access s ->
+      fprintf ppf "@[`%s' is not a valid field access qualifier@]" s
diff --git a/typing/typeclass.mli b/typing/typeclass.mli
index 6b74abd715..83a5315f45 100644
--- a/typing/typeclass.mli
+++ b/typing/typeclass.mli
@@ -75,6 +75,7 @@ type error =
       Ident.t * Types.class_declaration * (type_expr * type_expr) list
   | Final_self_clash of (type_expr * type_expr) list
   | Not_a_variable
+  | Bad_field_access of string
 
 exception Error of Location.t * error