@@ -7469,6 +7469,7 @@ access_attr_decl (gfc_statement st)
goto syntax;
case INTERFACE_GENERIC:
+ case INTERFACE_DTIO:
if (gfc_get_symbol (name, NULL, &sym))
goto done;
@@ -9378,6 +9379,7 @@ gfc_match_generic (void)
switch (op_type)
{
case INTERFACE_GENERIC:
+ case INTERFACE_DTIO:
snprintf (bind_name, sizeof (bind_name), "%s", name);
break;
@@ -9413,6 +9415,7 @@ gfc_match_generic (void)
switch (op_type)
{
+ case INTERFACE_DTIO:
case INTERFACE_USER_OP:
case INTERFACE_GENERIC:
{
@@ -9467,6 +9470,7 @@ gfc_match_generic (void)
switch (op_type)
{
+ case INTERFACE_DTIO:
case INTERFACE_GENERIC:
case INTERFACE_USER_OP:
{
@@ -177,8 +177,10 @@ enum gfc_intrinsic_op
/* .EQ., .NE., .GT., .GE., .LT., .LE. (OS = Old-Style) */
INTRINSIC_EQ_OS, INTRINSIC_NE_OS, INTRINSIC_GT_OS, INTRINSIC_GE_OS,
INTRINSIC_LT_OS, INTRINSIC_LE_OS,
- INTRINSIC_NOT, INTRINSIC_USER, INTRINSIC_ASSIGN,
- INTRINSIC_PARENTHESES, GFC_INTRINSIC_END /* Sentinel */
+ INTRINSIC_NOT, INTRINSIC_USER, INTRINSIC_ASSIGN, INTRINSIC_PARENTHESES,
+ /* User defined derived type pseudo operator. */
+ INTRINSIC_FORMATTED, INTRINSIC_UNFORMATTED,
+ GFC_INTRINSIC_END /* Sentinel */
};
/* This macro is the number of intrinsic operators that exist.
@@ -261,7 +263,8 @@ enum gfc_statement
enum interface_type
{
INTERFACE_NAMELESS = 1, INTERFACE_GENERIC,
- INTERFACE_INTRINSIC_OP, INTERFACE_USER_OP, INTERFACE_ABSTRACT
+ INTERFACE_INTRINSIC_OP, INTERFACE_USER_OP, INTERFACE_ABSTRACT,
+ INTERFACE_DTIO
};
/* Symbol flavors: these are all mutually exclusive.
@@ -313,6 +316,12 @@ extern const mstring access_types[];
extern const mstring ifsrc_types[];
extern const mstring save_status[];
+/* Strings for DTIO procedure names. In symbol.c. */
+extern const mstring dtio_procs[];
+
+enum dtio_codes
+{ DTIO_RF = 0, DTIO_WF, DTIO_RUF, DTIO_WUF };
+
/* Enumeration of all the generic intrinsic functions. Used by the
backend for identification of a function. */
@@ -784,7 +793,7 @@ typedef struct
unsigned implicit_pure:1;
/* This is set for a procedure that contains expressions referencing
- arrays coming from outside its namespace.
+ arrays coming from outside its namespace.
This is used to force the creation of a temporary when the LHS of
an array assignment may be used by an elemental procedure appearing
on the RHS. */
@@ -841,7 +850,8 @@ typedef struct
entities. */
unsigned alloc_comp:1, pointer_comp:1, proc_pointer_comp:1,
private_comp:1, zero_comp:1, coarray_comp:1, lock_comp:1,
- event_comp:1, defined_assign_comp:1, unlimited_polymorphic:1;
+ event_comp:1, defined_assign_comp:1, unlimited_polymorphic:1,
+ has_dtio_procs:1;
/* This is a temporary selector for SELECT TYPE or an associate
variable for SELECT_TYPE or ASSOCIATE. */
@@ -3170,6 +3180,9 @@ bool gfc_check_operator_interface (gfc_symbol*, gfc_intrinsic_op, locus);
int gfc_has_vector_subscript (gfc_expr*);
gfc_intrinsic_op gfc_equivalent_op (gfc_intrinsic_op);
bool gfc_check_typebound_override (gfc_symtree*, gfc_symtree*);
+void gfc_check_dtio_interfaces (gfc_symbol*);
+gfc_symbol* gfc_find_specific_dtio_proc (gfc_symbol*, bool, bool);
+
/* io.c */
extern gfc_st_label format_asterisk;
@@ -115,6 +115,19 @@ fold_unary_intrinsic (gfc_intrinsic_op op)
}
+/* Return the operator depending on the DTIO moded string. */
+
+static gfc_intrinsic_op
+dtio_op (char* mode)
+{
+ if (strncmp (mode, "formatted", 9) == 0)
+ return INTRINSIC_FORMATTED;
+ if (strncmp (mode, "unformatted", 9) == 0)
+ return INTRINSIC_UNFORMATTED;
+ return INTRINSIC_NONE;
+}
+
+
/* Match a generic specification. Depending on which type of
interface is found, the 'name' or 'op' pointers may be set.
This subroutine doesn't return MATCH_NO. */
@@ -162,6 +175,40 @@ gfc_match_generic_spec (interface_type *type,
return MATCH_YES;
}
+ if (gfc_match (" read ( %n )", buffer) == MATCH_YES)
+ {
+ *op = dtio_op (buffer);
+ if (*op == INTRINSIC_FORMATTED)
+ {
+ strcpy (name, gfc_code2string (dtio_procs, DTIO_RF));
+ *type = INTERFACE_DTIO;
+ }
+ if (*op == INTRINSIC_UNFORMATTED)
+ {
+ strcpy (name, gfc_code2string (dtio_procs, DTIO_RUF));
+ *type = INTERFACE_DTIO;
+ }
+ if (*op != INTRINSIC_NONE)
+ return MATCH_YES;
+ }
+
+ if (gfc_match (" write ( %n )", buffer) == MATCH_YES)
+ {
+ *op = dtio_op (buffer);
+ if (*op == INTRINSIC_FORMATTED)
+ {
+ strcpy (name, gfc_code2string (dtio_procs, DTIO_WF));
+ *type = INTERFACE_DTIO;
+ }
+ if (*op == INTRINSIC_UNFORMATTED)
+ {
+ strcpy (name, gfc_code2string (dtio_procs, DTIO_WUF));
+ *type = INTERFACE_DTIO;
+ }
+ if (*op != INTRINSIC_NONE)
+ return MATCH_YES;
+ }
+
if (gfc_match_name (buffer) == MATCH_YES)
{
strcpy (name, buffer);
@@ -209,6 +256,7 @@ gfc_match_interface (void)
switch (type)
{
+ case INTERFACE_DTIO:
case INTERFACE_GENERIC:
if (gfc_get_symbol (name, NULL, &sym))
return MATCH_ERROR;
@@ -349,7 +397,7 @@ gfc_match_end_interface (void)
if (strcmp(s2, "none") == 0)
gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> "
"at %C, ", s1);
- else
+ else
gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> at %C, "
"but got %s", s1, s2);
}
@@ -371,6 +419,7 @@ gfc_match_end_interface (void)
break;
+ case INTERFACE_DTIO:
case INTERFACE_GENERIC:
if (type != current_interface.type
|| strcmp (current_interface.sym->name, name) != 0)
@@ -3945,7 +3994,7 @@ gfc_extend_expr (gfc_expr *e)
else
return MATCH_YES;
}
-
+
if (i == INTRINSIC_USER)
{
for (ns = gfc_current_ns; ns; ns = ns->parent)
@@ -4136,60 +4185,60 @@ gfc_add_interface (gfc_symbol *new_sym)
{
case INTRINSIC_EQ:
case INTRINSIC_EQ_OS:
- if (!gfc_check_new_interface (ns->op[INTRINSIC_EQ], new_sym,
+ if (!gfc_check_new_interface (ns->op[INTRINSIC_EQ], new_sym,
gfc_current_locus)
- || !gfc_check_new_interface (ns->op[INTRINSIC_EQ_OS],
+ || !gfc_check_new_interface (ns->op[INTRINSIC_EQ_OS],
new_sym, gfc_current_locus))
return false;
break;
case INTRINSIC_NE:
case INTRINSIC_NE_OS:
- if (!gfc_check_new_interface (ns->op[INTRINSIC_NE], new_sym,
+ if (!gfc_check_new_interface (ns->op[INTRINSIC_NE], new_sym,
gfc_current_locus)
- || !gfc_check_new_interface (ns->op[INTRINSIC_NE_OS],
+ || !gfc_check_new_interface (ns->op[INTRINSIC_NE_OS],
new_sym, gfc_current_locus))
return false;
break;
case INTRINSIC_GT:
case INTRINSIC_GT_OS:
- if (!gfc_check_new_interface (ns->op[INTRINSIC_GT],
+ if (!gfc_check_new_interface (ns->op[INTRINSIC_GT],
new_sym, gfc_current_locus)
- || !gfc_check_new_interface (ns->op[INTRINSIC_GT_OS],
+ || !gfc_check_new_interface (ns->op[INTRINSIC_GT_OS],
new_sym, gfc_current_locus))
return false;
break;
case INTRINSIC_GE:
case INTRINSIC_GE_OS:
- if (!gfc_check_new_interface (ns->op[INTRINSIC_GE],
+ if (!gfc_check_new_interface (ns->op[INTRINSIC_GE],
new_sym, gfc_current_locus)
- || !gfc_check_new_interface (ns->op[INTRINSIC_GE_OS],
+ || !gfc_check_new_interface (ns->op[INTRINSIC_GE_OS],
new_sym, gfc_current_locus))
return false;
break;
case INTRINSIC_LT:
case INTRINSIC_LT_OS:
- if (!gfc_check_new_interface (ns->op[INTRINSIC_LT],
+ if (!gfc_check_new_interface (ns->op[INTRINSIC_LT],
new_sym, gfc_current_locus)
- || !gfc_check_new_interface (ns->op[INTRINSIC_LT_OS],
+ || !gfc_check_new_interface (ns->op[INTRINSIC_LT_OS],
new_sym, gfc_current_locus))
return false;
break;
case INTRINSIC_LE:
case INTRINSIC_LE_OS:
- if (!gfc_check_new_interface (ns->op[INTRINSIC_LE],
+ if (!gfc_check_new_interface (ns->op[INTRINSIC_LE],
new_sym, gfc_current_locus)
- || !gfc_check_new_interface (ns->op[INTRINSIC_LE_OS],
+ || !gfc_check_new_interface (ns->op[INTRINSIC_LE_OS],
new_sym, gfc_current_locus))
return false;
break;
default:
- if (!gfc_check_new_interface (ns->op[current_interface.op],
+ if (!gfc_check_new_interface (ns->op[current_interface.op],
new_sym, gfc_current_locus))
return false;
}
@@ -4198,13 +4247,14 @@ gfc_add_interface (gfc_symbol *new_sym)
break;
case INTERFACE_GENERIC:
+ case INTERFACE_DTIO:
for (ns = current_interface.ns; ns; ns = ns->parent)
{
gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
if (sym == NULL)
continue;
- if (!gfc_check_new_interface (sym->generic,
+ if (!gfc_check_new_interface (sym->generic,
new_sym, gfc_current_locus))
return false;
}
@@ -4213,7 +4263,7 @@ gfc_add_interface (gfc_symbol *new_sym)
break;
case INTERFACE_USER_OP:
- if (!gfc_check_new_interface (current_interface.uop->op,
+ if (!gfc_check_new_interface (current_interface.uop->op,
new_sym, gfc_current_locus))
return false;
@@ -4245,6 +4295,7 @@ gfc_current_interface_head (void)
break;
case INTERFACE_GENERIC:
+ case INTERFACE_DTIO:
return current_interface.sym->generic;
break;
@@ -4268,6 +4319,7 @@ gfc_set_current_interface_head (gfc_interface *i)
break;
case INTERFACE_GENERIC:
+ case INTERFACE_DTIO:
current_interface.sym->generic = i;
break;
@@ -4484,3 +4536,304 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
return true;
}
+
+
+/* The following three functions check that the formal arguments
+ of user defined derived type IO procedures are compliant with
+ the requirements of the standard. */
+
+static void
+check_dtio_arg_TKR_intent (gfc_symbol *fsym, bool typebound, bt type,
+ int kind, int rank, sym_intent intent)
+{
+ if (fsym->ts.type != type)
+ gfc_error ("DTIO dummy argument at %L must be of type %s",
+ &fsym->declared_at, gfc_basic_typename (type));
+
+ if (fsym->ts.type != BT_CLASS && fsym->ts.type != BT_DERIVED
+ && fsym->ts.kind != kind)
+ gfc_error ("DTIO dummy argument at %L must be of KIND = %d",
+ &fsym->declared_at, kind);
+
+ if (!typebound
+ && rank == 0
+ && (((type == BT_CLASS) && CLASS_DATA (fsym)->attr.dimension)
+ || ((type != BT_CLASS) && fsym->attr.dimension)))
+ gfc_error ("DTIO dummy argument at %L be a scalar",
+ &fsym->declared_at);
+ else if (rank == 1
+ && (fsym->as == NULL || fsym->as->type != AS_ASSUMED_SHAPE))
+ gfc_error ("DTIO dummy argument at %L must be an "
+ "ASSUMED SHAPE ARRAY", &fsym->declared_at);
+
+ if (fsym->attr.intent != intent)
+ gfc_error ("DTIO dummy argument at %L must have intent %s",
+ &fsym->declared_at, gfc_code2string (intents, (int)intent));
+ return;
+}
+
+
+static void
+check_dtio_interface1 (gfc_symbol *derived, gfc_symtree *tb_io_st,
+ bool typebound, bool formatted, int code)
+{
+ gfc_symbol *dtio_sub, *generic_proc, *fsym;
+ gfc_typebound_proc *tb_io_proc, *specific_proc;
+ gfc_interface *intr;
+ gfc_formal_arglist *formal;
+ int arg_num;
+
+ bool read = ((dtio_codes)code == DTIO_RF)
+ || ((dtio_codes)code == DTIO_RUF);
+ bt type;
+ sym_intent intent;
+ int kind;
+
+ dtio_sub = NULL;
+ if (typebound)
+ {
+ /* Typebound DTIO binding. */
+ tb_io_proc = tb_io_st->n.tb;
+ gcc_assert (tb_io_proc != NULL);
+ gcc_assert (tb_io_proc->is_generic);
+ gcc_assert (tb_io_proc->u.generic->next == NULL);
+
+ specific_proc = tb_io_proc->u.generic->specific;
+ gcc_assert (!specific_proc->is_generic);
+
+ dtio_sub = specific_proc->u.specific->n.sym;
+ }
+ else
+ {
+ generic_proc = tb_io_st->n.sym;
+ gcc_assert (generic_proc);
+ gcc_assert (generic_proc->generic);
+
+ for (intr = tb_io_st->n.sym->generic; intr; intr = intr->next)
+ {
+ if (intr->sym && intr->sym->formal
+ && ((intr->sym->formal->sym->ts.type == BT_CLASS
+ && CLASS_DATA (intr->sym->formal->sym)->ts.u.derived
+ == derived)
+ || (intr->sym->formal->sym->ts.type == BT_DERIVED
+ && intr->sym->formal->sym->ts.u.derived == derived)))
+ dtio_sub = intr->sym;
+ }
+
+ if (dtio_sub == NULL)
+ return;
+ }
+
+ gcc_assert (dtio_sub);
+ if (!dtio_sub->attr.subroutine)
+ gfc_error ("DTIO procedure %s at %L must be a subroutine",
+ dtio_sub->name, &dtio_sub->declared_at);
+
+ /* Now go through the formal arglist. */
+ arg_num = 1;
+ for (formal = dtio_sub->formal; formal; formal = formal->next, arg_num++)
+ {
+ if (!formatted && arg_num == 3)
+ arg_num = 5;
+ fsym = formal->sym;
+ switch (arg_num)
+ {
+ case(1): /* DTV */
+ type = derived->attr.sequence || derived->attr.is_bind_c ?
+ BT_DERIVED : BT_CLASS;
+ kind = 0;
+ intent = read ? INTENT_INOUT : INTENT_IN;
+ check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
+ 0, intent);
+ break;
+
+ case(2): /* UNIT */
+ type = BT_INTEGER;
+ kind = gfc_default_integer_kind;
+ intent = INTENT_IN;
+ check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
+ 0, intent);
+ break;
+ case(3): /* IOTYPE */
+ type = BT_CHARACTER;
+ kind = gfc_default_character_kind;
+ intent = INTENT_IN;
+ check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
+ 0, intent);
+ break;
+ case(4): /* VLIST */
+ type = BT_INTEGER;
+ kind = gfc_default_integer_kind;
+ intent = INTENT_IN;
+ check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
+ 1, intent);
+ break;
+ case(5): /* IOSTAT */
+ type = BT_INTEGER;
+ kind = gfc_default_integer_kind;
+ intent = INTENT_OUT;
+ check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
+ 0, intent);
+ break;
+ case(6): /* IOMSG */
+ type = BT_CHARACTER;
+ kind = gfc_default_character_kind;
+ intent = INTENT_INOUT;
+ check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
+ 0, intent);
+ break;
+ default:
+ gcc_unreachable ();
+ }
+ }
+ derived->attr.has_dtio_procs = 1;
+ return;
+}
+
+void
+gfc_check_dtio_interfaces (gfc_symbol *derived)
+{
+ gfc_symtree *tb_io_st;
+ bool t = false;
+ int code;
+ bool formatted;
+
+ if (derived->attr.is_class == 1 || derived->attr.vtype == 1)
+ return;
+
+ /* Check typebound DTIO bindings. */
+ for (code = 0; code < 4; code++)
+ {
+ formatted = ((dtio_codes)code == DTIO_RF)
+ || ((dtio_codes)code == DTIO_WF);
+
+ tb_io_st = gfc_find_typebound_proc (derived, &t,
+ gfc_code2string (dtio_procs, code),
+ true, &derived->declared_at);
+ if (tb_io_st != NULL)
+ check_dtio_interface1 (derived, tb_io_st, true, formatted, code);
+ }
+
+ /* Check generic DTIO interfaces. */
+ for (code = 0; code < 4; code++)
+ {
+ formatted = ((dtio_codes)code == DTIO_RF)
+ || ((dtio_codes)code == DTIO_WF);
+
+ tb_io_st = gfc_find_symtree (derived->ns->sym_root,
+ gfc_code2string (dtio_procs, code));
+ if (tb_io_st != NULL)
+ check_dtio_interface1 (derived, tb_io_st, false, formatted, code);
+ }
+}
+
+
+gfc_symbol *
+gfc_find_specific_dtio_proc (gfc_symbol *derived, bool write, bool formatted)
+{
+ gfc_symtree *tb_io_st = NULL;
+ gfc_symbol *dtio_sub = NULL;
+ gfc_symbol *extended;
+ gfc_typebound_proc *tb_io_proc, *specific_proc;
+ bool t = false;
+
+ /* Try to find a typebound DTIO binding. */
+ if (formatted == true)
+ {
+ if (write == true)
+ tb_io_st = gfc_find_typebound_proc (derived, &t,
+ gfc_code2string (dtio_procs,
+ DTIO_WF),
+ true,
+ &derived->declared_at);
+ else
+ tb_io_st = gfc_find_typebound_proc (derived, &t,
+ gfc_code2string (dtio_procs,
+ DTIO_RF),
+ true,
+ &derived->declared_at);
+ }
+ else
+ {
+ if (write == true)
+ tb_io_st = gfc_find_typebound_proc (derived, &t,
+ gfc_code2string (dtio_procs,
+ DTIO_WUF),
+ true,
+ &derived->declared_at);
+ else
+ tb_io_st = gfc_find_typebound_proc (derived, &t,
+ gfc_code2string (dtio_procs,
+ DTIO_RUF),
+ true,
+ &derived->declared_at);
+ }
+
+ if (tb_io_st != NULL)
+ {
+ tb_io_proc = tb_io_st->n.tb;
+ gcc_assert (tb_io_proc != NULL);
+ gcc_assert (tb_io_proc->is_generic);
+ gcc_assert (tb_io_proc->u.generic->next == NULL);
+
+ specific_proc = tb_io_proc->u.generic->specific;
+ gcc_assert (!specific_proc->is_generic);
+
+ dtio_sub = specific_proc->u.specific->n.sym;
+ }
+
+ if (tb_io_st != NULL)
+ goto finish;
+
+ /* If there is not a typebound binding, look for a generic
+ DTIO interface. */
+ for (extended = derived; extended;
+ extended = gfc_get_derived_super_type (extended))
+ {
+ if (formatted == true)
+ {
+ if (write == true)
+ tb_io_st = gfc_find_symtree (extended->ns->sym_root,
+ gfc_code2string (dtio_procs,
+ DTIO_WF));
+ else
+ tb_io_st = gfc_find_symtree (extended->ns->sym_root,
+ gfc_code2string (dtio_procs,
+ DTIO_RF));
+ }
+ else
+ {
+ if (write == true)
+ tb_io_st = gfc_find_symtree (extended->ns->sym_root,
+ gfc_code2string (dtio_procs,
+ DTIO_WUF));
+ else
+ tb_io_st = gfc_find_symtree (extended->ns->sym_root,
+ gfc_code2string (dtio_procs,
+ DTIO_RUF));
+ }
+
+ if (tb_io_st != NULL
+ && tb_io_st->n.sym
+ && tb_io_st->n.sym->generic)
+ {
+ gfc_interface *intr;
+ for (intr = tb_io_st->n.sym->generic; intr; intr = intr->next)
+ {
+ gfc_symbol *fsym = intr->sym->formal->sym;
+ if (intr->sym && intr->sym->formal
+ && ((fsym->ts.type == BT_CLASS
+ && CLASS_DATA (fsym)->ts.u.derived == extended)
+ || (fsym->ts.type == BT_DERIVED
+ && fsym->ts.u.derived == extended)))
+ dtio_sub = intr->sym;
+ }
+ }
+ }
+
+finish:
+ if (dtio_sub && derived != CLASS_DATA (dtio_sub->formal->sym)->ts.u.derived)
+ gfc_find_derived_vtab (derived);
+
+ return dtio_sub;
+}
@@ -113,7 +113,7 @@ enum format_token
FMT_RPAREN, FMT_X, FMT_SIGN, FMT_BLANK, FMT_CHAR, FMT_P, FMT_IBOZ, FMT_F,
FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END,
FMT_ERROR, FMT_DC, FMT_DP, FMT_T, FMT_TR, FMT_TL, FMT_STAR, FMT_RC,
- FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ
+ FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ, FMT_DT
};
/* Local variables for checking format strings. The saved_token is
@@ -463,6 +463,44 @@ format_lex (void)
return FMT_ERROR;
token = FMT_DC;
}
+ else if (c == 'T')
+ {
+ if (!gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DT format "
+ "specifier not allowed at %C"))
+ return FMT_ERROR;
+ token = FMT_DT;
+ c = next_char_not_space (&error);
+ if (c == '\'' || c == '"')
+ {
+ delim = c;
+ value = 0;
+
+ for (;;)
+ {
+ c = next_char (INSTRING_WARN);
+ if (c == '\0')
+ {
+ token = FMT_END;
+ break;
+ }
+
+ if (c == delim)
+ {
+ c = next_char (NONSTRING);
+
+ if (c == '\0')
+ {
+ token = FMT_END;
+ break;
+ }
+ unget_char ();
+ break;
+ }
+ }
+ }
+ else
+ unget_char ();
+ }
else
{
token = FMT_D;
@@ -652,6 +690,54 @@ format_item_1:
return false;
goto between_desc;
+ case FMT_DT:
+ t = format_lex ();
+ if (t == FMT_ERROR)
+ goto fail;
+ switch (t)
+ {
+ case FMT_RPAREN:
+ level--;
+ if (level < 0)
+ goto finished;
+ goto between_desc;
+
+ case FMT_COMMA:
+ goto format_item;
+
+ case FMT_LPAREN:
+
+ dtio_vlist:
+ t = format_lex ();
+ if (t == FMT_ERROR)
+ goto fail;
+
+ if (t != FMT_POSINT)
+ {
+ error = posint_required;
+ goto syntax;
+ }
+
+ t = format_lex ();
+ if (t == FMT_ERROR)
+ goto fail;
+
+ if (t == FMT_COMMA)
+ goto dtio_vlist;
+ if (t != FMT_RPAREN)
+ {
+ error = _("Right parenthesis expected at %C");
+ goto syntax;
+ }
+ goto between_desc;
+
+ default:
+ error = unexpected_element;
+ goto syntax;
+ }
+
+ goto format_item;
+
case FMT_SIGN:
case FMT_BLANK:
case FMT_DP:
@@ -102,6 +102,12 @@ gfc_op2string (gfc_intrinsic_op op)
case INTRINSIC_NONE:
return "none";
+ /* DTIO */
+ case INTRINSIC_FORMATTED:
+ return "formatted";
+ case INTRINSIC_UNFORMATTED:
+ return "unformatted";
+
default:
break;
}
@@ -6689,6 +6689,10 @@ derived_inaccessible (gfc_symbol *sym)
for (c = sym->components; c; c = c->next)
{
+ if (c->ts.type == BT_DERIVED && c->attr.pointer
+ && sym == c->ts.u.derived)
+ continue;
+
if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
return 1;
}
@@ -8642,9 +8646,13 @@ static void
resolve_transfer (gfc_code *code)
{
gfc_typespec *ts;
- gfc_symbol *sym;
+ gfc_symbol *sym, *derived;
gfc_ref *ref;
gfc_expr *exp;
+ bool write = false;
+ bool formatted = false;
+ gfc_dt *dt = code->ext.dt;
+ gfc_symbol *dtio_sub = NULL;
exp = code->expr1;
@@ -8668,7 +8676,7 @@ resolve_transfer (gfc_code *code)
/* If we are reading, the variable will be changed. Note that
code->ext.dt may be NULL if the TRANSFER is related to
an INQUIRE statement -- but in this case, we are not reading, either. */
- if (code->ext.dt && code->ext.dt->dt_io_kind->value.iokind == M_READ
+ if (dt && dt->dt_io_kind->value.iokind == M_READ
&& !gfc_check_vardef_context (exp, false, false, false,
_("item in READ")))
return;
@@ -8680,9 +8688,53 @@ resolve_transfer (gfc_code *code)
if (ref->type == REF_COMPONENT)
ts = &ref->u.c.component->ts;
- if (ts->type == BT_CLASS)
+ if (dt && dt->dt_io_kind->value.iokind != M_INQUIRE
+ && (ts->type == BT_DERIVED || ts->type == BT_CLASS))
+ {
+ if (ts->type == BT_DERIVED)
+ derived = ts->u.derived;
+ else
+ derived = ts->u.derived->components->ts.u.derived;
+
+ if (dt->format_expr)
+ {
+ char *fmt;
+ fmt = gfc_widechar_to_char (dt->format_expr->value.character.string,
+ -1);
+ if (strtok (fmt, "DT") != NULL)
+ formatted = true;
+ }
+ else if (dt->format_label == &format_asterisk)
+ {
+ /* List directed io must call the formatted DTIO procedure. */
+ formatted = true;
+ }
+
+ write = dt->dt_io_kind->value.iokind == M_WRITE
+ || dt->dt_io_kind->value.iokind == M_PRINT;
+ dtio_sub = gfc_find_specific_dtio_proc (derived, write, formatted);
+
+ if (dtio_sub != NULL && exp->expr_type == EXPR_VARIABLE)
+ {
+ sym = exp->symtree->n.sym->ns->proc_name;
+ /* Check to see if this is a nested DTIO call, with the
+ dummy as the io-list object. */
+ if (sym && sym == dtio_sub && sym->formal
+ && sym->formal->sym == exp->symtree->n.sym
+ && exp->ref == NULL)
+ {
+ if (!sym->attr.recursive)
+ {
+ gfc_error ("DTIO %s procedure at %L must be recursive",
+ sym->name, &sym->declared_at);
+ return;
+ }
+ }
+ }
+ }
+
+ if (ts->type == BT_CLASS && dtio_sub == NULL)
{
- /* FIXME: Test for defined input/output. */
gfc_error ("Data transfer element at %L cannot be polymorphic unless "
"it is processed by a defined input/output procedure",
&code->loc);
@@ -8692,8 +8744,9 @@ resolve_transfer (gfc_code *code)
if (ts->type == BT_DERIVED)
{
/* Check that transferred derived type doesn't contain POINTER
- components. */
- if (ts->u.derived->attr.pointer_comp)
+ components unless it is processed by a defined input/output
+ procedure". */
+ if (ts->u.derived->attr.pointer_comp && dtio_sub == NULL)
{
gfc_error ("Data transfer element at %L cannot have POINTER "
"components unless it is processed by a defined "
@@ -8709,7 +8762,7 @@ resolve_transfer (gfc_code *code)
return;
}
- if (ts->u.derived->attr.alloc_comp)
+ if (ts->u.derived->attr.alloc_comp && dtio_sub == NULL)
{
gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
"components unless it is processed by a defined "
@@ -8726,10 +8779,11 @@ resolve_transfer (gfc_code *code)
"cannot have PRIVATE components", &code->loc))
return;
}
- else if (derived_inaccessible (ts->u.derived))
+ else if (derived_inaccessible (ts->u.derived) && dtio_sub == NULL)
{
gfc_error ("Data transfer element at %L cannot have "
- "PRIVATE components",&code->loc);
+ "PRIVATE components unless it is processed by "
+ "a defined input/output procedure", &code->loc);
return;
}
}
@@ -10901,6 +10955,21 @@ resolve_bind_c_derived_types (gfc_symbol *derived_sym)
}
+/* Check the interfaces of DTIO procedures associated with derived
+ type 'sym'. These procedures can either have typebound bindings or
+ can appear in DTIO generic interfaces. */
+
+static void
+gfc_verify_DTIO_procedures (gfc_symbol *sym)
+{
+ if (!sym || sym->attr.flavor != FL_DERIVED)
+ return;
+
+ gfc_check_dtio_interfaces (sym);
+
+ return;
+}
+
/* Verify that any binding labels used in a given namespace do not collide
with the names or binding labels of any global symbols. Multiple INTERFACE
for the same procedure are permitted. */
@@ -13414,11 +13483,31 @@ resolve_fl_derived (gfc_symbol *sym)
}
+/* Check for formatted read and write DTIO procedures. */
+
+static bool
+dtio_procs_present (gfc_symbol *sym)
+{
+ gfc_symbol *derived;
+
+ if (sym->ts.type == BT_CLASS)
+ derived = CLASS_DATA (sym)->ts.u.derived;
+ else if (sym->ts.type == BT_DERIVED)
+ derived = sym->ts.u.derived;
+ else
+ return false;
+
+ return gfc_find_specific_dtio_proc (derived, true, true) != NULL
+ && gfc_find_specific_dtio_proc (derived, false, true) != NULL;
+}
+
+
static bool
resolve_fl_namelist (gfc_symbol *sym)
{
gfc_namelist *nl;
gfc_symbol *nlsym;
+ bool dtio;
for (nl = sym->namelist; nl; nl = nl->next)
{
@@ -13452,9 +13541,9 @@ resolve_fl_namelist (gfc_symbol *sym)
sym->name, &sym->declared_at))
return false;
- /* FIXME: Once UDDTIO is implemented, the following can be
- removed. */
- if (nl->sym->ts.type == BT_CLASS)
+ dtio = dtio_procs_present (nl->sym);
+
+ if (nl->sym->ts.type == BT_CLASS && !dtio)
{
gfc_error ("NAMELIST object %qs in namelist %qs at %L is "
"polymorphic and requires a defined input/output "
@@ -13472,13 +13561,14 @@ resolve_fl_namelist (gfc_symbol *sym)
sym->name, &sym->declared_at))
return false;
- /* FIXME: Once UDDTIO is implemented, the following can be
- removed. */
- gfc_error ("NAMELIST object %qs in namelist %qs at %L has "
- "ALLOCATABLE or POINTER components and thus requires "
- "a defined input/output procedure", nl->sym->name,
- sym->name, &sym->declared_at);
- return false;
+ if (!dtio)
+ {
+ gfc_error ("NAMELIST object %qs in namelist %qs at %L has "
+ "ALLOCATABLE or POINTER components and thus requires "
+ "a defined input/output procedure", nl->sym->name,
+ sym->name, &sym->declared_at);
+ return false;
+ }
}
}
@@ -13497,6 +13587,11 @@ resolve_fl_namelist (gfc_symbol *sym)
return false;
}
+ /* If the derived type has specific DTIO procedures for both read and
+ write then namelist objects with private components are OK. */
+ if (dtio_procs_present (nl->sym))
+ continue;
+
/* Types with private components that came here by USE-association. */
if (nl->sym->ts.type == BT_DERIVED
&& derived_inaccessible (nl->sym->ts.u.derived))
@@ -15520,6 +15615,8 @@ resolve_types (gfc_namespace *ns)
gfc_resolve_uops (ns->uop_root);
+ gfc_traverse_ns (ns, gfc_verify_DTIO_procedures);
+
gfc_resolve_omp_declare_simd (ns);
gfc_resolve_omp_udrs (ns->omp_udr_root);
@@ -87,6 +87,15 @@ const mstring save_status[] =
minit ("IMPLICIT-SAVE", SAVE_IMPLICIT),
};
+/* Set the mstrings for DTIO procedure names. */
+const mstring dtio_procs[] =
+{
+ minit ("_dtio_formatted_read", DTIO_RF),
+ minit ("_dtio_formatted_write", DTIO_WF),
+ minit ("_dtio_unformatted_read", DTIO_RUF),
+ minit ("_dtio_unformatted_write", DTIO_WUF),
+};
+
/* This is to make sure the backend generates setup code in the correct
order. */
@@ -638,6 +638,16 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym)
&& sym->attr.codimension && !sym->attr.allocatable)))
TREE_STATIC (decl) = 1;
+ /* If derived-type variables with DTIO procedures are not made static
+ some bits of code referencing them get optimized away.
+ TODO Understand why this is so and fix it. */
+ if (!sym->attr.use_assoc
+ && ((sym->ts.type == BT_DERIVED
+ && sym->ts.u.derived->attr.has_dtio_procs)
+ || (sym->ts.type == BT_CLASS
+ && CLASS_DATA (sym)->ts.u.derived->attr.has_dtio_procs)))
+ TREE_STATIC (decl) = 1;
+
if (sym->attr.volatile_)
{
TREE_THIS_VOLATILE (decl) = 1;
@@ -430,9 +430,17 @@ gfc_get_vptr_from_expr (tree expr)
else
type = NULL_TREE;
}
- if (TREE_CODE (tmp) == VAR_DECL)
+ if (TREE_CODE (tmp) == VAR_DECL
+ || TREE_CODE (tmp) == PARM_DECL)
break;
}
+
+ if (POINTER_TYPE_P (TREE_TYPE (tmp)))
+ tmp = build_fold_indirect_ref_loc (input_location, tmp);
+
+ if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
+ return gfc_class_vptr_get (tmp);
+
return NULL_TREE;
}
@@ -511,7 +519,14 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
if (optional)
cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
- if (parmse->ss && parmse->ss->info->useflags)
+ if (parmse->expr && POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
+ {
+ /* If there is a ready made pointer to a derived type, use it
+ rather than evaluating the expression again. */
+ tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
+ gfc_add_modify (&parmse->pre, ctree, tmp);
+ }
+ else if (parmse->ss && parmse->ss->info && parmse->ss->info->useflags)
{
/* For an array reference in an elemental procedure call we need
to retain the ss to provide the scalarized array reference. */
@@ -522,7 +537,6 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
cond_optional, tmp,
fold_convert (TREE_TYPE (tmp), null_pointer_node));
gfc_add_modify (&parmse->pre, ctree, tmp);
-
}
else
{
@@ -2319,7 +2333,7 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
On the other hand, if the context is a UNION or a MAP (a
RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */
- if (context != TREE_TYPE (decl)
+ if (context != TREE_TYPE (decl)
&& !( TREE_CODE (TREE_TYPE (field)) == UNION_TYPE /* Field is union */
|| TREE_CODE (context) == UNION_TYPE)) /* Field is map */
{
@@ -132,6 +132,7 @@ enum iocall
IOCALL_X_COMPLEX128_WRITE,
IOCALL_X_ARRAY,
IOCALL_X_ARRAY_WRITE,
+ IOCALL_X_DERIVED,
IOCALL_OPEN,
IOCALL_CLOSE,
IOCALL_INQUIRE,
@@ -397,6 +398,10 @@ gfc_build_io_library_fndecls (void)
void_type_node, 4, dt_parm_type, pvoid_type_node,
integer_type_node, gfc_charlen_type_node);
+ iocall[IOCALL_X_DERIVED] = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("transfer_derived")), ".wrR",
+ void_type_node, 2, dt_parm_type, pvoid_type_node, pchar_type_node);
+
/* Library entry points */
iocall[IOCALL_READ] = gfc_build_library_function_decl_with_spec (
@@ -465,8 +470,9 @@ gfc_build_io_library_fndecls (void)
iocall[IOCALL_SET_NML_VAL] = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("st_set_nml_var")), ".w.R",
- void_type_node, 6, dt_parm_type, pvoid_type_node, pvoid_type_node,
- gfc_int4_type_node, gfc_charlen_type_node, gfc_int4_type_node);
+ void_type_node, 8, dt_parm_type, pvoid_type_node, pvoid_type_node,
+ gfc_int4_type_node, gfc_charlen_type_node, gfc_int4_type_node,
+ pvoid_type_node, pvoid_type_node);
iocall[IOCALL_SET_NML_VAL_DIM] = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("st_set_nml_var_dim")), ".w",
@@ -475,12 +481,8 @@ gfc_build_io_library_fndecls (void)
}
-/* Generate code to store an integer constant into the
- st_parameter_XXX structure. */
-
-static unsigned int
-set_parameter_const (stmtblock_t *block, tree var, enum iofield type,
- unsigned int val)
+static void
+set_parameter_tree (stmtblock_t *block, tree var, enum iofield type, tree value)
{
tree tmp;
gfc_st_parameter_field *p = &st_parameter_field[type];
@@ -491,7 +493,21 @@ set_parameter_const (stmtblock_t *block, tree var, enum iofield type,
var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
var, p->field, NULL_TREE);
- gfc_add_modify (block, tmp, build_int_cst (TREE_TYPE (p->field), val));
+ gfc_add_modify (block, tmp, value);
+}
+
+
+/* Generate code to store an integer constant into the
+ st_parameter_XXX structure. */
+
+static unsigned int
+set_parameter_const (stmtblock_t *block, tree var, enum iofield type,
+ unsigned int val)
+{
+ gfc_st_parameter_field *p = &st_parameter_field[type];
+
+ set_parameter_tree (block, var, type,
+ build_int_cst (TREE_TYPE (p->field), val));
return p->mask;
}
@@ -637,7 +653,7 @@ set_parameter_value_inquire (stmtblock_t *block, tree var,
body = gfc_finish_block (&newblock);
- cond3 = gfc_unlikely (cond3, PRED_FORTRAN_FAIL_IO);
+ cond3 = gfc_unlikely (cond3, PRED_FORTRAN_FAIL_IO);
var = build3_v (COND_EXPR, cond3, body, build_empty_stmt (input_location));
gfc_add_expr_to_block (&se.pre, var);
}
@@ -697,13 +713,7 @@ set_parameter_ref (stmtblock_t *block, stmtblock_t *postblock,
gfc_add_modify (postblock, se.expr, tmp);
}
- if (p->param_type == IOPARM_ptype_common)
- var = fold_build3_loc (input_location, COMPONENT_REF,
- st_parameter[IOPARM_ptype_common].type,
- var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
- tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
- var, p->field, NULL_TREE);
- gfc_add_modify (block, tmp, addr);
+ set_parameter_tree (block, var, type, addr);
return p->mask;
}
@@ -1618,6 +1628,8 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name,
tree dt_parm_addr;
tree decl = NULL_TREE;
tree gfc_int4_type_node = gfc_get_int_type (4);
+ tree dtio_proc = null_pointer_node;
+ tree vtable = null_pointer_node;
int n_dim;
int itype;
int rank = 0;
@@ -1659,15 +1671,37 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name,
dt_parm_addr = gfc_build_addr_expr (NULL_TREE, dt_parm);
+ /* Check if the derived type has a specific DTIO for the mode.
+ Note that although namelist io is forbidden to have a format
+ list, the specific subroutine is of the formatted kind. */
+ if (ts->type == BT_DERIVED)
+ {
+ gfc_symbol *dtio_sub = NULL;
+ gfc_symbol *vtab;
+ dtio_sub = gfc_find_specific_dtio_proc (ts->u.derived,
+ last_dt == WRITE,
+ true);
+ if (dtio_sub != NULL)
+ {
+ dtio_proc = gfc_get_symbol_decl (dtio_sub);
+ dtio_proc = gfc_build_addr_expr (NULL, dtio_proc);
+ vtab = gfc_find_derived_vtab (ts->u.derived);
+ vtable = vtab->backend_decl;
+ if (vtable == NULL_TREE)
+ vtable = gfc_get_symbol_decl (vtab);
+ vtable = gfc_build_addr_expr (pvoid_type_node, vtable);
+ }
+ }
+
if (ts->type == BT_CHARACTER)
tmp = ts->u.cl->backend_decl;
else
tmp = build_int_cst (gfc_charlen_type_node, 0);
tmp = build_call_expr_loc (input_location,
- iocall[IOCALL_SET_NML_VAL], 6,
+ iocall[IOCALL_SET_NML_VAL], 8,
dt_parm_addr, addr_expr, string,
build_int_cst (gfc_int4_type_node, ts->kind),
- tmp, dtype);
+ tmp, dtype, dtio_proc, vtable);
gfc_add_expr_to_block (block, tmp);
/* If the object is an array, transfer rank times:
@@ -1685,7 +1719,8 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name,
gfc_add_expr_to_block (block, tmp);
}
- if (gfc_bt_struct (ts->type) && ts->u.derived->components)
+ if (gfc_bt_struct (ts->type) && ts->u.derived->components
+ && dtio_proc == null_pointer_node)
{
gfc_component *cmp;
@@ -1995,7 +2030,8 @@ gfc_trans_dt_end (gfc_code * code)
}
static void
-transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code);
+transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr,
+ gfc_code * code, tree vptr);
/* Given an array field in a derived type variable, generate the code
for the loop that iterates over array elements, and the code that
@@ -2061,7 +2097,7 @@ transfer_array_component (tree expr, gfc_component * cm, locus * where)
/* Now se.expr contains an element of the array. Take the address and pass
it to the IO routines. */
tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
- transfer_expr (&se, &cm->ts, tmp, NULL);
+ transfer_expr (&se, &cm->ts, tmp, NULL, NULL_TREE);
/* We are done now with the loop body. Wrap up the scalarizer and
return. */
@@ -2081,10 +2117,53 @@ transfer_array_component (tree expr, gfc_component * cm, locus * where)
return gfc_finish_block (&block);
}
+
+/* Helper function for transfer_expr that looks for the DTIO procedure
+ either as a typebound binding or in a generic interface. If present,
+ the address expression of the procedure is returned. It is assumed
+ that the procedure interface has been checked during resolution. */
+
+static tree
+get_dtio_proc (gfc_typespec * ts, gfc_code * code, gfc_symbol **dtio_sub)
+{
+ gfc_symbol *derived;
+ bool formatted = false;
+ gfc_dt *dt = code->ext.dt;
+
+ if (dt && dt->format_expr)
+ {
+ char *fmt;
+ fmt = gfc_widechar_to_char (dt->format_expr->value.character.string,
+ -1);
+ if (strtok (fmt, "DT") != NULL)
+ formatted = true;
+ }
+ else if (dt && dt->format_label == &format_asterisk)
+ {
+ /* List directed io must call the formatted DTIO procedure. */
+ formatted = true;
+ }
+
+ if (ts->type == BT_DERIVED)
+ derived = ts->u.derived;
+ else
+ derived = ts->u.derived->components->ts.u.derived;
+
+ *dtio_sub = gfc_find_specific_dtio_proc (derived, last_dt == WRITE,
+ formatted);
+
+ if (*dtio_sub)
+ return gfc_build_addr_expr (NULL, gfc_get_symbol_decl (*dtio_sub));
+
+ return NULL_TREE;
+
+}
+
/* Generate the call for a scalar transfer node. */
static void
-transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code)
+transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr,
+ gfc_code * code, tree vptr)
{
tree tmp, function, arg2, arg3, field, expr;
gfc_component *c;
@@ -2212,43 +2291,81 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code)
break;
case_bt_struct:
+ case BT_CLASS:
if (ts->u.derived->components == NULL)
return;
+ if (ts->type == BT_DERIVED || ts->type == BT_CLASS)
+ {
+ gfc_symbol *derived;
+ gfc_symbol *dtio_sub = NULL;
+ /* Test for a specific DTIO subroutine. */
+ if (ts->type == BT_DERIVED)
+ derived = ts->u.derived;
+ else
+ derived = ts->u.derived->components->ts.u.derived;
- /* Recurse into the elements of the derived type. */
- expr = gfc_evaluate_now (addr_expr, &se->pre);
- expr = build_fold_indirect_ref_loc (input_location,
- expr);
+ if (derived->attr.has_dtio_procs)
+ arg2 = get_dtio_proc (ts, code, &dtio_sub);
- /* Make sure that the derived type has been built. An external
- function, if only referenced in an io statement, requires this
- check (see PR58771). */
- if (ts->u.derived->backend_decl == NULL_TREE)
- (void) gfc_typenode_for_spec (ts);
+ if (dtio_sub != NULL)
+ {
+ tree decl;
+ decl = build_fold_indirect_ref_loc (input_location,
+ se->expr);
+ /* Remember that the first dummy of the DTIO subroutines
+ is CLASS(derived) for extensible derived types, so the
+ conversion must be done here for derived type and for
+ scalarized CLASS array element io-list objects. */
+ if ((ts->type == BT_DERIVED
+ && !(ts->u.derived->attr.sequence
+ || ts->u.derived->attr.is_bind_c))
+ || (ts->type == BT_CLASS
+ && !GFC_CLASS_TYPE_P (TREE_TYPE (decl))))
+ gfc_conv_derived_to_class (se, code->expr1,
+ dtio_sub->formal->sym->ts,
+ vptr, false, false);
+ addr_expr = se->expr;
+ function = iocall[IOCALL_X_DERIVED];
+ break;
+ }
+ else if (ts->type == BT_DERIVED)
+ {
+ /* Recurse into the elements of the derived type. */
+ expr = gfc_evaluate_now (addr_expr, &se->pre);
+ expr = build_fold_indirect_ref_loc (input_location,
+ expr);
- for (c = ts->u.derived->components; c; c = c->next)
- {
- field = c->backend_decl;
- gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
-
- tmp = fold_build3_loc (UNKNOWN_LOCATION,
- COMPONENT_REF, TREE_TYPE (field),
- expr, field, NULL_TREE);
-
- if (c->attr.dimension)
- {
- tmp = transfer_array_component (tmp, c, & code->loc);
- gfc_add_expr_to_block (&se->pre, tmp);
- }
- else
- {
- if (!c->attr.pointer)
- tmp = gfc_build_addr_expr (NULL_TREE, tmp);
- transfer_expr (se, &c->ts, tmp, code);
- }
+ /* Make sure that the derived type has been built. An external
+ function, if only referenced in an io statement, requires this
+ check (see PR58771). */
+ if (ts->u.derived->backend_decl == NULL_TREE)
+ (void) gfc_typenode_for_spec (ts);
+
+ for (c = ts->u.derived->components; c; c = c->next)
+ {
+ field = c->backend_decl;
+ gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
+
+ tmp = fold_build3_loc (UNKNOWN_LOCATION,
+ COMPONENT_REF, TREE_TYPE (field),
+ expr, field, NULL_TREE);
+
+ if (c->attr.dimension)
+ {
+ tmp = transfer_array_component (tmp, c, & code->loc);
+ gfc_add_expr_to_block (&se->pre, tmp);
+ }
+ else
+ {
+ if (!c->attr.pointer)
+ tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+ transfer_expr (se, &c->ts, tmp, code, NULL_TREE);
+ }
+ }
+ return;
+ }
+ /* If a CLASS object gets through to here, fall through and ICE. */
}
- return;
-
default:
gfc_internal_error ("Bad IO basetype (%d)", ts->type);
}
@@ -2303,6 +2420,7 @@ gfc_trans_transfer (gfc_code * code)
gfc_ss *ss;
gfc_se se;
tree tmp;
+ tree vptr;
int n;
gfc_start_block (&block);
@@ -2315,8 +2433,18 @@ gfc_trans_transfer (gfc_code * code)
if (expr->rank == 0)
{
/* Transfer a scalar value. */
- gfc_conv_expr_reference (&se, expr);
- transfer_expr (&se, &expr->ts, se.expr, code);
+ if (expr->ts.type == BT_CLASS)
+ {
+ se.want_pointer = 1;
+ gfc_conv_expr (&se, expr);
+ vptr = gfc_get_vptr_from_expr (se.expr);
+ }
+ else
+ {
+ vptr = NULL_TREE;
+ gfc_conv_expr_reference (&se, expr);
+ }
+ transfer_expr (&se, &expr->ts, se.expr, code, vptr);
}
else
{
@@ -2330,7 +2458,8 @@ gfc_trans_transfer (gfc_code * code)
gcc_assert (ref && ref->type == REF_ARRAY);
}
- if (!gfc_bt_struct (expr->ts.type)
+ if (!(gfc_bt_struct (expr->ts.type)
+ || expr->ts.type == BT_CLASS)
&& ref && ref->next == NULL
&& !is_subref_array (expr))
{
@@ -2378,9 +2507,12 @@ gfc_trans_transfer (gfc_code * code)
gfc_copy_loopinfo_to_se (&se, &loop);
se.ss = ss;
-
gfc_conv_expr_reference (&se, expr);
- transfer_expr (&se, &expr->ts, se.expr, code);
+ if (expr->ts.type == BT_CLASS)
+ vptr = gfc_get_vptr_from_expr (ss->info->data.array.descriptor);
+ else
+ vptr = NULL_TREE;
+ transfer_expr (&se, &expr->ts, se.expr, code, vptr);
}
finish_block_label:
new file mode 100644
@@ -0,0 +1,164 @@
+! { dg-do run }
+!
+! Functional test of User Defined Derived Type IO, Formatted WRITE/READ
+!
+! 1) Tests passing of iostat out of the user procedure.
+! 2) Tests parsing of the DT optional string and passing in and using
+! to control execution.
+! 3) Tests parsing of the optional vlist, passing in and using it to
+! generate a user defined format string.
+! 4) Tests passing an iostat or iomsg out of libgfortranthe child procedure back to
+! the parent.
+!
+MODULE p
+ USE ISO_FORTRAN_ENV
+ TYPE :: person
+ CHARACTER (LEN=20) :: name
+ INTEGER(4) :: age
+ CONTAINS
+ procedure :: pwf
+ procedure :: prf
+ GENERIC :: WRITE(FORMATTED) => pwf
+ GENERIC :: READ(FORMATTED) => prf
+ END TYPE person
+CONTAINS
+ SUBROUTINE pwf (dtv,unit,iotype,vlist,iostat,iomsg)
+ CLASS(person), INTENT(IN) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ CHARACTER (LEN=*), INTENT(IN) :: iotype
+ INTEGER, INTENT(IN) :: vlist(:)
+ INTEGER, INTENT(OUT) :: iostat
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+ CHARACTER (LEN=30) :: udfmt
+ INTEGER :: myios
+
+ udfmt='(*(g0))'
+ iomsg = "SUCCESS"
+ iostat=0
+ if (iotype.eq."DT") then
+ if (size(vlist).ne.0) print *, 36
+ WRITE(unit, FMT = '(a,5x,i2)', IOSTAT=iostat, advance='no') trim(dtv%name), dtv%age
+ if (iostat.ne.0) iomsg = "Fail PWF DT"
+ endif
+ if (iotype.eq."DTzeroth") then
+ if (size(vlist).ne.0) print *, 40
+ WRITE(unit, FMT = '(g0,g0)', advance='no') dtv%name, dtv%age
+ if (iostat.ne.0) iomsg = "Fail PWF DTzeroth"
+ endif
+ if (iotype.eq."DTtwo") then
+ if (size(vlist).ne.2) call abort
+ WRITE(udfmt,'(A,A,I1,A,I1,A)') '(', 'A', vlist(1),',I', vlist(2), ')'
+ WRITE(unit, FMT='(A8,I2)') dtv%name, dtv%age
+ if (iostat.ne.0) iomsg = "Fail PWF DTtwo"
+ endif
+ if (iotype.eq."DTthree") then
+ WRITE(udfmt,'(2A,I2,A,I1,A,I2,A)',iostat=myios) '(', 'A', vlist(1),',I', vlist(2), ',F', vlist(3), '.2)'
+ WRITE(unit, FMT=udfmt, IOSTAT=iostat, advance='no') trim(dtv%name), dtv%age, 3.14
+ if (iostat.ne.0) iomsg = "Fail PWF DTthree"
+ endif
+ if (iotype.eq."LISTDIRECTED") then
+ if (size(vlist).ne.0) print *, 55
+ WRITE(unit, FMT = *) dtv%name, dtv%age
+ if (iostat.ne.0) iomsg = "Fail PWF LISTDIRECTED"
+ endif
+ if (iotype.eq."NAMELIST") then
+ if (size(vlist).ne.0) print *, 59
+ iostat=6000
+ endif
+ END SUBROUTINE pwf
+
+ SUBROUTINE prf (dtv,unit,iotype,vlist,iostat,iomsg)
+ CLASS(person), INTENT(INOUT) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ CHARACTER (LEN=*), INTENT(IN) :: iotype
+ INTEGER, INTENT(IN) :: vlist(:)
+ INTEGER, INTENT(OUT) :: iostat
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+ CHARACTER (LEN=30) :: udfmt
+ INTEGER :: myios
+ real :: areal
+ udfmt='(*(g0))'
+ iomsg = "SUCCESS"
+ iostat=0
+ if (iotype.eq."DT") then
+ if (size(vlist).ne.0) print *, 36
+ READ(unit, FMT = '(a,5x,i2)', IOSTAT=iostat, advance='no') dtv%name, dtv%age
+ if (iostat.ne.0) iomsg = "Fail PWF DT"
+ endif
+ if (iotype.eq."DTzeroth") then
+ if (size(vlist).ne.0) print *, 40
+ READ(unit, FMT = '(a,I2)', advance='no') dtv%name, dtv%age
+ if (iostat.ne.0) iomsg = "Fail PWF DTzeroth"
+ endif
+ if (iotype.eq."DTtwo") then
+ if (size(vlist).ne.2) call abort
+ WRITE(udfmt,'(A,A,I1,A,I1,A)') '(', 'A', vlist(1),',I', vlist(2), ')'
+ READ(unit, FMT='(A8,I2)') dtv%name, dtv%age
+ if (iostat.ne.0) iomsg = "Fail PWF DTtwo"
+ endif
+ if (iotype.eq."DTthree") then
+ WRITE(udfmt,'(2A,I2,A,I1,A,I2,A)',iostat=myios) '(', 'A', vlist(1),',I', vlist(2), ',F', vlist(3), '.2)'
+ READ(unit, FMT=udfmt, IOSTAT=iostat, advance='no') dtv%name, dtv%age, areal
+ if (iostat.ne.0) iomsg = "Fail PWF DTthree"
+ endif
+ if (iotype.eq."LISTDIRECTED") then
+ if (size(vlist).ne.0) print *, 55
+ READ(unit, FMT = *) dtv%name, dtv%age
+ if (iostat.ne.0) iomsg = "Fail PWF LISTDIRECTED"
+ endif
+ if (iotype.eq."NAMELIST") then
+ if (size(vlist).ne.0) print *, 59
+ iostat=6000
+ endif
+ !READ (UNIT = UNIT, FMT = *) dtv%name, dtv%age
+ END SUBROUTINE prf
+
+END MODULE p
+
+PROGRAM test
+ USE p
+ TYPE (person), SAVE :: chairman
+ TYPE (person), SAVE :: member
+ character(80) :: astring
+ integer :: thelength
+
+ chairman%name="Charlie"
+ chairman%age=62
+ member%name="George"
+ member%age=42
+ astring = "FAILURE"
+ write (10, "(DT'zeroth',3x, DT'three'(11,4,10),11x,DT'two'(8,2))", &
+ & iostat=myiostat, iomsg=astring) member, chairman, member
+ if (myiostat.ne.0) call abort
+ if (astring.ne."SUCCESS") call abort
+ astring = "FAILURE"
+ write (10, *, iostat=myiostat, iomsg=astring) member, chairman, member
+ if (myiostat.ne.0) call abort
+ if (astring.ne."SUCCESS") call abort
+ write(10,*) ! See note below
+ rewind(10)
+ chairman%name="bogus1"
+ chairman%age=99
+ member%name="bogus2"
+ member%age=66
+ astring = "FAILURE"
+ read(10,"(DT'zeroth',3x, DT'three'(11,4,10),11x,DT'two'(8,2))") member, chairman, member
+ if (member%name.ne."George") call abort
+ if (chairman%name.ne." Charlie") call abort
+ if (member%age.ne.42) call abort
+ if (chairman%age.ne.62) call abort
+ chairman%name="bogus1"
+ chairman%age=99
+ member%name="bogus2"
+ member%age=66
+ astring = "FAILURE"
+ read (10, *, iostat=myiostat, iomsg=astring) member, chairman, member
+ ! The user defined procedure reads to the end of the line/file, then finalizing the parent
+ ! reads past, so we wrote a blank line above. User needs to address these nuances in their
+ ! procedures. (subject to interpretation)
+ if (astring.ne."SUCCESS") print *, astring
+ if (member%name.ne."George") call abort
+ if (chairman%name.ne."Charlie") call abort
+ if (member%age.ne.42) call abort
+ if (chairman%age.ne.62) call abort
+END PROGRAM test
new file mode 100644
@@ -0,0 +1,27 @@
+! { dg-do run }
+!
+! Tests runtime check of the required type in dtio formatted read.
+!
+module usertypes
+ type udt
+ integer :: myarray(15)
+ end type udt
+ type, extends(udt) :: more
+ integer :: itest = -25
+ end type
+
+end module usertypes
+
+program test1
+ use usertypes
+ type (udt) :: udt1
+ type (more) :: more1
+ class (more), allocatable :: somemore
+ integer :: thesize, i, ios
+ character(100) :: errormsg
+
+ read (10, fmt='(dt)', advance='no', size=thesize, iostat=ios, &
+ & iomsg=errormsg) i, udt1
+ if (ios.ne.5006) call abort
+ if (errormsg(1:25).ne."Expected CLASS or DERIVED") call abort
+end program test1
new file mode 100644
@@ -0,0 +1,71 @@
+! { dg-do run }
+!
+! Functional test of User Defined DT IO, unformatted WRITE/READ
+!
+! 1) Tests unformatted DTV write with other variables in the record
+! 2) Tests reading back the recods written.
+!
+module p
+ type :: person
+ character (len=20) :: name
+ integer(4) :: age
+ contains
+ procedure :: pwuf
+ procedure :: pruf
+ generic :: write(unformatted) => pwuf
+ generic :: read(unformatted) => pruf
+ end type person
+contains
+ subroutine pwuf (dtv,unit,iostat,iomsg)
+ class(person), intent(in) :: dtv
+ integer, intent(in) :: unit
+ integer, intent(out) :: iostat
+ character (len=*), intent(inout) :: iomsg
+ write (unit=unit, iostat=iostat, iomsg=iomsg) dtv%name, dtv%age
+ end subroutine pwuf
+
+ subroutine pruf (dtv,unit,iostat,iomsg)
+ class(person), intent(inout) :: dtv
+ integer, intent(in) :: unit
+ integer, intent(out) :: iostat
+ character (len=*), intent(inout) :: iomsg
+ read (unit = unit) dtv%name, dtv%age
+ end subroutine pruf
+
+end module p
+
+program test
+ use p
+ type (person), save :: chairman
+ character(3) :: tmpstr1, tmpstr2
+ chairman%name="charlie"
+ chairman%age=62
+
+ open (unit=71, file='myunformatted_data.dat', form='unformatted')
+ write (71) "abc", chairman, "efg"
+ write (71) "hij", chairman, "klm"
+ write (71) "nop", chairman, "qrs"
+ rewind (unit = 71)
+ chairman%name="boggle"
+ chairman%age=1234
+ read (71) tmpstr1, chairman, tmpstr2
+ if (tmpstr1.ne."abc") call abort
+ if (tmpstr2.ne."efg") call abort
+ if (chairman%name.ne."charlie") call abort
+ if (chairman%age.ne.62) call abort
+ chairman%name="boggle"
+ chairman%age=1234
+ read (71) tmpstr1, chairman, tmpstr2
+ if (tmpstr1.ne."hij") call abort
+ if (tmpstr2.ne."klm") call abort
+ if (chairman%name.ne."charlie") call abort
+ if (chairman%age.ne.62) call abort
+ chairman%name="boggle"
+ chairman%age=1234
+ read (71) tmpstr1, chairman, tmpstr2
+ if (tmpstr1.ne."nop") call abort
+ if (tmpstr2.ne."qrs") call abort
+ if (chairman%name.ne."charlie") call abort
+ if (chairman%age.ne.62) call abort
+ close (unit = 71, status='delete')
+end program test
new file mode 100644
@@ -0,0 +1,278 @@
+! { dg-do run }
+!
+! This test is based on the second case in the PGInsider article at
+! https://www.pgroup.com/lit/articles/insider/v6n2a3.htm
+!
+! The complete original code is at:
+! https://www.pgroup.com/lit/samples/pginsider/stack.f90
+!
+! Thanks to Mark LeAir.
+!
+! Copyright (c) 2015, NVIDIA CORPORATION. All rights reserved.
+!
+! NVIDIA CORPORATION and its licensors retain all intellectual property
+! and proprietary rights in and to this software, related documentation
+! and any modifications thereto. Any use, reproduction, disclosure or
+! distribution of this software and related documentation without an express
+! license agreement from NVIDIA CORPORATION is strictly prohibited.
+!
+
+! THIS CODE AND INFORMATION ARE PROVIDED "AS IS" WITHOUT
+! WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING BUT
+! NOT LIMITED TO THE IMPLIED WARRANTIES OF MERCHANTABILITY AND/OR
+! FITNESS FOR A PARTICULAR PURPOSE.
+!
+
+module stack_mod
+
+ type, abstract :: stack
+ private
+ class(*), allocatable :: item ! an item on the stack
+ class(stack), pointer :: next=>null() ! next item on the stack
+ contains
+ procedure :: empty ! returns true if stack is empty
+ procedure :: delete ! empties the stack
+ end type stack
+
+type, extends(stack) :: integer_stack
+contains
+ procedure :: push => push_integer ! add integer item to stack
+ procedure :: pop => pop_integer ! remove integer item from stack
+ procedure :: compare => compare_integer ! compare with an integer array
+end type integer_stack
+
+type, extends(integer_stack) :: io_stack
+contains
+ procedure,private :: wio_stack
+ procedure,private :: rio_stack
+ procedure,private :: dump_stack
+ generic :: write(unformatted) => wio_stack ! write stack item to file
+ generic :: read(unformatted) => rio_stack ! push item from file
+ generic :: write(formatted) => dump_stack ! print all items from stack
+end type io_stack
+
+contains
+
+ subroutine rio_stack (dtv, unit, iostat, iomsg)
+
+ ! read item from file and add it to stack
+
+ class(io_stack), intent(inout) :: dtv
+ integer, intent(in) :: unit
+ integer, intent(out) :: iostat
+ character(len=*), intent(inout) :: iomsg
+
+ integer :: item
+
+ read(unit,IOSTAT=iostat,IOMSG=iomsg) item
+
+ if (iostat .ne. 0) then
+ call dtv%push(item)
+ endif
+
+ end subroutine rio_stack
+
+ subroutine wio_stack(dtv, unit, iostat, iomsg)
+
+ ! pop an item from stack and write it to file
+
+ class(io_stack), intent(in) :: dtv
+ integer, intent(in) :: unit
+ integer, intent(out) :: iostat
+ character(len=*), intent(inout) :: iomsg
+ integer :: item
+
+ item = dtv%pop()
+ write(unit,IOSTAT=iostat,IOMSG=iomsg) item
+
+ end subroutine wio_stack
+
+ subroutine dump_stack(dtv, unit, iotype, v_list, iostat, iomsg)
+
+ ! Pop all items off stack and write them out to unit
+ ! Assumes default LISTDIRECTED output
+
+ class(io_stack), intent(in) :: dtv
+ integer, intent(in) :: unit
+ character(len=*), intent(in) :: iotype
+ integer, intent(in) :: v_list(:)
+ integer, intent(out) :: iostat
+ character(len=*), intent(inout) :: iomsg
+ character(len=80) :: buffer
+ integer :: item
+
+ if (iotype .ne. 'LISTDIRECTED') then
+ ! Error
+ iomsg = 'dump_stack: unsupported iotype'
+ iostat = 1
+ else
+ iostat = 0
+ do while( (.not. dtv%empty()) .and. (iostat .eq. 0) )
+ item = dtv%pop()
+ write(unit, '(I6/)',IOSTAT=iostat,IOMSG=iomsg) item
+ enddo
+ endif
+ end subroutine dump_stack
+
+ logical function empty(this)
+ class(stack) :: this
+ if (.not.associated(this%next)) then
+ empty = .true.
+ else
+ empty = .false.
+ end if
+ end function empty
+
+ subroutine push_integer(this,item)
+ class(integer_stack) :: this
+ integer :: item
+ type(integer_stack), allocatable :: new_item
+
+ allocate(new_item)
+ allocate(new_item%item, source=item)
+ new_item%next => this%next
+ allocate(this%next, source=new_item)
+ end subroutine push_integer
+
+ function pop_integer(this) result(item)
+ class(integer_stack) :: this
+ integer item
+
+ if (this%empty()) then
+ stop 'Error! pop_integer invoked on empty stack'
+ endif
+ select type(top=>this%next)
+ type is (integer_stack)
+ select type(i => top%item)
+ type is(integer)
+ item = i
+ class default
+ stop 'Error #1! pop_integer encountered non-integer stack item'
+ end select
+ this%next => top%next
+ deallocate(top)
+ class default
+ stop 'Error #2! pop_integer encountered non-integer_stack item'
+ end select
+ end function pop_integer
+
+! gfortran addition to check read/write
+ logical function compare_integer (this, array, error)
+ class(integer_stack), target :: this
+ class(stack), pointer :: ptr, next
+ integer :: array(:), i, j, error
+ compare_integer = .true.
+ ptr => this
+ do j = 0, size (array, 1)
+ if (compare_integer .eqv. .false.) return
+ select type (ptr)
+ type is (integer_stack)
+ select type(k => ptr%item)
+ type is(integer)
+ if (k .ne. array(j)) error = 1
+ class default
+ error = 2
+ compare_integer = .false.
+ end select
+ class default
+ if (j .ne. 0) then
+ error = 3
+ compare_integer = .false.
+ end if
+ end select
+ next => ptr%next
+ if (associated (next)) then
+ ptr => next
+ else if (j .ne. size (array, 1)) then
+ error = 4
+ compare_integer = .false.
+ end if
+ end do
+ end function
+
+ subroutine delete (this)
+ class(stack), target :: this
+ class(stack), pointer :: ptr1, ptr2
+ ptr1 => this%next
+ ptr2 => ptr1%next
+ do while (associated (ptr1))
+ deallocate (ptr1)
+ ptr1 => ptr2
+ if (associated (ptr1)) ptr2 => ptr1%next
+ end do
+ end subroutine
+
+end module stack_mod
+
+program stack_demo
+
+ use stack_mod
+ implicit none
+
+ integer i, k(10), error
+ class(io_stack), allocatable :: stk
+ allocate(stk)
+
+ k = [3,1,7,0,2,9,4,8,5,6]
+
+ ! step 1: set up an 'output' file > changed to 'scratch'
+
+ open(10, status='scratch', form='unformatted')
+
+ ! step 2: add values to stack
+
+ do i=1,10
+! write(*,*) 'Adding ',i,' to the stack'
+ call stk%push(k(i))
+ enddo
+
+ ! step 3: pop values from stack and write them to file
+
+! write(*,*)
+! write(*,*) 'Removing each item from stack and writing it to file.'
+! write(*,*)
+ do while(.not.stk%empty())
+ write(10) stk
+ enddo
+
+ ! step 4: close file and reopen it for read > changed to rewind.
+
+ rewind(10)
+
+ ! step 5: read values back into stack
+! write(*,*) 'Reading each value from file and adding it to stack:'
+ do while(.true.)
+ read(10,END=9999) i
+! write(*,*), 'Reading ',i,' from file. Adding it to stack'
+ call stk%push(i)
+ enddo
+
+9999 continue
+
+ ! step 6: Dump stack to standard out
+
+! write(*,*)
+! write(*,*), 'Removing every element from stack and writing it to screen:'
+! write(*,*) stk
+
+! gfortran addition to check read/write
+ if (.not. stk%compare (k, error)) then
+ select case (error)
+ case(1)
+ print *, "values do not match"
+ case(2)
+ print *, "non integer found in stack"
+ case(3)
+ print *, "type mismatch in stack"
+ case(4)
+ print *, "too few values in stack"
+ end select
+ call abort
+ end if
+
+ close(10)
+
+! Clean up - valgrind indicates no leaks.
+ call stk%delete
+ deallocate (stk)
+end program stack_demo
new file mode 100644
@@ -0,0 +1,98 @@
+! { dg-do compile }
+!
+! Tests the checks for interface compliance.
+!
+!
+MODULE p
+ USE ISO_C_BINDING
+
+ TYPE :: person
+ CHARACTER (LEN=20) :: name
+ INTEGER(4) :: age
+ CONTAINS
+ procedure :: pwf ! { dg-error "Non-polymorphic passed-object" }
+ procedure :: pwuf
+ GENERIC :: WRITE(FORMATTED) => pwf
+ GENERIC :: WRITE(UNFORMATTED) => pwuf
+ END TYPE person
+ INTERFACE READ(FORMATTED)
+ MODULE PROCEDURE prf
+ END INTERFACE
+ INTERFACE READ(UNFORMATTED)
+ MODULE PROCEDURE pruf
+ END INTERFACE
+
+ TYPE :: seq_type
+ sequence
+ INTEGER(4) :: i
+ END TYPE seq_type
+ INTERFACE WRITE(FORMATTED)
+ MODULE PROCEDURE pwf_seq
+ END INTERFACE
+
+ TYPE, BIND(C) :: bindc_type
+ INTEGER(C_INT) :: i
+ END TYPE bindc_type
+
+ INTERFACE WRITE(FORMATTED)
+ MODULE PROCEDURE pwf_bindc
+ END INTERFACE
+
+CONTAINS
+ SUBROUTINE pwf (dtv,unit,iotype,vlist,iostat,iomsg) ! { dg-error "must be of type CLASS" }
+ type(person), INTENT(IN) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ CHARACTER (LEN=*), INTENT(IN) :: iotype
+ INTEGER, INTENT(IN) :: vlist(:)
+ INTEGER, INTENT(OUT) :: iostat
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+ WRITE(unit, FMT = *, IOSTAT=iostat) dtv%name, dtv%age
+ END SUBROUTINE pwf
+
+ SUBROUTINE prf (dtv,unit,iotype,vlist,iostat,iomsg) ! { dg-error "must be an ASSUMED SHAPE ARRAY" }
+ CLASS(person), INTENT(INOUT) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ CHARACTER (LEN=*), INTENT(IN) :: iotype
+ INTEGER, INTENT(IN) :: vlist
+ INTEGER, INTENT(OUT) :: iostat
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+ READ (UNIT = UNIT, FMT = *) dtv%name, dtv%age
+ END SUBROUTINE prf
+
+ SUBROUTINE pwuf (dtv,unit,iostat,iomsg) ! { dg-error "must have intent IN" }
+ CLASS(person), INTENT(INOUT) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ INTEGER, INTENT(OUT) :: iostat
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+ WRITE (UNIT=UNIT, FMT = *) DTV%name, DTV%age
+ END SUBROUTINE pwuf
+
+ SUBROUTINE pruf (dtv,unit,iostat,iomsg) ! { dg-error "must be of KIND = 4" }
+ CLASS(person), INTENT(INOUT) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ INTEGER(8), INTENT(OUT) :: iostat
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+ READ (UNIT = UNIT, FMT = *) dtv%name, dtv%age
+ END SUBROUTINE pruf
+
+ SUBROUTINE pwf_seq (dtv,unit,iotype,vlist,iostat,iomsg) ! { dg-error "not extensible|DERIVED" }
+ class(seq_type), INTENT(IN) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ CHARACTER (LEN=*), INTENT(IN) :: iotype
+ INTEGER, INTENT(IN) :: vlist(:)
+ INTEGER, INTENT(OUT) :: iostat
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+ WRITE(unit, FMT = *, IOSTAT=iostat) dtv%i
+ END SUBROUTINE pwf_seq
+
+ SUBROUTINE pwf_bindc (dtv,unit,iotype,vlist,iostat,iomsg) ! { dg-error "not extensible|DERIVED" }
+ class(bindc_type), INTENT(IN) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ CHARACTER (LEN=*), INTENT(IN) :: iotype
+ INTEGER, INTENT(IN) :: vlist(:)
+ INTEGER, INTENT(OUT) :: iostat
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+ WRITE(unit, FMT = *, IOSTAT=iostat) dtv%i
+ END SUBROUTINE pwf_bindc
+
+END MODULE p
new file mode 100644
@@ -0,0 +1,139 @@
+! { dg-do run }
+!
+! Tests dtio transfer of arrays of derived types and classes
+!
+MODULE p
+ TYPE :: person
+ CHARACTER (LEN=20) :: name
+ INTEGER(4) :: age
+ CONTAINS
+ procedure :: pwf
+ procedure :: prf
+ GENERIC :: WRITE(FORMATTED) => pwf
+ GENERIC :: READ(FORMATTED) => prf
+ END TYPE person
+ type, extends(person) :: employee
+ character(20) :: job_title
+ end type
+ type, extends(person) :: officer
+ character(20) :: position
+ end type
+ type, extends(person) :: member
+ integer :: membership_number
+ end type
+ type :: club
+ type(employee), allocatable :: staff(:)
+ class(person), allocatable :: committee(:)
+ class(person), allocatable :: membership(:)
+ end type
+CONTAINS
+ SUBROUTINE pwf (dtv,unit,iotype,vlist,iostat,iomsg)
+ CLASS(person), INTENT(IN) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ CHARACTER (LEN=*), INTENT(IN) :: iotype
+ INTEGER, INTENT(IN) :: vlist(:)
+ INTEGER, INTENT(OUT) :: iostat
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+ select type (dtv)
+ type is (employee)
+ WRITE(unit, FMT = "(A/)", IOSTAT=iostat) "Employee"
+ WRITE(unit, FMT = "(A20,I4,A20/)", IOSTAT=iostat) dtv%name, dtv%age, dtv%job_title
+ type is (officer)
+ WRITE(unit, FMT = "(A/)", IOSTAT=iostat) "Officer"
+ WRITE(unit, FMT = "(A20,I4,A20/)", IOSTAT=iostat) dtv%name, dtv%age, dtv%position
+ type is (member)
+ WRITE(unit, FMT = "(A/)", IOSTAT=iostat) "Member"
+ WRITE(unit, FMT = "(A20,I4,I4/)", IOSTAT=iostat) dtv%name, dtv%age, dtv%membership_number
+ class default
+ WRITE(unit, FMT = "(A/)", IOSTAT=iostat) "Ugggh!"
+ WRITE(unit, FMT = "(A20,I4,' '/)", IOSTAT=iostat) dtv%name, dtv%age
+ end select
+ END SUBROUTINE pwf
+
+ SUBROUTINE prf (dtv,unit,iotype,vlist,iostat,iomsg)
+ CLASS(person), INTENT(INOUT) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ CHARACTER (LEN=*), INTENT(IN) :: iotype
+ INTEGER, INTENT(IN) :: vlist(:)
+ INTEGER, INTENT(OUT) :: iostat
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+ character (20) :: header, rname, jtitle, oposition
+ integer :: i
+ integer :: no
+ integer :: age
+ iostat = 0
+ select type (dtv)
+
+ type is (employee)
+ read (unit = unit, fmt = *) header
+ READ (UNIT = UNIT, FMT = "(A20,I4,A20)") rname, age, jtitle
+ if (trim (rname) .ne. dtv%name) iostat = 1
+ if (age .ne. dtv%age) iostat = 2
+ if (trim (jtitle) .ne. dtv%job_title) iostat = 3
+ if (iotype .ne. "DTstaff") iostat = 4
+
+ type is (officer)
+ read (unit = unit, fmt = *) header
+ READ (UNIT = UNIT, FMT = "(A20,I4,A20)") rname, age, oposition
+ if (trim (rname) .ne. dtv%name) iostat = 1
+ if (age .ne. dtv%age) iostat = 2
+ if (trim (oposition) .ne. dtv%position) iostat = 3
+ if (iotype .ne. "DTofficers") iostat = 4
+
+ type is (member)
+ read (unit = unit, fmt = *) header
+ READ (UNIT = UNIT, FMT = "(A20,I4,I4)") rname, age, no
+ if (trim (rname) .ne. dtv%name) iostat = 1
+ if (age .ne. dtv%age) iostat = 2
+ if (no .ne. dtv%membership_number) iostat = 3
+ if (iotype .ne. "DTmembers") iostat = 4
+
+ class default
+ call abort
+ end select
+ end subroutine
+END MODULE p
+
+PROGRAM test
+ USE p
+
+ type (club) :: social_club
+ TYPE (person) :: chairman
+ CLASS (person), allocatable :: president(:)
+ character (40) :: line
+ integer :: i, j
+
+ allocate (social_club%staff, source = [employee ("Bert",25,"Barman"), &
+ employee ("Joy",16,"Auditor")])
+
+ allocate (social_club%committee, source = [officer ("Hank",32, "Chair"), &
+ officer ("Ann", 29, "Secretary")])
+
+ allocate (social_club%membership, source = [member ("Dan",52,1), &
+ member ("Sue",39,2)])
+
+ chairman%name="Charlie"
+ chairman%age=62
+
+ open (7, status = "scratch")
+ write (7,*) social_club%staff ! Tests array of derived types
+ write (7,*) social_club%committee ! Tests class array
+ do i = 1, size (social_club%membership, 1)
+ write (7,*) social_club%membership(i) ! Tests class array elements
+ end do
+
+ rewind (7)
+ read (7, "(DT'staff')", iostat = i) social_club%staff
+ if (i .ne. 0) call abort
+
+ social_club%committee(2)%age = 33 ! Introduce an error
+
+ read (7, "(DT'officers')", iostat = i) social_club%committee
+ if (i .ne. 2) call abort ! Pick up error
+
+ do j = 1, size (social_club%membership, 1)
+ read (7, "(DT'members')", iostat = i) social_club%membership(j)
+ if (i .ne. 0) call abort
+ end do
+ close (7)
+END PROGRAM test
new file mode 100644
@@ -0,0 +1,65 @@
+! { dg-do run }
+!
+! Tests dtio transfer sequence types.
+!
+! Note difficulty at end with comparisons at any level of optimization.
+!
+MODULE p
+ TYPE :: person
+ sequence
+ CHARACTER (LEN=20) :: name
+ INTEGER(4) :: age
+ END TYPE person
+ INTERFACE WRITE(UNFORMATTED)
+ MODULE PROCEDURE pwuf
+ END INTERFACE
+ INTERFACE READ(UNFORMATTED)
+ MODULE PROCEDURE pruf
+ END INTERFACE
+
+CONTAINS
+
+ SUBROUTINE pwuf (dtv,unit,iostat,iomsg)
+ type(person), INTENT(IN) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ INTEGER, INTENT(OUT) :: iostat
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+ WRITE (UNIT=UNIT) DTV%name, DTV%age
+ END SUBROUTINE pwuf
+
+ SUBROUTINE pruf (dtv,unit,iostat,iomsg)
+ type(person), INTENT(INOUT) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ INTEGER, INTENT(OUT) :: iostat
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+ READ (UNIT = UNIT) dtv%name, dtv%age
+ END SUBROUTINE pruf
+
+END MODULE p
+
+PROGRAM test
+ USE p
+ TYPE (person) :: chairman
+ character(10) :: line
+
+ chairman%name="Charlie"
+ chairman%age=62
+
+ OPEN (UNIT=71, status = 'scratch', FORM='UNFORMATTED')
+ write (71) chairman
+ rewind (71)
+
+ chairman%name = "Charles"
+ chairman%age = 0
+
+ read (71) chairman
+ close (unit = 71)
+
+! Straight comparisons fail at any level of optimization.
+
+ write(line, "(A7)") chairman%name
+ if (trim (line) .ne. "Charlie") call abort
+ line = " "
+ write(line, "(I4)") chairman%age
+ if (trim (line) .eq. " 62") print *, trim(line)
+END PROGRAM test
new file mode 100644
@@ -0,0 +1,66 @@
+! { dg-do run }
+!
+! Tests dtio of transfer bind-C types.
+!
+! Note difficulties with c_char at -O1. This is why no character field is used.
+!
+MODULE p
+ USE ISO_C_BINDING
+ TYPE, BIND(C) :: person
+ integer(c_int) :: id_no
+ INTEGER(c_int) :: age
+ END TYPE person
+ INTERFACE WRITE(UNFORMATTED)
+ MODULE PROCEDURE pwuf
+ END INTERFACE
+ INTERFACE READ(UNFORMATTED)
+ MODULE PROCEDURE pruf
+ END INTERFACE
+
+CONTAINS
+
+ SUBROUTINE pwuf (dtv,unit,iostat,iomsg)
+ type(person), INTENT(IN) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ INTEGER, INTENT(OUT) :: iostat
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+ WRITE (UNIT=UNIT) DTV%id_no, DTV%age
+ END SUBROUTINE pwuf
+
+ SUBROUTINE pruf (dtv,unit,iostat,iomsg)
+ type(person), INTENT(INOUT) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ INTEGER, INTENT(OUT) :: iostat
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+ READ (UNIT = UNIT) dtv%id_no, dtv%age
+ END SUBROUTINE pruf
+
+END MODULE p
+
+PROGRAM test
+ USE p
+ TYPE (person) :: chairman
+ CHARACTER (kind=c_char) :: cname(20)
+ integer (c_int) :: cage, cid_no
+ character(10) :: line
+
+ cid_no = 1
+ cage = 62
+ chairman%id_no = cid_no
+ chairman%age = cage
+
+ OPEN (UNIT=71, status = 'scratch', FORM='UNFORMATTED')
+ write (71) chairman
+ rewind (71)
+
+ chairman%id_no = 0
+ chairman%age = 0
+
+ read (71) chairman
+ close (unit = 71)
+
+ write(line, "(I4)") chairman%id_no
+ if (trim (line) .ne. " 1") call abort
+ write(line, "(I4)") chairman%age
+ if (trim (line) .ne. " 62") call abort
+end program
@@ -1091,7 +1091,7 @@ GFORTRAN_1.1 {
_gfortran_transpose_char4;
_gfortran_unpack0_char4;
_gfortran_unpack1_char4;
-} GFORTRAN_1.0;
+} GFORTRAN_1.0;
GFORTRAN_1.2 {
@@ -1099,12 +1099,12 @@ GFORTRAN_1.2 {
_gfortran_clz128;
_gfortran_ctz128;
_gfortran_is_extension_of;
-} GFORTRAN_1.1;
+} GFORTRAN_1.1;
GFORTRAN_1.3 {
global:
_gfortran_error_stop_string;
-} GFORTRAN_1.2;
+} GFORTRAN_1.2;
GFORTRAN_1.4 {
global:
@@ -1187,13 +1187,13 @@ GFORTRAN_1.4 {
_gfortran_cshift0_16_char4;
_gfortran_eoshift0_16_char4;
_gfortran_eoshift2_16_char4;
-} GFORTRAN_1.3;
+} GFORTRAN_1.3;
GFORTRAN_1.5 {
global:
_gfortran_ftell2;
_gfortran_backtrace;
-} GFORTRAN_1.4;
+} GFORTRAN_1.4;
GFORTRAN_1.6 {
global:
@@ -1274,7 +1274,7 @@ GFORTRAN_1.6 {
__ieee_exceptions_MOD_ieee_support_flag_noarg;
__ieee_exceptions_MOD_ieee_support_halting;
__ieee_exceptions_MOD_ieee_usual;
-} GFORTRAN_1.5;
+} GFORTRAN_1.5;
GFORTRAN_1.7 {
global:
@@ -1287,7 +1287,12 @@ GFORTRAN_1.7 {
_gfortran_mvbits_i16;
_gfortran_shape_1;
_gfortran_shape_2;
-} GFORTRAN_1.6;
+} GFORTRAN_1.6;
+
+GFORTRAN_1.8 {
+ global:
+ _gfortran_transfer_derived;
+} GFORTRAN_1.7;
F2C_1.0 {
global:
@@ -70,7 +70,7 @@ free_format_hash_table (gfc_unit *u)
free (u->format_hash_table[i].key);
}
u->format_hash_table[i].key = NULL;
- u->format_hash_table[i].key_len = 0;
+ u->format_hash_table[i].key_len = 0;
u->format_hash_table[i].hashed_fmt = NULL;
}
}
@@ -84,7 +84,7 @@ reset_node (fnode *fn)
fn->count = 0;
fn->current = NULL;
-
+
if (fn->format != FMT_LPAREN)
return;
@@ -261,11 +261,20 @@ void
free_format_data (format_data *fmt)
{
fnode_array *fa, *fa_next;
-
+ fnode *fnp;
if (fmt == NULL)
return;
+ /* Free vlist descriptors in the fnode_array if one was allocated. */
+ for (fnp = fmt->array.array; fnp->format != FMT_NONE; fnp++)
+ if (fnp->format == FMT_DT)
+ {
+ if (GFC_DESCRIPTOR_DATA(fnp->u.udf.vlist))
+ free (GFC_DESCRIPTOR_DATA(fnp->u.udf.vlist));
+ free (fnp->u.udf.vlist);
+ }
+
for (fa = fmt->array.next; fa; fa = fa_next)
{
fa_next = fa->next;
@@ -545,6 +554,9 @@ format_lex (format_data *fmt)
case 'C':
token = FMT_DC;
break;
+ case 'T':
+ token = FMT_DT;
+ break;
default:
token = FMT_D;
unget_char (fmt);
@@ -740,7 +752,7 @@ parse_format_list (st_parameter_dt *dtp, bool *seen_dd)
tail->u.string.length = fmt->value;
tail->repeat = 1;
goto optional_comma;
-
+
case FMT_RC:
case FMT_RD:
case FMT_RN:
@@ -806,6 +818,7 @@ parse_format_list (st_parameter_dt *dtp, bool *seen_dd)
case FMT_EN:
case FMT_ES:
case FMT_D:
+ case FMT_DT:
case FMT_L:
case FMT_A:
case FMT_F:
@@ -849,6 +862,7 @@ parse_format_list (st_parameter_dt *dtp, bool *seen_dd)
/* In this state, t must currently be a data descriptor. Deal with
things that can/must follow the descriptor */
data_desc:
+
switch (t)
{
case FMT_L:
@@ -997,7 +1011,57 @@ parse_format_list (st_parameter_dt *dtp, bool *seen_dd)
}
break;
+ case FMT_DT:
+ *seen_dd = true;
+ get_fnode (fmt, &head, &tail, t);
+ tail->repeat = repeat;
+
+ t = format_lex (fmt);
+
+ /* Initialize the vlist to a zero size array. */
+ tail->u.udf.vlist= xmalloc (sizeof(gfc_array_i4));
+ GFC_DESCRIPTOR_DATA(tail->u.udf.vlist) = NULL;
+ GFC_DIMENSION_SET(tail->u.udf.vlist->dim[0],1, 0, 0);
+ if (t == FMT_STRING)
+ {
+ /* Get pointer to the optional format string. */
+ tail->u.udf.string = fmt->string;
+ tail->u.udf.string_len = fmt->value;
+ t = format_lex (fmt);
+ }
+ if (t == FMT_LPAREN)
+ {
+ /* Temporary buffer to hold the vlist values. */
+ GFC_INTEGER_4 temp[FARRAY_SIZE];
+ int i = 0;
+ loop:
+ t = format_lex (fmt);
+ if (t != FMT_POSINT)
+ {
+ fmt->error = posint_required;
+ goto finished;
+ }
+ /* Save the positive integer value. */
+ temp[i++] = fmt->value;
+ t = format_lex (fmt);
+ if (t == FMT_COMMA)
+ goto loop;
+ if (t == FMT_RPAREN)
+ {
+ /* We have parsed the complete vlist so initialize the
+ array descriptor and save it in the format node. */
+ gfc_array_i4 *vp = tail->u.udf.vlist;
+ GFC_DESCRIPTOR_DATA(vp) = xmalloc (i * sizeof(GFC_INTEGER_4));
+ GFC_DIMENSION_SET(vp->dim[0],1, i, 1);
+ memcpy (GFC_DESCRIPTOR_DATA(vp), temp, i * sizeof(GFC_INTEGER_4));
+ break;
+ }
+ fmt->error = unexpected_element;
+ goto finished;
+ }
+ fmt->saved_token = t;
+ break;
case FMT_H:
if (repeat > fmt->format_string_len)
{
@@ -1219,9 +1283,12 @@ parse_format (st_parameter_dt *dtp)
format_data *fmt;
bool format_cache_ok, seen_data_desc = false;
- /* Don't cache for internal units and set an arbitrary limit on the size of
- format strings we will cache. (Avoids memory issues.) */
- format_cache_ok = !is_internal_unit (dtp);
+ /* Don't cache for internal units and set an arbitrary limit on the
+ size of format strings we will cache. (Avoids memory issues.)
+ Also, the format_hash_table resides in the current_unit, so
+ child_dtio procedures would overwrite the parent table */
+ format_cache_ok = !is_internal_unit (dtp)
+ && (dtp->u.p.current_unit->child_dtio == 0);
/* Lookup format string to see if it has already been parsed. */
if (format_cache_ok)
@@ -1257,6 +1324,10 @@ parse_format (st_parameter_dt *dtp)
fmt->reversion_ok = 0;
fmt->saved_format = NULL;
+ /* Initialize the fnode_array. */
+
+ memset (&(fmt->array), 0, sizeof(fmt->array));
+
/* Allocate the first format node as the root of the tree. */
fmt->last = &fmt->array;
@@ -1392,7 +1463,7 @@ next_format (st_parameter_dt *dtp)
if (!fmt->reversion_ok &&
(t == FMT_I || t == FMT_B || t == FMT_O || t == FMT_Z || t == FMT_F ||
t == FMT_E || t == FMT_EN || t == FMT_ES || t == FMT_G || t == FMT_L ||
- t == FMT_A || t == FMT_D))
+ t == FMT_A || t == FMT_D || t == FMT_DT))
fmt->reversion_ok = 1;
return f;
}
@@ -38,7 +38,7 @@ typedef enum
FMT_LPAREN, FMT_RPAREN, FMT_X, FMT_S, FMT_SS, FMT_SP, FMT_STRING,
FMT_BADSTRING, FMT_P, FMT_I, FMT_B, FMT_BN, FMT_BZ, FMT_O, FMT_Z, FMT_F,
FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END, FMT_DC,
- FMT_DP, FMT_STAR, FMT_RC, FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ
+ FMT_DP, FMT_STAR, FMT_RC, FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ, FMT_DT
}
format_token;
@@ -74,6 +74,14 @@ struct fnode
}
integer;
+ struct
+ {
+ char *string;
+ int string_len;
+ gfc_array_i4 *vlist;
+ }
+ udf; /* User Defined Format. */
+
int w;
int k;
int r;
@@ -94,6 +94,30 @@ typedef struct array_loop_spec
}
array_loop_spec;
+/* User defined input/output iomsg length. */
+
+#define IOMSG_LEN 256
+
+/* Subroutine formatted_dtio (struct, unit, iotype, v_list, iostat,
+ iomsg, (_iotype), (_iomsg)) */
+typedef void (*formatted_dtio)(void *, GFC_INTEGER_4 *, char *, gfc_array_i4 *,
+ GFC_INTEGER_4 *, char *,
+ gfc_charlen_type, gfc_charlen_type);
+
+/* Subroutine unformatted_dtio (struct, unit, iostat, iomsg, (_iomsg)) */
+typedef void (*unformatted_dtio)(void *, GFC_INTEGER_4 *, GFC_INTEGER_4 *,
+ char *, gfc_charlen_type);
+
+/* The dtio calls for namelist require a CLASS object to be built. */
+typedef struct gfc_class
+{
+ void *data;
+ void *vptr;
+ index_type len;
+}
+gfc_class;
+
+
/* A structure to build a hash table for format data. */
#define FORMAT_HASH_SIZE 16
@@ -136,6 +160,12 @@ typedef struct namelist_type
/* Address for the start of the object's data. */
void * mem_pos;
+ /* Address of specific DTIO subroutine. */
+ void * dtio_sub;
+
+ /* Address of vtable if dtio_sub non-null. */
+ void * vtable;
+
/* Flag to show that a read is to be attempted for this node. */
int touched;
@@ -462,7 +492,7 @@ typedef struct st_parameter_dt
/* Used for ungetc() style functionality. Possible values
are an unsigned char, EOF, or EOF - 1 used to mark the
field as not valid. */
- int last_char;
+ int last_char; /* No longer used, moved to gfc_unit. */
char nml_delim;
int repeat_count;
@@ -484,6 +514,8 @@ typedef struct st_parameter_dt
largest kind. */
char value[32];
GFC_IO_INT size_used;
+ formatted_dtio fdtio_ptr;
+ unformatted_dtio ufdtio_ptr;
} p;
/* This pad size must be equal to the pad_size declared in
trans-io.c (gfc_build_io_library_fndecls). The above structure
@@ -607,6 +639,10 @@ typedef struct gfc_unit
/* Function pointer, points to list_read worker functions. */
int (*next_char_fn_ptr) (st_parameter_dt *);
void (*push_char_fn_ptr) (st_parameter_dt *, int);
+
+ /* DTIO Parent/Child procedure, 0 = parent, >0 = child level. */
+ int child_dtio;
+ int last_char;
}
gfc_unit;
@@ -728,6 +764,7 @@ internal_proto(read_radix);
extern void read_decimal (st_parameter_dt *, const fnode *, char *, int);
internal_proto(read_decimal);
+
/* list_read.c */
extern void list_formatted_read (st_parameter_dt *, bt, void *, int, size_t,
@@ -84,7 +84,7 @@ push_char_default (st_parameter_dt *dtp, int c)
if (dtp->u.p.saved_string == NULL)
{
- // Plain malloc should suffice here, zeroing not needed?
+ /* Plain malloc should suffice here, zeroing not needed? */
dtp->u.p.saved_string = xcalloc (SCRATCH_SIZE, 1);
dtp->u.p.saved_length = SCRATCH_SIZE;
dtp->u.p.saved_used = 0;
@@ -170,11 +170,11 @@ check_buffers (st_parameter_dt *dtp)
int c;
c = '\0';
- if (dtp->u.p.last_char != EOF - 1)
+ if (dtp->u.p.current_unit->last_char != EOF - 1)
{
dtp->u.p.at_eol = 0;
- c = dtp->u.p.last_char;
- dtp->u.p.last_char = EOF - 1;
+ c = dtp->u.p.current_unit->last_char;
+ dtp->u.p.current_unit->last_char = EOF - 1;
goto done;
}
@@ -369,7 +369,7 @@ utf_done:
static void
unget_char (st_parameter_dt *dtp, int c)
{
- dtp->u.p.last_char = c;
+ dtp->u.p.current_unit->last_char = c;
}
@@ -385,7 +385,7 @@ eat_spaces (st_parameter_dt *dtp)
This is an optimization unique to character arrays with large
character lengths (PR38199). This code eliminates numerous calls
to next_character. */
- if (is_array_io (dtp) && (dtp->u.p.last_char == EOF - 1))
+ if (is_array_io (dtp) && (dtp->u.p.current_unit->last_char == EOF - 1))
{
gfc_offset offset = stell (dtp->u.p.current_unit->s);
gfc_offset i;
@@ -2167,6 +2167,46 @@ list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p,
if (dtp->u.p.repeat_count > 0)
memcpy (dtp->u.p.value, p, size);
break;
+ case BT_CLASS:
+ {
+ int unit = dtp->u.p.current_unit->unit_number;
+ char iotype[] = "LISTDIRECTED";
+ gfc_charlen_type iotype_len = 12;
+ char tmp_iomsg[IOMSG_LEN] = "";
+ char *child_iomsg;
+ gfc_charlen_type child_iomsg_len;
+ int noiostat;
+ int *child_iostat = NULL;
+ gfc_array_i4 vlist;
+
+ GFC_DESCRIPTOR_DATA(&vlist) = NULL;
+ GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0);
+
+ /* Set iostat, intent(out). */
+ noiostat = 0;
+ child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
+ dtp->common.iostat : &noiostat;
+
+ /* Set iomsge, intent(inout). */
+ if (dtp->common.flags & IOPARM_HAS_IOMSG)
+ {
+ child_iomsg = dtp->common.iomsg;
+ child_iomsg_len = dtp->common.iomsg_len;
+ }
+ else
+ {
+ child_iomsg = tmp_iomsg;
+ child_iomsg_len = IOMSG_LEN;
+ }
+
+ /* Call the user defined formatted READ procedure. */
+ dtp->u.p.current_unit->child_dtio++;
+ dtp->u.p.fdtio_ptr (p, &unit, iotype, &vlist,
+ child_iostat, child_iomsg,
+ iotype_len, child_iomsg_len);
+ dtp->u.p.current_unit->child_dtio--;
+ }
+ break;
default:
internal_error (&dtp->common, "Bad type for list read");
}
@@ -3206,6 +3246,53 @@ get_name:
goto nml_err_ret;
}
+ else if (nl->dtio_sub != NULL)
+ {
+ int unit = dtp->u.p.current_unit->unit_number;
+ char iotype[] = "NAMELIST";
+ gfc_charlen_type iotype_len = 8;
+ char tmp_iomsg[IOMSG_LEN] = "";
+ char *child_iomsg;
+ gfc_charlen_type child_iomsg_len;
+ int noiostat;
+ int *child_iostat = NULL;
+ gfc_array_i4 vlist;
+ gfc_class list_obj;
+ formatted_dtio dtio_ptr = (formatted_dtio)nl->dtio_sub;
+
+ GFC_DESCRIPTOR_DATA(&vlist) = NULL;
+ GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0);
+
+ list_obj.data = (void *)nl->mem_pos;
+ list_obj.vptr = nl->vtable;
+ list_obj.len = 0;
+
+ /* Set iostat, intent(out). */
+ noiostat = 0;
+ child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
+ dtp->common.iostat : &noiostat;
+
+ /* Set iomsg, intent(inout). */
+ if (dtp->common.flags & IOPARM_HAS_IOMSG)
+ {
+ child_iomsg = dtp->common.iomsg;
+ child_iomsg_len = dtp->common.iomsg_len;
+ }
+ else
+ {
+ child_iomsg = tmp_iomsg;
+ child_iomsg_len = IOMSG_LEN;
+ }
+
+ /* Call the user defined formatted READ procedure. */
+ dtp->u.p.current_unit->child_dtio++;
+ dtio_ptr ((void *)&list_obj, &unit, iotype, &vlist,
+ child_iostat, child_iomsg,
+ iotype_len, child_iomsg_len);
+ dtp->u.p.current_unit->child_dtio--;
+
+ return true;
+ }
/* Get the length, data length, base pointer and rank of the variable.
Set the default loop specification first. */
@@ -57,7 +57,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
transfer_complex
transfer_real128
transfer_complex128
-
+
and for WRITE
transfer_integer_write
@@ -122,6 +122,15 @@ extern void transfer_array_write (st_parameter_dt *, gfc_array_char *, int,
gfc_charlen_type);
export_proto(transfer_array_write);
+/* User defined derived type input/output. */
+extern void
+transfer_derived (st_parameter_dt *dtp, void *dtio_source, void *dtio_proc);
+export_proto(transfer_derived);
+
+extern void
+transfer_derived_write (st_parameter_dt *dtp, void *dtio_source, void *dtio_proc);
+export_proto(transfer_derived_write);
+
static void us_read (st_parameter_dt *, int);
static void us_write (st_parameter_dt *, int);
static void next_record_r_unf (st_parameter_dt *, int);
@@ -315,7 +324,7 @@ read_sf (st_parameter_dt *dtp, int * length)
the rest of the I/O statement. Set the corresponding flag. */
if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
dtp->u.p.eor_condition = 1;
-
+
/* If we encounter a CR, it might be a CRLF. */
if (q == '\r') /* Probably a CRLF */
{
@@ -548,7 +557,7 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t nbytes)
if (is_stream_io (dtp))
{
- have_read_record = sread (dtp->u.p.current_unit->s, buf,
+ have_read_record = sread (dtp->u.p.current_unit->s, buf,
nbytes);
if (unlikely (have_read_record < 0))
{
@@ -556,7 +565,7 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t nbytes)
return;
}
- dtp->u.p.current_unit->strm_pos += (gfc_offset) have_read_record;
+ dtp->u.p.current_unit->strm_pos += (gfc_offset) have_read_record;
if (unlikely ((ssize_t) nbytes != have_read_record))
{
@@ -590,7 +599,7 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t nbytes)
return;
}
- if (to_read_record != (ssize_t) nbytes)
+ if (to_read_record != (ssize_t) nbytes)
{
/* Short read, e.g. if we hit EOF. Apparently, we read
more than was written to the last record. */
@@ -639,7 +648,7 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t nbytes)
dtp->u.p.current_unit->bytes_left_subrecord -= to_read_subrecord;
- have_read_subrecord = sread (dtp->u.p.current_unit->s,
+ have_read_subrecord = sread (dtp->u.p.current_unit->s,
buf + have_read_record, to_read_subrecord);
if (unlikely (have_read_subrecord < 0))
{
@@ -760,7 +769,7 @@ write_block (st_parameter_dt *dtp, int length)
return NULL;
}
}
-
+
if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
dtp->u.p.size_used += (GFC_IO_INT) length;
@@ -793,7 +802,7 @@ write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
return false;
}
- dtp->u.p.current_unit->strm_pos += (gfc_offset) have_written;
+ dtp->u.p.current_unit->strm_pos += (gfc_offset) have_written;
return true;
}
@@ -811,7 +820,7 @@ write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
if (buf == NULL && nbytes == 0)
return true;
- have_written = swrite (dtp->u.p.current_unit->s, buf, nbytes);
+ have_written = swrite (dtp->u.p.current_unit->s, buf, nbytes);
if (unlikely (have_written < 0))
{
generate_error (&dtp->common, LIBERROR_OS, NULL);
@@ -849,7 +858,7 @@ write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
dtp->u.p.current_unit->bytes_left_subrecord -=
(gfc_offset) to_write_subrecord;
- to_write_subrecord = swrite (dtp->u.p.current_unit->s,
+ to_write_subrecord = swrite (dtp->u.p.current_unit->s,
buf + have_written, to_write_subrecord);
if (unlikely (to_write_subrecord < 0))
{
@@ -857,7 +866,7 @@ write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
return false;
}
- dtp->u.p.current_unit->strm_pos += (gfc_offset) to_write_subrecord;
+ dtp->u.p.current_unit->strm_pos += (gfc_offset) to_write_subrecord;
nbytes -= to_write_subrecord;
have_written += to_write_subrecord;
@@ -903,7 +912,7 @@ reverse_memcpy (void *dest, const void *src, size_t n)
static void
bswap_array (void *dest, const void *src, size_t size, size_t nelems)
{
- const char *ps;
+ const char *ps;
char *pd;
switch (size)
@@ -988,6 +997,40 @@ static void
unformatted_read (st_parameter_dt *dtp, bt type,
void *dest, int kind, size_t size, size_t nelems)
{
+ if (type == BT_CLASS)
+ {
+ int unit = dtp->u.p.current_unit->unit_number;
+ char tmp_iomsg[IOMSG_LEN] = "";
+ char *child_iomsg;
+ gfc_charlen_type child_iomsg_len;
+ int noiostat;
+ int *child_iostat = NULL;
+
+ /* Set iostat, intent(out). */
+ noiostat = 0;
+ child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
+ dtp->common.iostat : &noiostat;
+
+ /* Set iomsg, intent(inout). */
+ if (dtp->common.flags & IOPARM_HAS_IOMSG)
+ {
+ child_iomsg = dtp->common.iomsg;
+ child_iomsg_len = dtp->common.iomsg_len;
+ }
+ else
+ {
+ child_iomsg = tmp_iomsg;
+ child_iomsg_len = IOMSG_LEN;
+ }
+
+ /* Call the user defined unformatted READ procedure. */
+ dtp->u.p.current_unit->child_dtio++;
+ dtp->u.p.ufdtio_ptr (dest, &unit, child_iostat, child_iomsg,
+ child_iomsg_len);
+ dtp->u.p.current_unit->child_dtio--;
+ return;
+ }
+
if (type == BT_CHARACTER)
size *= GFC_SIZE_OF_CHAR_KIND(kind);
read_block_direct (dtp, dest, size * nelems);
@@ -1016,13 +1059,47 @@ unformatted_read (st_parameter_dt *dtp, bt type,
/* Master function for unformatted writes. NOTE: For kind=10 the size is 16
bytes on 64 bit machines. The unused bytes are not initialized and never
used, which can show an error with memory checking analyzers like
- valgrind. */
+ valgrind. We us BT_CLASS to denote a User Defined I/O call. */
static void
unformatted_write (st_parameter_dt *dtp, bt type,
void *source, int kind, size_t size, size_t nelems)
{
- if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE)
+ if (type == BT_CLASS)
+ {
+ int unit = dtp->u.p.current_unit->unit_number;
+ char tmp_iomsg[IOMSG_LEN] = "";
+ char *child_iomsg;
+ gfc_charlen_type child_iomsg_len;
+ int noiostat;
+ int *child_iostat = NULL;
+
+ /* Set iostat, intent(out). */
+ noiostat = 0;
+ child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
+ dtp->common.iostat : &noiostat;
+
+ /* Set iomsg, intent(inout). */
+ if (dtp->common.flags & IOPARM_HAS_IOMSG)
+ {
+ child_iomsg = dtp->common.iomsg;
+ child_iomsg_len = dtp->common.iomsg_len;
+ }
+ else
+ {
+ child_iomsg = tmp_iomsg;
+ child_iomsg_len = IOMSG_LEN;
+ }
+
+ /* Call the user defined unformatted WRITE procedure. */
+ dtp->u.p.current_unit->child_dtio++;
+ dtp->u.p.ufdtio_ptr (source, &unit, child_iostat, child_iomsg,
+ child_iomsg_len);
+ dtp->u.p.current_unit->child_dtio--;
+ return;
+ }
+
+ if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE)
|| kind == 1)
{
size_t stride = type == BT_CHARACTER ?
@@ -1045,13 +1122,13 @@ unformatted_write (st_parameter_dt *dtp, bt type,
nelems *= size;
size = kind;
}
-
+
/* Break up complex into its constituent reals. */
if (type == BT_COMPLEX)
{
nelems *= 2;
size /= 2;
- }
+ }
/* By now, all complex variables have been split into their
constituent reals. */
@@ -1099,6 +1176,9 @@ type_name (bt type)
case BT_COMPLEX:
p = "COMPLEX";
break;
+ case BT_CLASS:
+ p = "CLASS or DERIVED";
+ break;
default:
internal_error (NULL, "type_name(): Bad type");
}
@@ -1115,7 +1195,7 @@ static void
write_constant_string (st_parameter_dt *dtp, const fnode *f)
{
char c, delimiter, *p, *q;
- int length;
+ int length;
length = f->u.string.length;
if (length == 0)
@@ -1124,7 +1204,7 @@ write_constant_string (st_parameter_dt *dtp, const fnode *f)
p = write_block (dtp, length);
if (p == NULL)
return;
-
+
q = f->u.string.p;
delimiter = q[-1];
@@ -1151,7 +1231,7 @@ require_type (st_parameter_dt *dtp, bt expected, bt actual, const fnode *f)
return 0;
/* Adjust item_count before emitting error message. */
- snprintf (buffer, BUFLEN,
+ snprintf (buffer, BUFLEN,
"Expected %s for item %d in formatted transfer, got %s",
type_name (expected), dtp->u.p.item_count - 1, type_name (actual));
@@ -1170,7 +1250,7 @@ require_numeric_type (st_parameter_dt *dtp, bt actual, const fnode *f)
return 0;
/* Adjust item_count before emitting error message. */
- snprintf (buffer, BUFLEN,
+ snprintf (buffer, BUFLEN,
"Expected numeric type for item %d in formatted transfer, got %s",
dtp->u.p.item_count - 1, type_name (actual));
@@ -1273,7 +1353,7 @@ formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind
case FMT_O:
if (n == 0)
- goto need_read_data;
+ goto need_read_data;
if (!(compile_options.allow_std & GFC_STD_GNU)
&& require_numeric_type (dtp, type, f))
return;
@@ -1322,6 +1402,65 @@ formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind
read_f (dtp, f, p, kind);
break;
+ case FMT_DT:
+ if (n == 0)
+ goto need_read_data;
+ if (require_type (dtp, BT_CLASS, type, f))
+ return;
+ int unit = dtp->u.p.current_unit->unit_number;
+ char dt[] = "DT";
+ char tmp_iomsg[IOMSG_LEN] = "";
+ char *child_iomsg;
+ gfc_charlen_type child_iomsg_len;
+ int noiostat;
+ int *child_iostat = NULL;
+ char *iotype = f->u.udf.string;
+ gfc_charlen_type iotype_len = f->u.udf.string_len;
+
+ /* Build the iotype string. */
+ if (iotype_len == 0)
+ {
+ iotype_len = 2;
+ iotype = dt;
+ }
+ else
+ {
+ iotype_len += 2;
+ iotype = xmalloc (iotype_len);
+ iotype[0] = dt[0];
+ iotype[1] = dt[1];
+ memcpy (iotype + 2, f->u.udf.string, f->u.udf.string_len);
+ }
+
+ /* Set iostat, intent(out). */
+ noiostat = 0;
+ child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
+ dtp->common.iostat : &noiostat;
+
+ /* Set iomsg, intent(inout). */
+ if (dtp->common.flags & IOPARM_HAS_IOMSG)
+ {
+ child_iomsg = dtp->common.iomsg;
+ child_iomsg_len = dtp->common.iomsg_len;
+ }
+ else
+ {
+ child_iomsg = tmp_iomsg;
+ child_iomsg_len = IOMSG_LEN;
+ }
+
+ /* Call the user defined formatted READ procedure. */
+ dtp->u.p.current_unit->child_dtio++;
+ dtp->u.p.fdtio_ptr (p, &unit, iotype, f->u.udf.vlist,
+ child_iostat, child_iomsg,
+ iotype_len, child_iomsg_len);
+ dtp->u.p.current_unit->child_dtio--;
+
+ if (f->u.udf.string_len != 0)
+ free (iotype);
+ /* Note: vlist is freed in free_format_data. */
+ break;
+
case FMT_E:
if (n == 0)
goto need_read_data;
@@ -1438,7 +1577,7 @@ formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind
}
if (dtp->u.p.skips < 0)
{
- if (is_internal_unit (dtp))
+ if (is_internal_unit (dtp))
sseek (dtp->u.p.current_unit->s, dtp->u.p.skips, SEEK_CUR);
else
fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips, SEEK_CUR);
@@ -1624,13 +1763,14 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin
/* Now discharge T, TR and X movements to the right. This is delayed
until a data producing format to suppress trailing spaces. */
-
+
t = f->format;
if (dtp->u.p.mode == WRITING && dtp->u.p.skips != 0
&& ((n>0 && ( t == FMT_I || t == FMT_B || t == FMT_O
|| t == FMT_Z || t == FMT_F || t == FMT_E
|| t == FMT_EN || t == FMT_ES || t == FMT_G
- || t == FMT_L || t == FMT_A || t == FMT_D))
+ || t == FMT_L || t == FMT_A || t == FMT_D
+ || t == FMT_DT))
|| t == FMT_STRING))
{
if (dtp->u.p.skips > 0)
@@ -1639,13 +1779,13 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin
write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
tmp = (int)(dtp->u.p.current_unit->recl
- dtp->u.p.current_unit->bytes_left);
- dtp->u.p.max_pos =
+ dtp->u.p.max_pos =
dtp->u.p.max_pos > tmp ? dtp->u.p.max_pos : tmp;
dtp->u.p.skips = 0;
}
if (dtp->u.p.skips < 0)
{
- if (is_internal_unit (dtp))
+ if (is_internal_unit (dtp))
sseek (dtp->u.p.current_unit->s, dtp->u.p.skips, SEEK_CUR);
else
fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips, SEEK_CUR);
@@ -1684,7 +1824,7 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin
case FMT_O:
if (n == 0)
- goto need_data;
+ goto need_data;
if (!(compile_options.allow_std & GFC_STD_GNU)
&& require_numeric_type (dtp, type, f))
return;
@@ -1733,6 +1873,65 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin
write_d (dtp, f, p, kind);
break;
+ case FMT_DT:
+ if (n == 0)
+ goto need_data;
+ if (require_type (dtp, BT_CLASS, type, f))
+ return;
+ int unit = dtp->u.p.current_unit->unit_number;
+ char dt[] = "DT";
+ char tmp_iomsg[IOMSG_LEN] = "";
+ char *child_iomsg;
+ gfc_charlen_type child_iomsg_len;
+ int noiostat;
+ int *child_iostat = NULL;
+ char *iotype = f->u.udf.string;
+ gfc_charlen_type iotype_len = f->u.udf.string_len;
+
+ /* Build the iotype string. */
+ if (iotype_len == 0)
+ {
+ iotype_len = 2;
+ iotype = dt;
+ }
+ else
+ {
+ iotype_len += 2;
+ iotype = xmalloc (iotype_len);
+ iotype[0] = dt[0];
+ iotype[1] = dt[1];
+ memcpy (iotype + 2, f->u.udf.string, f->u.udf.string_len);
+ }
+
+ /* Set iostat, intent(out). */
+ noiostat = 0;
+ child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
+ dtp->common.iostat : &noiostat;
+
+ /* Set iomsg, intent(inout). */
+ if (dtp->common.flags & IOPARM_HAS_IOMSG)
+ {
+ child_iomsg = dtp->common.iomsg;
+ child_iomsg_len = dtp->common.iomsg_len;
+ }
+ else
+ {
+ child_iomsg = tmp_iomsg;
+ child_iomsg_len = IOMSG_LEN;
+ }
+
+ /* Call the user defined formatted WRITE procedure. */
+ dtp->u.p.current_unit->child_dtio++;
+ dtp->u.p.fdtio_ptr (p, &unit, iotype, f->u.udf.vlist,
+ child_iostat, child_iomsg,
+ iotype_len, child_iomsg_len);
+ dtp->u.p.current_unit->child_dtio--;
+
+ if (f->u.udf.string_len != 0)
+ free (iotype);
+ /* Note: vlist is freed in free_format_data. */
+ break;
+
case FMT_E:
if (n == 0)
goto need_data;
@@ -2198,6 +2397,25 @@ transfer_array_write (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
transfer_array (dtp, desc, kind, charlen);
}
+
+/* User defined input/output iomsg. */
+
+#define IOMSG_LEN 256
+
+void
+transfer_derived (st_parameter_dt *parent, void *dtio_source, void *dtio_proc)
+{
+ if (parent->u.p.current_unit)
+ {
+ if (parent->u.p.current_unit->flags.form == FORM_UNFORMATTED)
+ parent->u.p.ufdtio_ptr = (unformatted_dtio) dtio_proc;
+ else
+ parent->u.p.fdtio_ptr = (formatted_dtio) dtio_proc;
+ }
+ parent->u.p.transfer (parent, BT_CLASS, dtio_source, 0, 0, 1);
+}
+
+
/* Preposition a sequential unformatted file while reading. */
static void
@@ -2340,7 +2558,7 @@ pre_position (st_parameter_dt *dtp)
was specified, we continue from where we last left off. I.e.
there is nothing to do here. */
break;
-
+
case UNFORMATTED_SEQUENTIAL:
if (dtp->u.p.mode == READING)
us_read (dtp, 0);
@@ -2384,6 +2602,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
dtp->u.p.size_used = 0; /* Initialize the count. */
dtp->u.p.current_unit = get_unit (dtp, 1);
+
if (dtp->u.p.current_unit->s == NULL)
{ /* Open the unit with some default flags. */
st_parameter_open opp;
@@ -2431,15 +2650,15 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
case GFC_CONVERT_NATIVE:
case GFC_CONVERT_SWAP:
break;
-
+
case GFC_CONVERT_BIG:
conv = big_endian ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
break;
-
+
case GFC_CONVERT_LITTLE:
conv = big_endian ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE;
break;
-
+
default:
internal_error (&opp.common, "Illegal value for CONVERT");
break;
@@ -2542,7 +2761,6 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
"EOF marker, possibly use REWIND or BACKSPACE");
return;
}
-
}
/* Process the ADVANCE option. */
@@ -2589,7 +2807,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
return;
}
- if ((cf & IOPARM_DT_HAS_SIZE) != 0
+ if ((cf & IOPARM_DT_HAS_SIZE) != 0
&& dtp->u.p.advance_status != ADVANCE_NO)
{
generate_error (&dtp->common, LIBERROR_MISSING_OPTION,
@@ -2653,7 +2871,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
= !(cf & IOPARM_DT_HAS_SIGN) ? SIGN_UNSPECIFIED :
find_option (&dtp->common, dtp->sign, dtp->sign_len, sign_opt,
"Bad SIGN parameter in data transfer statement");
-
+
if (dtp->u.p.sign_status == SIGN_UNSPECIFIED)
dtp->u.p.sign_status = dtp->u.p.current_unit->flags.sign;
@@ -2663,7 +2881,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
find_option (&dtp->common, dtp->blank, dtp->blank_len,
blank_opt,
"Bad BLANK parameter in data transfer statement");
-
+
if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank;
@@ -2703,28 +2921,28 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
/* Check the POS= specifier: that it is in range and that it is used with a
unit that has been connected for STREAM access. F2003 9.5.1.10. */
-
+
if (((cf & IOPARM_DT_HAS_POS) != 0))
{
if (is_stream_io (dtp))
{
-
+
if (dtp->pos <= 0)
{
generate_error (&dtp->common, LIBERROR_BAD_OPTION,
"POS=specifier must be positive");
return;
}
-
+
if (dtp->pos >= dtp->u.p.current_unit->maxrec)
{
generate_error (&dtp->common, LIBERROR_BAD_OPTION,
"POS=specifier too large");
return;
}
-
+
dtp->rec = dtp->pos;
-
+
if (dtp->u.p.mode == READING)
{
/* Reset the endfile flag; if we hit EOF during reading
@@ -2732,7 +2950,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
rather than worrying about it here. */
dtp->u.p.current_unit->endfile = NO_ENDFILE;
}
-
+
if (dtp->pos != dtp->u.p.current_unit->strm_pos)
{
fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
@@ -2752,7 +2970,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
return;
}
}
-
+
/* Sanity checks on the record number. */
if ((cf & IOPARM_DT_HAS_REC) != 0)
@@ -2789,11 +3007,11 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
/* Position the file. */
if (sseek (dtp->u.p.current_unit->s, (gfc_offset) (dtp->rec - 1)
- * dtp->u.p.current_unit->recl, SEEK_SET) < 0)
- {
- generate_error (&dtp->common, LIBERROR_OS, NULL);
- return;
- }
+ * dtp->u.p.current_unit->recl, SEEK_SET) < 0)
+ {
+ generate_error (&dtp->common, LIBERROR_OS, NULL);
+ return;
+ }
/* TODO: This is required to maintain compatibility between
4.3 and 4.4 runtime. Remove when ABI changes from 4.3 */
@@ -2822,7 +3040,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
dtp->u.p.max_pos = dtp->u.p.current_unit->saved_pos;
pre_position (dtp);
-
+
/* Set up the subroutine that will handle the transfers. */
@@ -2834,8 +3052,9 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
{
if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
{
- dtp->u.p.last_char = EOF - 1;
- dtp->u.p.transfer = list_formatted_read;
+ if (dtp->u.p.current_unit->child_dtio == 0)
+ dtp->u.p.current_unit->last_char = EOF - 1;
+ dtp->u.p.transfer = list_formatted_read;
}
else
dtp->u.p.transfer = formatted_transfer;
@@ -2896,14 +3115,14 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
returns the index of the last element of the array, and also returns
starting record, where the first I/O goes to (necessary in case of
negative strides). */
-
+
gfc_offset
init_loop_spec (gfc_array_char *desc, array_loop_spec *ls,
gfc_offset *start_record)
{
int rank = GFC_DESCRIPTOR_RANK(desc);
int i;
- gfc_offset index;
+ gfc_offset index;
int empty;
empty = 0;
@@ -2916,7 +3135,7 @@ init_loop_spec (gfc_array_char *desc, array_loop_spec *ls,
ls[i].start = GFC_DESCRIPTOR_LBOUND(desc,i);
ls[i].end = GFC_DESCRIPTOR_UBOUND(desc,i);
ls[i].step = GFC_DESCRIPTOR_STRIDE(desc,i);
- empty = empty || (GFC_DESCRIPTOR_UBOUND(desc,i)
+ empty = empty || (GFC_DESCRIPTOR_UBOUND(desc,i)
< GFC_DESCRIPTOR_LBOUND(desc,i));
if (GFC_DESCRIPTOR_STRIDE(desc,i) > 0)
@@ -2941,13 +3160,13 @@ init_loop_spec (gfc_array_char *desc, array_loop_spec *ls,
/* Determine the index to the next record in an internal unit array by
by incrementing through the array_loop_spec. */
-
+
gfc_offset
next_array_record (st_parameter_dt *dtp, array_loop_spec *ls, int *finished)
{
int i, carry;
gfc_offset index;
-
+
carry = 1;
index = 0;
@@ -2992,13 +3211,13 @@ skip_record (st_parameter_dt *dtp, ssize_t bytes)
/* Direct access files do not generate END conditions,
only I/O errors. */
- if (sseek (dtp->u.p.current_unit->s,
+ if (sseek (dtp->u.p.current_unit->s,
dtp->u.p.current_unit->bytes_left_subrecord, SEEK_CUR) < 0)
{
/* Seeking failed, fall back to seeking by reading data. */
while (dtp->u.p.current_unit->bytes_left_subrecord > 0)
{
- rlength =
+ rlength =
(MAX_READ < dtp->u.p.current_unit->bytes_left_subrecord) ?
MAX_READ : dtp->u.p.current_unit->bytes_left_subrecord;
@@ -3066,7 +3285,7 @@ next_record_r (st_parameter_dt *dtp, int done)
/* No records in unformatted STREAM I/O. */
case UNFORMATTED_STREAM:
return;
-
+
case UNFORMATTED_SEQUENTIAL:
next_record_r_unf (dtp, 1);
dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
@@ -3107,13 +3326,13 @@ next_record_r (st_parameter_dt *dtp, int done)
}
dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
}
- else
+ else
{
bytes_left = (int) dtp->u.p.current_unit->bytes_left;
- bytes_left = min_off (bytes_left,
+ bytes_left = min_off (bytes_left,
ssize (dtp->u.p.current_unit->s)
- stell (dtp->u.p.current_unit->s));
- if (sseek (dtp->u.p.current_unit->s,
+ if (sseek (dtp->u.p.current_unit->s,
bytes_left, SEEK_CUR) < 0)
{
generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
@@ -3121,16 +3340,16 @@ next_record_r (st_parameter_dt *dtp, int done)
}
dtp->u.p.current_unit->bytes_left
= dtp->u.p.current_unit->recl;
- }
+ }
break;
}
- else
+ else
{
do
{
errno = 0;
cc = fbuf_getc (dtp->u.p.current_unit);
- if (cc == EOF)
+ if (cc == EOF)
{
if (errno != 0)
generate_error (&dtp->common, LIBERROR_OS, NULL);
@@ -3144,10 +3363,10 @@ next_record_r (st_parameter_dt *dtp, int done)
}
break;
}
-
+
if (is_stream_io (dtp))
dtp->u.p.current_unit->strm_pos++;
-
+
p = (char) cc;
}
while (p != '\n');
@@ -3240,7 +3459,7 @@ next_record_w_unf (st_parameter_dt *dtp, int next_subrecord)
/* Seek to the head and overwrite the bogus length with the real
length. */
- if (unlikely (sseek (dtp->u.p.current_unit->s, - m - record_marker,
+ if (unlikely (sseek (dtp->u.p.current_unit->s, - m - record_marker,
SEEK_CUR) < 0))
goto io_error;
@@ -3301,7 +3520,7 @@ sset (stream * s, int c, ssize_t nbyte)
return trans;
bytes_left -= trans;
}
-
+
return nbyte - bytes_left;
}
@@ -3330,8 +3549,8 @@ next_record_w (st_parameter_dt *dtp, int done)
fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);
fbuf_flush (dtp->u.p.current_unit, WRITING);
- if (sset (dtp->u.p.current_unit->s, ' ',
- dtp->u.p.current_unit->bytes_left)
+ if (sset (dtp->u.p.current_unit->s, ' ',
+ dtp->u.p.current_unit->bytes_left)
!= dtp->u.p.current_unit->bytes_left)
goto io_error;
@@ -3362,7 +3581,7 @@ next_record_w (st_parameter_dt *dtp, int done)
int finished;
length = (int) dtp->u.p.current_unit->bytes_left;
-
+
/* If the farthest position reached is greater than current
position, adjust the position and set length to pad out
whats left. Otherwise just pad whats left.
@@ -3372,7 +3591,7 @@ next_record_w (st_parameter_dt *dtp, int done)
if (max_pos > m)
{
length = (int) (max_pos - m);
- if (sseek (dtp->u.p.current_unit->s,
+ if (sseek (dtp->u.p.current_unit->s,
length, SEEK_CUR) < 0)
{
generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
@@ -3399,7 +3618,7 @@ next_record_w (st_parameter_dt *dtp, int done)
&finished);
if (finished)
dtp->u.p.current_unit->endfile = AT_ENDFILE;
-
+
/* Now seek to this record */
record = record * dtp->u.p.current_unit->recl;
@@ -3425,7 +3644,7 @@ next_record_w (st_parameter_dt *dtp, int done)
if (max_pos > m)
{
length = (int) (max_pos - m);
- if (sseek (dtp->u.p.current_unit->s,
+ if (sseek (dtp->u.p.current_unit->s,
length, SEEK_CUR) < 0)
{
generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
@@ -3540,6 +3759,18 @@ finalize_transfer (st_parameter_dt *dtp)
{
GFC_INTEGER_4 cf = dtp->common.flags;
+ if ((dtp->u.p.ionml != NULL)
+ && (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0)
+ {
+ if ((cf & IOPARM_DT_NAMELIST_READ_MODE) != 0)
+ namelist_read (dtp);
+ else
+ namelist_write (dtp);
+ }
+
+ if (dtp->u.p.current_unit && (dtp->u.p.current_unit->child_dtio > 0))
+ return;
+
if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
*dtp->size = dtp->u.p.size_used;
@@ -3556,15 +3787,6 @@ finalize_transfer (st_parameter_dt *dtp)
goto done;
}
- if ((dtp->u.p.ionml != NULL)
- && (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0)
- {
- if ((cf & IOPARM_DT_NAMELIST_READ_MODE) != 0)
- namelist_read (dtp);
- else
- namelist_write (dtp);
- }
-
dtp->u.p.transfer = NULL;
if (dtp->u.p.current_unit == NULL)
goto done;
@@ -3607,7 +3829,7 @@ finalize_transfer (st_parameter_dt *dtp)
write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
tmp = (int)(dtp->u.p.current_unit->recl
- dtp->u.p.current_unit->bytes_left);
- dtp->u.p.max_pos =
+ dtp->u.p.max_pos =
dtp->u.p.max_pos > tmp ? dtp->u.p.max_pos : tmp;
dtp->u.p.skips = 0;
}
@@ -3618,9 +3840,9 @@ finalize_transfer (st_parameter_dt *dtp)
fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
goto done;
}
- else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
+ else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
&& dtp->u.p.mode == WRITING && !is_internal_unit (dtp))
- fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);
+ fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);
dtp->u.p.current_unit->saved_pos = 0;
@@ -3648,9 +3870,9 @@ finalize_transfer (st_parameter_dt *dtp)
data transfer, it just updates the length counter. */
static void
-iolength_transfer (st_parameter_dt *dtp, bt type __attribute__((unused)),
+iolength_transfer (st_parameter_dt *dtp, bt type __attribute__((unused)),
void *dest __attribute__ ((unused)),
- int kind __attribute__((unused)),
+ int kind __attribute__((unused)),
size_t size, size_t nelems)
{
if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
@@ -3722,7 +3944,7 @@ void
st_read_done (st_parameter_dt *dtp)
{
finalize_transfer (dtp);
-
+
if (is_internal_unit (dtp) || dtp->u.p.format_not_saved)
{
free_format_data (dtp->u.p.fmt);
@@ -3735,7 +3957,7 @@ st_read_done (st_parameter_dt *dtp)
unlock_unit (dtp->u.p.current_unit);
free_internal_unit (dtp);
-
+
library_end ();
}
@@ -3759,8 +3981,9 @@ st_write_done (st_parameter_dt *dtp)
/* Deal with endfile conditions associated with sequential files. */
- if (dtp->u.p.current_unit != NULL
- && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
+ if (dtp->u.p.current_unit != NULL
+ && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
+ && dtp->u.p.current_unit->child_dtio == 0)
switch (dtp->u.p.current_unit->endfile)
{
case AT_ENDFILE: /* Remain at the endfile record. */
@@ -3773,7 +3996,7 @@ st_write_done (st_parameter_dt *dtp)
case NO_ENDFILE:
/* Get rid of whatever is after this record. */
if (!is_internal_unit (dtp))
- unit_truncate (dtp->u.p.current_unit,
+ unit_truncate (dtp->u.p.current_unit,
stell (dtp->u.p.current_unit->s),
&dtp->common);
dtp->u.p.current_unit->endfile = AT_ENDFILE;
@@ -3790,7 +4013,7 @@ st_write_done (st_parameter_dt *dtp)
if (dtp->u.p.current_unit != NULL)
unlock_unit (dtp->u.p.current_unit);
-
+
free_internal_unit (dtp);
library_end ();
@@ -3808,14 +4031,15 @@ st_wait (st_parameter_wait *wtp __attribute__((unused)))
in a linked list of namelist_info types. */
extern void st_set_nml_var (st_parameter_dt *dtp, void *, char *,
- GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4);
+ GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4,
+ void *, void *);
export_proto(st_set_nml_var);
void
st_set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name,
GFC_INTEGER_4 len, gfc_charlen_type string_length,
- GFC_INTEGER_4 dtype)
+ GFC_INTEGER_4 dtype, void *dtio_sub, void *vtable)
{
namelist_info *t1 = NULL;
namelist_info *nml;
@@ -3824,6 +4048,8 @@ st_set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name,
nml = (namelist_info*) xmalloc (sizeof (namelist_info));
nml->mem_pos = var_addr;
+ nml->dtio_sub = dtio_sub;
+ nml->vtable = vtable;
nml->var_name = (char*) xmalloc (var_name_len + 1);
memcpy (nml->var_name, var_name, var_name_len);
@@ -3911,7 +4137,7 @@ hit_eof (st_parameter_dt * dtp)
else
dtp->u.p.current_unit->endfile = AT_ENDFILE;
break;
-
+
case AFTER_ENDFILE:
generate_error (&dtp->common, LIBERROR_ENDFILE, NULL);
dtp->u.p.current_unit->current_record = 0;
@@ -348,7 +348,7 @@ retry:
}
found:
- if (p != NULL)
+ if (p != NULL && (p->child_dtio == 0))
{
/* Fast path. */
if (! __gthread_mutex_trylock (&p->lock))
@@ -363,7 +363,7 @@ found:
__gthread_mutex_unlock (&unit_lock);
- if (p != NULL)
+ if (p != NULL && (p->child_dtio == 0))
{
__gthread_mutex_lock (&p->lock);
if (p->closed)
@@ -464,7 +464,7 @@ get_internal_unit (st_parameter_dt *dtp)
else
len = string_len_trim_char4 (dtp->internal_unit_len,
(const gfc_char4_t*) dtp->internal_unit);
- dtp->internal_unit_len = len;
+ dtp->internal_unit_len = len;
iunit->recl = dtp->internal_unit_len;
}
@@ -524,7 +524,7 @@ get_internal_unit (st_parameter_dt *dtp)
dtp->u.p.at_eof = 0;
/* This flag tells us the unit is assigned to internal I/O. */
-
+
dtp->u.p.unit_is_internal = 1;
return iunit;
@@ -544,13 +544,13 @@ free_internal_unit (st_parameter_dt *dtp)
if (dtp->u.p.current_unit != NULL)
{
free (dtp->u.p.current_unit->ls);
-
+
free (dtp->u.p.current_unit->s);
-
+
destroy_unit_mutex (dtp->u.p.current_unit);
}
}
-
+
/* get_unit()-- Returns the unit structure associated with the integer
@@ -612,14 +612,14 @@ init_units (void)
u->flags.encoding = ENCODING_DEFAULT;
u->flags.async = ASYNC_NO;
u->flags.round = ROUND_UNSPECIFIED;
-
+
u->recl = options.default_recl;
u->endfile = NO_ENDFILE;
u->filename = strdup (stdin_name);
fbuf_init (u, 0);
-
+
__gthread_mutex_unlock (&u->lock);
}
@@ -644,9 +644,9 @@ init_units (void)
u->recl = options.default_recl;
u->endfile = AT_ENDFILE;
-
+
u->filename = strdup (stdout_name);
-
+
fbuf_init (u, 0);
__gthread_mutex_unlock (&u->lock);
@@ -674,7 +674,7 @@ init_units (void)
u->endfile = AT_ENDFILE;
u->filename = strdup (stderr_name);
-
+
fbuf_init (u, 256); /* 256 bytes should be enough, probably not doing
any kind of exotic formatting to stderr. */
@@ -694,7 +694,7 @@ static int
close_unit_1 (gfc_unit *u, int locked)
{
int i, rc;
-
+
/* If there are previously written bytes from a write with ADVANCE="no"
Reposition the buffer before closing. */
if (u->previous_nonadvancing_write)
@@ -715,7 +715,7 @@ close_unit_1 (gfc_unit *u, int locked)
free (u->filename);
u->filename = NULL;
- free_format_hash_table (u);
+ free_format_hash_table (u);
fbuf_destroy (u);
if (!locked)
@@ -788,7 +788,7 @@ unit_truncate (gfc_unit * u, gfc_offset pos, st_parameter_common * common)
else
fbuf_flush (u, u->mode);
}
-
+
/* struncate() should flush the stream buffer if necessary, so don't
bother calling sflush() here. */
ret = struncate (u->s, pos);
@@ -838,7 +838,7 @@ filename_from_unit (int n)
void
finish_last_advance_record (gfc_unit *u)
{
-
+
if (u->saved_pos > 0)
fbuf_seek (u, u->saved_pos, SEEK_CUR);
@@ -1121,7 +1121,7 @@ tempfile_open (const char *tempdir, char **fname)
)
slash = "";
- // Take care that the template is longer in the mktemp() branch.
+ /* Take care that the template is longer in the mktemp() branch. */
char * template = xmalloc (tempdirlen + 23);
#ifdef HAVE_MKSTEMP
@@ -44,7 +44,7 @@ static void
memcpy4 (gfc_char4_t *dest, const char *source, int k)
{
int j;
-
+
const char *p = source;
for (j = 0; j < k; j++)
*dest++ = (gfc_char4_t) *p++;
@@ -63,7 +63,7 @@ write_default_char4 (st_parameter_dt *dtp, const gfc_char4_t *source,
int j, k = 0;
gfc_char4_t c;
uchar d;
-
+
/* Take care of preceding blanks. */
if (w_len > src_len)
{
@@ -153,7 +153,7 @@ write_utf8_char4 (st_parameter_dt *dtp, gfc_char4_t *source,
static const uchar masks[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
static const uchar limits[6] = { 0x80, 0xE0, 0xF0, 0xF8, 0xFC, 0xFE };
int nbytes;
- uchar buf[6], d, *q;
+ uchar buf[6], d, *q;
/* Take care of preceding blanks. */
if (w_len > src_len)
@@ -273,7 +273,7 @@ write_a (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
bytes = 0;
}
- /* Write out the CR_LF sequence. */
+ /* Write out the CR_LF sequence. */
q++;
p = write_block (dtp, 2);
if (p == NULL)
@@ -381,7 +381,7 @@ write_a_char4 (st_parameter_dt *dtp, const fnode *f, const char *source, int len
bytes = 0;
}
- /* Write out the CR_LF sequence. */
+ /* Write out the CR_LF sequence. */
write_default_char4 (dtp, crlf, 2, 0);
}
else
@@ -528,7 +528,7 @@ write_l (st_parameter_dt *dtp, const fnode *f, char *source, int len)
GFC_INTEGER_LARGEST n;
wlen = (f->format == FMT_G && f->u.w == 0) ? 1 : f->u.w;
-
+
p = write_block (dtp, wlen);
if (p == NULL)
return;
@@ -694,7 +694,7 @@ write_decimal (st_parameter_dt *dtp, const fnode *f, const char *source,
if (n < 0)
n = -n;
nsign = sign == S_NONE ? 0 : 1;
-
+
/* conv calls itoa which sets the negative sign needed
by write_integer. The sign '+' or '-' is set below based on sign
calculated above, so we just point past the sign in the string
@@ -847,7 +847,7 @@ btoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
{
char *q;
int i, j;
-
+
q = buffer;
if (big_endian)
{
@@ -893,7 +893,7 @@ btoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
if (*n == 0)
return "0";
- /* Move past any leading zeros. */
+ /* Move past any leading zeros. */
while (*buffer == '0')
buffer++;
@@ -968,7 +968,7 @@ otoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
if (*n == 0)
return "0";
- /* Move past any leading zeros. */
+ /* Move past any leading zeros. */
while (*q == '0')
q++;
@@ -986,9 +986,9 @@ ztoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
char *q;
uint8_t h, l;
int i;
-
+
q = buffer;
-
+
if (big_endian)
{
const char *p = s;
@@ -1021,11 +1021,11 @@ ztoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
}
*q = '\0';
-
+
if (*n == 0)
return "0";
-
- /* Move past any leading zeros. */
+
+ /* Move past any leading zeros. */
while (*buffer == '0')
buffer++;
@@ -1067,7 +1067,7 @@ write_o (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
const char *p;
char itoa_buf[GFC_OTOA_BUF_SIZE];
GFC_UINTEGER_LARGEST n = 0;
-
+
if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
{
p = otoa_big (source, itoa_buf, len, &n);
@@ -1407,12 +1407,12 @@ write_float_0 (st_parameter_dt *dtp, const fnode *f, const char *source, int kin
/* Precision for snprintf call. */
int precision = get_precision (dtp, f, source, kind);
-
+
/* String buffer to hold final result. */
result = select_string (f, str_buf, &res_len);
-
+
buffer = select_buffer (precision, buf_stack, &buf_size);
-
+
get_float_string (dtp, f, source , kind, 0, buffer,
precision, buf_size, result, &res_len);
write_float_string (dtp, result, res_len);
@@ -1525,13 +1525,13 @@ write_real (st_parameter_dt *dtp, const char *source, int kind)
/* Precision for snprintf call. */
int precision = get_precision (dtp, &f, source, kind);
-
+
/* String buffer to hold final result. */
result = select_string (&f, str_buf, &res_len);
/* scratch buffer to hold final result. */
buffer = select_buffer (precision, buf_stack, &buf_size);
-
+
get_float_string (dtp, &f, source , kind, 1, buffer,
precision, buf_size, result, &res_len);
write_float_string (dtp, result, res_len);
@@ -1554,7 +1554,7 @@ write_real_g0 (st_parameter_dt *dtp, const char *source, int kind, int d)
char str_buf[BUF_STACK_SZ];
char *buffer, *result;
size_t buf_size, res_len;
- int comp_d;
+ int comp_d;
set_fnode_default (dtp, &f, kind);
if (d > 0)
@@ -1570,7 +1570,7 @@ write_real_g0 (st_parameter_dt *dtp, const char *source, int kind, int d)
/* Precision for snprintf call. */
int precision = get_precision (dtp, &f, source, kind);
-
+
/* String buffer to hold final result. */
result = select_string (&f, str_buf, &res_len);
@@ -1608,36 +1608,36 @@ write_complex (st_parameter_dt *dtp, const char *source, int kind, size_t size)
dtp->u.p.scale_factor = 1;
set_fnode_default (dtp, &f, kind);
-
+
/* Set width for two values, parenthesis, and comma. */
width = 2 * f.u.real.w + 3;
/* Set for no blanks so we get a string result with no leading
blanks. We will pad left later. */
dtp->u.p.g0_no_blanks = 1;
-
+
/* Precision for snprintf call. */
int precision = get_precision (dtp, &f, source, kind);
-
+
/* String buffers to hold final result. */
result1 = select_string (&f, str1_buf, &res_len1);
result2 = select_string (&f, str2_buf, &res_len2);
buffer = select_buffer (precision, buf_stack, &buf_size);
-
+
get_float_string (dtp, &f, source , kind, 0, buffer,
precision, buf_size, result1, &res_len1);
get_float_string (dtp, &f, source + size / 2 , kind, 0, buffer,
precision, buf_size, result2, &res_len2);
lblanks = width - res_len1 - res_len2 - 3;
-
+
write_x (dtp, lblanks, lblanks);
write_char (dtp, '(');
write_float_string (dtp, result1, res_len1);
write_char (dtp, semi_comma);
write_float_string (dtp, result2, res_len2);
write_char (dtp, ')');
-
+
dtp->u.p.scale_factor = orig_scale;
dtp->u.p.g0_no_blanks = 0;
if (buf_size > BUF_STACK_SZ)
@@ -1710,6 +1710,46 @@ list_formatted_write_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
case BT_COMPLEX:
write_complex (dtp, p, kind, size);
break;
+ case BT_CLASS:
+ {
+ int unit = dtp->u.p.current_unit->unit_number;
+ char iotype[] = "LISTDIRECTED";
+ gfc_charlen_type iotype_len = 12;
+ char tmp_iomsg[IOMSG_LEN] = "";
+ char *child_iomsg;
+ gfc_charlen_type child_iomsg_len;
+ int noiostat;
+ int *child_iostat = NULL;
+ gfc_array_i4 vlist;
+
+ GFC_DESCRIPTOR_DATA(&vlist) = NULL;
+ GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0);
+
+ /* Set iostat, intent(out). */
+ noiostat = 0;
+ child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
+ dtp->common.iostat : &noiostat;
+
+ /* Set iomsge, intent(inout). */
+ if (dtp->common.flags & IOPARM_HAS_IOMSG)
+ {
+ child_iomsg = dtp->common.iomsg;
+ child_iomsg_len = dtp->common.iomsg_len;
+ }
+ else
+ {
+ child_iomsg = tmp_iomsg;
+ child_iomsg_len = IOMSG_LEN;
+ }
+
+ /* Call the user defined formatted WRITE procedure. */
+ dtp->u.p.current_unit->child_dtio++;
+ dtp->u.p.fdtio_ptr (p, &unit, iotype, &vlist,
+ child_iostat, child_iomsg,
+ iotype_len, child_iomsg_len);
+ dtp->u.p.current_unit->child_dtio--;
+ }
+ break;
default:
internal_error (&dtp->common, "list_formatted_write(): Bad type");
}
@@ -1844,7 +1884,7 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
size_t base_name_len;
size_t base_var_name_len;
size_t tot_len;
-
+
/* Set the character to be used to separate values
to a comma or semi-colon. */
@@ -1903,7 +1943,7 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
break;
default:
- obj_size = len;
+ obj_size = len;
}
if (obj->var_rank)
@@ -1985,7 +2025,7 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
break;
case BT_DERIVED:
-
+ case BT_CLASS:
/* To treat a derived type, we need to build two strings:
ext_name = the name, including qualifiers that prepends
component names in the output - passed to
@@ -1995,19 +2035,65 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
components. */
/* First ext_name => get length of all possible components */
+ if (obj->dtio_sub != NULL)
+ {
+ int unit = dtp->u.p.current_unit->unit_number;
+ char iotype[] = "NAMELIST";
+ gfc_charlen_type iotype_len = 8;
+ char tmp_iomsg[IOMSG_LEN] = "";
+ char *child_iomsg;
+ gfc_charlen_type child_iomsg_len;
+ int noiostat;
+ int *child_iostat = NULL;
+ gfc_array_i4 vlist;
+ gfc_class list_obj;
+ formatted_dtio dtio_ptr = (formatted_dtio)obj->dtio_sub;
+
+ GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0);
+
+ list_obj.data = p;
+ list_obj.vptr = obj->vtable;
+ list_obj.len = 0;
+
+ /* Set iostat, intent(out). */
+ noiostat = 0;
+ child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
+ dtp->common.iostat : &noiostat;
+
+ /* Set iomsg, intent(inout). */
+ if (dtp->common.flags & IOPARM_HAS_IOMSG)
+ {
+ child_iomsg = dtp->common.iomsg;
+ child_iomsg_len = dtp->common.iomsg_len;
+ }
+ else
+ {
+ child_iomsg = tmp_iomsg;
+ child_iomsg_len = IOMSG_LEN;
+ }
+ namelist_write_newline (dtp);
+ /* Call the user defined formatted WRITE procedure. */
+ dtp->u.p.current_unit->child_dtio++;
+ dtio_ptr ((void *)&list_obj, &unit, iotype, &vlist,
+ child_iostat, child_iomsg,
+ iotype_len, child_iomsg_len);
+ dtp->u.p.current_unit->child_dtio--;
+
+ goto obj_loop;
+ }
base_name_len = base_name ? strlen (base_name) : 0;
base_var_name_len = base ? strlen (base->var_name) : 0;
- ext_name_len = base_name_len + base_var_name_len
+ ext_name_len = base_name_len + base_var_name_len
+ strlen (obj->var_name) + obj->var_rank * NML_DIGITS + 1;
ext_name = xmalloc (ext_name_len);
if (base_name)
memcpy (ext_name, base_name, base_name_len);
clen = strlen (obj->var_name + base_var_name_len);
- memcpy (ext_name + base_name_len,
+ memcpy (ext_name + base_name_len,
obj->var_name + base_var_name_len, clen);
-
+
/* Append the qualifier. */
tot_len = base_name_len + clen;
@@ -2018,7 +2104,7 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
ext_name[tot_len] = '(';
tot_len++;
}
- snprintf (ext_name + tot_len, ext_name_len - tot_len, "%d",
+ snprintf (ext_name + tot_len, ext_name_len - tot_len, "%d",
(int) obj->ls[dim_i].idx);
tot_len += strlen (ext_name + tot_len);
ext_name[tot_len] = ((int) dim_i == obj->var_rank - 1) ? ')' : ',';