#6688: allow val declarations as structure items.

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

6 files changed, 20 insertions, 6 deletions

diff --git a/typing/env.ml b/typing/env.ml
index 2175ad3372..997e6d75b7 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -226,8 +226,13 @@ let empty = {
   functor_args = Ident.empty;
  }
 
-let in_signature env =
-  {env with flags = env.flags lor in_signature_flag}
+let in_signature b env =
+  let flags =
+    if b then env.flags lor in_signature_flag
+    else env.flags land (lnot in_signature_flag)
+  in
+  {env with flags}
+
 let implicit_coercion env =
   {env with flags = env.flags lor implicit_coercion_flag}
 
diff --git a/typing/env.mli b/typing/env.mli
index 4ab08e83a8..549e58fb93 100644
--- a/typing/env.mli
+++ b/typing/env.mli
@@ -209,9 +209,11 @@ val mark_constructor:
 val mark_extension_used:
     constructor_usage -> t -> extension_constructor -> string -> unit
 
-val in_signature: t -> t
+val in_signature: bool -> t -> t
 val implicit_coercion: t -> t
 
+val is_in_signature: t -> bool
+
 val set_value_used_callback:
     string -> value_description -> (unit -> unit) -> unit
 val set_type_used_callback:
diff --git a/typing/includemod.ml b/typing/includemod.ml
index 67c4c32803..049f37aa4b 100644
--- a/typing/includemod.ml
+++ b/typing/includemod.ml
@@ -280,7 +280,7 @@ and try_modtypes2 env cxt mty1 mty2 =
 and signatures env cxt subst sig1 sig2 =
   (* Environment used to check inclusion of components *)
   let new_env =
-    Env.add_signature sig1 (Env.in_signature env) in
+    Env.add_signature sig1 (Env.in_signature true env) in
   (* Keep ids for module aliases *)
   let (id_pos_list,_) =
     List.fold_left
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index 8981421691..9a77ce538a 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -45,6 +45,7 @@ type error =
   | Bad_fixed_type of string
   | Unbound_type_var_ext of type_expr * extension_constructor
   | Varying_anonymous
+  | Val_in_structure
 
 open Typedtree
 
@@ -1346,9 +1347,11 @@ let transl_value_decl env loc valdecl =
   let ty = cty.ctyp_type in
   let v =
   match valdecl.pval_prim with
-    [] ->
+    [] when Env.is_in_signature env ->
       { val_type = ty; val_kind = Val_reg; Types.val_loc = loc;
         val_attributes = valdecl.pval_attributes }
+  | [] ->
+      raise (Error(valdecl.pval_loc, Val_in_structure))
   | decl ->
       let arity = Ctype.arity ty in
       let prim = Primitive.parse_declaration arity decl in
@@ -1699,6 +1702,8 @@ let report_error ppf = function
       fprintf ppf "@[%s@ %s@ %s@]"
         "In this GADT definition," "the variance of some parameter"
         "cannot be checked"
+  | Val_in_structure ->
+      fprintf ppf "Value declarations are only allowed in signatures"
 
 let () =
   Location.register_error_of_exn
diff --git a/typing/typedecl.mli b/typing/typedecl.mli
index 452674958b..4c2a935e99 100644
--- a/typing/typedecl.mli
+++ b/typing/typedecl.mli
@@ -82,6 +82,7 @@ type error =
   | Bad_fixed_type of string
   | Unbound_type_var_ext of type_expr * extension_constructor
   | Varying_anonymous
+  | Val_in_structure
 
 exception Error of Location.t * error
 
diff --git a/typing/typemod.ml b/typing/typemod.ml
index bf3e1bfafc..08cef79a7d 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -555,6 +555,7 @@ let rec transl_modtype env smty =
         (Mtype.freshen (Mty_signature final_sg)) env loc
         smty.pmty_attributes
   | Pmty_typeof smod ->
+      let env = Env.in_signature false env in
       let tmty, mty = !type_module_type_of_fwd env smod in
       mkmty (Tmty_typeof tmty) mty env loc smty.pmty_attributes
   | Pmty_extension ext ->
@@ -721,7 +722,7 @@ and transl_signature env sg =
   in
   let previous_saved_types = Cmt_format.get_saved_types () in
   Typetexp.warning_enter_scope ();
-  let (trem, rem, final_env) = transl_sig (Env.in_signature env) sg in
+  let (trem, rem, final_env) = transl_sig (Env.in_signature true env) sg in
   let rem = simplify_signature rem in
   let sg = { sig_items = trem; sig_type =  rem; sig_final_env = final_env } in
   Typetexp.warning_leave_scope ();