[Patch, fortran] PR29642 - Fortran 2003: VALUE Attribute (pass by value)

Paul Thomas paulthomas2@wanadoo.fr
Fri Nov 17 20:58:00 GMT 2006


Ping!   Tobias, what about you reviewing this?

The %VAL patch has hit a slight consistency problem (g77 vs vms) that I 
will have to sort out before submitting

Paul
> :ADDPATCH fortran:
>
> The attached patch supplies an implementation of the VALUE attribute 
> and three associated testscases.
>
> The patch consists of a repetition of the code that implements other 
> attributes, such as TARGET  or VOLATILE.  In addition, two small 
> changes are needed to pass by value (gfc_conv_function_call) and to 
> treat a dummy as having been passed by value (gfc_conv_variable and 
> gfc_sym_type).
>
> The first test case checks the functionality of the patch; that a 
> reasonable sprinkling of types and kinds are passed correctly, that it 
> is the value that is passed and the modules do the right thing.  The 
> second testcase check that -std=F2003 is applied.  The third checks 
> the constraints on the value attribute.  Allocatable has been included 
> in the conflicts but I could not get it to do anything because the 
> compiler either grumbled that the variable was not a scalar or that 
> the allocatable attribute had to be applied to an array.
>
> A patch for %VAL, %LOC and %REF is on its way in the next 24hours.  It 
> turned out that they are completely separate from each other, even 
> though, at first sight, the functionality is not disimilar.
>
> Regtested on Cygwin_NT/amd64 - OK for trunk?
>
> Paul
>
> 2006-11-14 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.
>    * match.h : Add prototype for gfc_match_public.
>    * parse.c (decode_statement): Try to match a VALUE statement.
>
>
> 2006-11-14 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_2.f90 : New test.
>
>
>
> ------------------------------------------------------------------------
>
> Index: gcc/fortran/trans-expr.c
> ===================================================================
> *** gcc/fortran/trans-expr.c	(revision 118704)
> --- gcc/fortran/trans-expr.c	(working copy)
> *************** gfc_conv_variable (gfc_se * se, gfc_expr
> *** 416,430 ****
>   	 separately.  */
>         if (sym->ts.type == BT_CHARACTER)
>   	{
> !           /* 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);
>   	}
> !       else
>   	{
>             /* Dereference non-character scalar dummy arguments.  */
>   	  if (sym->attr.dummy && !sym->attr.dimension)
> --- 416,436 ----
>   	 separately.  */
>         if (sym->ts.type == BT_CHARACTER)
>   	{
> ! 	  /* 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 if (!sym->attr.value)
>   	{
>             /* Dereference non-character scalar dummy arguments.  */
>   	  if (sym->attr.dummy && !sym->attr.dimension)
> *************** gfc_conv_function_call (gfc_se * se, gfc
> *** 1973,1991 ****
>   	  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);
> !                 }
> !             }
>   	  else
>   	    {
>                 /* If the procedure requires an explicit interface, the actual
> --- 1979,2004 ----
>   	  argss = gfc_walk_expr (e);
>   
>   	  if (argss == gfc_ss_terminator)
> ! 	    {
>   	      parm_kind = SCALAR;
> ! 	      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
> Index: gcc/fortran/symbol.c
> ===================================================================
> *** gcc/fortran/symbol.c	(revision 118704)
> --- gcc/fortran/symbol.c	(working copy)
> *************** check_conflict (symbol_attribute * attr,
> *** 266,271 ****
> --- 266,272 ----
>     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",
> *************** check_conflict (symbol_attribute * attr,
> *** 273,279 ****
>       *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";
>     static const char *threadprivate = "THREADPRIVATE";
>   
>     const char *a1, *a2;
> --- 274,281 ----
>       *function = "FUNCTION", *subroutine = "SUBROUTINE",
>       *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
>       *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
> !     *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
> !     *volatile_ = "VOLATILE";
>     static const char *threadprivate = "THREADPRIVATE";
>   
>     const char *a1, *a2;
> *************** check_conflict (symbol_attribute * attr,
> *** 400,405 ****
> --- 402,421 ----
>     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)
> + 
> +   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)
>   
> *************** gfc_add_save (symbol_attribute * attr, c
> *** 800,805 ****
> --- 816,841 ----
>   }
>   
>   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)
>   {
>   
> *************** gfc_copy_attr (symbol_attribute * dest, 
> *** 1252,1257 ****
> --- 1288,1295 ----
>       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)
> Index: gcc/fortran/decl.c
> ===================================================================
> *** gcc/fortran/decl.c	(revision 118704)
> --- gcc/fortran/decl.c	(working copy)
> *************** match_attr_spec (void)
> *** 2026,2032 ****
>       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,
>       GFC_DECL_END /* Sentinel */
>     }
>     decl_types;
> --- 2026,2032 ----
>       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_VALUE, DECL_VOLATILE, DECL_COLON, DECL_NONE,
>       GFC_DECL_END /* Sentinel */
>     }
>     decl_types;
> *************** match_attr_spec (void)
> *** 2049,2054 ****
> --- 2049,2055 ----
>       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)
> *************** match_attr_spec (void)
> *** 2170,2175 ****
> --- 2171,2179 ----
>   	  case DECL_TARGET:
>   	    attr = "TARGET";
>   	    break;
> + 	  case DECL_VALUE:
> + 	    attr = "VALUE";
> + 	    break;
>   	  case DECL_VOLATILE:
>   	    attr = "VOLATILE";
>   	    break;
> *************** match_attr_spec (void)
> *** 2287,2292 ****
> --- 2291,2305 ----
>   	  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")
> *************** syntax:
> *** 3960,3965 ****
> --- 3973,4029 ----
>   
>   
>   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;
> Index: gcc/fortran/dump-parse-tree.c
> ===================================================================
> *** gcc/fortran/dump-parse-tree.c	(revision 118704)
> --- gcc/fortran/dump-parse-tree.c	(working copy)
> *************** gfc_show_attr (symbol_attribute * attr)
> *** 552,557 ****
> --- 552,559 ----
>       gfc_status (" POINTER");
>     if (attr->save)
>       gfc_status (" SAVE");
> +   if (attr->value)
> +     gfc_status (" VALUE");
>     if (attr->volatile_)
>       gfc_status (" VOLATILE");
>     if (attr->threadprivate)
> Index: gcc/fortran/gfortran.h
> ===================================================================
> *** gcc/fortran/gfortran.h	(revision 118704)
> --- gcc/fortran/gfortran.h	(working copy)
> *************** typedef struct
> *** 477,483 ****
>   {
>     /* Variable attributes.  */
>     unsigned allocatable:1, dimension:1, external:1, intrinsic:1,
> !     optional:1, pointer:1, save:1, target:1, volatile_:1,
>       dummy:1, result:1, assign:1, threadprivate:1;
>   
>     unsigned data:1,		/* Symbol is named in a DATA statement.  */
> --- 477,483 ----
>   {
>     /* Variable attributes.  */
>     unsigned allocatable:1, dimension:1, external:1, intrinsic: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.  */
> *************** try gfc_add_pure (symbol_attribute *, lo
> *** 1865,1870 ****
> --- 1865,1871 ----
>   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 *);
> Index: gcc/fortran/module.c
> ===================================================================
> *** gcc/fortran/module.c	(revision 118704)
> --- gcc/fortran/module.c	(working copy)
> *************** mio_internal_string (char *string)
> *** 1431,1441 ****
>   
>   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_attribute;
>   
> --- 1431,1441 ----
>   
>   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_VALUE, AB_VOLATILE
>   }
>   ab_attribute;
>   
> *************** static const mstring attr_bits[] =
> *** 1448,1453 ****
> --- 1448,1454 ----
>       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),
> *************** mio_symbol_attribute (symbol_attribute *
> *** 1519,1524 ****
> --- 1520,1527 ----
>   	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)
> *************** mio_symbol_attribute (symbol_attribute *
> *** 1599,1604 ****
> --- 1602,1610 ----
>   	    case AB_SAVE:
>   	      attr->save = 1;
>   	      break;
> + 	    case AB_VALUE:
> + 	      attr->value = 1;
> + 	      break;
>   	    case AB_VOLATILE:
>   	      attr->volatile_ = 1;
>   	      break;
> Index: gcc/fortran/trans-types.c
> ===================================================================
> *** gcc/fortran/trans-types.c	(revision 118704)
> --- gcc/fortran/trans-types.c	(working copy)
> *************** gfc_sym_type (gfc_symbol * sym)
> *** 1327,1333 ****
>         sym->ts.kind = gfc_default_real_kind;
>       }
>   
> !   if (sym->attr.dummy && !sym->attr.function)
>       byref = 1;
>     else
>       byref = 0;
> --- 1327,1333 ----
>         sym->ts.kind = gfc_default_real_kind;
>       }
>   
> !   if (sym->attr.dummy && !sym->attr.function && !sym->attr.value)
>       byref = 1;
>     else
>       byref = 0;
> Index: gcc/fortran/resolve.c
> ===================================================================
> *** gcc/fortran/resolve.c	(revision 118704)
> --- gcc/fortran/resolve.c	(working copy)
> *************** was_declared (gfc_symbol * sym)
> *** 677,683 ****
>       return 1;
>   
>     if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
> !       || a.optional || a.pointer || a.save || a.target || a.volatile_
>         || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
>       return 1;
>   
> --- 677,683 ----
>       return 1;
>   
>     if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
> !       || a.optional || a.pointer || a.save || a.target || a.volatile_ || a.value
>         || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
>       return 1;
>   
> Index: gcc/fortran/match.h
> ===================================================================
> *** gcc/fortran/match.h	(revision 118704)
> --- gcc/fortran/match.h	(working copy)
> *************** match gfc_match_public (gfc_statement *)
> *** 146,151 ****
> --- 146,152 ----
>   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 */
> Index: gcc/fortran/parse.c
> ===================================================================
> *** gcc/fortran/parse.c	(revision 118704)
> --- gcc/fortran/parse.c	(working copy)
> *************** decode_statement (void)
> *** 283,288 ****
> --- 283,289 ----
>         break;
>   
>       case 'v':
> +       match ("value", gfc_match_value, ST_ATTR_DECL);
>         match ("volatile", gfc_match_volatile, ST_ATTR_DECL);
>         break;
>   
> Index: gcc/testsuite/gfortran.dg/value_1.f90
> ===================================================================
> *** gcc/testsuite/gfortran.dg/value_1.f90	(revision 0)
> --- gcc/testsuite/gfortran.dg/value_1.f90	(revision 0)
> ***************
> *** 0 ****
> --- 1,80 ----
> + ! { dg-do run }
> + ! { dg-options "-std=gnu" }
> + ! Tests the functionality of the patch for PR29642, which requested the
> + ! implementation of the F2003 VALUE attribute for gfortran.
> + !
> + ! Contributed by Paul Thomas  <pault@gcc.gnu.org> 
> + !
> + module global
> +   type :: mytype
> +     real(4) :: x
> +     character(4) :: c
> +   end type mytype
> + contains
> +   subroutine typhoo (dt)
> +     type(mytype), value :: dt
> +     if (dtne (dt, mytype (acos(0.0), "lmno"))) call abort ()
> +     dt = mytype (acos(0.0)/2.0, "wxyz")
> +     if (dtne (dt, mytype (acos(0.0)/2.0, "wxyz"))) call abort ()
> +   end subroutine typhoo
> + 
> +   logical function dtne (a, b)
> +     type(mytype) :: a, b
> +     dtne = .FALSE.
> +     if ((a%x /= b%x) .or. (a%c /= b%c)) dtne = .TRUE.
> +   end function dtne
> + end module global
> + 
> + program test_value
> +   use global
> +   integer(8) :: i = 42
> +   real(8) :: r = 42.0
> +   character(2) ::   c = "ab"
> +   complex(8) :: z = (-99.0, 199.0)
> +   type(mytype) :: dt = mytype (acos(0.0), "lmno")
> + 
> +   call foo (c)
> +   if (c /= "ab") call abort ()
> + 
> +   call bar (i)
> +   if (i /= 42) call abort ()
> + 
> +   call foobar (r)
> +   if (r /= 42.0) call abort ()
> + 
> +   call complex_foo (z)
> +   if (z /= (-99.0, 199.0)) call abort ()
> + 
> +   call typhoo (dt)
> +   if (dtne (dt, mytype (acos(0.0), "lmno"))) call abort ()
> + contains
> +   subroutine foo (c)
> +     character(2), value :: c
> +     if (c /= "ab") call abort ()
> +     c = "cd"
> +     if (c /= "cd") call abort ()
> +   end subroutine foo
> + 
> +   subroutine bar (i)
> +     integer(8), value :: i
> +     if (i /= 42) call abort ()
> +     i = 99
> +     if (i /= 99) call abort ()
> +   end subroutine bar
> + 
> +   subroutine foobar (r)
> +     real(8), value :: r
> +     if (r /= 42.0) call abort ()
> +     r = 99.0
> +     if (r /= 99.0) call abort ()
> +   end subroutine foobar
> + 
> +   subroutine complex_foo (z)
> +     COMPLEX(8), value :: z
> +     if (z /= (-99.0, 199.0)) call abort ()
> +     z = (77.0, -42.0)
> +     if (z /= (77.0, -42.0)) call abort ()
> +   end subroutine complex_foo
> + 
> + end program test_value
> + ! { dg-final { cleanup-modules "global" } }
> Index: gcc/testsuite/gfortran.dg/value_2.f90
> ===================================================================
> *** gcc/testsuite/gfortran.dg/value_2.f90	(revision 0)
> --- gcc/testsuite/gfortran.dg/value_2.f90	(revision 0)
> ***************
> *** 0 ****
> --- 1,21 ----
> + ! { dg-do compile }
> + ! { dg-options "-std=f95" }
> + ! Tests the standard check in the patch for PR29642, which requested the
> + ! implementation of the F2003 VALUE attribute for gfortran.
> + !
> + ! Contributed by Paul Thomas  <pault@gcc.gnu.org> 
> + !
> + program test_value
> +   integer(8) :: i = 42
> + 
> +   call bar (i)
> +   if (i /= 42) call abort ()
> + contains
> +   subroutine bar (i)
> +     integer(8) :: i
> +     value :: i      ! { dg-error "Fortran 2003: VALUE" }
> +     if (i /= 42) call abort ()
> +     i = 99
> +     if (i /= 99) call abort ()
> +   end subroutine bar
> + end program test_value
> Index: gcc/testsuite/gfortran.dg/value_3.f90
> ===================================================================
> *** gcc/testsuite/gfortran.dg/value_3.f90	(revision 0)
> --- gcc/testsuite/gfortran.dg/value_3.f90	(revision 0)
> ***************
> *** 0 ****
> --- 1,42 ----
> + ! { dg-do compile }
> + ! Tests the constraints in the patch for PR29642, which requested the
> + ! implementation of the F2003 VALUE attribute for gfortran.
> + !
> + ! Contributed by Paul Thomas  <pault@gcc.gnu.org> 
> + !
> + program test_value
> +   integer(8) :: i = 42
> + 
> + contains
> +   subroutine bar_1 (i)
> +     integer(8) :: i
> +     dimension i(8)
> +     value :: i  ! { dg-error "conflicts with DIMENSION" }
> +     i = 0
> +   end subroutine bar_1
> + 
> +   subroutine bar_2 (i)
> +     integer(8) :: i
> +     pointer :: i
> +     value :: i  ! { dg-error "conflicts with POINTER" }
> +     i = 0
> +   end subroutine bar_2
> + 
> +   integer function bar_3 (i)
> +     integer(8) :: i
> +     dimension i(8)
> +     value :: bar_3  ! { dg-error "conflicts with FUNCTION" }
> +     i = 0
> +     bar_3 = 0
> +   end function bar_3
> + 
> +   subroutine bar_4 (i, j)
> +     integer(8), intent(inout) :: i
> +     integer(8), intent(out) :: j
> +     value :: i  ! { dg-error "conflicts with INTENT" }
> +     value :: j  ! { dg-error "conflicts with INTENT" }
> +     i = 0
> +     j = 0
> +   end subroutine bar_4
> + 
> + end program test_value
>   



More information about the Gcc-patches mailing list