+2009-03-30 Steven G. Kargl <kargls@comcast.net>
+
+ PR fortran/38389
+ * trans-stmt.c(gfc_trans_allocate): Add translation of ERRMSG.
+ (gfc_trans_deallocate): Add translation of ERRMSG. Remove stale
+ comments. Minor whitespace cleanup.
+ * resolve.c(is_scalar_expr_ptr): Whitespace cleanup.
+ (resolve_deallocate_expr (gfc_expr *e): Update error message.
+ (resolve_allocate_expr): Remove dead code. Update error message.
+ Move error checking to ...
+ (resolve_allocate_deallocate): ... here. Add additional error
+ checking for STAT, ERRMSG, and allocate-objects.
+ * match.c(gfc_match_allocate,gfc_match_deallocate): Parse ERRMSG.
+ Check for redundant uses of STAT and ERRMSG. Reword error message
+ and add checking for pointer, allocatable, and proc_pointer attributes.
+
2009-03-30 Paul Thomas <pault@gcc.gnu.org>
PR fortran/22571
gfc_match_allocate (void)
{
gfc_alloc *head, *tail;
- gfc_expr *stat;
+ gfc_expr *stat, *errmsg, *tmp;
match m;
+ bool saw_stat, saw_errmsg;
head = tail = NULL;
- stat = NULL;
+ stat = errmsg = tmp = NULL;
+ saw_stat = saw_errmsg = false;
if (gfc_match_char ('(') != MATCH_YES)
goto syntax;
if (gfc_check_do_variable (tail->expr->symtree))
goto cleanup;
- if (gfc_pure (NULL)
- && gfc_impure_variable (tail->expr->symtree->n.sym))
+ if (gfc_pure (NULL) && gfc_impure_variable (tail->expr->symtree->n.sym))
{
- gfc_error ("Bad allocate-object in ALLOCATE statement at %C for a "
- "PURE procedure");
+ gfc_error ("Bad allocate-object at %C for a PURE procedure");
goto cleanup;
}
if (tail->expr->ts.type == BT_DERIVED)
tail->expr->ts.derived = gfc_use_derived (tail->expr->ts.derived);
+ /* FIXME: disable the checking on derived types and arrays. */
+ if (!(tail->expr->ref
+ && (tail->expr->ref->type == REF_COMPONENT
+ || tail->expr->ref->type == REF_ARRAY))
+ && tail->expr->symtree->n.sym
+ && !(tail->expr->symtree->n.sym->attr.allocatable
+ || tail->expr->symtree->n.sym->attr.pointer
+ || tail->expr->symtree->n.sym->attr.proc_pointer))
+ {
+ gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
+ "or an allocatable variable");
+ goto cleanup;
+ }
+
if (gfc_match_char (',') != MATCH_YES)
break;
- m = gfc_match (" stat = %v", &stat);
+alloc_opt_list:
+
+ m = gfc_match (" stat = %v", &tmp);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_YES)
- break;
+ {
+ if (saw_stat)
+ {
+ gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
+ gfc_free_expr (tmp);
+ goto cleanup;
+ }
+
+ stat = tmp;
+ saw_stat = true;
+
+ if (gfc_check_do_variable (stat->symtree))
+ goto cleanup;
+
+ if (gfc_match_char (',') == MATCH_YES)
+ goto alloc_opt_list;
+ }
+
+ m = gfc_match (" errmsg = %v", &tmp);
+ if (m == MATCH_ERROR)
+ goto cleanup;
+ if (m == MATCH_YES)
+ {
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG at %L",
+ &tmp->where) == FAILURE)
+ goto cleanup;
+
+ if (saw_errmsg)
+ {
+ gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
+ gfc_free_expr (tmp);
+ goto cleanup;
+ }
+
+ errmsg = tmp;
+ saw_errmsg = true;
+
+ if (gfc_match_char (',') == MATCH_YES)
+ goto alloc_opt_list;
+ }
+
+ gfc_gobble_whitespace ();
+
+ if (gfc_peek_char () == ')')
+ break;
}
- if (stat != NULL)
- gfc_check_do_variable(stat->symtree);
if (gfc_match (" )%t") != MATCH_YES)
goto syntax;
new_st.op = EXEC_ALLOCATE;
new_st.expr = stat;
+ new_st.expr2 = errmsg;
new_st.ext.alloc_list = head;
return MATCH_YES;
gfc_syntax_error (ST_ALLOCATE);
cleanup:
+ gfc_free_expr (errmsg);
gfc_free_expr (stat);
gfc_free_alloc_list (head);
return MATCH_ERROR;
gfc_match_deallocate (void)
{
gfc_alloc *head, *tail;
- gfc_expr *stat;
+ gfc_expr *stat, *errmsg, *tmp;
match m;
+ bool saw_stat, saw_errmsg;
head = tail = NULL;
- stat = NULL;
+ stat = errmsg = tmp = NULL;
+ saw_stat = saw_errmsg = false;
if (gfc_match_char ('(') != MATCH_YES)
goto syntax;
if (gfc_check_do_variable (tail->expr->symtree))
goto cleanup;
- if (gfc_pure (NULL)
- && gfc_impure_variable (tail->expr->symtree->n.sym))
+ if (gfc_pure (NULL) && gfc_impure_variable (tail->expr->symtree->n.sym))
{
- gfc_error ("Illegal deallocate-expression in DEALLOCATE at %C "
- "for a PURE procedure");
+ gfc_error ("Illegal allocate-object at %C for a PURE procedure");
+ goto cleanup;
+ }
+
+ /* FIXME: disable the checking on derived types. */
+ if (!(tail->expr->ref
+ && (tail->expr->ref->type == REF_COMPONENT
+ || tail->expr->ref->type == REF_ARRAY))
+ && tail->expr->symtree->n.sym
+ && !(tail->expr->symtree->n.sym->attr.allocatable
+ || tail->expr->symtree->n.sym->attr.pointer
+ || tail->expr->symtree->n.sym->attr.proc_pointer))
+ {
+ gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
+ "or an allocatable variable");
goto cleanup;
}
if (gfc_match_char (',') != MATCH_YES)
break;
- m = gfc_match (" stat = %v", &stat);
+dealloc_opt_list:
+
+ m = gfc_match (" stat = %v", &tmp);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_YES)
- break;
- }
+ {
+ if (saw_stat)
+ {
+ gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
+ gfc_free_expr (tmp);
+ goto cleanup;
+ }
+
+ stat = tmp;
+ saw_stat = true;
+
+ if (gfc_check_do_variable (stat->symtree))
+ goto cleanup;
+
+ if (gfc_match_char (',') == MATCH_YES)
+ goto dealloc_opt_list;
+ }
- if (stat != NULL)
- gfc_check_do_variable(stat->symtree);
+ m = gfc_match (" errmsg = %v", &tmp);
+ if (m == MATCH_ERROR)
+ goto cleanup;
+ if (m == MATCH_YES)
+ {
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG at %L",
+ &tmp->where) == FAILURE)
+ goto cleanup;
+
+ if (saw_errmsg)
+ {
+ gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
+ gfc_free_expr (tmp);
+ goto cleanup;
+ }
+
+ errmsg = tmp;
+ saw_errmsg = true;
+
+ if (gfc_match_char (',') == MATCH_YES)
+ goto dealloc_opt_list;
+ }
+
+ gfc_gobble_whitespace ();
+
+ if (gfc_peek_char () == ')')
+ break;
+ }
if (gfc_match (" )%t") != MATCH_YES)
goto syntax;
new_st.op = EXEC_DEALLOCATE;
new_st.expr = stat;
+ new_st.expr2 = errmsg;
new_st.ext.alloc_list = head;
return MATCH_YES;
gfc_syntax_error (ST_DEALLOCATE);
cleanup:
+ gfc_free_expr (errmsg);
gfc_free_expr (stat);
gfc_free_alloc_list (head);
return MATCH_ERROR;
}
else
{
- /* We have constant lower and upper bounds. If the
- difference between is 1, it can be considered a
- scalar. */
- start = (int) mpz_get_si
- (ref->u.ar.as->lower[0]->value.integer);
- end = (int) mpz_get_si
- (ref->u.ar.as->upper[0]->value.integer);
- if (end - start + 1 != 1)
- retval = FAILURE;
- }
+ /* We have constant lower and upper bounds. If the
+ difference between is 1, it can be considered a
+ scalar. */
+ start = (int) mpz_get_si
+ (ref->u.ar.as->lower[0]->value.integer);
+ end = (int) mpz_get_si
+ (ref->u.ar.as->upper[0]->value.integer);
+ if (end - start + 1 != 1)
+ retval = FAILURE;
+ }
}
else
retval = FAILURE;
if (allocatable == 0 && attr.pointer == 0)
{
bad:
- gfc_error ("Expression in DEALLOCATE statement at %L must be "
- "ALLOCATABLE or a POINTER", &e->where);
+ gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
+ &e->where);
}
if (check_intent_in
if (gfc_resolve_expr (e) == FAILURE)
return FAILURE;
- if (code->expr && code->expr->expr_type == EXPR_VARIABLE)
- sym = code->expr->symtree->n.sym;
- else
- sym = NULL;
-
/* Make sure the expression is allocatable or a pointer. If it is
pointer, the next-to-last reference must be a pointer. */
pointer = e->symtree->n.sym->attr.pointer;
dimension = e->symtree->n.sym->attr.dimension;
- if (sym == e->symtree->n.sym && sym->ts.type != BT_DERIVED)
- {
- gfc_error ("The STAT variable '%s' in an ALLOCATE statement must "
- "not be allocated in the same statement at %L",
- sym->name, &e->where);
- return FAILURE;
- }
-
for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
{
if (pointer)
if (allocatable == 0 && pointer == 0)
{
- gfc_error ("Expression in ALLOCATE statement at %L must be "
- "ALLOCATABLE or a POINTER", &e->where);
+ gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER",
+ &e->where);
return FAILURE;
}
static void
resolve_allocate_deallocate (gfc_code *code, const char *fcn)
{
- gfc_symbol *s = NULL;
- gfc_alloc *a;
+ gfc_expr *stat, *errmsg, *pe, *qe;
+ gfc_alloc *a, *p, *q;
+
+ stat = code->expr ? code->expr : NULL;
- if (code->expr)
- s = code->expr->symtree->n.sym;
+ errmsg = code->expr2 ? code->expr2 : NULL;
- if (s)
+ /* Check the stat variable. */
+ if (stat)
{
- if (s->attr.intent == INTENT_IN)
- gfc_error ("STAT variable '%s' of %s statement at %C cannot "
- "be INTENT(IN)", s->name, fcn);
+ if (stat->symtree->n.sym->attr.intent == INTENT_IN)
+ gfc_error ("Stat-variable '%s' at %L cannot be INTENT(IN)",
+ stat->symtree->n.sym->name, &stat->where);
- if (gfc_pure (NULL) && gfc_impure_variable (s))
- gfc_error ("Illegal STAT variable in %s statement at %C "
- "for a PURE procedure", fcn);
+ if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym))
+ gfc_error ("Illegal stat-variable at %L for a PURE procedure",
+ &stat->where);
+
+ if (stat->ts.type != BT_INTEGER
+ && !(stat->ref && (stat->ref->type == REF_ARRAY
+ || stat->ref->type == REF_COMPONENT)))
+ gfc_error ("Stat-variable at %L must be a scalar INTEGER "
+ "variable", &stat->where);
+
+ for (p = code->ext.alloc_list; p; p = p->next)
+ if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
+ gfc_error ("Stat-variable at %L shall not be %sd within "
+ "the same %s statement", &stat->where, fcn, fcn);
}
- if (s && code->expr->ts.type != BT_INTEGER)
- gfc_error ("STAT tag in %s statement at %L must be "
- "of type INTEGER", fcn, &code->expr->where);
+ /* Check the errmsg variable. */
+ if (errmsg)
+ {
+ if (!stat)
+ gfc_warning ("ERRMSG at %L is useless without a STAT tag",
+ &errmsg->where);
+
+ if (errmsg->symtree->n.sym->attr.intent == INTENT_IN)
+ gfc_error ("Errmsg-variable '%s' at %L cannot be INTENT(IN)",
+ errmsg->symtree->n.sym->name, &errmsg->where);
+
+ if (gfc_pure (NULL) && gfc_impure_variable (errmsg->symtree->n.sym))
+ gfc_error ("Illegal errmsg-variable at %L for a PURE procedure",
+ &errmsg->where);
+
+ if (errmsg->ts.type != BT_CHARACTER
+ && !(errmsg->ref
+ && (errmsg->ref->type == REF_ARRAY
+ || errmsg->ref->type == REF_COMPONENT)))
+ gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
+ "variable", &errmsg->where);
+
+ for (p = code->ext.alloc_list; p; p = p->next)
+ if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
+ gfc_error ("Errmsg-variable at %L shall not be %sd within "
+ "the same %s statement", &errmsg->where, fcn, fcn);
+ }
+
+ /* Check that an allocate-object appears only once in the statement.
+ FIXME: Checking derived types is disabled. */
+ for (p = code->ext.alloc_list; p; p = p->next)
+ {
+ pe = p->expr;
+ if ((pe->ref && pe->ref->type != REF_COMPONENT)
+ && (pe->symtree->n.sym->ts.type != BT_DERIVED))
+ {
+ for (q = p->next; q; q = q->next)
+ {
+ qe = q->expr;
+ if ((qe->ref && qe->ref->type != REF_COMPONENT)
+ && (qe->symtree->n.sym->ts.type != BT_DERIVED)
+ && (pe->symtree->n.sym->name == qe->symtree->n.sym->name))
+ gfc_error ("Allocate-object at %L also appears at %L",
+ &pe->where, &qe->where);
+ }
+ }
+ }
if (strcmp (fcn, "ALLOCATE") == 0)
{
}
}
+
/************ SELECT CASE resolution subroutines ************/
/* Callback function for our mergesort variant. Determines interval
if (!code->ext.alloc_list)
return NULL_TREE;
+ pstat = stat = error_label = tmp = NULL_TREE;
+
gfc_start_block (&block);
- if (code->expr)
+ /* Either STAT= and/or ERRMSG is present. */
+ if (code->expr || code->expr2)
{
tree gfc_int4_type_node = gfc_get_int_type (4);
error_label = gfc_build_label_decl (NULL_TREE);
TREE_USED (error_label) = 1;
}
- else
- pstat = stat = error_label = NULL_TREE;
for (al = code->ext.alloc_list; al != NULL; al = al->next)
{
fold_convert (TREE_TYPE (se.expr), tmp));
gfc_add_expr_to_block (&se.pre, tmp);
- if (code->expr)
+ if (code->expr || code->expr2)
{
tmp = build1_v (GOTO_EXPR, error_label);
parm = fold_build2 (NE_EXPR, boolean_type_node,
gfc_add_expr_to_block (&block, tmp);
}
- /* Assign the value to the status variable. */
+ /* STAT block. */
if (code->expr)
{
tmp = build1_v (LABEL_EXPR, error_label);
gfc_add_modify (&block, se.expr, tmp);
}
+ /* ERRMSG block. */
+ if (code->expr2)
+ {
+ /* A better error message may be possible, but not required. */
+ const char *msg = "Attempt to allocate an allocated object";
+ tree errmsg, slen, dlen;
+
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr_lhs (&se, code->expr2);
+
+ errmsg = gfc_create_var (pchar_type_node, "ERRMSG");
+
+ gfc_add_modify (&block, errmsg,
+ gfc_build_addr_expr (pchar_type_node,
+ gfc_build_localized_cstring_const (msg)));
+
+ slen = build_int_cst (gfc_charlen_type_node, ((int) strlen (msg)));
+ dlen = gfc_get_expr_charlen (code->expr2);
+ slen = fold_build2 (MIN_EXPR, TREE_TYPE (slen), dlen, slen);
+
+ dlen = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
+ gfc_build_addr_expr (pvoid_type_node, se.expr), errmsg, slen);
+
+ tmp = fold_build2 (NE_EXPR, boolean_type_node, stat,
+ build_int_cst (TREE_TYPE (stat), 0));
+
+ tmp = build3_v (COND_EXPR, tmp, dlen, build_empty_stmt ());
+
+ gfc_add_expr_to_block (&block, tmp);
+ }
+
return gfc_finish_block (&block);
}
-/* Translate a DEALLOCATE statement.
- There are two cases within the for loop:
- (1) deallocate(a1, a2, a3) is translated into the following sequence
- _gfortran_deallocate(a1, 0B)
- _gfortran_deallocate(a2, 0B)
- _gfortran_deallocate(a3, 0B)
- where the STAT= variable is passed a NULL pointer.
- (2) deallocate(a1, a2, a3, stat=i) is translated into the following
- astat = 0
- _gfortran_deallocate(a1, &stat)
- astat = astat + stat
- _gfortran_deallocate(a2, &stat)
- astat = astat + stat
- _gfortran_deallocate(a3, &stat)
- astat = astat + stat
- In case (1), we simply return at the end of the for loop. In case (2)
- we set STAT= astat. */
+/* Translate a DEALLOCATE statement. */
+
tree
-gfc_trans_deallocate (gfc_code * code)
+gfc_trans_deallocate (gfc_code *code)
{
gfc_se se;
gfc_alloc *al;
tree apstat, astat, pstat, stat, tmp;
stmtblock_t block;
+ pstat = apstat = stat = astat = tmp = NULL_TREE;
+
gfc_start_block (&block);
- /* Set up the optional STAT= */
- if (code->expr)
+ /* Count the number of failed deallocations. If deallocate() was
+ called with STAT= , then set STAT to the count. If deallocate
+ was called with ERRMSG, then set ERRMG to a string. */
+ if (code->expr || code->expr2)
{
tree gfc_int4_type_node = gfc_get_int_type (4);
- /* Variable used with the library call. */
stat = gfc_create_var (gfc_int4_type_node, "stat");
pstat = gfc_build_addr_expr (NULL_TREE, stat);
/* Initialize astat to 0. */
gfc_add_modify (&block, astat, build_int_cst (TREE_TYPE (astat), 0));
}
- else
- pstat = apstat = stat = astat = NULL_TREE;
for (al = code->ext.alloc_list; al != NULL; al = al->next)
{
se.descriptor_only = 1;
gfc_conv_expr (&se, expr);
- if (expr->ts.type == BT_DERIVED
- && expr->ts.derived->attr.alloc_comp)
+ if (expr->ts.type == BT_DERIVED && expr->ts.derived->attr.alloc_comp)
{
gfc_ref *ref;
gfc_ref *last = NULL;
/* Do not deallocate the components of a derived type
ultimate pointer component. */
if (!(last && last->u.c.component->attr.pointer)
- && !(!last && expr->symtree->n.sym->attr.pointer))
+ && !(!last && expr->symtree->n.sym->attr.pointer))
{
tmp = gfc_deallocate_alloc_comp (expr->ts.derived, se.expr,
expr->rank);
/* Keep track of the number of failed deallocations by adding stat
of the last deallocation to the running total. */
- if (code->expr)
+ if (code->expr || code->expr2)
{
apstat = fold_build2 (PLUS_EXPR, TREE_TYPE (stat), astat, stat);
gfc_add_modify (&se.pre, astat, apstat);
}
- /* Assign the value to the status variable. */
+ /* Set STAT. */
if (code->expr)
{
gfc_init_se (&se, NULL);
gfc_add_modify (&block, se.expr, tmp);
}
+ /* Set ERRMSG. */
+ if (code->expr2)
+ {
+ /* A better error message may be possible, but not required. */
+ const char *msg = "Attempt to deallocate an unallocated object";
+ tree errmsg, slen, dlen;
+
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr_lhs (&se, code->expr2);
+
+ errmsg = gfc_create_var (pchar_type_node, "ERRMSG");
+
+ gfc_add_modify (&block, errmsg,
+ gfc_build_addr_expr (pchar_type_node,
+ gfc_build_localized_cstring_const (msg)));
+
+ slen = build_int_cst (gfc_charlen_type_node, ((int) strlen (msg)));
+ dlen = gfc_get_expr_charlen (code->expr2);
+ slen = fold_build2 (MIN_EXPR, TREE_TYPE (slen), dlen, slen);
+
+ dlen = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
+ gfc_build_addr_expr (pvoid_type_node, se.expr), errmsg, slen);
+
+ tmp = fold_build2 (NE_EXPR, boolean_type_node, astat,
+ build_int_cst (TREE_TYPE (astat), 0));
+
+ tmp = build3_v (COND_EXPR, tmp, dlen, build_empty_stmt ());
+
+ gfc_add_expr_to_block (&block, tmp);
+ }
+
return gfc_finish_block (&block);
}
+2009-03-30 Steven G. Kargl <kargls@comcast.net>
+
+ PR fortran/38389
+ * gfortran.dg/alloc_alloc_expr_1.f90: Adjust for new error message.
+ * gfortran.dg/allocate_alloc_opt_1.f90: New test.
+ * gfortran.dg/allocate_alloc_opt_2.f90: Ditto.
+ * gfortran.dg/allocate_alloc_opt_3.f90: Ditto.
+ * gfortran.dg/deallocate_alloc_opt_1.f90: Ditto.
+ * gfortran.dg/deallocate_alloc_opt_2.f90: Ditto.
+ * gfortran.dg/deallocate_alloc_opt_3.f90: Ditto.
+
2009-03-30 Paul Thomas <pault@gcc.gnu.org>
PR fortran/22571
integer, pointer :: PTR
integer, allocatable :: ALLOCS(:)
- allocate (PTR, stat=PTR) ! { dg-error "allocated in the same statement" }
+ allocate (PTR, stat=PTR) ! { dg-error "in the same ALLOCATE statement" }
- allocate (ALLOCS(10),stat=ALLOCS(1)) ! { dg-error "allocated in the same statement" }
+ allocate (ALLOCS(10),stat=ALLOCS(1)) ! { dg-error "in the same ALLOCATE statement" }
ALLOCATE(PTR,ALLOCS(PTR)) ! { dg-error "same ALLOCATE statement" }
--- /dev/null
+! { dg-do compile }
+program a
+
+ implicit none
+
+ real x
+ integer j, k, n(4)
+ character(len=70) err
+ character(len=70), allocatable :: error(:)
+
+ integer, allocatable :: i(:)
+
+ type b
+ integer, allocatable :: c(:), d(:)
+ end type b
+
+ type(b) e, f(3)
+
+ allocate(i(2), stat=x) ! { dg-error "must be a scalar INTEGER" }
+ allocate(i(2), stat=j, stat=k) ! { dg-error "Redundant STAT" }
+ allocate(i(2))
+ allocate(i(2))) ! { dg-error "Syntax error in ALLOCATE" }
+ allocate(i(2), errmsg=err, errmsg=err) ! { dg-error "Redundant ERRMSG" }
+ allocate(i(2), errmsg=err) ! { dg-warning "useless without a STAT" }
+ allocate(i(2), stat=j, errmsg=x) ! { dg-error "must be a scalar CHARACTER" }
+
+ allocate(err) ! { dg-error "nonprocedure pointer or an allocatable" }
+
+ allocate(error(2),stat=j,errmsg=error) ! { dg-error "shall not be ALLOCATEd within" }
+ allocate(i(2), stat = i) ! { dg-error "shall not be ALLOCATEd within" }
+
+ allocate(n) ! { dg-error "must be ALLOCATABLE or a POINTER" }
+
+ allocate(i(2), i(2)) ! { dg-error "Allocate-object at" }
+
+ ! These should not fail the check for duplicate alloc-objects.
+ allocate(f(1)%c(2), f(2)%d(2))
+ allocate(e%c(2), e%d(2))
+
+end program a
--- /dev/null
+! { dg-do compile }
+subroutine sub(i, j, err)
+ implicit none
+ character(len=*), intent(in) :: err
+ integer, intent(in) :: j
+ integer, intent(in), allocatable :: i(:)
+ integer, allocatable :: m(:)
+ integer n
+ allocate(i(2)) ! { dg-error "Cannot allocate" "" }
+ allocate(m(2), stat=j) ! { dg-error "cannot be" "" }
+ allocate(m(2),stat=n,errmsg=err) ! { dg-error "cannot be" "" }
+end subroutine sub
--- /dev/null
+! { dg-do run }
+program a
+
+ implicit none
+
+ integer n
+ character(len=70) e1
+ character(len=30) e2
+ integer, allocatable :: i(:)
+
+ e1 = 'No error'
+ allocate(i(4), stat=n, errmsg=e1)
+ if (trim(e1) /= 'No error') call abort
+ deallocate(i)
+
+ e2 = 'No error'
+ allocate(i(4),stat=n, errmsg=e2)
+ if (trim(e2) /= 'No error') call abort
+ deallocate(i)
+
+
+ e1 = 'No error'
+ allocate(i(4), stat=n, errmsg=e1)
+ allocate(i(4), stat=n, errmsg=e1)
+ if (trim(e1) /= 'Attempt to allocate an allocated object') call abort
+ deallocate(i)
+
+ e2 = 'No error'
+ allocate(i(4), stat=n, errmsg=e2)
+ allocate(i(4), stat=n, errmsg=e2)
+ if (trim(e2) /= 'Attempt to allocate an allocat') call abort
+
+end program a
--- /dev/null
+! { dg-do compile }
+program a
+
+ implicit none
+
+ real x
+ integer j, k, n(4)
+ character(len=70) err
+ character(len=70), allocatable :: error(:)
+
+ integer, allocatable :: i(:)
+
+ type b
+ integer, allocatable :: c(:), d(:)
+ end type b
+
+ type(b) e, f(3)
+
+ deallocate(i, stat=x) ! { dg-error "must be a scalar INTEGER" }
+ deallocate(i, stat=j, stat=k) ! { dg-error "Redundant STAT" }
+ deallocate(i)
+ deallocate(i)) ! { dg-error "Syntax error in DEALLOCATE" }
+ deallocate(i, errmsg=err, errmsg=err) ! { dg-error "Redundant ERRMSG" }
+ deallocate(i, errmsg=err) ! { dg-warning "useless without a STAT" }
+ deallocate(i, stat=j, errmsg=x) ! { dg-error "must be a scalar CHARACTER" }
+
+ deallocate(err) ! { dg-error "nonprocedure pointer or an allocatable" }
+
+ deallocate(error,stat=j,errmsg=error) ! { dg-error "shall not be DEALLOCATEd within" }
+ deallocate(i, stat = i) ! { dg-error "shall not be DEALLOCATEd within" }
+
+ deallocate(n) ! { dg-error "must be ALLOCATABLE or a POINTER" }
+
+ deallocate(i, i) ! { dg-error "Allocate-object at" }
+
+ ! These should not fail the check for duplicate alloc-objects.
+ deallocate(f(1)%c, f(2)%d)
+ deallocate(e%c, e%d)
+
+end program a
--- /dev/null
+! { dg-do compile }
+subroutine sub(i, j, err)
+ implicit none
+ character(len=*), intent(in) :: err
+ integer, intent(in) :: j
+ integer, intent(in), allocatable :: i(:)
+ integer, allocatable :: m(:)
+ integer n
+ deallocate(i) ! { dg-error "Cannot deallocate" "" }
+ deallocate(m, stat=j) ! { dg-error "cannot be" "" }
+ deallocate(m,stat=n,errmsg=err) ! { dg-error "cannot be" "" }
+end subroutine sub
--- /dev/null
+! { dg-do run }
+program a
+
+ implicit none
+
+ integer n
+ character(len=70) e1
+ character(len=30) e2
+ integer, allocatable :: i(:)
+
+ e1 = 'No error'
+ allocate(i(4))
+ deallocate(i, stat=n, errmsg=e1)
+ if (trim(e1) /= 'No error') call abort
+
+ e2 = 'No error'
+ allocate(i(4))
+ deallocate(i, stat=n, errmsg=e2)
+ if (trim(e2) /= 'No error') call abort
+
+ e1 = 'No error'
+ deallocate(i, stat=n, errmsg=e1)
+ if (trim(e1) /= 'Attempt to deallocate an unallocated object') call abort
+
+ e2 = 'No error'
+ deallocate(i, stat=n, errmsg=e2)
+ if (trim(e2) /= 'Attempt to deallocate an unall') call abort
+
+end program a
projects / thirdparty / gcc.git / commitdiff
