}
-/* Do expression resolution and type-checking on an expression tag. */
+/* Resolution of the FORMAT tag, to be called from resolve_tag. */
static try
-resolve_tag (const io_tag *tag, gfc_expr *e)
+resolve_tag_format (const gfc_expr *e)
{
- if (e == NULL)
- return SUCCESS;
-
- if (gfc_resolve_expr (e) == FAILURE)
- return FAILURE;
-
- if (e->ts.type != tag->type && tag != &tag_format)
+ if (e->expr_type == EXPR_CONSTANT
+ && (e->ts.type != BT_CHARACTER
+ || e->ts.kind != gfc_default_character_kind))
{
- gfc_error ("%s tag at %L must be of type %s", tag->name,
- &e->where, gfc_basic_typename (tag->type));
+ gfc_error ("Constant expression in FORMAT tag at %L must be "
+ "of type default CHARACTER", &e->where);
return FAILURE;
}
- if (tag == &tag_format)
+ /* If e's rank is zero and e is not an element of an array, it should be
+ of integer or character type. The integer variable should be
+ ASSIGNED. */
+ if (e->symtree == NULL || e->symtree->n.sym->as == NULL
+ || e->symtree->n.sym->as->rank == 0)
{
- if (e->expr_type == EXPR_CONSTANT
- && (e->ts.type != BT_CHARACTER
- || e->ts.kind != gfc_default_character_kind))
+ if (e->ts.type != BT_CHARACTER && e->ts.type != BT_INTEGER)
{
- gfc_error ("Constant expression in FORMAT tag at %L must be "
- "of type default CHARACTER", &e->where);
+ gfc_error ("FORMAT tag at %L must be of type CHARACTER or INTEGER",
+ &e->where);
return FAILURE;
}
-
- /* If e's rank is zero and e is not an element of an array, it should be
- of integer or character type. The integer variable should be
- ASSIGNED. */
- if (e->symtree == NULL || e->symtree->n.sym->as == NULL
- || e->symtree->n.sym->as->rank == 0)
+ else if (e->ts.type == BT_INTEGER && e->expr_type == EXPR_VARIABLE)
{
- if (e->ts.type != BT_CHARACTER && e->ts.type != BT_INTEGER)
- {
- gfc_error ("%s tag at %L must be of type %s or %s", tag->name,
- &e->where, gfc_basic_typename (BT_CHARACTER),
- gfc_basic_typename (BT_INTEGER));
- return FAILURE;
- }
- else if (e->ts.type == BT_INTEGER && e->expr_type == EXPR_VARIABLE)
- {
- if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: ASSIGNED "
- "variable in FORMAT tag at %L", &e->where)
- == FAILURE)
- return FAILURE;
- if (e->symtree->n.sym->attr.assign != 1)
- {
- gfc_error ("Variable '%s' at %L has not been assigned a "
- "format label", e->symtree->n.sym->name,
- &e->where);
- return FAILURE;
- }
- }
- else if (e->ts.type == BT_INTEGER)
+ if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: ASSIGNED "
+ "variable in FORMAT tag at %L", &e->where)
+ == FAILURE)
+ return FAILURE;
+ if (e->symtree->n.sym->attr.assign != 1)
{
- gfc_error ("scalar '%s' FORMAT tag at %L is not an ASSIGNED "
- "variable", gfc_basic_typename (e->ts.type),
- &e->where);
+ gfc_error ("Variable '%s' at %L has not been assigned a "
+ "format label", e->symtree->n.sym->name, &e->where);
return FAILURE;
}
-
- return SUCCESS;
}
- else
+ else if (e->ts.type == BT_INTEGER)
{
- /* if rank is nonzero, we allow the type to be character under
- GFC_STD_GNU and other type under GFC_STD_LEGACY. It may be
- assigned an Hollerith constant. */
- if (e->ts.type == BT_CHARACTER)
- {
- if (gfc_notify_std (GFC_STD_GNU, "Extension: Character array "
- "in FORMAT tag at %L", &e->where)
- == FAILURE)
- return FAILURE;
- }
- else
- {
- if (gfc_notify_std (GFC_STD_LEGACY, "Extension: Non-character "
- "in FORMAT tag at %L", &e->where)
- == FAILURE)
- return FAILURE;
- }
- return SUCCESS;
+ gfc_error ("Scalar '%s' in FORMAT tag at %L is not an ASSIGNED "
+ "variable", gfc_basic_typename (e->ts.type), &e->where);
+ return FAILURE;
}
+
+ return SUCCESS;
+ }
+
+ /* If rank is nonzero, we allow the type to be character under GFC_STD_GNU
+ and other type under GFC_STD_LEGACY. It may be assigned an Hollerith
+ constant. */
+ if (e->ts.type == BT_CHARACTER)
+ {
+ if (gfc_notify_std (GFC_STD_GNU, "Extension: Character array "
+ "in FORMAT tag at %L", &e->where) == FAILURE)
+ return FAILURE;
}
else
{
- if (e->rank != 0)
- {
- gfc_error ("%s tag at %L must be scalar", tag->name, &e->where);
- return FAILURE;
- }
+ if (gfc_notify_std (GFC_STD_LEGACY, "Extension: Non-character "
+ "in FORMAT tag at %L", &e->where) == FAILURE)
+ return FAILURE;
+ }
- if (tag == &tag_iomsg)
- {
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: IOMSG tag at %L",
- &e->where) == FAILURE)
- return FAILURE;
- }
+ return SUCCESS;
+}
- if (tag == &tag_iostat && e->ts.kind != gfc_default_integer_kind)
- {
- if (gfc_notify_std (GFC_STD_GNU, "Fortran 95 requires default "
- "INTEGER in IOSTAT tag at %L", &e->where)
- == FAILURE)
- return FAILURE;
- }
- if (tag == &tag_size && e->ts.kind != gfc_default_integer_kind)
- {
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 95 requires default "
- "INTEGER in SIZE tag at %L", &e->where)
- == FAILURE)
- return FAILURE;
- }
+/* Do expression resolution and type-checking on an expression tag. */
- if (tag == &tag_convert)
- {
- if (gfc_notify_std (GFC_STD_GNU, "Extension: CONVERT tag at %L",
- &e->where) == FAILURE)
- return FAILURE;
- }
-
- if (tag == &tag_iolength && e->ts.kind != gfc_default_integer_kind)
- {
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 95 requires default "
- "INTEGER in IOLENGTH tag at %L", &e->where)
- == FAILURE)
- return FAILURE;
- }
+static try
+resolve_tag (const io_tag *tag, gfc_expr *e)
+{
+ if (e == NULL)
+ return SUCCESS;
+
+ if (gfc_resolve_expr (e) == FAILURE)
+ return FAILURE;
+
+ if (tag == &tag_format)
+ return resolve_tag_format (e);
+
+ if (e->ts.type != tag->type)
+ {
+ gfc_error ("%s tag at %L must be of type %s", tag->name,
+ &e->where, gfc_basic_typename (tag->type));
+ return FAILURE;
}
+ if (e->rank != 0)
+ {
+ gfc_error ("%s tag at %L must be scalar", tag->name, &e->where);
+ return FAILURE;
+ }
+
+ if (tag == &tag_iomsg)
+ {
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: IOMSG tag at %L",
+ &e->where) == FAILURE)
+ return FAILURE;
+ }
+
+ if ((tag == &tag_iostat || tag == &tag_size || tag == &tag_iolength)
+ && e->ts.kind != gfc_default_integer_kind)
+ {
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 95 requires default "
+ "INTEGER in %s tag at %L", tag->name, &e->where)
+ == FAILURE)
+ return FAILURE;
+ }
+
+ if (tag == &tag_convert)
+ {
+ if (gfc_notify_std (GFC_STD_GNU, "Extension: CONVERT tag at %L",
+ &e->where) == FAILURE)
+ return FAILURE;
+ }
+
return SUCCESS;
}