+2005-03-05 Erik Edelmann <eedelman@gcc.gnu.org>
+
+ PR fortran/16136
+ * symbol.c (conf_std): New macro.
+ (check_conflict): Use it to allow ALLOCATABLE dummy
+ arguments for F2003.
+ * trans-expr.c (gfc_conv_function_call): Pass the
+ address of the array descriptor when dummy argument is
+ ALLOCATABLE.
+ * interface.c (compare_allocatable): New function.
+ (compare_actual_formal): Use it.
+ * resolve.c (resolve_deallocate_expr,
+ resolve_allocate_expr): Check that INTENT(IN) variables
+ aren't (de)allocated.
+ * gfortran.texi (Fortran 2003 status): List ALLOCATABLE
+ dummy arguments as supported.
+
2006-03-03 Roger Sayle <roger@eyesopen.com>
* dependency.c (gfc_check_element_vs_element): Revert last change.
@command{gcc} is guaranteed also for the case where the
@command{-fshort-enums} command line option is given.
+@item
+@cindex @code{ALLOCATABLE} dummy arguments
+The @code{ALLOCATABLE} attribute for dummy arguments.
+
@end itemize
}
+/* Given a symbol of a formal argument list and an expression, if the
+ formal argument is allocatable, check that the actual argument is
+ allocatable. Returns nonzero if compatible, zero if not compatible. */
+
+static int
+compare_allocatable (gfc_symbol * formal, gfc_expr * actual)
+{
+ symbol_attribute attr;
+
+ if (formal->attr.allocatable)
+ {
+ attr = gfc_expr_attr (actual);
+ if (!attr.allocatable)
+ return 0;
+ }
+
+ return 1;
+}
+
+
/* Given a symbol of a formal argument list and an expression, if the
formal argument is a pointer, see if the actual argument is a
pointer. Returns nonzero if compatible, zero if not compatible. */
return 0;
}
+ if (a->expr->expr_type != EXPR_NULL
+ && compare_allocatable (f->sym, a->expr) == 0)
+ {
+ if (where)
+ gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
+ f->sym->name, &a->expr->where);
+ return 0;
+ }
+
/* Check intent = OUT/INOUT for definable actual argument. */
if (a->expr->expr_type != EXPR_VARIABLE
&& (f->sym->attr.intent == INTENT_OUT
"ALLOCATABLE or a POINTER", &e->where);
}
+ if (e->symtree->n.sym->attr.intent == INTENT_IN)
+ {
+ gfc_error ("Can't deallocate INTENT(IN) variable '%s' at %L",
+ e->symtree->n.sym->name, &e->where);
+ return FAILURE;
+ }
+
return SUCCESS;
}
return FAILURE;
}
+ if (e->symtree->n.sym->attr.intent == INTENT_IN)
+ {
+ gfc_error ("Can't allocate INTENT(IN) variable '%s' at %L",
+ e->symtree->n.sym->name, &e->where);
+ return FAILURE;
+ }
+
/* Add default initializer for those derived types that need them. */
if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
{
#define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
#define conf2(a) if (attr->a) { a2 = a; goto conflict; }
+#define conf_std(a, b, std) if (attr->a && attr->b)\
+ {\
+ a1 = a;\
+ a2 = b;\
+ standard = std;\
+ goto conflict_std;\
+ }
static try
check_conflict (symbol_attribute * attr, const char * name, locus * where)
static const char *threadprivate = "THREADPRIVATE";
const char *a1, *a2;
+ int standard;
if (where == NULL)
where = &gfc_current_locus;
}
conf (allocatable, pointer);
- conf (allocatable, dummy); /* TODO: Allowed in Fortran 200x. */
+ conf_std (allocatable, dummy, GFC_STD_F2003);
conf (allocatable, function); /* TODO: Allowed in Fortran 200x. */
conf (allocatable, result); /* TODO: Allowed in Fortran 200x. */
conf (elemental, recursive);
a1, a2, name, where);
return FAILURE;
+
+conflict_std:
+ if (name == NULL)
+ {
+ return gfc_notify_std (standard, "In the selected standard, %s attribute "
+ "conflicts with %s attribute at %L", a1, a2,
+ where);
+ }
+ else
+ {
+ return gfc_notify_std (standard, "In the selected standard, %s attribute "
+ "conflicts with %s attribute in '%s' at %L",
+ a1, a2, name, where);
+ }
}
#undef conf
#undef conf2
+#undef conf_std
/* Mark a symbol as referenced. */
}
else
{
- /* If the procedure requires an explicit interface, the
- actual argument is passed according to the
- corresponding formal argument. If the corresponding
- formal argument is a POINTER or assumed shape, we do
- not use g77's calling convention, and pass the
- address of the array descriptor instead. Otherwise we
- use g77's calling convention. */
+ /* If the procedure requires an explicit interface, the actual
+ argument is passed according to the corresponding formal
+ argument. If the corresponding formal argument is a POINTER,
+ ALLOCATABLE or assumed shape, we do not use g77's calling
+ convention, and pass the address of the array descriptor
+ instead. Otherwise we use g77's calling convention. */
int f;
f = (formal != NULL)
- && !formal->sym->attr.pointer
+ && !(formal->sym->attr.pointer || formal->sym->attr.allocatable)
&& formal->sym->as->type != AS_ASSUMED_SHAPE;
f = f || !sym->attr.always_explicit;
if (arg->expr->expr_type == EXPR_VARIABLE
+2005-03-05 Erik Edelmann <eedelman@gcc.gnu.org>
+
+ PR fortran/16136
+ * allocatable_dummy_1.f90: New.
+ * allocatable_dummy_2.f90: New.
+
2006-03-05 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR libgfortran/26554
--- /dev/null
+! { dg-do run }
+! Test procedures with allocatable dummy arguments
+program alloc_dummy
+
+ implicit none
+ integer, allocatable :: a(:)
+
+ call init(a)
+ if (.NOT.allocated(a)) call abort()
+ if (.NOT.all(a == [ 1, 2, 3 ])) call abort()
+
+ call kill(a)
+ if (allocated(a)) call abort()
+
+
+contains
+
+ subroutine init(x)
+ integer, allocatable, intent(out) :: x(:)
+
+ allocate(x(3))
+ x = [ 1, 2, 3 ]
+ end subroutine init
+
+
+ subroutine kill(x)
+ integer, allocatable, intent(out) :: x(:)
+
+ deallocate(x)
+ end subroutine kill
+
+end program alloc_dummy
--- /dev/null
+! { dg-do compile }
+! Check a few constraints for ALLOCATABLE dummy arguments.
+program alloc_dummy
+
+ implicit none
+ integer :: a(5)
+
+ call init(a) ! { dg-error "must be ALLOCATABLE" }
+
+contains
+
+ subroutine init(x)
+ integer, allocatable, intent(out) :: x(:)
+ end subroutine init
+
+ subroutine init2(x)
+ integer, allocatable, intent(in) :: x(:)
+
+ allocate(x(3)) ! { dg-error "Can't allocate" }
+ end subroutine init2
+
+ subroutine kill(x)
+ integer, allocatable, intent(in) :: x(:)
+
+ deallocate(x) ! { dg-error "Can't deallocate" }
+ end subroutine kill
+
+end program alloc_dummy
projects / gcc.git / commitdiff