re PR fortran/29642 (Fortran 2003: VALUE Attribute (call by value not call by reference for actual arguments))

2006-12-03  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/29642
	* trans-expr.c (gfc_conv_variable): A character expression with
	the VALUE attribute needs an address expression; otherwise all
	other expressions with this attribute must not be dereferenced.
	(gfc_conv_function_call): Pass expressions with the VALUE
	attribute by value, using gfc_conv_expr.
	* symbol.c (check_conflict): Add strings for INTENT OUT, INOUT
	and VALUE.  Apply all the constraints associated with the VALUE
	attribute.
	(gfc_add_value): New function.
	(gfc_copy_attr): Call it for VALUE attribute.
	* decl.c (match_attr_spec): Include the VALUE attribute.
	(gfc_match_value): New function.
	* dump-parse-tree.c (gfc_show_attr): Include VALUE.
	* gfortran.h : Add value to the symbol_attribute structure and
	add a prototype for gfc_add_value
	* module.c (mio_internal_string): Include AB_VALUE in enum.
	(attr_bits): Provide the VALUE string for it.
	(mio_symbol_attribute): Read or apply the VLUE attribute.
	* trans-types.c (gfc_sym_type): Variables with the VLAUE
	attribute are not passed by reference!
	* resolve.c (was_declared): Add value to those that return 1.
	(resolve_symbol): Value attribute requires dummy attribute.
	* match.h : Add prototype for gfc_match_public.
	* parse.c (decode_statement): Try to match a VALUE statement.


2006-12-03  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/29642
	* gfortran.dg/value_1.f90 : New test.
	* gfortran.dg/value_2.f90 : New test.
	* gfortran.dg/value_3.f90 : New test.
	* gfortran.dg/value_4.f90 : New test.
	* gfortran.dg/value_4.c : Called from value_4.f90.

From-SVN: r119461

11 files changed, 188 insertions, 24 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index be3e91e..d17b047 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,31 @@
+2006-12-03  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/29642
+	* trans-expr.c (gfc_conv_variable): A character expression with
+	the VALUE attribute needs an address expression; otherwise all
+	other expressions with this attribute must not be dereferenced.
+	(gfc_conv_function_call): Pass expressions with the VALUE
+	attribute by value, using gfc_conv_expr.
+	* symbol.c (check_conflict): Add strings for INTENT OUT, INOUT
+	and VALUE.  Apply all the constraints associated with the VALUE
+	attribute.
+	(gfc_add_value): New function.
+	(gfc_copy_attr): Call it for VALUE attribute.
+	* decl.c (match_attr_spec): Include the VALUE attribute.
+	(gfc_match_value): New function.
+	* dump-parse-tree.c (gfc_show_attr): Include VALUE.
+	* gfortran.h : Add value to the symbol_attribute structure and
+	add a prototype for gfc_add_value
+	* module.c (mio_internal_string): Include AB_VALUE in enum.
+	(attr_bits): Provide the VALUE string for it.
+	(mio_symbol_attribute): Read or apply the VLUE attribute.
+	* trans-types.c (gfc_sym_type): Variables with the VLAUE
+	attribute are not passed by reference!
+	* resolve.c (was_declared): Add value to those that return 1.
+	(resolve_symbol): Value attribute requires dummy attribute.
+	* match.h : Add prototype for gfc_match_public.
+	* parse.c (decode_statement): Try to match a VALUE statement.
+
 2006-12-01  Thomas Koenig  <Thomas.Koenig@online.de>
 
 	PR libfortran/29568
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 25fa6b5..46c49ba 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -2117,7 +2117,7 @@ match_attr_spec (void)
     DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL,
     DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
     DECL_PARAMETER, DECL_POINTER, DECL_PRIVATE, DECL_PUBLIC, DECL_SAVE,
-    DECL_TARGET, DECL_VOLATILE, DECL_COLON, DECL_NONE,
+    DECL_TARGET, DECL_VALUE, DECL_VOLATILE, DECL_COLON, DECL_NONE,
     GFC_DECL_END /* Sentinel */
   }
   decl_types;
@@ -2140,6 +2140,7 @@ match_attr_spec (void)
     minit (", public", DECL_PUBLIC),
     minit (", save", DECL_SAVE),
     minit (", target", DECL_TARGET),
+    minit (", value", DECL_VALUE),
     minit (", volatile", DECL_VOLATILE),
     minit ("::", DECL_COLON),
     minit (NULL, DECL_NONE)
