}
+/* Test for non-constant shape arrays. */
+
+static bool
+is_non_constant_shape_array (gfc_symbol *sym)
+{
+ gfc_expr *e;
+ int i;
+
+ if (sym->as != NULL)
+ {
+ /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
+ has not been simplified; parameter array references. Do the
+ simplification now. */
+ for (i = 0; i < sym->as->rank; i++)
+ {
+ e = sym->as->lower[i];
+ if (e && (resolve_index_expr (e) == FAILURE
+ || !gfc_is_constant_expr (e)))
+ return true;
+
+ e = sym->as->upper[i];
+ if (e && (resolve_index_expr (e) == FAILURE
+ || !gfc_is_constant_expr (e)))
+ return true;
+ }
+ }
+ return false;
+}
+
/* Resolution of common features of flavors variable and procedure. */
static try
return FAILURE;
/* The shape of a main program or module array needs to be constant. */
- if (sym->as != NULL
- && sym->ns->proc_name
+ if (sym->ns->proc_name
&& (sym->ns->proc_name->attr.flavor == FL_MODULE
|| sym->ns->proc_name->attr.is_main_program)
&& !sym->attr.use_assoc
&& !sym->attr.allocatable
- && !sym->attr.pointer)
+ && !sym->attr.pointer
+ && is_non_constant_shape_array (sym))
{
- /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
- has not been simplified; parameter array references. Do the
- simplification now. */
- flag = 0;
- for (i = 0; i < sym->as->rank; i++)
- {
- e = sym->as->lower[i];
- if (e && (resolve_index_expr (e) == FAILURE
- || !gfc_is_constant_expr (e)))
- {
- flag = 1;
- break;
- }
-
- e = sym->as->upper[i];
- if (e && (resolve_index_expr (e) == FAILURE
- || !gfc_is_constant_expr (e)))
- {
- flag = 1;
- break;
- }
- }
-
- if (flag)
- {
- gfc_error ("The module or main program array '%s' at %L must "
+ gfc_error ("The module or main program array '%s' at %L must "
"have constant shape", sym->name, &sym->declared_at);
return FAILURE;
- }
}
if (sym->ts.type == BT_CHARACTER)
}
+static try
+resolve_fl_namelist (gfc_symbol *sym)
+{
+ gfc_namelist *nl;
+ gfc_symbol *nlsym;
+
+ /* Reject PRIVATE objects in a PUBLIC namelist. */
+ if (gfc_check_access(sym->attr.access, sym->ns->default_access))
+ {
+ for (nl = sym->namelist; nl; nl = nl->next)
+ {
+ if (!nl->sym->attr.use_assoc
+ && !(sym->ns->parent == nl->sym->ns)
+ && !gfc_check_access(nl->sym->attr.access,
+ nl->sym->ns->default_access))
+ {
+ gfc_error ("PRIVATE symbol '%s' cannot be member of "
+ "PUBLIC namelist at %L", nl->sym->name,
+ &sym->declared_at);
+ return FAILURE;
+ }
+ }
+ }
+
+ /* Reject namelist arrays that are not constant shape. */
+ for (nl = sym->namelist; nl; nl = nl->next)
+ {
+ if (is_non_constant_shape_array (nl->sym))
+ {
+ gfc_error ("The array '%s' must have constant shape to be "
+ "a NAMELIST object at %L", nl->sym->name,
+ &sym->declared_at);
+ return FAILURE;
+ }
+ }
+
+ /* 14.1.2 A module or internal procedure represent local entities
+ of the same type as a namelist member and so are not allowed.
+ Note that this is sometimes caught by check_conflict so the
+ same message has been used. */
+ for (nl = sym->namelist; nl; nl = nl->next)
+ {
+ nlsym = NULL;
+ if (sym->ns->parent && nl->sym && nl->sym->name)
+ gfc_find_symbol (nl->sym->name, sym->ns->parent, 0, &nlsym);
+ if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
+ {
+ gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
+ "attribute in '%s' at %L", nlsym->name,
+ &sym->declared_at);
+ return FAILURE;
+ }
+ }
+
+ return SUCCESS;
+}
+
+
static try
resolve_fl_parameter (gfc_symbol *sym)
{
/* Zero if we are checking a formal namespace. */
static int formal_ns_flag = 1;
int formal_ns_save, check_constant, mp_flag;
- gfc_namelist *nl;
gfc_symtree *symtree;
gfc_symtree *this_symtree;
gfc_namespace *ns;
break;
case FL_NAMELIST:
- /* Reject PRIVATE objects in a PUBLIC namelist. */
- if (gfc_check_access(sym->attr.access, sym->ns->default_access))
- {
- for (nl = sym->namelist; nl; nl = nl->next)
- {
- if (!nl->sym->attr.use_assoc
- &&
- !(sym->ns->parent == nl->sym->ns)
- &&
- !gfc_check_access(nl->sym->attr.access,
- nl->sym->ns->default_access))
- gfc_error ("PRIVATE symbol '%s' cannot be member of "
- "PUBLIC namelist at %L", nl->sym->name,
- &sym->declared_at);
- }
- }
-
+ if (resolve_fl_namelist (sym) == FAILURE)
+ return;
break;
case FL_PARAMETER:
break;
}
-
/* Make sure that intrinsic exist */
if (sym->attr.intrinsic
&& ! gfc_intrinsic_name(sym->name, 0)
--- /dev/null
+! { dg-do compile }\r
+! This tests the fix for PR25089 in which it was noted that a\r
+! NAMELIST member that is an internal(or module) procedure gave\r
+! no error if the NAMELIST declaration appeared before the\r
+! procedure declaration. Not mentioned in the PR is that any\r
+! reference to the NAMELIST object would cause a segfault.\r
+!\r
+! Based on the contribution from Joost VanderVondele\r
+!\r
+module M1\r
+CONTAINS\r
+! This is the original PR\r
+ INTEGER FUNCTION G1()\r
+ NAMELIST /NML1/ G2 ! { dg-error "PROCEDURE attribute conflicts" }\r
+ G1=1\r
+ END FUNCTION\r
+ INTEGER FUNCTION G2()\r
+ G2=1\r
+ END FUNCTION\r
+! This has always been picked up - namelist after function\r
+ INTEGER FUNCTION G3()\r
+ NAMELIST /NML2/ G1 ! { dg-error "PROCEDURE attribute conflicts" }\r
+ G3=1\r
+ END FUNCTION\r
+END module M1\r
+
+program P1\r
+CONTAINS\r
+! This has the additional wrinkle of a reference to the object.\r
+ INTEGER FUNCTION F1()\r
+ NAMELIST /NML3/ F2 ! { dg-error "PROCEDURE attribute conflicts" }\r
+ f2 = 1 ! Used to ICE here\r
+ F1=1\r
+ END FUNCTION\r
+ INTEGER FUNCTION F2()\r
+ F2=1\r
+ END FUNCTION\r
+END
+\r
projects / gcc.git / commitdiff