+/* Check the constraints for a data transfer statement. The majority of the
+ constraints appearing in 9.4 of the standard appear here. Some are handled
+ in resolve_tag and others in gfc_resolve_dt. */
+
+static match
+check_io_constraints (io_kind k, gfc_dt *dt, gfc_code *io_code,
+ locus *spec_end)
+{
+#define io_constraint(condition,msg,arg)\
+if (condition) \
+ {\
+ gfc_error(msg,arg);\
+ m = MATCH_ERROR;\
+ }
+
+ match m;
+ gfc_expr *expr;
+ gfc_symbol *sym = NULL;
+ bool warn, unformatted;
+
+ warn = (dt->err || dt->iostat) ? true : false;
+ unformatted = dt->format_expr == NULL && dt->format_label == NULL
+ && dt->namelist == NULL;
+
+ m = MATCH_YES;
+
+ expr = dt->io_unit;
+ if (expr && expr->expr_type == EXPR_VARIABLE
+ && expr->ts.type == BT_CHARACTER)
+ {
+ sym = expr->symtree->n.sym;
+
+ io_constraint (k == M_WRITE && sym->attr.intent == INTENT_IN,
+ "Internal file at %L must not be INTENT(IN)",
+ &expr->where);
+
+ io_constraint (gfc_has_vector_index (dt->io_unit),
+ "Internal file incompatible with vector subscript at %L",
+ &expr->where);
+
+ io_constraint (dt->rec != NULL,
+ "REC tag at %L is incompatible with internal file",
+ &dt->rec->where);
+
+ io_constraint (dt->pos != NULL,
+ "POS tag at %L is incompatible with internal file",
+ &dt->pos->where);
+
+ io_constraint (unformatted,
+ "Unformatted I/O not allowed with internal unit at %L",
+ &dt->io_unit->where);
+
+ io_constraint (dt->asynchronous != NULL,
+ "ASYNCHRONOUS tag at %L not allowed with internal file",
+ &dt->asynchronous->where);
+
+ if (dt->namelist != NULL)
+ {
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Internal file "
+ "at %L with namelist", &expr->where)
+ == FAILURE)
+ m = MATCH_ERROR;
+ }
+
+ io_constraint (dt->advance != NULL,
+ "ADVANCE tag at %L is incompatible with internal file",
+ &dt->advance->where);
+ }
+
+ if (expr && expr->ts.type != BT_CHARACTER)
+ {
+
+ io_constraint (gfc_pure (NULL) && (k == M_READ || k == M_WRITE),
+ "IO UNIT in %s statement at %C must be "
+ "an internal file in a PURE procedure",
+ io_kind_name (k));
+ }
+
+ if (k != M_READ)
+ {
+ io_constraint (dt->end, "END tag not allowed with output at %L",
+ &dt->end_where);
+
+ io_constraint (dt->eor, "EOR tag not allowed with output at %L",
+ &dt->eor_where);
+
+ io_constraint (dt->blank, "BLANK= specifier not allowed with output at %L",
+ &dt->blank->where);
+
+ io_constraint (dt->pad, "PAD= specifier not allowed with output at %L",
+ &dt->pad->where);
+
+ io_constraint (dt->size, "SIZE= specifier not allowed with output at %L",
+ &dt->size->where);
+ }
+ else
+ {
+ io_constraint (dt->size && dt->advance == NULL,
+ "SIZE tag at %L requires an ADVANCE tag",
+ &dt->size->where);
+
+ io_constraint (dt->eor && dt->advance == NULL,
+ "EOR tag at %L requires an ADVANCE tag",
+ &dt->eor_where);
+ }
+
+ if (dt->asynchronous)
+ {
+ static const char * asynchronous[] = { "YES", "NO", NULL };
+
+ if (gfc_reduce_init_expr (dt->asynchronous) != SUCCESS)
+ {
+ gfc_error ("ASYNCHRONOUS= specifier at %L must be an initialization "
+ "expression", &dt->asynchronous->where);
+ return MATCH_ERROR;
+ }
+
+ if (!compare_to_allowed_values
+ ("ASYNCHRONOUS", asynchronous, NULL, NULL,
+ dt->asynchronous->value.character.string,
+ io_kind_name (k), warn))
+ return MATCH_ERROR;
+ }
+
+ if (dt->id)
+ {
+ bool not_yes
+ = !dt->asynchronous
+ || gfc_wide_strlen (dt->asynchronous->value.character.string) != 3
+ || gfc_wide_strncasecmp (dt->asynchronous->value.character.string,
+ "yes", 3) != 0;
+ io_constraint (not_yes,
+ "ID= specifier at %L must be with ASYNCHRONOUS='yes' "
+ "specifier", &dt->id->where);
+ }
+
+ if (dt->decimal)
+ {
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DECIMAL= at %C "
+ "not allowed in Fortran 95") == FAILURE)
+ return MATCH_ERROR;
+
+ if (dt->decimal->expr_type == EXPR_CONSTANT)
+ {
+ static const char * decimal[] = { "COMMA", "POINT", NULL };
+
+ if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL,
+ dt->decimal->value.character.string,
+ io_kind_name (k), warn))
+ return MATCH_ERROR;
+
+ io_constraint (unformatted,
+ "the DECIMAL= specifier at %L must be with an "
+ "explicit format expression", &dt->decimal->where);
+ }
+ }
+
+ if (dt->blank)
+ {
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BLANK= at %C "
+ "not allowed in Fortran 95") == FAILURE)
+ return MATCH_ERROR;
+
+ if (dt->blank->expr_type == EXPR_CONSTANT)
+ {
+ static const char * blank[] = { "NULL", "ZERO", NULL };
+
+ if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL,
+ dt->blank->value.character.string,
+ io_kind_name (k), warn))
+ return MATCH_ERROR;
+
+ io_constraint (unformatted,
+ "the BLANK= specifier at %L must be with an "
+ "explicit format expression", &dt->blank->where);
+ }
+ }
+
+ if (dt->pad)
+ {
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PAD= at %C "
+ "not allowed in Fortran 95") == FAILURE)
+ return MATCH_ERROR;
+
+ if (dt->pad->expr_type == EXPR_CONSTANT)
+ {
+ static const char * pad[] = { "YES", "NO", NULL };
+
+ if (!compare_to_allowed_values ("PAD", pad, NULL, NULL,
+ dt->pad->value.character.string,
+ io_kind_name (k), warn))
+ return MATCH_ERROR;
+
+ io_constraint (unformatted,
+ "the PAD= specifier at %L must be with an "
+ "explicit format expression", &dt->pad->where);
+ }
+ }
+
+ if (dt->round)
+ {
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ROUND= at %C "
+ "not allowed in Fortran 95") == FAILURE)
+ return MATCH_ERROR;
+
+ if (dt->round->expr_type == EXPR_CONSTANT)
+ {
+ static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST",
+ "COMPATIBLE", "PROCESSOR_DEFINED",
+ NULL };
+
+ if (!compare_to_allowed_values ("ROUND", round, NULL, NULL,
+ dt->round->value.character.string,
+ io_kind_name (k), warn))
+ return MATCH_ERROR;
+ }
+ }
+
+ if (dt->sign)
+ {
+ /* When implemented, change the following to use gfc_notify_std F2003.
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SIGN= at %C "
+ "not allowed in Fortran 95") == FAILURE)
+ return MATCH_ERROR; */
+ if (dt->sign->expr_type == EXPR_CONSTANT)
+ {
+ static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
+ NULL };
+
+ if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL,
+ dt->sign->value.character.string,
+ io_kind_name (k), warn))
+ return MATCH_ERROR;
+
+ io_constraint (unformatted,
+ "SIGN= specifier at %L must be with an "
+ "explicit format expression", &dt->sign->where);
+
+ io_constraint (k == M_READ,
+ "SIGN= specifier at %L not allowed in a "
+ "READ statement", &dt->sign->where);
+ }
+ }
+
+ if (dt->delim)
+ {
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DELIM= at %C "
+ "not allowed in Fortran 95") == FAILURE)
+ return MATCH_ERROR;
+
+ if (dt->delim->expr_type == EXPR_CONSTANT)
+ {
+ static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
+
+ if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
+ dt->delim->value.character.string,
+ io_kind_name (k), warn))
+ return MATCH_ERROR;
+
+ io_constraint (k == M_READ,
+ "DELIM= specifier at %L not allowed in a "
+ "READ statement", &dt->delim->where);
+
+ io_constraint (dt->format_label != &format_asterisk
+ && dt->namelist == NULL,
+ "DELIM= specifier at %L must have FMT=*",
+ &dt->delim->where);
+
+ io_constraint (unformatted && dt->namelist == NULL,
+ "DELIM= specifier at %L must be with FMT=* or "
+ "NML= specifier ", &dt->delim->where);
+ }
+ }
+
+ if (dt->namelist)
+ {
+ io_constraint (io_code && dt->namelist,
+ "NAMELIST cannot be followed by IO-list at %L",
+ &io_code->loc);
+
+ io_constraint (dt->format_expr,
+ "IO spec-list cannot contain both NAMELIST group name "
+ "and format specification at %L",
+ &dt->format_expr->where);
+
+ io_constraint (dt->format_label,
+ "IO spec-list cannot contain both NAMELIST group name "
+ "and format label at %L", spec_end);
+
+ io_constraint (dt->rec,
+ "NAMELIST IO is not allowed with a REC= specifier "
+ "at %L", &dt->rec->where);
+
+ io_constraint (dt->advance,
+ "NAMELIST IO is not allowed with a ADVANCE= specifier "
+ "at %L", &dt->advance->where);
+ }
+
+ if (dt->rec)
+ {
+ io_constraint (dt->end,
+ "An END tag is not allowed with a "
+ "REC= specifier at %L", &dt->end_where);
+
+ io_constraint (dt->format_label == &format_asterisk,
+ "FMT=* is not allowed with a REC= specifier "
+ "at %L", spec_end);
+
+ io_constraint (dt->pos,
+ "POS= is not allowed with REC= specifier "
+ "at %L", &dt->pos->where);
+ }
+
+ if (dt->advance)
+ {
+ int not_yes, not_no;
+ expr = dt->advance;
+
+ io_constraint (dt->format_label == &format_asterisk,
+ "List directed format(*) is not allowed with a "
+ "ADVANCE= specifier at %L.", &expr->where);
+
+ io_constraint (unformatted,
+ "the ADVANCE= specifier at %L must appear with an "
+ "explicit format expression", &expr->where);
+
+ if (expr->expr_type == EXPR_CONSTANT && expr->ts.type == BT_CHARACTER)
+ {
+ const gfc_char_t *advance = expr->value.character.string;
+ not_no = gfc_wide_strlen (advance) != 2
+ || gfc_wide_strncasecmp (advance, "no", 2) != 0;
+ not_yes = gfc_wide_strlen (advance) != 3
+ || gfc_wide_strncasecmp (advance, "yes", 3) != 0;
+ }
+ else
+ {
+ not_no = 0;
+ not_yes = 0;
+ }
+
+ io_constraint (not_no && not_yes,
+ "ADVANCE= specifier at %L must have value = "
+ "YES or NO.", &expr->where);
+
+ io_constraint (dt->size && not_no && k == M_READ,
+ "SIZE tag at %L requires an ADVANCE = 'NO'",
+ &dt->size->where);
+
+ io_constraint (dt->eor && not_no && k == M_READ,
+ "EOR tag at %L requires an ADVANCE = 'NO'",
+ &dt->eor_where);
+ }
+
+ expr = dt->format_expr;
+ if (gfc_simplify_expr (expr, 0) == FAILURE
+ || check_format_string (expr, k == M_READ) == FAILURE)
+ return MATCH_ERROR;
+
+ return m;
+}
+#undef io_constraint
+
+