@@ -2261,6 +2262,9 @@ match_attr_spec (void)
 	  case DECL_TARGET:
 	    attr = "TARGET";
 	    break;
+	  case DECL_VALUE:
+	    attr = "VALUE";
+	    break;
 	  case DECL_VOLATILE:
 	    attr = "VOLATILE";
 	    break;
@@ -2378,6 +2382,15 @@ match_attr_spec (void)
 	  t = gfc_add_target (&current_attr, &seen_at[d]);
 	  break;
 
+	case DECL_VALUE:
+	  if (gfc_notify_std (GFC_STD_F2003,
+                              "Fortran 2003: VALUE attribute at %C")
+	      == FAILURE)
+	    t = FAILURE;
+	  else
+	    t = gfc_add_value (&current_attr, NULL, &seen_at[d]);
+	  break;
+
 	case DECL_VOLATILE:
 	  if (gfc_notify_std (GFC_STD_F2003,
                               "Fortran 2003: VOLATILE attribute at %C")
@@ -4051,6 +4064,57 @@ syntax:
 
 
 match
+gfc_match_value (void)
+{
+  gfc_symbol *sym;
+  match m;
+
+  if (gfc_notify_std (GFC_STD_F2003, 
+		      "Fortran 2003: VALUE statement at %C")
+      == FAILURE)
+    return MATCH_ERROR;
+
+  if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
+    {
+      return MATCH_ERROR;
+    }
+
+  if (gfc_match_eos () == MATCH_YES)
+    goto syntax;
+
+  for(;;)
+    {
+      m = gfc_match_symbol (&sym, 0);
+      switch (m)
+	{
+	case MATCH_YES:
+	  if (gfc_add_value (&sym->attr, sym->name,
+  			        &gfc_current_locus) == FAILURE)
+	    return MATCH_ERROR;
+	  goto next_item;
+
+	case MATCH_NO:
+	  break;
+
+	case MATCH_ERROR:
+	  return MATCH_ERROR;
+	}
+
+    next_item:
+      if (gfc_match_eos () == MATCH_YES)
+	break;
+      if (gfc_match_char (',') != MATCH_YES)
+	goto syntax;
+    }
+
+  return MATCH_YES;
+
+syntax:
+  gfc_error ("Syntax error in VALUE statement at %C");
+  return MATCH_ERROR;
+}
+
+match
 gfc_match_volatile (void)
 {
   gfc_symbol *sym;
diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c
index dd08d1f..f53ee2e 100644
--- a/gcc/fortran/dump-parse-tree.c
+++ b/gcc/fortran/dump-parse-tree.c
@@ -552,6 +552,8 @@ gfc_show_attr (symbol_attribute * attr)
     gfc_status (" POINTER");
   if (attr->save)
     gfc_status (" SAVE");
+  if (attr->value)
+    gfc_status (" VALUE");
   if (attr->volatile_)
     gfc_status (" VOLATILE");
   if (attr->threadprivate)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 9a18e7851..3a3b680 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -479,7 +479,7 @@ typedef struct
 {
   /* Variable attributes.  */
   unsigned allocatable:1, dimension:1, external:1, intrinsic:1,
-    optional:1, pointer:1, save:1, target:1, volatile_:1,
+    optional:1, pointer:1, save:1, target:1, value:1, volatile_:1,
     dummy:1, result:1, assign:1, threadprivate:1;
 
   unsigned data:1,		/* Symbol is named in a DATA statement.  */
@@ -1871,6 +1871,7 @@ try gfc_add_pure (symbol_attribute *, locus *);
 try gfc_add_recursive (symbol_attribute *, locus *);
 try gfc_add_function (symbol_attribute *, const char *, locus *);
 try gfc_add_subroutine (symbol_attribute *, const char *, locus *);
+try gfc_add_value (symbol_attribute *, const char *, locus *);
 try gfc_add_volatile (symbol_attribute *, const char *, locus *);
 
 try gfc_add_access (symbol_attribute *, gfc_access, const char *, locus *);
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index 8a8ab99..cc0207b 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -147,6 +147,7 @@ match gfc_match_public (gfc_statement *);
 match gfc_match_save (void);
 match gfc_match_modproc (void);
 match gfc_match_target (void);
+match gfc_match_value (void);
 match gfc_match_volatile (void);
 
 /* primary.c */
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index cd83ff9..6956fc9 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -1487,11 +1487,11 @@ mio_internal_string (char *string)
 
 typedef enum
 { AB_ALLOCATABLE, AB_DIMENSION, AB_EXTERNAL, AB_INTRINSIC, AB_OPTIONAL,
-  AB_POINTER, AB_SAVE, AB_TARGET, AB_DUMMY, AB_RESULT,
-  AB_DATA, AB_IN_NAMELIST, AB_IN_COMMON, 
-  AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE, AB_ELEMENTAL, AB_PURE,
-  AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT, AB_CRAY_POINTER,
-  AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP, AB_VOLATILE
+  AB_POINTER, AB_SAVE, AB_TARGET, AB_DUMMY, AB_RESULT, AB_DATA,
+  AB_IN_NAMELIST, AB_IN_COMMON, AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE,
+  AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT,
+  AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP,
+  AB_VALUE, AB_VOLATILE
 }
 ab_attribute;
 
@@ -1504,6 +1504,7 @@ static const mstring attr_bits[] =
     minit ("OPTIONAL", AB_OPTIONAL),
     minit ("POINTER", AB_POINTER),
     minit ("SAVE", AB_SAVE),
+    minit ("VALUE", AB_VALUE),
     minit ("VOLATILE", AB_VOLATILE),
     minit ("TARGET", AB_TARGET),
     minit ("THREADPRIVATE", AB_THREADPRIVATE),
@@ -1575,6 +1576,8 @@ mio_symbol_attribute (symbol_attribute * attr)
 	MIO_NAME(ab_attribute) (AB_POINTER, attr_bits);
       if (attr->save)
 	MIO_NAME(ab_attribute) (AB_SAVE, attr_bits);
+      if (attr->value)
+	MIO_NAME(ab_attribute) (AB_VALUE, attr_bits);
       if (attr->volatile_)
 	MIO_NAME(ab_attribute) (AB_VOLATILE, attr_bits);
       if (attr->target)
@@ -1655,6 +1658,9 @@ mio_symbol_attribute (symbol_attribute * attr)
 	    case AB_SAVE:
 	      attr->save = 1;
 	      break;
+	    case AB_VALUE:
+	      attr->value = 1;
+	      break;
 	    case AB_VOLATILE:
 	      attr->volatile_ = 1;
 	      break;
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index eebe448..d237373 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -284,6 +284,7 @@ decode_statement (void)
       break;
 
     case 'v':
+      match ("value", gfc_match_value, ST_ATTR_DECL);
       match ("volatile", gfc_match_volatile, ST_ATTR_DECL);
       break;
 
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index fd544c9..d682b22 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -675,7 +675,7 @@ was_declared (gfc_symbol * sym)
     return 1;
 
   if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
-      || a.optional || a.pointer || a.save || a.target || a.volatile_
+      || a.optional || a.pointer || a.save || a.target || a.volatile_ || a.value
       || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
     return 1;
 
@@ -5961,6 +5961,14 @@ resolve_symbol (gfc_symbol * sym)
       return;
     }
 
+  if (sym->attr.value && !sym->attr.dummy)
+    {
+      gfc_error ("'%s' at %L cannot have the VALUE attribute because "
+		 "it is not a dummy", sym->name, &sym->declared_at);
+      return;
+    }
+
+
   /* If a derived type symbol has reached this point, without its
      type being declared, we have an error.  Notice that most
      conditions that produce undefined derived types have already
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 7982920..228567b 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -266,6 +266,7 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where)
   static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
     *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT",
     *intent_in = "INTENT(IN)", *intrinsic = "INTRINSIC",
+    *intent_out = "INTENT(OUT)", *intent_inout = "INTENT(INOUT)",
     *allocatable = "ALLOCATABLE", *elemental = "ELEMENTAL",
     *private = "PRIVATE", *recursive = "RECURSIVE",
     *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
@@ -273,7 +274,8 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where)
     *function = "FUNCTION", *subroutine = "SUBROUTINE",
     *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
     *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
-    *cray_pointee = "CRAY POINTEE", *data = "DATA", *volatile_ = "VOLATILE";
+    *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
+    *volatile_ = "VOLATILE";
   static const char *threadprivate = "THREADPRIVATE";
 
   const char *a1, *a2;
@@ -402,6 +404,21 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where)
   conf (data, allocatable);
   conf (data, use_assoc);
 
+  conf (value, pointer)
+  conf (value, allocatable)
+  conf (value, subroutine)
+  conf (value, function)
+  conf (value, volatile_)
+  conf (value, dimension)
+  conf (value, external)
+
+  if (attr->value && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT))
+    {
+      a1 = value;
+      a2 = attr->intent == INTENT_OUT ? intent_out : intent_inout;
+      goto conflict;
+    }
+
   conf (volatile_, intrinsic)
   conf (volatile_, external)
 
@@ -524,6 +541,7 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where)
       conf2 (dummy);
       conf2 (in_common);
       conf2 (save);
+      conf2 (value);
       conf2 (volatile_);
       conf2 (threadprivate);
       break;
@@ -805,6 +823,26 @@ gfc_add_save (symbol_attribute * attr, const char *name, locus * where)
 }
 
 try
+gfc_add_value (symbol_attribute * attr, const char *name, locus * where)
+{
+
+  if (check_used (attr, name, where))
+    return FAILURE;
+
+  if (attr->value)
+    {
+	if (gfc_notify_std (GFC_STD_LEGACY, 
+			    "Duplicate VALUE attribute specified at %L",
+			    where) 
+	    == FAILURE)
+	  return FAILURE;
+    }
+
+  attr->value = 1;
+  return check_conflict (attr, name, where);
+}
+
+try
 gfc_add_volatile (symbol_attribute * attr, const char *name, locus * where)
 {
 
@@ -1257,6 +1295,8 @@ gfc_copy_attr (symbol_attribute * dest, symbol_attribute * src, locus * where)
     goto fail;
   if (src->save && gfc_add_save (dest, NULL, where) == FAILURE)
     goto fail;
+  if (src->value && gfc_add_value (dest, NULL, where) == FAILURE)
+    goto fail;
   if (src->volatile_ && gfc_add_volatile (dest, NULL, where) == FAILURE)
     goto fail;
   if (src->threadprivate && gfc_add_threadprivate (dest, NULL, where) == FAILURE)
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index d504043..3505236 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -447,15 +447,21 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
 	 separately.  */
       if (sym->ts.type == BT_CHARACTER)
 	{
-          /* Dereference character pointer dummy arguments
+	  /* Dereference character pointer dummy arguments
 	     or results.  */
 	  if ((sym->attr.pointer || sym->attr.allocatable)
 	      && (sym->attr.dummy
 		  || sym->attr.function
 		  || sym->attr.result))
 	    se->expr = build_fold_indirect_ref (se->expr);
+
+	  /* A character with VALUE attribute needs an address
+	     expression.  */
+	  if (sym->attr.value)
+	    se->expr = build_fold_addr_expr (se->expr);
+
 	}
-      else
+      else if (!sym->attr.value)
 	{
           /* Dereference non-character scalar dummy arguments.  */
 	  if (sym->attr.dummy && !sym->attr.dimension)
@@ -2005,19 +2011,26 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 	  argss = gfc_walk_expr (e);
 
 	  if (argss == gfc_ss_terminator)
-            {
-	      gfc_conv_expr_reference (&parmse, e);
+	    {
 	      parm_kind = SCALAR;
-              if (fsym && fsym->attr.pointer
-		  && e->expr_type != EXPR_NULL)
-                {
-                  /* Scalar pointer dummy args require an extra level of
-		  indirection. The null pointer already contains
-		  this level of indirection.  */
-		  parm_kind = SCALAR_POINTER;
-                  parmse.expr = build_fold_addr_expr (parmse.expr);
-                }
-            }
+	      if (fsym && fsym->attr.value)
+		{
+		  gfc_conv_expr (&parmse, e);
+		}
+	      else
+		{
+		  gfc_conv_expr_reference (&parmse, e);
+		  if (fsym && fsym->attr.pointer
+			&& e->expr_type != EXPR_NULL)
+		    {
+		      /* Scalar pointer dummy args require an extra level of
+			 indirection. The null pointer already contains
+			 this level of indirection.  */
+		      parm_kind = SCALAR_POINTER;
+		      parmse.expr = build_fold_addr_expr (parmse.expr);
+		    }
+		}
+	    }
 	  else
 	    {
               /* If the procedure requires an explicit interface, the actual
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index b1eeffc..381e007 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -1343,7 +1343,7 @@ gfc_sym_type (gfc_symbol * sym)
       sym->ts.kind = gfc_default_real_kind;
     }
 
-  if (sym->attr.dummy && !sym->attr.function)
+  if (sym->attr.dummy && !sym->attr.function && !sym->attr.value)
     byref = 1;
   else
     byref = 0;