This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
Re: [Patch, fortran] PR29642 - Fortran 2003: VALUE Attribute (pass by value)
- From: Paul Thomas <paulthomas2 at wanadoo dot fr>
- To: Tobias Burnus <burnus at net-b dot de>
- Cc: Fortran List <fortran at gcc dot gnu dot org>, gcc-patches <gcc-patches at gcc dot gnu dot org>
- Date: Thu, 23 Nov 2006 18:40:33 +0100
- Subject: Re: [Patch, fortran] PR29642 - Fortran 2003: VALUE Attribute (pass by value)
- References: <45599379.4010206@wanadoo.fr> <455E16F8.60806@wanadoo.fr> <455E47C8.8080309@net-b.de>
Tobias,
Standard is two spaces between date and name and between name and email
address.
Done - I put my glasses on this time.
You should add a test whether the VALUE variable is also a dummy
variable; currently,e.g.
Done in resolve_symbol.
program test
real, value :: a
end program test
gives no error.
value_3.f90 is suitably updated.
case FL_PROGRAM:
case FL_BLOCK_DATA:
case FL_MODULE:
case FL_LABEL:
(not found in the standard, but should be obvious; for VALUE probably
not needed if one requires "dummy".)
I took that point of view - I would need, in all conscience, to think
about VOLATILE in these cases and to test what happens if the conflict
is not flagged.
VALUE should conflict with PARAMETER, EXTERNAL
See:
Done and tested; for some reason, I could not get EXTERNAL to do
anything before :-)
Maybe better: "-std=f2003 -fall-intrinsics"
Done.
Please add a test like:
program x
real,value :: r
end program x
Done.
value_4.f90
+ if ((2.0 * a).ne.b) call abort ()
This fails here. You should use something like:
if(abs(2.0*a -b)>epsilon(a)) call abort()
Done - I used a generic function delta for real, integer and complex.
Regtested on Cygwin_NT/amd64
OK for trunk?
Thanks
Paul
2006-11-23 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-11-23 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.
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 119075)
--- gcc/fortran/trans-expr.c (working copy)
*************** gfc_conv_variable (gfc_se * se, gfc_expr
*** 446,460 ****
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)
--- 446,466 ----
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
*** 2004,2022 ****
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
--- 2010,2035 ----
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 119075)
--- 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,
*** 402,407 ****
--- 404,424 ----
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)
*************** check_conflict (symbol_attribute * attr,
*** 524,529 ****
--- 541,547 ----
conf2 (dummy);
conf2 (in_common);
conf2 (save);
+ conf2 (value);
conf2 (volatile_);
conf2 (threadprivate);
break;
*************** gfc_add_save (symbol_attribute * attr, c
*** 805,810 ****
--- 823,848 ----
}
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,
*** 1257,1262 ****
--- 1295,1302 ----
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 119075)
--- gcc/fortran/decl.c (working copy)
*************** match_attr_spec (void)
*** 2117,2123 ****
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;
--- 2117,2123 ----
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)
*** 2140,2145 ****
--- 2140,2146 ----
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)
*** 2261,2266 ****
--- 2262,2270 ----
case DECL_TARGET:
attr = "TARGET";
break;
+ case DECL_VALUE:
+ attr = "VALUE";
+ break;
case DECL_VOLATILE:
attr = "VOLATILE";
break;
*************** match_attr_spec (void)
*** 2378,2383 ****
--- 2382,2396 ----
t = gfc_add_target (¤t_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 (¤t_attr, NULL, &seen_at[d]);
+ break;
+
case DECL_VOLATILE:
if (gfc_notify_std (GFC_STD_F2003,
"Fortran 2003: VOLATILE attribute at %C")
*************** syntax:
*** 4051,4056 ****
--- 4064,4120 ----
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 119075)
--- 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 119075)
--- gcc/fortran/gfortran.h (working copy)
*************** typedef struct
*** 476,482 ****
{
/* 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. */
--- 476,482 ----
{
/* 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
*** 1868,1873 ****
--- 1868,1874 ----
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 119075)
--- gcc/fortran/module.c (working copy)
*************** mio_internal_string (char *string)
*** 1487,1497 ****
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;
--- 1487,1497 ----
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[] =
*** 1504,1509 ****
--- 1504,1510 ----
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 *
*** 1575,1580 ****
--- 1576,1583 ----
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 *
*** 1655,1660 ****
--- 1658,1666 ----
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 119075)
--- gcc/fortran/trans-types.c (working copy)
*************** gfc_sym_type (gfc_symbol * sym)
*** 1343,1349 ****
sym->ts.kind = gfc_default_real_kind;
}
! if (sym->attr.dummy && !sym->attr.function)
byref = 1;
else
byref = 0;
--- 1343,1349 ----
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 119077)
--- gcc/fortran/resolve.c (working copy)
*************** was_declared (gfc_symbol * sym)
*** 675,681 ****
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;
--- 675,681 ----
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;
*************** resolve_symbol (gfc_symbol * sym)
*** 5956,5961 ****
--- 5956,5969 ----
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
Index: gcc/fortran/match.h
===================================================================
*** gcc/fortran/match.h (revision 119075)
--- gcc/fortran/match.h (working copy)
*************** match gfc_match_public (gfc_statement *)
*** 147,152 ****
--- 147,153 ----
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 119075)
--- gcc/fortran/parse.c (working copy)
*************** decode_statement (void)
*** 284,289 ****
--- 284,290 ----
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=f2003 -fall-intrinsics" }
+ ! 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_4.c
===================================================================
*** gcc/testsuite/gfortran.dg/value_4.c (revision 0)
--- gcc/testsuite/gfortran.dg/value_4.c (revision 0)
***************
*** 0 ****
--- 1,37 ----
+ /* Passing from fortran to C by value, using VALUE. This is identical
+ to c_by_val_1.c, which performs the same function for %VAL. */
+
+ typedef struct { float r, i; } complex;
+ extern float f_to_f__ (float, float*);
+ extern long i_to_i__ (long, long*);
+ extern void c_to_c__ (complex*, complex, complex*);
+ extern void abort (void);
+
+ float
+ f_to_f__(float a1, float *a2)
+ {
+ if ( a1 != *a2 ) abort();
+ a1 = 0.0;
+ return *a2 * 2.0;
+ }
+
+ long
+ i_to_i__(long i1, long *i2)
+ {
+ if ( i1 != *i2 ) abort();
+ i1 = 0;
+ return *i2 * 3;
+ }
+
+ void
+ c_to_c__(complex *retval, complex c1, complex *c2)
+ {
+ if ( c1.r != c2->r ) abort();
+ if ( c1.i != c2->i ) abort();
+ c1.r = 0.0;
+ c1.i = 0.0;
+ retval->r = c2->r * 4.0;
+ retval->i = c2->i * 4.0;
+ return;
+ }
+
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,53 ----
+ ! { 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, j ! { dg-error "not a dummy" }
+ integer(8), value :: k ! { dg-error "not a dummy" }
+ value :: j
+
+ 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
+
+ integer function bar_5 ()
+ integer(8) :: i
+ external :: i
+ integer, parameter :: j = 99
+ value :: i ! { dg-error "conflicts with EXTERNAL" }
+ value :: j ! { dg-error "PARAMETER attribute conflicts with" }
+ bar_5 = 0
+ end function bar_5
+
+ end program test_value
Index: gcc/testsuite/gfortran.dg/value_4.f90
===================================================================
*** gcc/testsuite/gfortran.dg/value_4.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/value_4.f90 (revision 0)
***************
*** 0 ****
--- 1,82 ----
+ ! { dg-do run }
+ ! { dg-additional-sources value_4.c }
+ ! { dg-options "-ff2c -w -O0" }
+ !
+ ! Tests the functionality of the patch for PR29642, which requested the
+ ! implementation of the F2003 VALUE attribute for gfortran, by calling
+ ! external C functions by value and by reference. This is effectively
+ ! identical to c_by_val_1.f, which does the same for %VAL.
+ !
+ ! Contributed by Paul Thomas <pault@gcc.gnu.org>
+ !
+ module global
+ interface delta
+ module procedure deltai, deltar, deltac
+ end interface delta
+ real :: epsi = epsilon (1.0_4)
+ contains
+ function deltai (a, b) result (c)
+ integer :: a, b
+ logical :: c
+ c = (a /= b)
+ end function deltai
+
+ function deltar (a, b) result (c)
+ real :: a, b
+ logical :: c
+ c = (abs (a-b) > epsi)
+ end function deltar
+
+ function deltac (a, b) result (c)
+ complex :: a, b
+ logical :: c
+ c = ((abs (real (a-b)) > epsi).or.(abs (aimag (a-b)) > epsi))
+ end function deltac
+ end module global
+
+ program value_4
+ use global
+ interface
+ real function f_to_f (x, y)
+ real :: x, y
+ value :: x
+ end function f_to_f
+ end interface
+
+ interface
+ integer function i_to_i (x, y)
+ integer :: x, y
+ value :: x
+ end function i_to_i
+ end interface
+
+ interface
+ complex function c_to_c (x, y)
+ complex :: x, y
+ value :: x
+ end function c_to_c
+ end interface
+
+ real a, b, c
+ integer i, j, k
+ complex u, v, w
+
+ a = 42.0
+ b = 0.0
+ c = a
+ b = f_to_f (a, c)
+ if (delta ((2.0 * a), b)) call abort ()
+
+ i = 99
+ j = 0
+ k = i
+ j = i_to_i (i, k)
+ if (delta ((3 * i), j)) call abort ()
+
+ u = (-1.0, 2.0)
+ v = (1.0, -2.0)
+ w = u
+ v = c_to_c (u, w)
+ if (delta ((4.0 * u), v)) call abort ()
+ end program value_4
+ ! { dg-final { cleanup-modules "global" } }