+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
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;
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)
case DECL_TARGET:
attr = "TARGET";
break;
+ case DECL_VALUE:
+ attr = "VALUE";
+ break;
case DECL_VOLATILE:
attr = "VOLATILE";
break;
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")
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;
gfc_status (" POINTER");
if (attr->save)
gfc_status (" SAVE");
+ if (attr->value)
+ gfc_status (" VALUE");
if (attr->volatile_)
gfc_status (" VOLATILE");
if (attr->threadprivate)
{
/* 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. */
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 *);
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 */
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;
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_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)
case AB_SAVE:
attr->save = 1;
break;
+ case AB_VALUE:
+ attr->value = 1;
+ break;
case AB_VOLATILE:
attr->volatile_ = 1;
break;
break;
case 'v':
+ match ("value", gfc_match_value, ST_ATTR_DECL);
match ("volatile", gfc_match_volatile, ST_ATTR_DECL);
break;
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;
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
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",
*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;
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)
conf2 (dummy);
conf2 (in_common);
conf2 (save);
+ conf2 (value);
conf2 (volatile_);
conf2 (threadprivate);
break;
}
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)
{
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)
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)
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
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;
+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.
+
2006-12-02 Andrew Pinski <andrew_pinski@playstation.sony.com>
PR C++/30033
--- /dev/null
+! { 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 (42.0, "lmno"))) call abort ()
+ dt = mytype (21.0, "wxyz")
+ if (dtne (dt, mytype (21.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 (42.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 (42.0, "lmno"))) call abort ()
+
+ r = 20.0
+ call foobar (r*2.0 + 2.0)
+
+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" } }
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+/* 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.
+
+ Contributed by Paul Thomas <pault@gcc.gnu.org> */
+
+typedef struct { float r, i; } complex;
+extern float *f_to_f__ (float, float*);
+extern int *i_to_i__ (int, int*);
+extern void c_to_c__ (complex*, complex, complex*);
+extern void abort (void);
+
+/* In f_to_f and i_to_i we return the second argument, so that we do
+ not have to worry about keeping track of memory allocation between
+ fortran and C. All three functions check that the argument passed
+ by value is the same as that passed by reference. Then the passed
+ by value argument is modified so that the caller can check that
+ its version has not changed.*/
+
+float *
+f_to_f__(float a1, float *a2)
+{
+ if ( a1 != *a2 ) abort();
+ *a2 = a1 * 2.0;
+ a1 = 0.0;
+ return a2;
+}
+
+int *
+i_to_i__(int i1, int *i2)
+{
+ if ( i1 != *i2 ) abort();
+ *i2 = i1 * 3;
+ i1 = 0;
+ return i2;
+}
+
+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;
+}
+
--- /dev/null
+! { 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(4) :: epsi = epsilon (1.0_4)
+contains
+ function deltai (a, b) result (c)
+ integer(4) :: a, b
+ logical :: c
+ c = (a /= b)
+ end function deltai
+
+ function deltar (a, b) result (c)
+ real(4) :: a, b
+ logical :: c
+ c = (abs (a-b) > epsi)
+ end function deltar
+
+ function deltac (a, b) result (c)
+ complex(4) :: 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
+ function f_to_f (x, y)
+ real(4), pointer :: f_to_f
+ real(4) :: x, y
+ value :: x
+ end function f_to_f
+ end interface
+
+ interface
+ function i_to_i (x, y)
+ integer(4), pointer :: i_to_i
+ integer(4) :: x, y
+ value :: x
+ end function i_to_i
+ end interface
+
+ interface
+ complex(4) function c_to_c (x, y)
+ complex(4) :: x, y
+ value :: x
+ end function c_to_c
+ end interface
+
+ real(4) a, b, c
+ integer(4) i, j, k
+ complex(4) 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" } }
OSDN Git Service
